-/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003 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
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
-
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
- gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ */
\f
* marked with the string "SECTION:".
*/
-
/* SECTION: This code is compiled once.
*/
-#ifndef DEVAL
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
-/* We need this to get the definitions for HAVE_ALLOCA_H, etc. */
-#include "libguile/scmconfig.h"
+#include "libguile/__scm.h"
+
+#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
# include <alloca.h>
# else
# ifdef _AIX
- #pragma alloca
+# pragma alloca
# else
# ifndef alloca /* predefined by HP cc +Olibcalls */
char *alloca ();
#include "libguile/alist.h"
#include "libguile/eq.h"
#include "libguile/continuations.h"
+#include "libguile/futures.h"
#include "libguile/throw.h"
#include "libguile/smob.h"
#include "libguile/macros.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
#include "libguile/fluids.h"
+#include "libguile/goops.h"
+#include "libguile/values.h"
#include "libguile/validate.h"
#include "libguile/eval.h"
+#include "libguile/lang.h"
+
+\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
* 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.
- *
* SCM_EVALIM is used when it is known that the expression is an
* immediate. (This macro never calls an evaluator.)
*
* EVALCAR evaluates the car of an expression.
*
- * 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):
*
*/
#define SCM_CEVAL scm_ceval
-#define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env))
-
-#define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
- ? *scm_lookupcar (x, env, 1) \
- : SCM_CEVAL (SCM_CAR (x), env))
-#define EVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \
- ? (SCM_IMP (SCM_CAR (x)) \
- ? SCM_EVALIM (SCM_CAR (x), env) \
- : SCM_GLOC_VAL (SCM_CAR (x))) \
- : EVALCELLCAR (x, env))
+#define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
+ ? SCM_EVALIM (SCM_CAR (x), env) \
+ : (SCM_SYMBOLP (SCM_CAR (x)) \
+ ? *scm_lookupcar (x, env, 1) \
+ : SCM_CEVAL (SCM_CAR (x), env)))
-#define EXTEND_ENV SCM_EXTEND_ENV
+SCM_REC_MUTEX (source_mutex);
-#ifdef MEMOIZE_LOCALS
+/* Lookup a given local variable in an environment. The local variable is
+ * given as an iloc, that is a triple <frame, binding, last?>, where frame
+ * indicates the relative number of the environment frame (counting upwards
+ * from the innermost environment frame), binding indicates the number of the
+ * binding within the frame, and last? (which is extracted from the iloc using
+ * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
+ * very end of the improper list of bindings. */
SCM *
scm_ilookup (SCM iloc, SCM env)
{
- register int ir = SCM_IFRAME (iloc);
- register SCM er = env;
- for (; 0 != ir; --ir)
- er = SCM_CDR (er);
- er = SCM_CAR (er);
- for (ir = SCM_IDIST (iloc); 0 != ir; --ir)
- er = SCM_CDR (er);
+ unsigned int frame_nr = SCM_IFRAME (iloc);
+ unsigned int binding_nr = SCM_IDIST (iloc);
+ SCM frames = env;
+ SCM bindings;
+
+ for (; 0 != frame_nr; --frame_nr)
+ frames = SCM_CDR (frames);
+
+ bindings = SCM_CAR (frames);
+ for (; 0 != binding_nr; --binding_nr)
+ bindings = SCM_CDR (bindings);
+
if (SCM_ICDRP (iloc))
- return SCM_CDRLOC (er);
- return SCM_CARLOC (SCM_CDR (er));
+ return SCM_CDRLOC (bindings);
+ return SCM_CARLOC (SCM_CDR (bindings));
}
-#endif
-#ifdef USE_THREADS
/* The Lookup Car Race
- by Eva Luator
tree-code instructions.
There shouldn't normally be a problem with memoizing local and
- global variable references (into ilocs and glocs), because all
+ global variable references (into ilocs and variables), because all
threads will mutate the code in *exactly* the same way and (if I
read the C code correctly) it is not possible to observe a half-way
mutated cons cell. The lookup procedure can handle this
It is different with macro expansion, because macro expansion
happens outside of the lookup procedure and can't be
- undone. Therefore it can't cope with it. It has to indicate
- failure when it detects a lost race and hope that the caller can
- handle it. Luckily, it turns out that this is the case.
+ undone. Therefore the lookup procedure can't cope with it. It has
+ to indicate failure when it detects a lost race and hope that the
+ caller can handle it. Luckily, it turns out that this is the case.
- An example to illustrate this: Suppose that the follwing form will
+ An example to illustrate this: Suppose that the following form will
be memoized concurrently by two threads
(let ((x 12)) x)
But let's see what will happen when the race occurs while looking
up the symbol "let" at the start of the form. It could happen that
the second thread interrupts the lookup of the first thread and not
- only substitutes a gloc for it but goes right ahead and replaces it
- with the compiled form (#@let* (x 12) x). Now, when the first
- thread completes its lookup, it would replace the #@let* with a
- gloc pointing to the "let" binding, effectively reverting the form
- to (let (x 12) x). This is wrong. It has to detect that it has
- lost the race and the evaluator has to reconsider the changed form
- completely.
+ only substitutes a variable for it but goes right ahead and
+ replaces it with the compiled form (#@let* (x 12) x). Now, when
+ the first thread completes its lookup, it would replace the #@let*
+ with a variable containing the "let" binding, effectively reverting
+ the form to (let (x 12) x). This is wrong. It has to detect that
+ it has lost the race and the evaluator has to reconsider the
+ changed form completely.
This race condition could be resolved with some kind of traffic
light (like mutexes) around scm_lookupcar, but I think that it is
arbitrary amount of time or even deadlock. But with the current
solution a lot of unnecessary work is potentially done. */
-/* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
+/* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
return NULL to indicate a failed lookup due to some race conditions
between threads. This only happens when VLOC is the first cell of
a special form that will eventually be memoized (like `let', etc.)
reconsider the complete special form.
SCM_LOOKUPCAR is still there, of course. It just calls
- SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
+ SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
should only be called when it is known that VLOC is not the first
pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
for NULL. I think I've found the only places where this
applies. */
-#endif /* USE_THREADS */
-
SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
-#ifdef USE_THREADS
static SCM *
scm_lookupcar1 (SCM vloc, SCM genv, int check)
-#else
-SCM *
-scm_lookupcar (SCM vloc, SCM genv, int check)
-#endif
{
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
for (; SCM_NIMP (env); env = SCM_CDR (env))
{
if (!SCM_CONSP (SCM_CAR (env)))
al = SCM_CARLOC (env);
for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl))
{
- if (SCM_NCONSP (fl))
+ if (!SCM_CONSP (fl))
{
if (SCM_EQ_P (fl, var))
{
-#ifdef MEMOIZE_LOCALS
-#ifdef USE_THREADS
if (! SCM_EQ_P (SCM_CAR (vloc), var))
goto race;
-#endif
SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (iloc) + SCM_ICDR);
-#endif
return SCM_CDRLOC (*al);
}
else
al = SCM_CDRLOC (*al);
if (SCM_EQ_P (SCM_CAR (fl), var))
{
-#ifdef MEMOIZE_LOCALS
-#ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
if (SCM_UNBNDP (SCM_CAR (*al)))
{
env = SCM_EOL;
goto errout;
}
-#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
return SCM_CARLOC (*al);
}
-#ifdef MEMOIZE_LOCALS
iloc = SCM_PACK (SCM_UNPACK (iloc) + SCM_IDINC);
-#endif
}
-#ifdef MEMOIZE_LOCALS
iloc = SCM_PACK ((~SCM_IDSTMSK) & (SCM_UNPACK(iloc) + SCM_IFRINC));
-#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_NULLP (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var)))
+ {
+ errout:
+ if (check)
+ {
+ if (SCM_NULLP (env))
+ scm_error (scm_unbound_variable_key, NULL,
+ "Unbound variable: ~S",
+ scm_list_1 (var), SCM_BOOL_F);
+ else
+ scm_misc_error (NULL, "Damaged environment: ~S",
+ scm_list_1 (var));
+ }
+ 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_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_VARIABLEP (var))
+ return SCM_VARIABLE_LOC (var);
+ if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00))
+ return scm_ilookup (var, genv);
+ /* We can't cope with anything else than variables and ilocs. When
+ a special form has been memoized (i.e. `let' into `#@let') we
+ 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
-#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);
-#ifdef MEMOIZE_LOCALS
- if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00))
- return scm_ilookup (var, genv);
-#endif
- /* We can't cope with anything else than glocs and ilocs. When
- 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_SETCAR (vloc, real_var);
+ return SCM_VARIABLE_LOC (real_var);
+ }
}
-#ifdef USE_THREADS
SCM *
scm_lookupcar (SCM vloc, SCM genv, int check)
{
abort ();
return loc;
}
-#endif
#define unmemocar scm_unmemocar
+SCM_SYMBOL (sym_three_question_marks, "???");
+
SCM
scm_unmemocar (SCM form, SCM env)
{
- SCM c;
-
- if (SCM_IMP (form))
+ if (!SCM_CONSP (form))
return form;
- c = SCM_CAR (form);
- if (SCM_ITAG3 (c) == scm_tc3_cons_gloc)
- SCM_SETCAR (form, SCM_GLOC_SYM (c));
-#ifdef MEMOIZE_LOCALS
-#ifdef DEBUG_EXTENSIONS
- else if (SCM_ILOCP (c))
+ else
{
- int ir;
-
- for (ir = SCM_IFRAME (c); ir != 0; --ir)
- env = SCM_CDR (env);
- env = SCM_CAR (SCM_CAR (env));
- for (ir = SCM_IDIST (c); ir != 0; --ir)
- env = SCM_CDR (env);
- SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env));
+ SCM c = SCM_CAR (form);
+ if (SCM_VARIABLEP (c))
+ {
+ SCM sym = scm_module_reverse_lookup (scm_env_module (env), c);
+ if (SCM_FALSEP (sym))
+ sym = sym_three_question_marks;
+ SCM_SETCAR (form, sym);
+ }
+ else if (SCM_ILOCP (c))
+ {
+ unsigned long int ir;
+
+ for (ir = SCM_IFRAME (c); ir != 0; --ir)
+ env = SCM_CDR (env);
+ env = SCM_CAAR (env);
+ for (ir = SCM_IDIST (c); ir != 0; --ir)
+ env = SCM_CDR (env);
+ SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env));
+ }
+ return form;
}
-#endif
-#endif
- return form;
}
const char scm_s_clauses[] = "bad or missing clauses";
const char scm_s_formals[] = "bad formals";
const char scm_s_duplicate_formals[] = "duplicate formals";
+static const char s_splicing[] = "bad (non-list) result for unquote-splicing";
SCM_GLOBAL_SYMBOL (scm_sym_dot, ".");
SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
-SCM scm_f_apply;
-
-#ifdef DEBUG_EXTENSIONS
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
/* Check that the body denoted by XORIG is valid and rewrite it into
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_body, what);
/* Don't add another ISYM if one is present already. */
if (SCM_ISYMP (SCM_CAR (xorig)))
/* Retain possible doc string. */
if (!SCM_CONSP (SCM_CAR (xorig)))
{
- if (SCM_NNULLP (SCM_CDR(xorig)))
+ if (!SCM_NULLP (SCM_CDR (xorig)))
return scm_cons (SCM_CAR (xorig),
- scm_m_body (op, SCM_CDR(xorig), what));
+ scm_m_body (op, SCM_CDR (xorig), what));
return xorig;
}
return scm_cons (op, xorig);
}
-SCM_SYNTAX(s_quote,"quote", scm_makmmacro, scm_m_quote);
-SCM_GLOBAL_SYMBOL(scm_sym_quote, s_quote);
-
-SCM
-scm_m_quote (SCM xorig, SCM env)
-{
- SCM x = scm_copy_tree (SCM_CDR (xorig));
-
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
- xorig, scm_s_expression, s_quote);
- return scm_cons (SCM_IM_QUOTE, x);
-}
-
-
-
-SCM_SYNTAX(s_begin, "begin", scm_makmmacro, scm_m_begin);
-SCM_GLOBAL_SYMBOL(scm_sym_begin, s_begin);
-
-SCM
-scm_m_begin (SCM xorig, SCM env)
-{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1,
- xorig, scm_s_expression, s_begin);
- return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig));
-}
-
-SCM_SYNTAX(s_if, "if", scm_makmmacro, scm_m_if);
-SCM_GLOBAL_SYMBOL(scm_sym_if, s_if);
-
-SCM
-scm_m_if (SCM xorig, SCM env)
-{
- int len = scm_ilength (SCM_CDR (xorig));
- SCM_ASSYNT (len >= 2 && len <= 3, xorig, scm_s_expression, "if");
- return scm_cons (SCM_IM_IF, SCM_CDR (xorig));
-}
-
-
-/* Will go into the RnRS module when Guile is factorized.
-SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
-const char scm_s_set_x[] = "set!";
-SCM_GLOBAL_SYMBOL(scm_sym_set_x, scm_s_set_x);
-SCM
-scm_m_set_x (SCM xorig, SCM env)
-{
- 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);
- return scm_cons (SCM_IM_SET_X, x);
-}
+/* Start of the memoizers for the standard R5RS builtin macros. */
-SCM_SYNTAX(s_and, "and", scm_makmmacro, scm_m_and);
-SCM_GLOBAL_SYMBOL(scm_sym_and, s_and);
+SCM_SYNTAX (s_and, "and", scm_makmmacro, scm_m_and);
+SCM_GLOBAL_SYMBOL (scm_sym_and, s_and);
-SCM
-scm_m_and (SCM xorig, SCM env)
+SCM
+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
return SCM_BOOL_T;
}
-SCM_SYNTAX(s_or,"or", scm_makmmacro, scm_m_or);
-SCM_GLOBAL_SYMBOL(scm_sym_or,s_or);
-SCM
-scm_m_or (SCM xorig, SCM env)
+SCM_SYNTAX (s_begin, "begin", scm_makmmacro, scm_m_begin);
+SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
+
+SCM
+scm_m_begin (SCM xorig, SCM env SCM_UNUSED)
{
- int len = scm_ilength (SCM_CDR (xorig));
- SCM_ASSYNT (len >= 0, xorig, scm_s_test, s_or);
- if (len >= 1)
- return scm_cons (SCM_IM_OR, SCM_CDR (xorig));
- else
- return SCM_BOOL_F;
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 0, scm_s_expression, s_begin);
+ return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig));
}
-SCM_SYNTAX(s_case, "case", scm_makmmacro, scm_m_case);
-SCM_GLOBAL_SYMBOL(scm_sym_case, s_case);
+SCM_SYNTAX (s_case, "case", scm_makmmacro, scm_m_case);
+SCM_GLOBAL_SYMBOL (scm_sym_case, s_case);
-SCM
-scm_m_case (SCM xorig, SCM env)
+SCM
+scm_m_case (SCM xorig, SCM env SCM_UNUSED)
{
- SCM proc, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx;
- SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_clauses, s_case);
- while (SCM_NIMP (x = SCM_CDR (x)))
+ SCM clauses;
+ SCM cdrx = SCM_CDR (xorig);
+ SCM_ASSYNT (scm_ilength (cdrx) >= 2, scm_s_clauses, s_case);
+ clauses = SCM_CDR (cdrx);
+ while (!SCM_NULLP (clauses))
{
- proc = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (proc) >= 2, xorig, scm_s_clauses, s_case);
- SCM_ASSYNT (scm_ilength (SCM_CAR (proc)) >= 0
- || (SCM_EQ_P (scm_sym_else, SCM_CAR (proc))
- && SCM_NULLP (SCM_CDR (x))),
- xorig, scm_s_clauses, s_case);
+ SCM clause = SCM_CAR (clauses);
+ SCM_ASSYNT (scm_ilength (clause) >= 2, scm_s_clauses, s_case);
+ SCM_ASSYNT (scm_ilength (SCM_CAR (clause)) >= 0
+ || (SCM_EQ_P (scm_sym_else, SCM_CAR (clause))
+ && SCM_NULLP (SCM_CDR (clauses))),
+ scm_s_clauses, s_case);
+ clauses = SCM_CDR (clauses);
}
return scm_cons (SCM_IM_CASE, cdrx);
}
-SCM_SYNTAX(s_cond, "cond", scm_makmmacro, scm_m_cond);
-SCM_GLOBAL_SYMBOL(scm_sym_cond, s_cond);
+SCM_SYNTAX (s_cond, "cond", scm_makmmacro, scm_m_cond);
+SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond);
-
-SCM
-scm_m_cond (SCM xorig, SCM env)
+SCM
+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);
- while (SCM_NIMP (x))
+ SCM cdrx = SCM_CDR (xorig);
+ SCM clauses = cdrx;
+ SCM_ASSYNT (scm_ilength (clauses) >= 1, scm_s_clauses, s_cond);
+ while (!SCM_NULLP (clauses))
{
- arg1 = SCM_CAR (x);
- len = scm_ilength (arg1);
- SCM_ASSYNT (len >= 1, xorig, scm_s_clauses, s_cond);
- if (SCM_EQ_P (scm_sym_else, SCM_CAR (arg1)))
+ SCM clause = SCM_CAR (clauses);
+ long len = scm_ilength (clause);
+ SCM_ASSYNT (len >= 1, scm_s_clauses, s_cond);
+ if (SCM_EQ_P (scm_sym_else, SCM_CAR (clause)))
{
- SCM_ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2,
- xorig, "bad ELSE clause", s_cond);
- SCM_SETCAR (arg1, SCM_BOOL_T);
+ int last_clause_p = SCM_NULLP (SCM_CDR (clauses));
+ SCM_ASSYNT (len >= 2 && last_clause_p, "bad ELSE clause", s_cond);
}
- if (len >= 2 && SCM_EQ_P (scm_sym_arrow, SCM_CAR (SCM_CDR (arg1))))
- SCM_ASSYNT (3 == len && SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1)))),
- xorig, "bad recipient", s_cond);
- x = SCM_CDR (x);
+ else if (len >= 2 && SCM_EQ_P (scm_sym_arrow, SCM_CADR (clause)))
+ {
+ SCM_ASSYNT (len > 2, "missing recipient", s_cond);
+ SCM_ASSYNT (len == 3, "bad recipient", s_cond);
+ }
+ clauses = SCM_CDR (clauses);
}
return scm_cons (SCM_IM_COND, cdrx);
}
-SCM_SYNTAX(s_lambda, "lambda", scm_makmmacro, scm_m_lambda);
-SCM_GLOBAL_SYMBOL(scm_sym_lambda, s_lambda);
-/* Return #t if OBJ is `eq?' to one of the elements of LIST or to the
- cdr of the last cons. (Thus, LIST is not required to be a proper
- list and when OBJ also found in the improper ending.) */
+SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define);
+SCM_GLOBAL_SYMBOL(scm_sym_define, s_define);
-static int
-scm_c_improper_memq (SCM obj, SCM list)
+/* Guile provides an extension to R5RS' define syntax to represent function
+ * currying in a compact way. With this extension, it is allowed to write
+ * (define <nested-variable> <body>), where <nested-variable> has of one of
+ * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
+ * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
+ * should be either a sequence of zero or more variables, or a sequence of one
+ * or more variables followed by a space-delimited period and another
+ * variable. Each level of argument nesting wraps the <body> within another
+ * lambda expression. For example, the following forms are allowed, each one
+ * followed by an equivalent, more explicit implementation.
+ * Example 1:
+ * (define ((a b . c) . d) <body>) is equivalent to
+ * (define a (lambda (b . c) (lambda d <body>)))
+ * Example 2:
+ * (define (((a) b) c . d) <body>) is equivalent to
+ * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
+ */
+/* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
+ * module that does not implement this extension. */
+SCM
+scm_m_define (SCM x, SCM env)
{
- for (; SCM_CONSP (list); list = SCM_CDR (list))
+ SCM name;
+ x = SCM_CDR (x);
+ SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_expression, s_define);
+ name = SCM_CAR (x);
+ x = SCM_CDR (x);
+ while (SCM_CONSP (name))
{
- if (SCM_EQ_P (SCM_CAR (list), obj))
- return SCM_BOOL_T;
+ /* This while loop realizes function currying by variable nesting. */
+ SCM formals = SCM_CDR (name);
+ x = scm_list_1 (scm_cons2 (scm_sym_lambda, formals, x));
+ name = SCM_CAR (name);
}
- return SCM_EQ_P (list, obj);
-}
-
-SCM
-scm_m_lambda (SCM xorig, SCM env)
-{
- SCM proc, x = SCM_CDR (xorig);
- if (scm_ilength (x) < 2)
- goto badforms;
- proc = SCM_CAR (x);
- if (SCM_NULLP (proc))
- goto memlambda;
- if (SCM_EQ_P (SCM_IM_LET, proc)) /* named let */
- goto memlambda;
- if (SCM_IMP (proc))
- goto badforms;
- if (SCM_SYMBOLP (proc))
- goto memlambda;
- if (SCM_NCONSP (proc))
- goto badforms;
- while (SCM_NIMP (proc))
+ SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_variable, s_define);
+ SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_define);
+ if (SCM_TOP_LEVEL (env))
{
- if (SCM_NCONSP (proc))
+ SCM var;
+ x = scm_eval_car (x, env);
+ if (SCM_REC_PROCNAMES_P)
{
- if (!SCM_SYMBOLP (proc))
- goto badforms;
- else
- goto memlambda;
+ SCM tmp = x;
+ while (SCM_MACROP (tmp))
+ tmp = SCM_MACRO_CODE (tmp);
+ if (SCM_CLOSUREP (tmp)
+ /* Only the first definition determines the name. */
+ && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name)))
+ scm_set_procedure_property_x (tmp, scm_sym_name, name);
}
- 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_misc_error (s_lambda, scm_s_formals, SCM_EOL);
+ var = scm_sym2var (name, scm_env_top_level (env), SCM_BOOL_T);
+ SCM_VARIABLE_SET (var, x);
+ return SCM_UNSPECIFIED;
}
-
- memlambda:
- return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (x),
- scm_m_body (SCM_IM_LAMBDA, SCM_CDR (x), s_lambda));
+ else
+ return scm_cons2 (SCM_IM_DEFINE, name, x);
}
-SCM_SYNTAX(s_letstar,"let*", scm_makmmacro, scm_m_letstar);
-SCM_GLOBAL_SYMBOL(scm_sym_letstar,s_letstar);
+SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay);
+SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
-SCM
-scm_m_letstar (SCM xorig, SCM env)
+/* Promises are implemented as closures with an empty parameter list. Thus,
+ * (delay <expression>) is transformed into (#@delay '() <expression>), where
+ * the empty list represents the empty parameter list. This representation
+ * allows for easy creation of the closure during evaluation. */
+SCM
+scm_m_delay (SCM xorig, SCM env SCM_UNUSED)
{
- SCM 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);
- proc = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, 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);
- *varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
- varloc = SCM_CDRLOC (SCM_CDR (*varloc));
- proc = SCM_CDR (proc);
- }
- x = scm_cons (vars, SCM_CDR (x));
-
- return scm_cons2 (SCM_IM_LETSTAR, SCM_CAR (x),
- scm_m_body (SCM_IM_LETSTAR, SCM_CDR (x), s_letstar));
+ SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_delay);
+ return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig));
}
-/* DO gets the most radically altered syntax
+
+/* DO gets the most radically altered syntax. The order of the vars is
+ * reversed here. In contrast, the order of the inits and steps is reversed
+ * during the evaluation:
+
(do ((<var1> <init1> <step1>)
(<var2> <init2>)
... )
(<test> <return>)
<body>)
+
;; becomes
- (do_mem (varn ... var2 var1)
+
+ (#@do (varn ... var2 var1)
(<init1> <init2> ... <initn>)
(<test> <return>)
(<body>)
<step1> <step2> ... <stepn>) ;; missing steps replaced by var
- */
+ */
SCM_SYNTAX(s_do, "do", scm_makmmacro, scm_m_do);
SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
SCM
-scm_m_do (SCM xorig, SCM env)
+scm_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");
- proc = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_s_bindings, "do");
- while (SCM_NIMP(proc))
+ SCM bindings;
+ SCM x = SCM_CDR (xorig);
+ SCM vars = SCM_EOL;
+ SCM inits = SCM_EOL;
+ SCM *initloc = &inits;
+ SCM steps = SCM_EOL;
+ SCM *steploc = &steps;
+ SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_test, "do");
+ bindings = SCM_CAR (x);
+ SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, "do");
+ while (!SCM_NULLP (bindings))
{
- arg1 = SCM_CAR (proc);
- len = scm_ilength (arg1);
- SCM_ASSYNT (2 == len || 3 == len, xorig, scm_s_bindings, "do");
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, "do");
- /* vars reversed here, inits and steps reversed at evaluation */
- vars = scm_cons (SCM_CAR (arg1), vars); /* variable */
- arg1 = SCM_CDR (arg1);
- *initloc = scm_cons (SCM_CAR (arg1), SCM_EOL); /* init */
- initloc = SCM_CDRLOC (*initloc);
- arg1 = SCM_CDR (arg1);
- *steploc = scm_cons (SCM_IMP (arg1) ? SCM_CAR (vars) : SCM_CAR (arg1), SCM_EOL); /* step */
- steploc = SCM_CDRLOC (*steploc);
- proc = SCM_CDR (proc);
+ SCM binding = SCM_CAR (bindings);
+ long len = scm_ilength (binding);
+ SCM_ASSYNT (len == 2 || len == 3, scm_s_bindings, "do");
+ {
+ SCM name = SCM_CAR (binding);
+ SCM init = SCM_CADR (binding);
+ SCM step = (len == 2) ? name : SCM_CADDR (binding);
+ SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_variable, "do");
+ vars = scm_cons (name, vars);
+ *initloc = scm_list_1 (init);
+ initloc = SCM_CDRLOC (*initloc);
+ *steploc = scm_list_1 (step);
+ steploc = SCM_CDRLOC (*steploc);
+ bindings = SCM_CDR (bindings);
+ }
}
x = SCM_CDR (x);
- SCM_ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, 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);
}
-/* evalcar is small version of inline EVALCAR when we don't care about
- * speed
- */
-#define evalcar scm_eval_car
-
-
-static SCM iqq (SCM form, SCM env, int depth);
-SCM_SYNTAX(s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
-SCM_GLOBAL_SYMBOL(scm_sym_quasiquote, s_quasiquote);
+SCM_SYNTAX (s_if, "if", scm_makmmacro, scm_m_if);
+SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
-SCM
-scm_m_quasiquote (SCM xorig, SCM env)
+SCM
+scm_m_if (SCM xorig, SCM env SCM_UNUSED)
{
- SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) == 1, xorig, scm_s_expression, s_quasiquote);
- return iqq (SCM_CAR (x), env, 1);
+ long len = scm_ilength (SCM_CDR (xorig));
+ SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, s_if);
+ return scm_cons (SCM_IM_IF, SCM_CDR (xorig));
}
-static SCM
-iqq (SCM form,SCM env,int depth)
+SCM_SYNTAX (s_lambda, "lambda", scm_makmmacro, scm_m_lambda);
+SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda);
+
+/* Return true if OBJ is `eq?' to one of the elements of LIST or to the
+ * cdr of the last cons. (Thus, LIST is not required to be a proper
+ * list and OBJ can also be found in the improper ending.) */
+static int
+scm_c_improper_memq (SCM obj, SCM list)
{
- SCM tmp;
- int edepth = depth;
- if (SCM_IMP(form))
- return form;
- if (SCM_VECTORP (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))
- return form;
- tmp = SCM_CAR (form);
- if (SCM_EQ_P (scm_sym_quasiquote, tmp))
- {
- depth++;
- goto label;
- }
- if (SCM_EQ_P (scm_sym_unquote, tmp))
- {
- --depth;
- label:
- form = SCM_CDR (form);
- SCM_ASSERT (SCM_ECONSP (form) && SCM_NULLP (SCM_CDR (form)),
- form, SCM_ARG1, s_quasiquote);
- if (0 == depth)
- return evalcar (form, env);
- return scm_cons2 (tmp, iqq (SCM_CAR (form), env, depth), SCM_EOL);
- }
- if (SCM_NIMP (tmp) && (SCM_EQ_P (scm_sym_uq_splicing, SCM_CAR (tmp))))
+ for (; SCM_CONSP (list); list = SCM_CDR (list))
{
- tmp = SCM_CDR (tmp);
- if (0 == --edepth)
- return scm_append (scm_cons2 (evalcar (tmp, env), iqq (SCM_CDR (form), env, depth), SCM_EOL));
+ if (SCM_EQ_P (SCM_CAR (list), obj))
+ return 1;
}
- return scm_cons (iqq (SCM_CAR (form), env, edepth), iqq (SCM_CDR (form), env, depth));
+ return SCM_EQ_P (list, obj);
}
-/* Here are acros which return values rather than code. */
-
-SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay);
-SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
-
-SCM
-scm_m_delay (SCM xorig, SCM env)
+SCM
+scm_m_lambda (SCM xorig, SCM env SCM_UNUSED)
{
- SCM_ASSYNT (scm_ilength (xorig) == 2, xorig, scm_s_expression, s_delay);
- return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig));
-}
-
+ SCM formals;
+ SCM x = SCM_CDR (xorig);
-SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define);
-SCM_GLOBAL_SYMBOL(scm_sym_define, s_define);
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_formals, s_lambda);
-SCM
-scm_m_define (SCM x, SCM env)
-{
- SCM proc, arg1 = x;
- x = SCM_CDR (x);
- SCM_ASSYNT (scm_ilength (x) >= 2, arg1, scm_s_expression, s_define);
- proc = SCM_CAR (x);
- x = SCM_CDR (x);
- while (SCM_CONSP (proc))
- { /* nested define syntax */
- x = scm_cons (scm_cons2 (scm_sym_lambda, SCM_CDR (proc), x), SCM_EOL);
- proc = SCM_CAR (proc);
- }
- SCM_ASSYNT (SCM_SYMBOLP (proc),
- arg1, scm_s_variable, s_define);
- SCM_ASSYNT (1 == scm_ilength (x), arg1, scm_s_expression, s_define);
- if (SCM_TOP_LEVEL (env))
+ formals = SCM_CAR (x);
+ while (SCM_CONSP (formals))
{
- x = evalcar (x, env);
-#ifdef DEBUG_EXTENSIONS
- if (SCM_REC_PROCNAMES_P && SCM_NIMP (x))
- {
- arg1 = x;
- proc:
- if (SCM_CLOSUREP (arg1)
- /* 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))
- {
- arg1 = SCM_CDR (arg1);
- goto proc;
- }
- }
-#endif
- arg1 = scm_sym2vcell (proc, scm_env_top_level (env), SCM_BOOL_T);
- SCM_SETCDR (arg1, x);
-#ifdef SICP
- return scm_cons2 (scm_sym_quote, SCM_CAR (arg1), SCM_EOL);
-#else
- return SCM_UNSPECIFIED;
-#endif
+ SCM formal = SCM_CAR (formals);
+ SCM_ASSYNT (SCM_SYMBOLP (formal), scm_s_formals, s_lambda);
+ if (scm_c_improper_memq (formal, SCM_CDR (formals)))
+ scm_misc_error (s_lambda, scm_s_duplicate_formals, SCM_EOL);
+ formals = SCM_CDR (formals);
}
- return scm_cons2 (SCM_IM_DEFINE, proc, x);
+ if (!SCM_NULLP (formals) && !SCM_SYMBOLP (formals))
+ scm_misc_error (s_lambda, scm_s_formals, SCM_EOL);
+
+ return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (x),
+ scm_m_body (SCM_IM_LAMBDA, SCM_CDR (x), s_lambda));
}
-/* end of acros */
-static SCM
-scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env)
+/* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
+ * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
+ * reversed here, the list of inits gets reversed during evaluation. */
+static void
+transform_bindings (SCM bindings, SCM *rvarloc, SCM *initloc, const char *what)
{
- SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */
- char *what = SCM_SYMBOL_CHARS (SCM_CAR (xorig));
- SCM x = cdrx, proc, arg1; /* structure traversers */
- SCM vars = SCM_EOL, inits = SCM_EOL, *initloc = &inits;
+ SCM rvars = SCM_EOL;
+ *rvarloc = SCM_EOL;
+ *initloc = SCM_EOL;
+
+ SCM_ASSYNT (scm_ilength (bindings) >= 1, scm_s_bindings, what);
- proc = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (proc) >= 1, xorig, 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);
- if (scm_c_improper_memq (SCM_CAR (arg1), vars))
+ SCM binding = SCM_CAR (bindings);
+ SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, what);
+ SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, what);
+ if (scm_c_improper_memq (SCM_CAR (binding), rvars))
scm_misc_error (what, scm_s_duplicate_bindings, SCM_EOL);
- vars = scm_cons (SCM_CAR (arg1), vars);
- *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
+ rvars = scm_cons (SCM_CAR (binding), rvars);
+ *initloc = scm_list_1 (SCM_CADR (binding));
initloc = SCM_CDRLOC (*initloc);
+ bindings = SCM_CDR (bindings);
}
- while (SCM_NIMP (proc = SCM_CDR (proc)));
+ while (!SCM_NULLP (bindings));
- return scm_cons2 (op, vars,
- scm_cons (inits, scm_m_body (imm, SCM_CDR (x), what)));
+ *rvarloc = rvars;
}
-SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec);
-SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
-
-SCM
-scm_m_letrec (SCM xorig, SCM env)
-{
- SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) >= 2, xorig, 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_m_body (SCM_IM_LETREC,
- SCM_CDR (x),
- s_letrec)),
- env);
- else
- return scm_m_letrec1 (SCM_IM_LETREC, SCM_IM_LETREC, xorig, env);
-}
SCM_SYNTAX(s_let, "let", scm_makmmacro, scm_m_let);
SCM_GLOBAL_SYMBOL(scm_sym_let, s_let);
-SCM
+SCM
scm_m_let (SCM xorig, SCM env)
{
- SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */
- SCM x = cdrx, proc, arg1, name; /* structure traversers */
- SCM vars = SCM_EOL, inits = SCM_EOL, *varloc = &vars, *initloc = &inits;
-
- SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_let);
- proc = SCM_CAR (x);
- if (SCM_NULLP (proc)
- || (SCM_CONSP (proc)
- && SCM_CONSP (SCM_CAR (proc)) && SCM_NULLP (SCM_CDR (proc))))
+ SCM x = SCM_CDR (xorig);
+ SCM temp;
+
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_let);
+ temp = SCM_CAR (x);
+ if (SCM_NULLP (temp)
+ || (scm_ilength (temp) == 1 && SCM_CONSP (SCM_CAR (temp))))
{
/* null or single binding, let* is faster */
- return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), proc,
- scm_m_body (SCM_IM_LET,
- SCM_CDR (x),
- s_let)),
- env);
+ SCM bindings = temp;
+ SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (x), s_let);
+ return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), bindings, body), env);
}
-
- SCM_ASSYNT (SCM_NIMP (proc), xorig, scm_s_bindings, s_let);
- if (SCM_CONSP (proc))
+ else if (SCM_CONSP (temp))
{
- /* plain let, proc is <bindings> */
- return scm_m_letrec1 (SCM_IM_LET, SCM_IM_LET, xorig, env);
+ /* plain let */
+ SCM bindings = temp;
+ SCM rvars, inits, body;
+ transform_bindings (bindings, &rvars, &inits, "let");
+ body = scm_m_body (SCM_IM_LET, SCM_CDR (x), "let");
+ return scm_cons2 (SCM_IM_LET, rvars, scm_cons (inits, body));
}
+ else
+ {
+ /* named let: Transform (let name ((var init) ...) body ...) into
+ * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
- if (!SCM_SYMBOLP (proc))
- scm_misc_error (s_let, scm_s_bindings, SCM_EOL); /* bad let */
- name = proc; /* named let, build equiv letrec */
- x = SCM_CDR (x);
- SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_let);
- proc = SCM_CAR (x); /* bindings list */
- SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, 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);
- *varloc = scm_cons (SCM_CAR (arg1), SCM_EOL);
- varloc = SCM_CDRLOC (*varloc);
- *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
- initloc = SCM_CDRLOC (*initloc);
- proc = SCM_CDR (proc);
- }
+ SCM name = temp;
+ SCM vars = SCM_EOL;
+ SCM *varloc = &vars;
+ SCM inits = SCM_EOL;
+ SCM *initloc = &inits;
+ SCM bindings;
- proc = scm_cons2 (scm_sym_lambda, vars,
- scm_m_body (SCM_IM_LET, SCM_CDR (x), "let"));
- proc = scm_cons2 (scm_sym_let, scm_cons (scm_cons2 (name, proc, SCM_EOL),
- SCM_EOL),
- scm_acons (name, inits, SCM_EOL));
- return scm_m_letrec1 (SCM_IM_LETREC, SCM_IM_LET, proc, env);
+ SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_bindings, s_let);
+ x = SCM_CDR (x);
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_let);
+ bindings = SCM_CAR (x);
+ SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_let);
+ while (!SCM_NULLP (bindings))
+ { /* vars and inits both in order */
+ SCM binding = SCM_CAR (bindings);
+ SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, s_let);
+ SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, s_let);
+ *varloc = scm_list_1 (SCM_CAR (binding));
+ varloc = SCM_CDRLOC (*varloc);
+ *initloc = scm_list_1 (SCM_CADR (binding));
+ initloc = SCM_CDRLOC (*initloc);
+ bindings = SCM_CDR (bindings);
+ }
+
+ {
+ SCM lambda_body = scm_m_body (SCM_IM_LET, SCM_CDR (x), "let");
+ SCM lambda_form = scm_cons2 (scm_sym_lambda, vars, lambda_body);
+ SCM rvar = scm_list_1 (name);
+ SCM init = scm_list_1 (lambda_form);
+ SCM body = scm_m_body (SCM_IM_LET, scm_list_1 (name), "let");
+ SCM letrec = scm_cons2 (SCM_IM_LETREC, rvar, scm_cons (init, body));
+ return scm_cons (letrec, inits);
+ }
+ }
}
-SCM_SYNTAX (s_atapply,"@apply", scm_makmmacro, scm_m_apply);
-SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply);
-SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
+SCM_SYNTAX (s_letstar, "let*", scm_makmmacro, scm_m_letstar);
+SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);
+
+/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
+ * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
+SCM
+scm_m_letstar (SCM xorig, SCM env SCM_UNUSED)
+{
+ SCM bindings;
+ SCM x = SCM_CDR (xorig);
+ SCM vars = SCM_EOL;
+ SCM *varloc = &vars;
+
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letstar);
+
+ bindings = SCM_CAR (x);
+ SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_letstar);
+ while (!SCM_NULLP (bindings))
+ {
+ SCM binding = SCM_CAR (bindings);
+ SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, s_letstar);
+ SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, s_letstar);
+ *varloc = scm_list_2 (SCM_CAR (binding), SCM_CADR (binding));
+ varloc = SCM_CDRLOC (SCM_CDR (*varloc));
+ bindings = SCM_CDR (bindings);
+ }
+
+ return scm_cons2 (SCM_IM_LETSTAR, vars,
+ scm_m_body (SCM_IM_LETSTAR, SCM_CDR (x), s_letstar));
+}
+
+
+SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec);
+SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
SCM
-scm_m_apply (SCM xorig, SCM env)
+scm_m_letrec (SCM xorig, SCM env)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2,
- xorig, scm_s_expression, s_atapply);
- return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig));
+ SCM x = SCM_CDR (xorig);
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letrec);
+
+ if (SCM_NULLP (SCM_CAR (x)))
+ {
+ /* null binding, let* faster */
+ SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), s_letrec);
+ return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL, body), env);
+ }
+ else
+ {
+ SCM rvars, inits, body;
+ transform_bindings (SCM_CAR (x), &rvars, &inits, "letrec");
+ body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), "letrec");
+ return scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body));
+ }
}
-SCM_SYNTAX(s_atcall_cc,"@call-with-current-continuation", scm_makmmacro, scm_m_cont);
-SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc,s_atcall_cc);
+SCM_SYNTAX (s_or, "or", scm_makmmacro, scm_m_or);
+SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
+
+SCM
+scm_m_or (SCM xorig, SCM env SCM_UNUSED)
+{
+ long len = scm_ilength (SCM_CDR (xorig));
+ SCM_ASSYNT (len >= 0, scm_s_test, s_or);
+ if (len >= 1)
+ return scm_cons (SCM_IM_OR, SCM_CDR (xorig));
+ else
+ return SCM_BOOL_F;
+}
+
+SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
+SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);
-SCM
-scm_m_cont (SCM xorig, SCM env)
+/* Internal function to handle a quasiquotation: 'form' is the parameter in
+ * the call (quasiquotation form), 'env' is the environment where unquoted
+ * expressions will be evaluated, and 'depth' is the current quasiquotation
+ * nesting level and is known to be greater than zero. */
+static SCM
+iqq (SCM form, SCM env, unsigned long int depth)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
- xorig, scm_s_expression, s_atcall_cc);
- return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));
+ if (SCM_CONSP (form))
+ {
+ SCM tmp = SCM_CAR (form);
+ if (SCM_EQ_P (tmp, scm_sym_quasiquote))
+ {
+ SCM args = SCM_CDR (form);
+ SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote);
+ return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1));
+ }
+ else if (SCM_EQ_P (tmp, scm_sym_unquote))
+ {
+ SCM args = SCM_CDR (form);
+ SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote);
+ if (depth - 1 == 0)
+ return scm_eval_car (args, env);
+ else
+ return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth - 1));
+ }
+ else if (SCM_CONSP (tmp)
+ && SCM_EQ_P (SCM_CAR (tmp), scm_sym_uq_splicing))
+ {
+ SCM args = SCM_CDR (tmp);
+ SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote);
+ if (depth - 1 == 0)
+ {
+ SCM list = scm_eval_car (args, env);
+ SCM rest = SCM_CDR (form);
+ SCM_ASSYNT (scm_ilength (list) >= 0, s_splicing, s_quasiquote);
+ return scm_append (scm_list_2 (list, iqq (rest, env, depth)));
+ }
+ else
+ return scm_cons (iqq (SCM_CAR (form), env, depth - 1),
+ iqq (SCM_CDR (form), env, depth));
+ }
+ else
+ return scm_cons (iqq (SCM_CAR (form), env, depth),
+ iqq (SCM_CDR (form), env, depth));
+ }
+ else if (SCM_VECTORP (form))
+ {
+ size_t i = SCM_VECTOR_LENGTH (form);
+ SCM const *const data = SCM_VELTS (form);
+ SCM tmp = SCM_EOL;
+ while (i != 0)
+ tmp = scm_cons (data[--i], tmp);
+ scm_remember_upto_here_1 (form);
+ return scm_vector (iqq (tmp, env, depth));
+ }
+ else
+ return form;
}
-/* Multi-language support */
+SCM
+scm_m_quasiquote (SCM xorig, SCM env)
+{
+ SCM x = SCM_CDR (xorig);
+ SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_quasiquote);
+ return iqq (SCM_CAR (x), env, 1);
+}
-SCM scm_lisp_nil;
-SCM scm_lisp_t;
-SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond);
+SCM_SYNTAX (s_quote, "quote", scm_makmmacro, scm_m_quote);
+SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
SCM
-scm_m_nil_cond (SCM xorig, SCM env)
+scm_m_quote (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");
- return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig));
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, s_quote);
+ return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig));
}
-SCM_SYNTAX (s_nil_ify, "nil-ify", scm_makmmacro, scm_m_nil_ify);
+
+/* Will go into the RnRS module when Guile is factorized.
+SCM_SYNTAX (s_set_x, "set!", scm_makmmacro, scm_m_set_x); */
+static const char s_set_x[] = "set!";
+SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x);
SCM
-scm_m_nil_ify (SCM xorig, SCM env)
+scm_m_set_x (SCM xorig, SCM env SCM_UNUSED)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
- xorig, scm_s_expression, "nil-ify");
- return scm_cons (SCM_IM_NIL_IFY, SCM_CDR (xorig));
+ SCM x = SCM_CDR (xorig);
+ SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, s_set_x);
+ SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), scm_s_variable, s_set_x);
+ return scm_cons (SCM_IM_SET_X, x);
+}
+
+
+/* Start of the memoizers for non-R5RS builtin macros. */
+
+
+SCM_SYNTAX (s_atapply, "@apply", scm_makmmacro, scm_m_apply);
+SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply);
+SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
+
+SCM
+scm_m_apply (SCM xorig, SCM env SCM_UNUSED)
+{
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, scm_s_expression, s_atapply);
+ return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig));
}
-SCM_SYNTAX (s_t_ify, "t-ify", scm_makmmacro, scm_m_t_ify);
+
+/* (@bind ((var exp) ...) body ...)
+
+ This will assign the values of the `exp's to the global variables
+ named by `var's (symbols, not evaluated), creating them if they
+ don't exist, executes body, and then restores the previous values of
+ the `var's. Additionally, whenever control leaves body, the values
+ of the `var's are saved and restored when control returns. It is an
+ error when a symbol appears more than once among the `var's.
+ All `exp's are evaluated before any `var' is set.
+
+ Think of this as `let' for dynamic scope.
+
+ It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
+
+ XXX - also implement `@bind*'.
+*/
+
+SCM_SYNTAX (s_atbind, "@bind", scm_makmmacro, scm_m_atbind);
SCM
-scm_m_t_ify (SCM xorig, SCM env)
+scm_m_atbind (SCM xorig, SCM env)
+{
+ SCM x = SCM_CDR (xorig);
+ SCM top_level = scm_env_top_level (env);
+ SCM vars = SCM_EOL, var;
+ SCM exps = SCM_EOL;
+
+ SCM_ASSYNT (scm_ilength (x) > 1, scm_s_expression, s_atbind);
+
+ x = SCM_CAR (x);
+ while (SCM_NIMP (x))
+ {
+ SCM rest;
+ SCM sym_exp = SCM_CAR (x);
+ SCM_ASSYNT (scm_ilength (sym_exp) == 2, scm_s_bindings, s_atbind);
+ SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp)), scm_s_bindings, s_atbind);
+ x = SCM_CDR (x);
+ for (rest = x; SCM_NIMP (rest); rest = SCM_CDR (rest))
+ if (SCM_EQ_P (SCM_CAR (sym_exp), SCM_CAAR (rest)))
+ scm_misc_error (s_atbind, scm_s_duplicate_bindings, SCM_EOL);
+ /* The first call to scm_sym2var will look beyond the current
+ module, while the second call wont. */
+ var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_F);
+ if (SCM_FALSEP (var))
+ var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_T);
+ vars = scm_cons (var, vars);
+ exps = scm_cons (SCM_CADR (sym_exp), exps);
+ }
+ return scm_cons (SCM_IM_BIND,
+ scm_cons (scm_cons (scm_reverse_x (vars, SCM_EOL), exps),
+ SCM_CDDR (xorig)));
+}
+
+
+SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_makmmacro, scm_m_cont);
+SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc);
+
+
+SCM
+scm_m_cont (SCM xorig, SCM env SCM_UNUSED)
{
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
- xorig, scm_s_expression, "t-ify");
- return scm_cons (SCM_IM_T_IFY, SCM_CDR (xorig));
+ scm_s_expression, s_atcall_cc);
+ return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));
}
-SCM_SYNTAX (s_0_cond, "0-cond", scm_makmmacro, scm_m_0_cond);
+
+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_0_cond (SCM xorig, SCM env)
+scm_m_at_call_with_values (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");
- return scm_cons (SCM_IM_0_COND, SCM_CDR (xorig));
+ 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_SYNTAX (s_0_ify, "0-ify", scm_makmmacro, scm_m_0_ify);
+SCM_SYNTAX (s_future, "future", scm_makmmacro, scm_m_future);
+SCM_GLOBAL_SYMBOL (scm_sym_future, s_future);
+
+/* Like promises, futures are implemented as closures with an empty
+ * parameter list. Thus, (future <expression>) is transformed into
+ * (#@future '() <expression>), where the empty list represents the
+ * empty parameter list. This representation allows for easy creation
+ * of the closure during evaluation. */
SCM
-scm_m_0_ify (SCM xorig, SCM env)
+scm_m_future (SCM xorig, SCM env SCM_UNUSED)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
- xorig, scm_s_expression, "0-ify");
- return scm_cons (SCM_IM_0_IFY, SCM_CDR (xorig));
+ SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_future);
+ return scm_cons2 (SCM_IM_FUTURE, SCM_EOL, 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_SYNTAX (s_gset_x, "set!", scm_makmmacro, scm_m_generalized_set_x);
+SCM_SYMBOL (scm_sym_setter, "setter");
+
+SCM
+scm_m_generalized_set_x (SCM xorig, SCM env SCM_UNUSED)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
- xorig, scm_s_expression, "1-ify");
- return scm_cons (SCM_IM_1_IFY, SCM_CDR (xorig));
+ SCM x = SCM_CDR (xorig);
+ SCM_ASSYNT (2 == scm_ilength (x), scm_s_expression, s_set_x);
+ if (SCM_SYMBOLP (SCM_CAR (x)))
+ return scm_cons (SCM_IM_SET_X, x);
+ else if (SCM_CONSP (SCM_CAR (x)))
+ return scm_cons (scm_list_2 (scm_sym_setter, SCM_CAAR (x)),
+ scm_append (scm_list_2 (SCM_CDAR (x), SCM_CDR (x))));
+ else
+ scm_misc_error (s_set_x, scm_s_variable, SCM_EOL);
}
-SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop);
+static const char* s_atslot_ref = "@slot-ref";
+
+/* @slot-ref is bound privately in the (oop goops) module from goops.c. As
+ * soon as the module system allows us to more freely create bindings in
+ * arbitrary modules during the startup phase, the code from goops.c should be
+ * moved here. */
SCM
-scm_m_atfop (SCM xorig, SCM env)
+scm_m_atslot_ref (SCM xorig, SCM env SCM_UNUSED)
+#define FUNC_NAME s_atslot_ref
{
- 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,
- "Symbol's function definition is void", NULL);
- SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (vcell) + scm_tc3_cons_gloc);
- return x;
+ SCM x = SCM_CDR (xorig);
+ SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, FUNC_NAME);
+ SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x));
+ return scm_cons (SCM_IM_SLOT_REF, x);
}
+#undef FUNC_NAME
-SCM_SYNTAX (s_atbind, "@bind", scm_makmmacro, scm_m_atbind);
+static const char* s_atslot_set_x = "@slot-set!";
+
+/* @slot-set! is bound privately in the (oop goops) module from goops.c. As
+ * soon as the module system allows us to more freely create bindings in
+ * arbitrary modules during the startup phase, the code from goops.c should be
+ * moved here. */
SCM
-scm_m_atbind (SCM xorig, SCM env)
+scm_m_atslot_set_x (SCM xorig, SCM env SCM_UNUSED)
+#define FUNC_NAME s_atslot_set_x
{
SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) > 1, xorig, scm_s_expression, "@bind");
+ SCM_ASSYNT (scm_ilength (x) == 3, scm_s_expression, FUNC_NAME);
+ SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x));
+ return scm_cons (SCM_IM_SLOT_SET_X, x);
+}
+#undef FUNC_NAME
- if (SCM_IMP (env))
- env = SCM_BOOL_F;
- else
+
+#if SCM_ENABLE_ELISP
+
+SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond);
+
+SCM
+scm_m_nil_cond (SCM xorig, SCM env SCM_UNUSED)
+{
+ 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_atfop, "@fop", scm_makmmacro, scm_m_atfop);
+
+SCM
+scm_m_atfop (SCM xorig, SCM env SCM_UNUSED)
+{
+ SCM x = SCM_CDR (xorig), var;
+ SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop");
+ var = scm_symbol_fref (SCM_CAR (x));
+ /* Passing the symbol name as the `subr' arg here isn't really
+ right, but without it it can be very difficult to work out from
+ the error message which function definition was missing. In any
+ case, we shouldn't really use SCM_ASSYNT here at all, but instead
+ something equivalent to (signal void-function (list SYM)) in
+ Elisp. */
+ SCM_ASSYNT (SCM_VARIABLEP (var),
+ "Symbol's function definition is void",
+ SCM_SYMBOL_CHARS (SCM_CAR (x)));
+ /* Support `defalias'. */
+ while (SCM_SYMBOLP (SCM_VARIABLE_REF (var)))
{
- while (SCM_NIMP (SCM_CDR (env)))
- env = SCM_CDR (env);
- env = SCM_CAR (env);
- if (SCM_CONSP (env))
- env = SCM_BOOL_F;
+ var = scm_symbol_fref (SCM_VARIABLE_REF (var));
+ SCM_ASSYNT (SCM_VARIABLEP (var),
+ "Symbol's function definition is void",
+ SCM_SYMBOL_CHARS (SCM_CAR (x)));
}
-
- x = SCM_CAR (x);
- while (SCM_NIMP (x))
+ /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
+ former allows for automatically picking up redefinitions of the
+ corresponding symbol. */
+ SCM_SETCAR (x, var);
+ /* If the variable contains a procedure, leave the
+ `transformer-macro' in place so that the procedure's arguments
+ get properly transformed, and change the initial @fop to
+ SCM_IM_APPLY. */
+ if (!SCM_MACROP (SCM_VARIABLE_REF (var)))
{
- SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_sym2vcell (SCM_CAR (x), env, SCM_BOOL_T)) + scm_tc3_cons_gloc);
- x = SCM_CDR (x);
+ SCM_SETCAR (xorig, SCM_IM_APPLY);
+ return xorig;
}
- return scm_cons (SCM_IM_BIND, SCM_CDR (xorig));
+ /* Otherwise (the variable contains a macro), the arguments should
+ not be transformed, so cut the `transformer-macro' out and return
+ the resulting expression starting with the variable. */
+ SCM_SETCDR (x, SCM_CDADR (x));
+ return x;
}
+#endif /* SCM_ENABLE_ELISP */
+
+
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 if (SCM_EQ_P (SCM_IM_BEGIN, SCM_CAR (form)))
{
- x = scm_append (scm_cons2 (SCM_CDR (form), SCM_CDR (x), SCM_EOL));
+ x = scm_append (scm_list_2 (SCM_CDR (form), SCM_CDR (x)));
}
else
{
- 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);
- if (SCM_NIMP (defs))
+ if (!SCM_NULLP (defs))
{
- x = scm_cons (scm_m_letrec1 (SCM_IM_LETREC,
- SCM_IM_DEFINE,
- scm_cons2 (scm_sym_define, defs, x),
- env),
- SCM_EOL);
+ SCM rvars, inits, body, letrec;
+ transform_bindings (defs, &rvars, &inits, what);
+ body = scm_m_body (SCM_IM_DEFINE, x, what);
+ letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body));
+ SCM_SETCAR (xorig, letrec);
+ SCM_SETCDR (xorig, SCM_EOL);
+ }
+ else
+ {
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_body, what);
+ SCM_SETCAR (xorig, SCM_CAR (x));
+ SCM_SETCDR (xorig, SCM_CDR (x));
}
-
- SCM_DEFER_INTS;
- SCM_SETCAR (xorig, SCM_CAR (x));
- SCM_SETCDR (xorig, SCM_CDR (x));
- SCM_ALLOW_INTS;
return xorig;
}
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
{
SCM *proc_ptr = scm_lookupcar1 (x, env, 0);
if (proc_ptr == NULL)
}
proc = *proc_ptr;
}
-#else
- proc = *scm_lookupcar (x, env, 0);
-#endif
/* 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);
+ res = scm_list_2 (SCM_IM_BEGIN, res);
SCM_DEFER_INTS;
SCM_SETCAR (x, SCM_CAR (res));
goto macro_tail;
}
+#define SCM_BIT7(x) (127 & SCM_UNPACK (x))
+
+/* A function object to implement "apply" for non-closure functions. */
+static SCM f_apply;
+/* An endless list consisting of #<undefined> objects: */
+static SCM undefineds;
+
/* 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
* 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.
+ *
+ * Unmemoizing is not a reliable process. You cannot in general
+ * expect to get the original source back.
+ *
+ * However, GOOPS currently relies on this for method compilation.
+ * This ought to change.
*/
-/* 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... :)
- */
-
-#define SCM_BIT8(x) (127 & SCM_UNPACK (x))
+static SCM
+build_binding_list (SCM names, SCM inits)
+{
+ SCM bindings = SCM_EOL;
+ while (!SCM_NULLP (names))
+ {
+ SCM binding = scm_list_2 (SCM_CAR (names), SCM_CAR (inits));
+ bindings = scm_cons (binding, bindings);
+ names = SCM_CDR (names);
+ inits = SCM_CDR (inits);
+ }
+ return bindings;
+}
static SCM
unmemocopy (SCM x, SCM env)
{
SCM ls, z;
-#ifdef DEBUG_EXTENSIONS
SCM p;
-#endif
- if (SCM_NCELLP (x) || SCM_NECONSP (x))
+ if (!SCM_CONSP (x))
return x;
-#ifdef DEBUG_EXTENSIONS
p = scm_whash_lookup (scm_source_whash, x);
-#endif
- switch (SCM_TYP7 (x))
+ switch (SCM_ITAG7 (SCM_CAR (x)))
{
- case SCM_BIT8(SCM_IM_AND):
+ case SCM_BIT7 (SCM_IM_AND):
ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED);
break;
- case SCM_BIT8(SCM_IM_BEGIN):
+ case SCM_BIT7 (SCM_IM_BEGIN):
ls = z = scm_cons (scm_sym_begin, SCM_UNSPECIFIED);
break;
- case SCM_BIT8(SCM_IM_CASE):
+ case SCM_BIT7 (SCM_IM_CASE):
ls = z = scm_cons (scm_sym_case, SCM_UNSPECIFIED);
break;
- case SCM_BIT8(SCM_IM_COND):
+ case SCM_BIT7 (SCM_IM_COND):
ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED);
break;
- case SCM_BIT8(SCM_IM_DO):
- ls = scm_cons (scm_sym_do, SCM_UNSPECIFIED);
- goto transform;
- case SCM_BIT8(SCM_IM_IF):
- ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED);
- break;
- case SCM_BIT8(SCM_IM_LET):
- ls = scm_cons (scm_sym_let, SCM_UNSPECIFIED);
- goto transform;
- case SCM_BIT8(SCM_IM_LETREC):
+ case SCM_BIT7 (SCM_IM_DO):
{
- SCM f, v, e, s;
- ls = scm_cons (scm_sym_letrec, SCM_UNSPECIFIED);
- transform:
+ /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
+ * where nx is the name of a local variable, ix is an initializer for
+ * the local variable, test is the test clause of the do loop, body is
+ * the body of the do loop and sx are the step clauses for the local
+ * variables. */
+ SCM names, inits, test, memoized_body, steps, bindings;
+
x = SCM_CDR (x);
- /* binding names */
- f = v = SCM_CAR (x);
+ names = SCM_CAR (x);
x = SCM_CDR (x);
- z = EXTEND_ENV (f, SCM_EOL, env);
- /* inits */
- e = scm_reverse (unmemocopy (SCM_CAR (x),
- SCM_EQ_P (SCM_CAR (ls), scm_sym_letrec) ? z : env));
- env = z;
- /* increments */
- s = SCM_EQ_P (SCM_CAR (ls), scm_sym_do)
- ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x))), env))
- : f;
+ inits = scm_reverse (unmemocopy (SCM_CAR (x), env));
+ env = SCM_EXTEND_ENV (names, SCM_EOL, env);
+ x = SCM_CDR (x);
+ test = unmemocopy (SCM_CAR (x), env);
+ x = SCM_CDR (x);
+ memoized_body = SCM_CAR (x);
+ x = SCM_CDR (x);
+ steps = scm_reverse (unmemocopy (x, env));
+
/* build transformed binding list */
- z = SCM_EOL;
- while (SCM_NIMP (v))
+ bindings = SCM_EOL;
+ while (!SCM_NULLP (names))
{
- z = scm_acons (SCM_CAR (v),
- scm_cons (SCM_CAR (e),
- SCM_EQ_P (SCM_CAR (s), SCM_CAR (v))
- ? SCM_EOL
- : scm_cons (SCM_CAR (s), SCM_EOL)),
- z);
- v = SCM_CDR (v);
- e = SCM_CDR (e);
- s = SCM_CDR (s);
- }
- z = scm_cons (z, SCM_UNSPECIFIED);
- SCM_SETCDR (ls, z);
- if (SCM_EQ_P (SCM_CAR (ls), scm_sym_do))
- {
- x = SCM_CDR (x);
- /* test clause */
- SCM_SETCDR (z, scm_cons (unmemocopy (SCM_CAR (x), env),
- SCM_UNSPECIFIED));
- z = SCM_CDR (z);
- x = (SCM) (SCM_CARLOC (SCM_CDR (x)) - 1);
- /* body forms are now to be found in SCM_CDR (x)
- (this is how *real* code look like! :) */
+ SCM name = SCM_CAR (names);
+ SCM init = SCM_CAR (inits);
+ SCM step = SCM_CAR (steps);
+ step = SCM_EQ_P (step, name) ? SCM_EOL : scm_list_1 (step);
+
+ bindings = scm_cons (scm_cons2 (name, init, step), bindings);
+
+ names = SCM_CDR (names);
+ inits = SCM_CDR (inits);
+ steps = SCM_CDR (steps);
}
+ z = scm_cons (test, SCM_UNSPECIFIED);
+ ls = scm_cons2 (scm_sym_do, bindings, z);
+
+ x = scm_cons (SCM_BOOL_F, memoized_body);
+ break;
+ }
+ case SCM_BIT7 (SCM_IM_IF):
+ ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED);
+ break;
+ case SCM_BIT7 (SCM_IM_LET):
+ {
+ /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
+ * where nx is the name of a local variable, ix is an initializer for
+ * the local variable and by are the body clauses. */
+ SCM names, inits, bindings;
+
+ x = SCM_CDR (x);
+ names = SCM_CAR (x);
+ x = SCM_CDR (x);
+ inits = scm_reverse (unmemocopy (SCM_CAR (x), env));
+ env = SCM_EXTEND_ENV (names, SCM_EOL, env);
+
+ bindings = build_binding_list (names, inits);
+ z = scm_cons (bindings, SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_let, z);
break;
}
- case SCM_BIT8(SCM_IM_LETSTAR):
+ case SCM_BIT7 (SCM_IM_LETREC):
+ {
+ /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
+ * where nx is the name of a local variable, ix is an initializer for
+ * the local variable and by are the body clauses. */
+ SCM names, inits, bindings;
+
+ x = SCM_CDR (x);
+ names = SCM_CAR (x);
+ env = SCM_EXTEND_ENV (names, SCM_EOL, env);
+ x = SCM_CDR (x);
+ inits = scm_reverse (unmemocopy (SCM_CAR (x), env));
+
+ bindings = build_binding_list (names, inits);
+ z = scm_cons (bindings, SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_letrec, z);
+ break;
+ }
+ case SCM_BIT7 (SCM_IM_LETSTAR):
{
SCM b, y;
x = SCM_CDR (x);
y = SCM_EOL;
if SCM_IMP (b)
{
- env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
+ env = SCM_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_cons (unmemocopy (SCM_CADR (b), env), SCM_EOL), env),
SCM_UNSPECIFIED);
- env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
- b = SCM_CDR (SCM_CDR (b));
+ env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
+ b = SCM_CDDR (b);
if (SCM_IMP (b))
{
SCM_SETCDR (y, SCM_EOL);
- ls = scm_cons (scm_sym_let, z = scm_cons (y, SCM_UNSPECIFIED));
+ z = scm_cons (y, SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_let, z);
break;
}
do
{
SCM_SETCDR (z, scm_acons (SCM_CAR (b),
unmemocar (
- scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env),
+ scm_list_1 (unmemocopy (SCM_CADR (b), env)), env),
SCM_UNSPECIFIED));
z = SCM_CDR (z);
- env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
- b = SCM_CDR (SCM_CDR (b));
+ env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
+ b = SCM_CDDR (b);
}
while (SCM_NIMP (b));
SCM_SETCDR (z, SCM_EOL);
letstar:
- ls = scm_cons (scm_sym_letstar, z = scm_cons (y, SCM_UNSPECIFIED));
+ z = scm_cons (y, SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_letstar, z);
break;
}
- case SCM_BIT8(SCM_IM_OR):
+ case SCM_BIT7 (SCM_IM_OR):
ls = z = scm_cons (scm_sym_or, SCM_UNSPECIFIED);
break;
- case SCM_BIT8(SCM_IM_LAMBDA):
+ case SCM_BIT7 (SCM_IM_LAMBDA):
x = SCM_CDR (x);
- ls = scm_cons (scm_sym_lambda,
- z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED));
- env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
+ z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_lambda, z);
+ env = SCM_EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
break;
- case SCM_BIT8(SCM_IM_QUOTE):
+ case SCM_BIT7 (SCM_IM_QUOTE):
ls = z = scm_cons (scm_sym_quote, SCM_UNSPECIFIED);
break;
- case SCM_BIT8(SCM_IM_SET_X):
+ case SCM_BIT7 (SCM_IM_SET_X):
ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED);
break;
- case SCM_BIT8(SCM_IM_DEFINE):
+ case SCM_BIT7 (SCM_IM_DEFINE):
{
SCM n;
x = SCM_CDR (x);
- ls = scm_cons (scm_sym_define,
- z = scm_cons (n = SCM_CAR (x), SCM_UNSPECIFIED));
- if (SCM_NNULLP (env))
- SCM_SETCAR (SCM_CAR (env), scm_cons (n, SCM_CAR (SCM_CAR (env))));
+ n = SCM_CAR (x);
+ z = scm_cons (n, SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_define, z);
+ if (!SCM_NULLP (env))
+ env = scm_cons (scm_cons (scm_cons (n, SCM_CAAR (env)),
+ SCM_CDAR (env)),
+ SCM_CDR (env));
break;
}
- case SCM_BIT8(SCM_MAKISYM (0)):
+ case SCM_BIT7 (SCM_MAKISYM (0)):
z = SCM_CAR (x);
if (!SCM_ISYMP (z))
goto unmemo;
ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED);
x = SCM_CDR (x);
goto loop;
+ case (SCM_ISYMNUM (SCM_IM_FUTURE)):
+ ls = z = scm_cons (scm_sym_future, SCM_UNSPECIFIED);
+ x = SCM_CDR (x);
+ goto loop;
+ case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
+ ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED);
+ goto loop;
default:
/* appease the Sun compiler god: */ ;
}
env);
}
loop:
- while (SCM_CELLP (x = SCM_CDR (x)) && SCM_ECONSP (x))
+ x = SCM_CDR (x);
+ while (SCM_CONSP (x))
{
- if (SCM_ISYMP (SCM_CAR (x)))
- /* skip body markers */
- continue;
- SCM_SETCDR (z, unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env),
- SCM_UNSPECIFIED),
- env));
- z = SCM_CDR (z);
+ SCM form = SCM_CAR (x);
+ if (!SCM_ISYMP (form))
+ {
+ SCM copy = scm_cons (unmemocopy (form, env), SCM_UNSPECIFIED);
+ SCM_SETCDR (z, unmemocar (copy, env));
+ z = SCM_CDR (z);
+ }
+ x = SCM_CDR (x);
}
SCM_SETCDR (z, x);
-#ifdef DEBUG_EXTENSIONS
- if (SCM_NFALSEP (p))
+ if (!SCM_FALSEP (p))
scm_whash_insert (scm_source_whash, ls, p);
-#endif
return ls;
}
SCM
scm_unmemocopy (SCM x, SCM env)
{
- if (SCM_NNULLP (env))
+ if (!SCM_NULLP (env))
/* Make a copy of the lowest frame to protect it from
modifications by SCM_IM_DEFINE */
return unmemocopy (x, scm_cons (SCM_CAR (env), SCM_CDR (env)));
return unmemocopy (x, env);
}
-#ifndef SCM_RECKLESS
int
scm_badargsp (SCM formals, SCM args)
{
- while (SCM_NIMP (formals))
+ while (!SCM_NULLP (formals))
{
- if (SCM_NCONSP (formals))
+ if (!SCM_CONSP (formals))
return 0;
- if (SCM_IMP(args))
+ if (SCM_NULLP (args))
return 1;
formals = SCM_CDR (formals);
args = SCM_CDR (args);
}
- return SCM_NNULLP (args) ? 1 : 0;
+ return !SCM_NULLP (args) ? 1 : 0;
}
-#endif
+
static int
scm_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_CONSP (l))
{
-#ifdef SCM_CAUTIOUS
- if (SCM_CONSP (l))
- {
- if (SCM_IMP (SCM_CAR (l)))
- res = SCM_EVALIM (SCM_CAR (l), env);
- else
- res = EVALCELLCAR (l, env);
- }
- else if (SCM_TYP3 (l) == scm_tc3_cons_gloc)
- {
- scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell];
- if (vcell == 0)
- res = SCM_CAR (l); /* struct planted in code */
- else
- res = SCM_PACK (vcell);
- }
- else
- goto wrongnumargs;
-#else
res = EVALCAR (l, env);
-#endif
- *lloc = scm_cons (res, SCM_EOL);
+
+ *lloc = scm_list_1 (res);
lloc = SCM_CDRLOC (*lloc);
l = SCM_CDR (l);
}
-#ifdef SCM_CAUTIOUS
- if (SCM_NNULLP (l))
- {
- wrongnumargs:
- scm_wrong_num_args (proc);
- }
-#endif
+ if (!SCM_NULLP (l))
+ scm_wrong_num_args (proc);
return results;
}
+
SCM
scm_eval_body (SCM code, SCM env)
{
SCM next;
again:
- next = code;
- while (SCM_NNULLP (next = SCM_CDR (next)))
+ next = SCM_CDR (code);
+ while (!SCM_NULLP (next))
{
if (SCM_IMP (SCM_CAR (code)))
{
if (SCM_ISYMP (SCM_CAR (code)))
{
- code = scm_m_expand_body (code, env);
+ scm_rec_mutex_lock (&source_mutex);
+ /* check for race condition */
+ if (SCM_ISYMP (SCM_CAR (code)))
+ code = scm_m_expand_body (code, env);
+ scm_rec_mutex_unlock (&source_mutex);
goto again;
}
}
else
SCM_XEVAL (SCM_CAR (code), env);
code = next;
+ next = SCM_CDR (code);
}
return SCM_XEVALCAR (code, env);
}
-
#endif /* !DEVAL */
#define SCM_APPLY scm_apply
#define PREP_APPLY(proc, args)
#define ENTER_APPLY
-#define RETURN(x) return x;
+#define RETURN(x) do { return x; } while (0)
#ifdef STACK_CHECKING
#ifndef NO_CEVAL_STACK_CHECKING
#define EVAL_STACK_CHECKING
#define ENTER_APPLY \
do { \
SCM_SET_ARGSREADY (debug);\
- if (CHECK_APPLY && SCM_TRAPS_P)\
+ if (scm_check_apply_p && SCM_TRAPS_P)\
if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (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\
{\
int first;\
tmp = scm_make_continuation (&first);\
if (first)\
- scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
+ scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
}\
+ SCM_TRAPS_P = 1;\
}\
} while (0)
#undef RETURN
-#define RETURN(e) {proc = (e); goto exit;}
+#define RETURN(e) do { proc = (e); goto exit; } while (0)
#ifdef STACK_CHECKING
#ifndef EVAL_STACK_CHECKING
#define EVAL_STACK_CHECKING
* 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;
+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}.")
+ "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
#define FUNC_NAME s_scm_eval_options_interface
{
SCM ans;
}
#undef FUNC_NAME
+
SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
(SCM setting),
"Option interface for the evaluator trap options.")
}
#undef FUNC_NAME
-SCM
-scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
+
+static SCM
+deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
{
SCM *results = lloc, res;
- while (SCM_NIMP (l))
+ while (SCM_CONSP (l))
{
-#ifdef SCM_CAUTIOUS
- if (SCM_CONSP (l))
- {
- if (SCM_IMP (SCM_CAR (l)))
- res = SCM_EVALIM (SCM_CAR (l), env);
- else
- res = EVALCELLCAR (l, env);
- }
- else if (SCM_TYP3 (l) == scm_tc3_cons_gloc)
- {
- scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell];
- if (vcell == 0)
- res = SCM_CAR (l); /* struct planted in code */
- else
- res = SCM_PACK (vcell);
- }
- else
- goto wrongnumargs;
-#else
res = EVALCAR (l, env);
-#endif
- *lloc = scm_cons (res, SCM_EOL);
+
+ *lloc = scm_list_1 (res);
lloc = SCM_CDRLOC (*lloc);
l = SCM_CDR (l);
}
-#ifdef SCM_CAUTIOUS
- if (SCM_NNULLP (l))
- {
- wrongnumargs:
- scm_wrong_num_args (proc);
- }
-#endif
+ if (!SCM_NULLP (l))
+ scm_wrong_num_args (proc);
return *results;
}
#endif /* !DEVAL */
-/* SECTION: Some local definitions for the evaluator.
+/* SECTION: This code is compiled twice.
*/
+
/* Update the toplevel environment frame ENV so that it refers to the
- current module.
-*/
+ * current module. */
#define UPDATE_TOPLEVEL_ENV(env) \
do { \
SCM p = scm_current_module_lookup_closure (); \
- if (p != SCM_CAR(env)) \
+ 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 */
-
-#define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
-/* SECTION: This is the evaluator. Like any real monster, it has
- * three heads. This code is compiled twice.
- */
+/* This is the evaluator. Like any real monster, it has three heads:
+ *
+ * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
+ * version. Both are implemented using a common code base, using the
+ * following mechanism: SCM_CEVAL is a macro, which is either defined to
+ * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
+ * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
+ * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
+ * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
+ * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
+ * are enclosed within #ifdef DEVAL ... #endif.
+ *
+ * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
+ * take two input parameters, x and env: x is a single expression to be
+ * evalutated. env is the environment in which bindings are searched.
+ *
+ * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
+ * is a single expression, it is necessarily in a tail position. If x is just
+ * a call to another function like in the expression (foo exp1 exp2 ...), the
+ * realization of that call therefore _must_not_ increase stack usage (the
+ * evaluation of exp1, exp2 etc., however, may do so). This is realized by
+ * making extensive use of 'goto' statements within the evaluator: The gotos
+ * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
+ * that SCM_CEVAL was already using. If, however, x represents some form that
+ * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
+ * then recursive calls to SCM_CEVAL are performed for all but the last
+ * expression of that sequence. */
#if 0
-
SCM
scm_ceval (SCM x, SCM env)
{}
#endif
-#if 0
+#if 0
SCM
scm_deval (SCM x, SCM env)
{}
SCM
SCM_CEVAL (SCM x, SCM env)
{
- union
- {
- SCM *lloc;
- SCM arg1;
- } t;
- SCM proc, arg2;
+ SCM proc, arg1;
#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;
+ debug.status = 0;
/*
- * 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
- * sizeof (debug.vect[0]));
+ debug.vect = (scm_t_debug_info *) alloca (scm_debug_eframe_size
+ * sizeof (scm_t_debug_info));
debug.info = debug.vect;
debug_info_end = debug.vect + scm_debug_eframe_size;
scm_last_debug_frame = &debug;
scm_report_stack_overflow ();
}
#endif
+
#ifdef DEVAL
goto start;
#endif
-loopnoap:
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+
loop:
#ifdef DEVAL
SCM_CLEAR_ARGSREADY (debug);
*
* For this to be the case, however, it is necessary that primitive
* special forms which jump back to `loop', `begin' or some similar
- * label call PREP_APPLY. A convenient way to do this is to jump to
- * `loopnoap' or `cdrxnoap'.
+ * label call PREP_APPLY.
*/
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 && SCM_TRAPS_P)
- if (SCM_ENTER_FRAME_P || (SCM_BREAKPOINTS_P && SRCBRKP (x)))
- {
- SCM tail = SCM_BOOL(SCM_TAILRECP (debug));
- SCM_SET_TAILREC (debug);
- if (SCM_CHEAPTRAPS_P)
- t.arg1 = scm_make_debugobj (&debug);
- else
- {
- int first;
- SCM val = scm_make_continuation (&first);
-
- if (first)
- t.arg1 = val;
- else
- {
- x = val;
- if (SCM_IMP (x))
- {
+ if (scm_check_entry_p && SCM_TRAPS_P)
+ {
+ if (SCM_ENTER_FRAME_P
+ || (SCM_BREAKPOINTS_P && scm_c_source_property_breakpoint_p (x)))
+ {
+ SCM stackrep;
+ SCM tail = SCM_BOOL (SCM_TAILRECP (debug));
+ SCM_SET_TAILREC (debug);
+ if (SCM_CHEAPTRAPS_P)
+ stackrep = scm_make_debugobj (&debug);
+ else
+ {
+ int first;
+ SCM val = scm_make_continuation (&first);
+
+ if (first)
+ stackrep = val;
+ else
+ {
+ x = val;
+ 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_sym_enter_frame,
- scm_cons2 (t.arg1, tail,
- scm_cons (scm_unmemocopy (x, env), SCM_EOL)),
- 0);
- }
+ else
+ /* This gives the possibility for the debugger to
+ modify the source expression before evaluation. */
+ goto dispatch;
+ }
+ }
+ SCM_TRAPS_P = 0;
+ scm_call_4 (SCM_ENTER_FRAME_HDLR,
+ scm_sym_enter_frame,
+ stackrep,
+ tail,
+ scm_unmemocopy (x, env));
+ SCM_TRAPS_P = 1;
+ }
+ }
#endif
-#if defined (USE_THREADS) || defined (DEVAL)
dispatch:
-#endif
SCM_TICK;
switch (SCM_TYP7 (x))
{
case scm_tc7_symbol:
- /* Only happens when called at top level.
- */
+ /* Only happens when called at top level. */
x = scm_cons (x, SCM_UNDEFINED);
- goto retval;
+ RETURN (*scm_lookupcar (x, env, 1));
- case SCM_BIT8(SCM_IM_AND):
+ case SCM_BIT7 (SCM_IM_AND):
x = SCM_CDR (x);
- t.arg1 = x;
- while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
- if (SCM_FALSEP (EVALCAR (x, env)))
- {
+ while (!SCM_NULLP (SCM_CDR (x)))
+ {
+ SCM test_result = EVALCAR (x, env);
+ if (SCM_FALSEP (test_result) || SCM_NILP (test_result))
RETURN (SCM_BOOL_F);
- }
- else
- x = t.arg1;
+ else
+ x = SCM_CDR (x);
+ }
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop;
- case SCM_BIT8(SCM_IM_BEGIN):
- /* (currently unused)
- cdrxnoap: */
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- /* (currently unused)
- cdrxbegin: */
+ case SCM_BIT7 (SCM_IM_BEGIN):
x = SCM_CDR (x);
+ if (SCM_NULLP (x))
+ RETURN (SCM_UNSPECIFIED);
+
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
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)))
+ if (SCM_CONSP (env) && !SCM_CONSP (SCM_CAR (env)))
{
- t.arg1 = x;
UPDATE_TOPLEVEL_ENV (env);
- while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
+ while (!SCM_NULLP (SCM_CDR (x)))
{
EVALCAR (x, env);
- x = t.arg1;
UPDATE_TOPLEVEL_ENV (env);
+ x = SCM_CDR (x);
}
goto carloop;
}
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 (SCM_CDR (x)))
{
- if (SCM_IMP (SCM_CAR (x)))
+ SCM form = SCM_CAR (x);
+ if (SCM_IMP (form))
{
- if (SCM_ISYMP (SCM_CAR (x)))
+ if (SCM_ISYMP (form))
{
- x = scm_m_expand_body (x, env);
+ scm_rec_mutex_lock (&source_mutex);
+ /* check for race condition */
+ if (SCM_ISYMP (SCM_CAR (x)))
+ x = scm_m_expand_body (x, env);
+ scm_rec_mutex_unlock (&source_mutex);
goto nontoplevel_begin;
}
else
- SCM_EVALIM2 (SCM_CAR(x));
+ SCM_VALIDATE_NON_EMPTY_COMBINATION (form);
}
else
- SCM_CEVAL (SCM_CAR (x), env);
- x = t.arg1;
+ SCM_CEVAL (form, env);
+ x = SCM_CDR (x);
}
- carloop: /* scm_eval car of last form in list */
- if (SCM_NCELLP (SCM_CAR (x)))
- {
- x = SCM_CAR (x);
- RETURN (SCM_IMP (x) ? SCM_EVALIM (x, env) : SCM_GLOC_VAL (x))
- }
+ carloop:
+ {
+ /* scm_eval last form in list */
+ SCM last_form = SCM_CAR (x);
- if (SCM_SYMBOLP (SCM_CAR (x)))
- {
- retval:
- RETURN (*scm_lookupcar (x, env, 1))
- }
+ if (SCM_CONSP (last_form))
+ {
+ /* This is by far the most frequent case. */
+ x = last_form;
+ goto loop; /* tail recurse */
+ }
+ else if (SCM_IMP (last_form))
+ RETURN (SCM_EVALIM (last_form, env));
+ else if (SCM_VARIABLEP (last_form))
+ RETURN (SCM_VARIABLE_REF (last_form));
+ else if (SCM_SYMBOLP (last_form))
+ RETURN (*scm_lookupcar (x, env, 1));
+ else
+ RETURN (last_form);
+ }
- x = SCM_CAR (x);
- goto loop; /* tail recurse */
+
+ case SCM_BIT7 (SCM_IM_CASE):
+ x = SCM_CDR (x);
+ {
+ SCM key = EVALCAR (x, env);
+ x = SCM_CDR (x);
+ while (!SCM_NULLP (x))
+ {
+ SCM clause = SCM_CAR (x);
+ SCM labels = SCM_CAR (clause);
+ if (SCM_EQ_P (labels, scm_sym_else))
+ {
+ x = SCM_CDR (clause);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
+ while (!SCM_NULLP (labels))
+ {
+ SCM label = SCM_CAR (labels);
+ if (SCM_EQ_P (label, key) || !SCM_FALSEP (scm_eqv_p (label, key)))
+ {
+ x = SCM_CDR (clause);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
+ labels = SCM_CDR (labels);
+ }
+ x = SCM_CDR (x);
+ }
+ }
+ RETURN (SCM_UNSPECIFIED);
- case SCM_BIT8(SCM_IM_CASE):
+ case SCM_BIT7 (SCM_IM_COND):
x = SCM_CDR (x);
- t.arg1 = EVALCAR (x, env);
- while (SCM_NIMP (x = SCM_CDR (x)))
+ while (!SCM_NULLP (x))
{
- proc = SCM_CAR (x);
- if (SCM_EQ_P (scm_sym_else, SCM_CAR (proc)))
+ SCM clause = SCM_CAR (x);
+ if (SCM_EQ_P (SCM_CAR (clause), scm_sym_else))
{
- x = SCM_CDR (proc);
+ x = SCM_CDR (clause);
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto begin;
}
- proc = SCM_CAR (proc);
- while (SCM_NIMP (proc))
+ else
{
- if (CHECK_EQVISH (SCM_CAR (proc), t.arg1))
+ arg1 = EVALCAR (clause, env);
+ if (!SCM_FALSEP (arg1) && !SCM_NILP (arg1))
{
- x = SCM_CDR (SCM_CAR (x));
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
+ x = SCM_CDR (clause);
+ if (SCM_NULLP (x))
+ RETURN (arg1);
+ else if (!SCM_EQ_P (SCM_CAR (x), scm_sym_arrow))
+ {
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
+ else
+ {
+ proc = SCM_CDR (x);
+ proc = EVALCAR (proc, env);
+ SCM_ASRTGO (!SCM_IMP (proc), badfun);
+ PREP_APPLY (proc, scm_list_1 (arg1));
+ ENTER_APPLY;
+ if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))
+ goto umwrongnumargs;
+ else
+ goto evap1;
+ }
}
- proc = SCM_CDR (proc);
+ x = SCM_CDR (x);
}
}
- RETURN (SCM_UNSPECIFIED)
+ RETURN (SCM_UNSPECIFIED);
- case SCM_BIT8(SCM_IM_COND):
- while (SCM_NIMP (x = SCM_CDR (x)))
- {
- proc = SCM_CAR (x);
- t.arg1 = EVALCAR (proc, env);
- if (SCM_NFALSEP (t.arg1))
+ case SCM_BIT7 (SCM_IM_DO):
+ x = SCM_CDR (x);
+ {
+ /* Compute the initialization values and the initial environment. */
+ SCM init_forms = SCM_CADR (x);
+ SCM init_values = SCM_EOL;
+ while (!SCM_NULLP (init_forms))
+ {
+ init_values = scm_cons (EVALCAR (init_forms, env), init_values);
+ init_forms = SCM_CDR (init_forms);
+ }
+ env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
+ }
+ x = SCM_CDDR (x);
+ {
+ SCM test_form = SCM_CAR (x);
+ SCM body_forms = SCM_CADR (x);
+ SCM step_forms = SCM_CDDR (x);
+
+ SCM test_result = EVALCAR (test_form, env);
+
+ while (SCM_FALSEP (test_result) || SCM_NILP (test_result))
+ {
{
- x = SCM_CDR (proc);
- if SCM_NULLP (x)
- {
- RETURN (t.arg1)
- }
- if (! SCM_EQ_P (scm_sym_arrow, SCM_CAR (x)))
+ /* Evaluate body forms. */
+ SCM temp_forms;
+ for (temp_forms = body_forms;
+ !SCM_NULLP (temp_forms);
+ temp_forms = SCM_CDR (temp_forms))
{
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
+ SCM form = SCM_CAR (temp_forms);
+ /* Dirk:FIXME: We only need to eval forms, that may have a
+ * side effect here. This is only true for forms that start
+ * with a pair. All others are just constants. However,
+ * since in the common case there is no constant expression
+ * in a body of a do form, we just check for immediates here
+ * and have SCM_CEVAL take care of other cases. In the long
+ * run it would make sense to get rid of this test and have
+ * the macro transformer of 'do' eliminate all forms that
+ * have no sideeffect. */
+ if (!SCM_IMP (form))
+ SCM_CEVAL (form, env);
}
- 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;
}
- }
- RETURN (SCM_UNSPECIFIED)
-
- case SCM_BIT8(SCM_IM_DO):
- x = SCM_CDR (x);
- proc = SCM_CAR (SCM_CDR (x)); /* inits */
- t.arg1 = SCM_EOL; /* values */
- while (SCM_NIMP (proc))
- {
- t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
- proc = SCM_CDR (proc);
- }
- env = EXTEND_ENV (SCM_CAR (x), t.arg1, env);
- x = SCM_CDR (SCM_CDR (x));
- while (proc = SCM_CAR (x), SCM_FALSEP (EVALCAR (proc, env)))
- {
- for (proc = SCM_CADR (x); SCM_NIMP (proc); proc = SCM_CDR (proc))
{
- t.arg1 = SCM_CAR (proc); /* body */
- SIDEVAL (t.arg1, env);
+ /* Evaluate the step expressions. */
+ SCM temp_forms;
+ SCM step_values = SCM_EOL;
+ for (temp_forms = step_forms;
+ !SCM_NULLP (temp_forms);
+ temp_forms = SCM_CDR (temp_forms))
+ {
+ SCM value = EVALCAR (temp_forms, env);
+ step_values = scm_cons (value, step_values);
+ }
+ env = SCM_EXTEND_ENV (SCM_CAAR (env),
+ step_values,
+ SCM_CDR (env));
}
- for (t.arg1 = SCM_EOL, proc = SCM_CDDR (x);
- SCM_NIMP (proc);
- proc = SCM_CDR (proc))
- t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); /* steps */
- env = EXTEND_ENV (SCM_CAR (SCM_CAR (env)), t.arg1, SCM_CDR (env));
- }
- x = SCM_CDR (proc);
+
+ test_result = EVALCAR (test_form, env);
+ }
+ }
+ x = SCM_CDAR (x);
if (SCM_NULLP (x))
RETURN (SCM_UNSPECIFIED);
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto nontoplevel_begin;
- case SCM_BIT8(SCM_IM_IF):
+ case SCM_BIT7 (SCM_IM_IF):
x = SCM_CDR (x);
- if (SCM_NFALSEP (EVALCAR (x, env)))
- x = SCM_CDR (x);
- else if (SCM_IMP (x = SCM_CDR (SCM_CDR (x))))
- {
- RETURN (SCM_UNSPECIFIED);
- }
+ {
+ SCM test_result = EVALCAR (x, env);
+ if (!SCM_FALSEP (test_result) && !SCM_NILP (test_result))
+ x = SCM_CDR (x);
+ else
+ {
+ x = SCM_CDDR (x);
+ if (SCM_NULLP (x))
+ RETURN (SCM_UNSPECIFIED);
+ }
+ }
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop;
- case SCM_BIT8(SCM_IM_LET):
+ case SCM_BIT7 (SCM_IM_LET):
x = SCM_CDR (x);
- proc = SCM_CAR (SCM_CDR (x));
- t.arg1 = SCM_EOL;
- do
- {
- t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
- }
- while (SCM_NIMP (proc = SCM_CDR (proc)));
- env = EXTEND_ENV (SCM_CAR (x), t.arg1, env);
- x = SCM_CDR (x);
- goto nontoplevel_cdrxnoap;
+ {
+ SCM init_forms = SCM_CADR (x);
+ SCM init_values = SCM_EOL;
+ do
+ {
+ init_values = scm_cons (EVALCAR (init_forms, env), init_values);
+ init_forms = SCM_CDR (init_forms);
+ }
+ while (!SCM_NULLP (init_forms));
+ env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
+ }
+ x = SCM_CDDR (x);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto nontoplevel_begin;
- case SCM_BIT8(SCM_IM_LETREC):
+ case SCM_BIT7 (SCM_IM_LETREC):
x = SCM_CDR (x);
- env = EXTEND_ENV (SCM_CAR (x), scm_undefineds, env);
+ env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env);
x = SCM_CDR (x);
- proc = SCM_CAR (x);
- t.arg1 = SCM_EOL;
- do
- {
- t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
- }
- while (SCM_NIMP (proc = SCM_CDR (proc)));
- SCM_SETCDR (SCM_CAR (env), t.arg1);
- goto nontoplevel_cdrxnoap;
+ {
+ SCM init_forms = SCM_CAR (x);
+ SCM init_values = SCM_EOL;
+ do
+ {
+ init_values = scm_cons (EVALCAR (init_forms, env), init_values);
+ init_forms = SCM_CDR (init_forms);
+ }
+ while (!SCM_NULLP (init_forms));
+ SCM_SETCDR (SCM_CAR (env), init_values);
+ }
+ x = SCM_CDR (x);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto nontoplevel_begin;
- case SCM_BIT8(SCM_IM_LETSTAR):
+ case SCM_BIT7 (SCM_IM_LETSTAR):
x = SCM_CDR (x);
- proc = SCM_CAR (x);
- if (SCM_IMP (proc))
- {
- env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
- goto nontoplevel_cdrxnoap;
- }
- do
- {
- t.arg1 = SCM_CAR (proc);
- proc = SCM_CDR (proc);
- env = EXTEND_ENV (t.arg1, EVALCAR (proc, env), env);
- }
- while (SCM_NIMP (proc = SCM_CDR (proc)));
- goto nontoplevel_cdrxnoap;
+ {
+ SCM bindings = SCM_CAR (x);
+ if (SCM_NULLP (bindings))
+ env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env);
+ else
+ {
+ do
+ {
+ SCM name = SCM_CAR (bindings);
+ SCM init = SCM_CDR (bindings);
+ env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env);
+ bindings = SCM_CDR (init);
+ }
+ while (!SCM_NULLP (bindings));
+ }
+ }
+ x = SCM_CDR (x);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto nontoplevel_begin;
+
- case SCM_BIT8(SCM_IM_OR):
+ case SCM_BIT7 (SCM_IM_OR):
x = SCM_CDR (x);
- t.arg1 = x;
- while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
+ while (!SCM_NULLP (SCM_CDR (x)))
{
- x = EVALCAR (x, env);
- if (SCM_NFALSEP (x))
- {
- RETURN (x);
- }
- x = t.arg1;
+ SCM val = EVALCAR (x, env);
+ if (!SCM_FALSEP (val) && !SCM_NILP (val))
+ RETURN (val);
+ else
+ x = SCM_CDR (x);
}
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop;
- case SCM_BIT8(SCM_IM_LAMBDA):
+ case SCM_BIT7 (SCM_IM_LAMBDA):
RETURN (scm_closure (SCM_CDR (x), env));
- case SCM_BIT8(SCM_IM_QUOTE):
- RETURN (SCM_CAR (SCM_CDR (x)));
+ case SCM_BIT7 (SCM_IM_QUOTE):
+ RETURN (SCM_CADR (x));
- case SCM_BIT8(SCM_IM_SET_X):
- x = SCM_CDR (x);
- proc = SCM_CAR (x);
- switch (SCM_ITAG3 (proc))
- {
- case scm_tc3_cons:
- t.lloc = scm_lookupcar (x, env, 1);
- break;
- case scm_tc3_cons_gloc:
- t.lloc = SCM_GLOC_VAL_LOC (proc);
- break;
-#ifdef MEMOIZE_LOCALS
- case scm_tc3_imm24:
- t.lloc = scm_ilookup (proc, env);
- break;
-#endif
- }
+ case SCM_BIT7 (SCM_IM_SET_X):
x = SCM_CDR (x);
- *t.lloc = EVALCAR (x, env);
-#ifdef SICP
- RETURN (*t.lloc);
-#else
+ {
+ SCM *location;
+ SCM variable = SCM_CAR (x);
+ if (SCM_ILOCP (variable))
+ location = scm_ilookup (variable, env);
+ else if (SCM_VARIABLEP (variable))
+ location = SCM_VARIABLE_LOC (variable);
+ else /* (SCM_SYMBOLP (variable)) is known to be true */
+ location = scm_lookupcar (x, env, 1);
+ x = SCM_CDR (x);
+ *location = EVALCAR (x, env);
+ }
RETURN (SCM_UNSPECIFIED);
-#endif
- case SCM_BIT8(SCM_IM_DEFINE): /* only for internal defines */
+ case SCM_BIT7 (SCM_IM_DEFINE): /* only for internal defines */
scm_misc_error (NULL, "Bad define placement", SCM_EOL);
+
/* new syntactic forms go here. */
- case SCM_BIT8(SCM_MAKISYM (0)):
+ case SCM_BIT7 (SCM_MAKISYM (0)):
proc = SCM_CAR (x);
SCM_ASRTGO (SCM_ISYMP (proc), badfun);
- switch SCM_ISYMNUM (proc)
+ switch (SCM_ISYMNUM (proc))
{
+
+
case (SCM_ISYMNUM (SCM_IM_APPLY)):
proc = SCM_CDR (x);
proc = EVALCAR (proc, env);
- SCM_ASRTGO (SCM_NIMP (proc), badfun);
+ SCM_ASRTGO (!SCM_IMP (proc), badfun);
if (SCM_CLOSUREP (proc))
{
- SCM argl, tl;
PREP_APPLY (proc, SCM_EOL);
- t.arg1 = SCM_CDR (SCM_CDR (x));
- t.arg1 = EVALCAR (t.arg1, env);
+ arg1 = SCM_CDDR (x);
+ arg1 = EVALCAR (arg1, env);
+ apply_closure:
+ /* Go here to tail-call a closure. PROC is the closure
+ and ARG1 is the list of arguments. Do not forget to
+ call PREP_APPLY. */
+ {
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
#ifdef DEVAL
- debug.info->a.args = t.arg1;
-#endif
-#ifndef SCM_RECKLESS
- if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), t.arg1))
- goto wrongnumargs;
+ debug.info->a.args = arg1;
#endif
- ENTER_APPLY;
- /* Copy argument list */
- if (SCM_IMP (t.arg1))
- argl = t.arg1;
- else
- {
- argl = tl = scm_cons (SCM_CAR (t.arg1), SCM_UNSPECIFIED);
- while (SCM_NIMP (t.arg1 = SCM_CDR (t.arg1))
- && SCM_CONSP (t.arg1))
- {
- SCM_SETCDR (tl, scm_cons (SCM_CAR (t.arg1),
- SCM_UNSPECIFIED));
- tl = SCM_CDR (tl);
- }
- SCM_SETCDR (tl, t.arg1);
- }
+ if (scm_badargsp (formals, arg1))
+ scm_wrong_num_args (proc);
+ ENTER_APPLY;
+ /* Copy argument list */
+ if (SCM_NULL_OR_NIL_P (arg1))
+ env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
+ else
+ {
+ SCM args = scm_list_1 (SCM_CAR (arg1));
+ SCM tail = args;
+ arg1 = SCM_CDR (arg1);
+ while (!SCM_NULL_OR_NIL_P (arg1))
+ {
+ SCM new_tail = scm_list_1 (SCM_CAR (arg1));
+ SCM_SETCDR (tail, new_tail);
+ tail = new_tail;
+ arg1 = SCM_CDR (arg1);
+ }
+ env = SCM_EXTEND_ENV (formals, args, SCM_ENV (proc));
+ }
- env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), argl, SCM_ENV (proc));
- x = SCM_CODE (proc);
- goto nontoplevel_cdrxbegin;
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
+ }
+ }
+ else
+ {
+ proc = f_apply;
+ goto evapply;
}
- proc = scm_f_apply;
- goto evapply;
+
case (SCM_ISYMNUM (SCM_IM_CONT)):
{
int first;
SCM val = scm_make_continuation (&first);
- if (first)
- t.arg1 = val;
- else
+ if (!first)
RETURN (val);
+ else
+ {
+ arg1 = val;
+ proc = SCM_CDR (x);
+ proc = scm_eval_car (proc, env);
+ SCM_ASRTGO (SCM_NIMP (proc), badfun);
+ PREP_APPLY (proc, scm_list_1 (arg1));
+ ENTER_APPLY;
+ if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))
+ goto umwrongnumargs;
+ goto evap1;
+ }
}
- 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)):
- RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)))
+ RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));
- case (SCM_ISYMNUM (SCM_IM_DISPATCH)):
- proc = SCM_CADR (x); /* unevaluated operands */
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- if (SCM_IMP (proc))
- arg2 = *scm_ilookup (proc, env);
- else if (SCM_NCONSP (proc))
- {
- if (SCM_NCELLP (proc))
- arg2 = SCM_GLOC_VAL (proc);
- else
- arg2 = *scm_lookupcar (SCM_CDR (x), env, 1);
- }
- else
- {
- arg2 = scm_cons (EVALCAR (proc, env), SCM_EOL);
- t.lloc = SCM_CDRLOC (arg2);
- while (SCM_NIMP (proc = SCM_CDR (proc)))
- {
- *t.lloc = scm_cons (EVALCAR (proc, env), SCM_EOL);
- t.lloc = SCM_CDRLOC (*t.lloc);
- }
- }
+
+ case (SCM_ISYMNUM (SCM_IM_FUTURE)):
+ RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env)));
+
+
+ /* PLACEHOLDER for case (SCM_ISYMNUM (SCM_IM_DISPATCH)): The
+ following code (type_dispatch) is intended to be the tail
+ of the case clause for the internal macro
+ SCM_IM_DISPATCH. Please don't remove it from this
+ location without discussing it with Mikael
+ <djurfeldt@nada.kth.se> */
- type_dispatch:
- /* The type dispatch code is duplicated here
+ /* The type dispatch code is duplicated below
* (c.f. objects.c:scm_mcache_compute_cmethod) since that
- * cuts down execution time for type dispatch to 50%.
- */
- {
- int i, n, end, mask;
- SCM z = SCM_CDDR (x);
- n = SCM_INUM (SCM_CAR (z)); /* maximum number of specializers */
- proc = SCM_CADR (z);
+ * cuts down execution time for type dispatch to 50%. */
+ type_dispatch: /* inputs: x, arg1 */
+ /* Type dispatch means to determine from the types of the function
+ * arguments (i. e. the 'signature' of the call), which method from
+ * a generic function is to be called. This process of selecting
+ * the right method takes some time. To speed it up, guile uses
+ * caching: Together with the macro call to dispatch the signatures
+ * of some previous calls to that generic function from the same
+ * place are stored (in the code!) in a cache that we call the
+ * 'method cache'. This is done since it is likely, that
+ * consecutive calls to dispatch from that position in the code will
+ * have the same signature. Thus, the type dispatch works as
+ * follows: First, determine a hash value from the signature of the
+ * actual arguments. Second, use this hash value as an index to
+ * find that same signature in the method cache stored at this
+ * position in the code. If found, you have also found the
+ * corresponding method that belongs to that signature. If the
+ * signature is not found in the method cache, you have to perform a
+ * full search over all signatures stored with the generic
+ * function. */
+ {
+ unsigned long int specializers;
+ unsigned long int hash_value;
+ unsigned long int cache_end_pos;
+ unsigned long int mask;
+ SCM method_cache;
- if (SCM_NIMP (proc))
- {
- /* Prepare for linear search */
- mask = -1;
- i = 0;
- 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)));
- proc = SCM_CADR (z);
- i = 0;
- t.arg1 = arg2;
- if (SCM_NIMP (t.arg1))
- do
+ {
+ SCM z = SCM_CDDR (x);
+ SCM tmp = SCM_CADR (z);
+ specializers = SCM_INUM (SCM_CAR (z));
+
+ /* Compute a hash value for searching the method cache. There
+ * are two variants for computing the hash value, a (rather)
+ * complicated one, and a simple one. For the complicated one
+ * explained below, tmp holds a number that is used in the
+ * computation. */
+ if (SCM_INUMP (tmp))
+ {
+ /* Use the signature of the actual arguments to determine
+ * the hash value. This is done as follows: Each class has
+ * an array of random numbers, that are determined when the
+ * class is created. The integer 'hashset' is an index into
+ * that array of random numbers. Now, from all classes that
+ * are part of the signature of the actual arguments, the
+ * random numbers at index 'hashset' are taken and summed
+ * up, giving the hash value. The value of 'hashset' is
+ * stored at the call to dispatch. This allows to have
+ * different 'formulas' for calculating the hash value at
+ * different places where dispatch is called. This allows
+ * to optimize the hash formula at every individual place
+ * where dispatch is called, such that hopefully the hash
+ * value that is computed will directly point to the right
+ * method in the method cache. */
+ unsigned long int hashset = SCM_INUM (tmp);
+ unsigned long int counter = specializers + 1;
+ SCM tmp_arg = arg1;
+ hash_value = 0;
+ while (!SCM_NULLP (tmp_arg) && counter != 0)
{
- i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t.arg1)))
- [scm_si_hashsets + hashset];
- t.arg1 = SCM_CDR (t.arg1);
+ SCM class = scm_class_of (SCM_CAR (tmp_arg));
+ hash_value += SCM_INSTANCE_HASH (class, hashset);
+ tmp_arg = SCM_CDR (tmp_arg);
+ counter--;
}
- while (j-- && SCM_NIMP (t.arg1));
- i &= mask;
- end = i;
- }
+ z = SCM_CDDR (z);
+ method_cache = SCM_CADR (z);
+ mask = SCM_INUM (SCM_CAR (z));
+ hash_value &= mask;
+ cache_end_pos = hash_value;
+ }
+ else
+ {
+ /* This method of determining the hash value is much
+ * simpler: Set the hash value to zero and just perform a
+ * linear search through the method cache. */
+ method_cache = tmp;
+ mask = (unsigned long int) ((long) -1);
+ hash_value = 0;
+ cache_end_pos = SCM_VECTOR_LENGTH (method_cache);
+ }
+ }
- /* Search for match */
- do
- {
- int j = n;
- z = SCM_VELTS (proc)[i];
- t.arg1 = arg2; /* list of arguments */
- if (SCM_NIMP (t.arg1))
- do
+ {
+ /* Search the method cache for a method with a matching
+ * signature. Start the search at position 'hash_value'. The
+ * hashing implementation uses linear probing for conflict
+ * resolution, that is, if the signature in question is not
+ * found at the starting index in the hash table, the next table
+ * entry is tried, and so on, until in the worst case the whole
+ * cache has been searched, but still the signature has not been
+ * found. */
+ SCM z;
+ do
+ {
+ SCM args = arg1; /* list of arguments */
+ z = SCM_VELTS (method_cache)[hash_value];
+ while (!SCM_NULLP (args))
{
/* More arguments than specifiers => CLASS != ENV */
- if (! SCM_EQ_P (scm_class_of (SCM_CAR (t.arg1)), SCM_CAR (z)))
+ SCM class_of_arg = scm_class_of (SCM_CAR (args));
+ if (!SCM_EQ_P (class_of_arg, SCM_CAR (z)))
goto next_method;
- t.arg1 = SCM_CDR (t.arg1);
+ args = SCM_CDR (args);
z = SCM_CDR (z);
}
- 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;
- apply_cmethod:
- env = EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z)),
- arg2,
- SCM_CMETHOD_ENV (z));
- x = SCM_CMETHOD_CODE (z);
- goto nontoplevel_cdrxbegin;
- next_method:
- i = (i + 1) & mask;
- } while (i != end);
-
- z = scm_memoize_method (x, arg2);
- goto apply_cmethod;
+ /* Fewer arguments than specifiers => CAR != ENV */
+ if (SCM_NULLP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z)))
+ goto apply_cmethod;
+ next_method:
+ hash_value = (hash_value + 1) & mask;
+ } while (hash_value != cache_end_pos);
+
+ /* No appropriate method was found in the cache. */
+ z = scm_memoize_method (x, arg1);
+
+ apply_cmethod: /* inputs: z, arg1 */
+ {
+ SCM formals = SCM_CMETHOD_FORMALS (z);
+ env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
+ x = SCM_CMETHOD_BODY (z);
+ goto nontoplevel_begin;
+ }
+ }
}
+
case (SCM_ISYMNUM (SCM_IM_SLOT_REF)):
x = SCM_CDR (x);
- t.arg1 = EVALCAR (x, env);
- RETURN (SCM_PACK (SCM_STRUCT_DATA (t.arg1) [SCM_INUM (SCM_CADR (x))]))
-
+ {
+ SCM instance = EVALCAR (x, env);
+ unsigned long int slot = SCM_INUM (SCM_CADR (x));
+ RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
+ }
+
+
case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X)):
x = SCM_CDR (x);
- t.arg1 = EVALCAR (x, env);
- x = SCM_CDR (x);
- proc = SCM_CDR (x);
- SCM_STRUCT_DATA (t.arg1) [SCM_INUM (SCM_CAR (x))]
- = SCM_UNPACK (EVALCAR (proc, env));
- RETURN (SCM_UNSPECIFIED)
+ {
+ SCM instance = EVALCAR (x, env);
+ unsigned long int slot = SCM_INUM (SCM_CADR (x));
+ SCM value = EVALCAR (SCM_CDDR (x), env);
+ SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (value);
+ RETURN (SCM_UNSPECIFIED);
+ }
+
+
+#if SCM_ENABLE_ELISP
case (SCM_ISYMNUM (SCM_IM_NIL_COND)):
- proc = SCM_CDR (x);
- while (SCM_NIMP (x = SCM_CDR (proc)))
- {
- if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env))
- || SCM_EQ_P (t.arg1, scm_lisp_nil)))
- {
- if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED))
- RETURN (t.arg1);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
- }
- proc = SCM_CDR (x);
- }
- x = proc;
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
-
- case (SCM_ISYMNUM (SCM_IM_NIL_IFY)):
- x = SCM_CDR (x);
- RETURN ((SCM_FALSEP (proc = EVALCAR (x, env)) || SCM_NULLP (proc))
- ? scm_lisp_nil
- : proc)
-
- case (SCM_ISYMNUM (SCM_IM_T_IFY)):
- x = SCM_CDR (x);
- RETURN (SCM_NFALSEP (EVALCAR (x, env)) ? scm_lisp_t : scm_lisp_nil)
-
- case (SCM_ISYMNUM (SCM_IM_0_COND)):
- proc = SCM_CDR (x);
- while (SCM_NIMP (x = SCM_CDR (proc)))
- {
- if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env))
- || SCM_EQ_P (t.arg1, SCM_INUM0)))
- {
- if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED))
- RETURN (t.arg1);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
- }
- proc = SCM_CDR (x);
- }
- x = proc;
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
+ {
+ SCM test_form = SCM_CDR (x);
+ x = SCM_CDR (test_form);
+ while (!SCM_NULL_OR_NIL_P (x))
+ {
+ SCM test_result = EVALCAR (test_form, env);
+ if (!(SCM_FALSEP (test_result)
+ || SCM_NULL_OR_NIL_P (test_result)))
+ {
+ if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED))
+ RETURN (test_result);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto carloop;
+ }
+ else
+ {
+ test_form = SCM_CDR (x);
+ x = SCM_CDR (test_form);
+ }
+ }
+ x = test_form;
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto carloop;
+ }
- case (SCM_ISYMNUM (SCM_IM_0_IFY)):
- x = SCM_CDR (x);
- RETURN (SCM_FALSEP (proc = EVALCAR (x, env))
- ? SCM_INUM0
- : proc)
-
- case (SCM_ISYMNUM (SCM_IM_1_IFY)):
- x = SCM_CDR (x);
- RETURN (SCM_NFALSEP (EVALCAR (x, env))
- ? SCM_MAKINUM (1)
- : SCM_INUM0)
+#endif /* SCM_ENABLE_ELISP */
case (SCM_ISYMNUM (SCM_IM_BIND)):
- x = SCM_CDR (x);
+ {
+ SCM vars, exps, vals;
- t.arg1 = SCM_CAR (x);
- arg2 = SCM_CDAR (env);
- while (SCM_NIMP (arg2))
- {
- proc = SCM_GLOC_VAL (SCM_CAR (t.arg1));
- SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t.arg1)) - 1L),
- SCM_CAR (arg2));
- SCM_SETCAR (arg2, proc);
- t.arg1 = SCM_CDR (t.arg1);
- arg2 = SCM_CDR (arg2);
- }
- t.arg1 = SCM_CAR (x);
- scm_dynwinds = scm_acons (t.arg1, SCM_CDAR (env), scm_dynwinds);
-
- arg2 = x = SCM_CDR (x);
- while (SCM_NNULLP (arg2 = SCM_CDR (arg2)))
- {
- SIDEVAL (SCM_CAR (x), env);
- x = arg2;
- }
- proc = EVALCAR (x, env);
-
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- arg2 = SCM_CDAR (env);
- while (SCM_NIMP (arg2))
- {
- SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t.arg1)) - 1L),
- SCM_CAR (arg2));
- t.arg1 = SCM_CDR (t.arg1);
- arg2 = SCM_CDR (arg2);
- }
+ x = SCM_CDR (x);
+ vars = SCM_CAAR (x);
+ exps = SCM_CDAR (x);
+
+ vals = SCM_EOL;
+
+ while (SCM_NIMP (exps))
+ {
+ vals = scm_cons (EVALCAR (exps, env), vals);
+ exps = SCM_CDR (exps);
+ }
+
+ scm_swap_bindings (vars, vals);
+ scm_dynwinds = scm_acons (vars, vals, scm_dynwinds);
- RETURN (proc)
+ /* Ignore all but the last evaluation result. */
+ for (x = SCM_CDR (x); !SCM_NULLP (SCM_CDR (x)); x = SCM_CDR (x))
+ {
+ if (SCM_CONSP (SCM_CAR (x)))
+ SCM_CEVAL (SCM_CAR (x), env);
+ }
+ proc = EVALCAR (x, env);
+ scm_dynwinds = SCM_CDR (scm_dynwinds);
+ scm_swap_bindings (vars, vals);
+
+ 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);
+ arg1 = SCM_APPLY (x, SCM_EOL, SCM_EOL);
+ if (SCM_VALUESP (arg1))
+ arg1 = scm_struct_ref (arg1, SCM_INUM0);
+ else
+ arg1 = scm_list_1 (arg1);
+ if (SCM_CLOSUREP (proc))
+ {
+ PREP_APPLY (proc, arg1);
+ goto apply_closure;
+ }
+ return SCM_APPLY (proc, arg1, SCM_EOL);
+ }
+
+
default:
goto badfun;
}
default:
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
+#if SCM_HAVE_ARRAYS
case scm_tc7_bvect:
case scm_tc7_byvect:
case scm_tc7_svect:
case scm_tc7_fvect:
case scm_tc7_dvect:
case scm_tc7_cvect:
-#ifdef HAVE_LONG_LONGS
+#if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect:
#endif
#endif
case scm_tc7_string:
- case scm_tc7_substring:
case scm_tc7_smob:
case scm_tcs_closures:
case scm_tc7_cclo:
case scm_tc7_pws:
case scm_tcs_subrs:
+ case scm_tcs_struct:
RETURN (x);
-#ifdef MEMOIZE_LOCALS
- case SCM_BIT8(SCM_ILOC00):
+ case scm_tc7_variable:
+ RETURN (SCM_VARIABLE_REF(x));
+
+ case SCM_BIT7 (SCM_ILOC00):
proc = *scm_ilookup (SCM_CAR (x), env);
SCM_ASRTGO (SCM_NIMP (proc), badfun);
-#ifndef SCM_RECKLESS
-#ifdef SCM_CAUTIOUS
goto checkargs;
-#endif
-#endif
- break;
-#endif /* ifdef MEMOIZE_LOCALS */
-
-
- case scm_tcs_cons_gloc: {
- scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell];
- if (vcell == 0) {
- /* This is a struct implanted in the code, not a gloc. */
- RETURN (x);
- } else {
- proc = SCM_PACK (vcell);
- SCM_ASRTGO (SCM_NIMP (proc), badfun);
-#ifndef SCM_RECKLESS
-#ifdef SCM_CAUTIOUS
- goto checkargs;
-#endif
-#endif
- }
- break;
- }
case scm_tcs_cons_nimcar:
if (SCM_SYMBOLP (SCM_CAR (x)))
{
-#ifdef USE_THREADS
- t.lloc = scm_lookupcar1 (x, env, 1);
- if (t.lloc == NULL)
- {
- /* we have lost the race, start again. */
- goto dispatch;
- }
- proc = *t.lloc;
-#else
- proc = *scm_lookupcar (x, env, 1);
-#endif
+ SCM orig_sym = SCM_CAR (x);
+ {
+ SCM *location = scm_lookupcar1 (x, env, 1);
+ if (location == NULL)
+ {
+ /* we have lost the race, start again. */
+ goto dispatch;
+ }
+ proc = *location;
+ }
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);
-
- handle_a_macro:
+ SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of
+ lookupcar */
+ handle_a_macro: /* inputs: x, env, proc */
#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,
+ 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);
+ if (scm_ilength (arg1) <= 0)
+ arg1 = scm_list_2 (SCM_IM_BEGIN, arg1);
#ifdef DEVAL
- if (!SCM_CLOSUREP (SCM_CDR (proc)))
+ if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
{
SCM_DEFER_INTS;
- SCM_SETCAR (x, SCM_CAR (t.arg1));
- SCM_SETCDR (x, SCM_CDR (t.arg1));
+ SCM_SETCAR (x, SCM_CAR (arg1));
+ SCM_SETCDR (x, SCM_CDR (arg1));
SCM_ALLOW_INTS;
goto dispatch;
}
SCM_CDR (x));
#endif
SCM_DEFER_INTS;
- SCM_SETCAR (x, SCM_CAR (t.arg1));
- SCM_SETCDR (x, SCM_CDR (t.arg1));
+ SCM_SETCAR (x, SCM_CAR (arg1));
+ SCM_SETCDR (x, SCM_CDR (arg1));
SCM_ALLOW_INTS;
- goto loopnoap;
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto loop;
+#if SCM_ENABLE_DEPRECATED == 1
case 1:
- if (SCM_NIMP (x = t.arg1))
- goto loopnoap;
+ x = arg1;
+ if (SCM_NIMP (x))
+ {
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto loop;
+ }
+ else
+ RETURN (arg1);
+#endif
case 0:
- RETURN (t.arg1);
+ RETURN (arg1);
}
}
}
else
proc = SCM_CEVAL (SCM_CAR (x), env);
- SCM_ASRTGO (SCM_NIMP (proc), badfun);
-#ifndef SCM_RECKLESS
-#ifdef SCM_CAUTIOUS
+ SCM_ASRTGO (!SCM_IMP (proc), badfun);
+
checkargs:
-#endif
if (SCM_CLOSUREP (proc))
{
- arg2 = SCM_CAR (SCM_CODE (proc));
- t.arg1 = SCM_CDR (x);
- while (SCM_NIMP (arg2))
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
+ SCM args = SCM_CDR (x);
+ while (!SCM_NULLP (formals))
{
- if (SCM_NCONSP (arg2))
+ if (!SCM_CONSP (formals))
goto evapply;
- if (SCM_IMP (t.arg1))
+ if (SCM_IMP (args))
goto umwrongnumargs;
- arg2 = SCM_CDR (arg2);
- t.arg1 = SCM_CDR (t.arg1);
+ formals = SCM_CDR (formals);
+ args = SCM_CDR (args);
}
- if (SCM_NNULLP (t.arg1))
+ if (!SCM_NULLP (args))
goto umwrongnumargs;
}
- else if (scm_tc16_macro == SCM_TYP16 (proc))
+ else if (SCM_MACROP (proc))
goto handle_a_macro;
-#endif
}
-evapply:
+evapply: /* inputs: x, proc */
PREP_APPLY (proc, SCM_EOL);
if (SCM_NULLP (SCM_CDR (x))) {
ENTER_APPLY;
goto badfun;
RETURN (SCM_SMOB_APPLY_0 (proc));
case scm_tc7_cclo:
- t.arg1 = proc;
+ arg1 = proc;
proc = SCM_CCLO_SUBR (proc);
#ifdef DEVAL
debug.info->a.proc = proc;
- debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
+ debug.info->a.args = scm_list_1 (arg1);
#endif
goto evap1;
case scm_tc7_pws:
if (scm_badformalsp (proc, 0))
goto umwrongnumargs;
case scm_tcs_closures:
- x = SCM_CODE (proc);
- env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc));
- goto nontoplevel_cdrxbegin;
- case scm_tcs_cons_gloc:
+ x = SCM_CLOSURE_BODY (proc);
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ SCM_EOL,
+ SCM_ENV (proc));
+ goto nontoplevel_begin;
+ case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
x = SCM_ENTITY_PROCEDURE (proc);
- arg2 = SCM_EOL;
+ arg1 = SCM_EOL;
goto type_dispatch;
}
else if (!SCM_I_OPERATORP (proc))
goto badfun;
else
{
- t.arg1 = proc;
+ arg1 = proc;
proc = (SCM_I_ENTITYP (proc)
? SCM_ENTITY_PROCEDURE (proc)
: SCM_OPERATOR_PROCEDURE (proc));
#ifdef DEVAL
debug.info->a.proc = proc;
- debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
+ debug.info->a.args = scm_list_1 (arg1);
#endif
if (SCM_NIMP (proc))
goto evap1;
case scm_tc7_lsubr_2:
umwrongnumargs:
unmemocar (x, env);
- wrongnumargs:
- /* scm_everr (x, env,...) */
scm_wrong_num_args (proc);
default:
/* handle macros here */
/* must handle macros by here */
x = SCM_CDR (x);
-#ifdef SCM_CAUTIOUS
- if (SCM_IMP (x))
- goto wrongnumargs;
- else if (SCM_CONSP (x))
- {
- if (SCM_IMP (SCM_CAR (x)))
- t.arg1 = SCM_EVALIM (SCM_CAR (x), env);
- else
- t.arg1 = EVALCELLCAR (x, env);
- }
- else if (SCM_TYP3 (x) == scm_tc3_cons_gloc)
- {
- scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell];
- if (vcell == 0)
- t.arg1 = SCM_CAR (x); /* struct planted in code */
- else
- t.arg1 = SCM_PACK (vcell);
- }
+ if (SCM_CONSP (x))
+ arg1 = EVALCAR (x, env);
else
- goto wrongnumargs;
-#else
- t.arg1 = EVALCAR (x, env);
-#endif
+ scm_wrong_num_args (proc);
#ifdef DEVAL
- debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
+ debug.info->a.args = scm_list_1 (arg1);
#endif
x = SCM_CDR (x);
- if (SCM_NULLP (x))
- {
- ENTER_APPLY;
- evap1:
- switch (SCM_TYP7 (proc))
- { /* have one argument in t.arg1 */
- case scm_tc7_subr_2o:
- RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED));
- case scm_tc7_subr_1:
- case scm_tc7_subr_1o:
- RETURN (SCM_SUBRF (proc) (t.arg1));
- case scm_tc7_cxr:
- if (SCM_SUBRF (proc))
+ {
+ SCM arg2;
+ if (SCM_NULLP (x))
+ {
+ ENTER_APPLY;
+ evap1: /* inputs: proc, arg1 */
+ switch (SCM_TYP7 (proc))
+ { /* have one argument in arg1 */
+ case scm_tc7_subr_2o:
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
+ case scm_tc7_subr_1:
+ case scm_tc7_subr_1o:
+ RETURN (SCM_SUBRF (proc) (arg1));
+ case scm_tc7_cxr:
+ if (SCM_SUBRF (proc))
+ {
+ if (SCM_INUMP (arg1))
+ {
+ RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
+ }
+ else if (SCM_REALP (arg1))
+ {
+ RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
+ }
+ else if (SCM_BIGP (arg1))
+ {
+ RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
+ }
+ SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
+ SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
+ }
+ proc = SCM_SNAME (proc);
{
- if (SCM_INUMP (t.arg1))
- {
- RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (t.arg1))));
- }
- SCM_ASRTGO (SCM_NIMP (t.arg1), floerr);
- if (SCM_REALP (t.arg1))
- {
- RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (t.arg1))));
- }
-#ifdef SCM_BIGDIG
- if (SCM_BIGP (t.arg1))
+ char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1;
+ while ('c' != *--chrs)
{
- RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_big2dbl (t.arg1))));
+ SCM_ASSERT (SCM_CONSP (arg1),
+ arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc));
+ arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1);
}
-#endif
- floerr:
- SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), t.arg1,
- SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
+ RETURN (arg1);
}
- proc = SCM_SNAME (proc);
- {
- char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1;
- while ('c' != *--chrs)
+ case scm_tc7_rpsubr:
+ RETURN (SCM_BOOL_T);
+ case scm_tc7_asubr:
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
+ case scm_tc7_lsubr:
+#ifdef DEVAL
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args));
+#else
+ RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1)));
+#endif
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
+ case scm_tc7_cclo:
+ arg2 = arg1;
+ arg1 = proc;
+ proc = SCM_CCLO_SUBR (proc);
+#ifdef DEVAL
+ debug.info->a.args = scm_cons (arg1, debug.info->a.args);
+ debug.info->a.proc = proc;
+#endif
+ goto evap2;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+#ifdef DEVAL
+ debug.info->a.proc = proc;
+#endif
+ if (!SCM_CLOSUREP (proc))
+ goto evap1;
+ if (scm_badformalsp (proc, 1))
+ goto umwrongnumargs;
+ case scm_tcs_closures:
+ /* clos1: */
+ x = SCM_CLOSURE_BODY (proc);
+#ifdef DEVAL
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ debug.info->a.args,
+ SCM_ENV (proc));
+#else
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ scm_list_1 (arg1),
+ SCM_ENV (proc));
+#endif
+ goto nontoplevel_begin;
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
- SCM_ASSERT (SCM_CONSP (t.arg1),
- t.arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc));
- t.arg1 = ('a' == *chrs) ? SCM_CAR (t.arg1) : SCM_CDR (t.arg1);
- }
- RETURN (t.arg1);
- }
- case scm_tc7_rpsubr:
- RETURN (SCM_BOOL_T);
- case scm_tc7_asubr:
- RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED));
- case scm_tc7_lsubr:
+ x = SCM_ENTITY_PROCEDURE (proc);
#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (debug.info->a.args))
+ arg1 = debug.info->a.args;
#else
- RETURN (SCM_SUBRF (proc) (scm_cons (t.arg1, SCM_EOL)));
+ arg1 = scm_list_1 (arg1);
#endif
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto type_dispatch;
+ }
+ else if (!SCM_I_OPERATORP (proc))
+ goto badfun;
+ else
+ {
+ arg2 = arg1;
+ arg1 = proc;
+ proc = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc));
+#ifdef DEVAL
+ debug.info->a.args = scm_cons (arg1, debug.info->a.args);
+ debug.info->a.proc = proc;
+#endif
+ if (SCM_NIMP (proc))
+ goto evap2;
+ else
+ goto badfun;
+ }
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_0:
+ case scm_tc7_subr_3:
+ case scm_tc7_lsubr_2:
+ scm_wrong_num_args (proc);
+ default:
goto badfun;
- RETURN (SCM_SMOB_APPLY_1 (proc, t.arg1));
- case scm_tc7_cclo:
- arg2 = t.arg1;
- t.arg1 = proc;
- proc = SCM_CCLO_SUBR (proc);
+ }
+ }
+ if (SCM_CONSP (x))
+ arg2 = EVALCAR (x, env);
+ else
+ scm_wrong_num_args (proc);
+
+ { /* have two or more arguments */
#ifdef DEVAL
- debug.info->a.args = scm_cons (t.arg1, debug.info->a.args);
- debug.info->a.proc = proc;
+ debug.info->a.args = scm_list_2 (arg1, arg2);
#endif
- goto evap2;
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
+ x = SCM_CDR (x);
+ if (SCM_NULLP (x)) {
+ ENTER_APPLY;
+ evap2:
+ switch (SCM_TYP7 (proc))
+ { /* have two arguments */
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_2o:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2));
+ case scm_tc7_lsubr:
#ifdef DEVAL
- debug.info->a.proc = proc;
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args));
+#else
+ RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)));
#endif
- if (!SCM_CLOSUREP (proc))
- goto evap1;
- if (scm_badformalsp (proc, 1))
- goto umwrongnumargs;
- case scm_tcs_closures:
- /* clos1: */
- x = SCM_CODE (proc);
+ case scm_tc7_lsubr_2:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL));
+ case scm_tc7_rpsubr:
+ case scm_tc7_asubr:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2));
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
+ cclon:
+ case scm_tc7_cclo:
#ifdef DEVAL
- env = EXTEND_ENV (SCM_CAR (x), debug.info->a.args, SCM_ENV (proc));
+ RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
+ scm_cons (proc, debug.info->a.args),
+ SCM_EOL));
#else
- env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
+ RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
+ scm_cons2 (proc, arg1,
+ scm_cons (arg2,
+ scm_eval_args (x,
+ env,
+ proc))),
+ SCM_EOL));
#endif
- goto nontoplevel_cdrxbegin;
- case scm_tcs_cons_gloc:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- x = SCM_ENTITY_PROCEDURE (proc);
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+ x = SCM_ENTITY_PROCEDURE (proc);
#ifdef DEVAL
- arg2 = debug.info->a.args;
+ arg1 = debug.info->a.args;
#else
- arg2 = scm_cons (t.arg1, SCM_EOL);
+ arg1 = scm_list_2 (arg1, arg2);
#endif
- goto type_dispatch;
- }
- else if (!SCM_I_OPERATORP (proc))
+ goto type_dispatch;
+ }
+ else if (!SCM_I_OPERATORP (proc))
+ goto badfun;
+ else
+ {
+ operatorn:
+#ifdef DEVAL
+ RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc),
+ scm_cons (proc, debug.info->a.args),
+ SCM_EOL));
+#else
+ RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc),
+ scm_cons2 (proc, arg1,
+ scm_cons (arg2,
+ scm_eval_args (x,
+ env,
+ proc))),
+ SCM_EOL));
+#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:
+ scm_wrong_num_args (proc);
+ default:
goto badfun;
- else
- {
- arg2 = t.arg1;
- t.arg1 = proc;
- proc = (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROCEDURE (proc)
- : SCM_OPERATOR_PROCEDURE (proc));
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
#ifdef DEVAL
- debug.info->a.args = scm_cons (t.arg1, debug.info->a.args);
- debug.info->a.proc = proc;
+ debug.info->a.proc = proc;
#endif
- if (SCM_NIMP (proc))
- goto evap2;
- else
- goto badfun;
- }
- case scm_tc7_subr_2:
- case scm_tc7_subr_0:
- case scm_tc7_subr_3:
- case scm_tc7_lsubr_2:
- goto wrongnumargs;
- default:
- goto badfun;
- }
- }
-#ifdef SCM_CAUTIOUS
- if (SCM_IMP (x))
- goto wrongnumargs;
- else if (SCM_CONSP (x))
- {
- if (SCM_IMP (SCM_CAR (x)))
- arg2 = SCM_EVALIM (SCM_CAR (x), env);
- else
- arg2 = EVALCELLCAR (x, env);
- }
- else if (SCM_TYP3 (x) == scm_tc3_cons_gloc)
- {
- scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell];
- if (vcell == 0)
- arg2 = SCM_CAR (x); /* struct planted in code */
- else
- arg2 = SCM_PACK (vcell);
- }
- else
- goto wrongnumargs;
+ if (!SCM_CLOSUREP (proc))
+ goto evap2;
+ if (scm_badformalsp (proc, 2))
+ goto umwrongnumargs;
+ case scm_tcs_closures:
+ /* clos2: */
+#ifdef DEVAL
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ debug.info->a.args,
+ SCM_ENV (proc));
#else
- arg2 = EVALCAR (x, env);
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ scm_list_2 (arg1, arg2),
+ SCM_ENV (proc));
#endif
- { /* have two or more arguments */
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
+ }
+ }
+ if (!SCM_CONSP (x))
+ scm_wrong_num_args (proc);
#ifdef DEVAL
- debug.info->a.args = scm_cons2 (t.arg1, arg2, SCM_EOL);
+ debug.info->a.args = scm_cons2 (arg1, arg2,
+ deval_args (x, env, proc,
+ SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
#endif
- x = SCM_CDR (x);
- if (SCM_NULLP (x)) {
ENTER_APPLY;
- evap2:
+ evap3:
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:
+ { /* have 3 or more arguments */
#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (debug.info->a.args))
-#else
- RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, SCM_EOL)));
-#endif
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_EOL));
+ case scm_tc7_subr_3:
+ if (!SCM_NULLP (SCM_CDR (x)))
+ scm_wrong_num_args (proc);
+ else
+ RETURN (SCM_SUBRF (proc) (arg1, arg2,
+ SCM_CADDR (debug.info->a.args)));
+ case scm_tc7_asubr:
+ arg1 = SCM_SUBRF(proc)(arg1, arg2);
+ arg2 = SCM_CDDR (debug.info->a.args);
+ do
+ {
+ arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2));
+ arg2 = SCM_CDR (arg2);
+ }
+ while (SCM_NIMP (arg2));
+ RETURN (arg1);
case scm_tc7_rpsubr:
+ if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2)))
+ RETURN (SCM_BOOL_F);
+ arg1 = SCM_CDDR (debug.info->a.args);
+ do
+ {
+ if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1))))
+ RETURN (SCM_BOOL_F);
+ arg2 = SCM_CAR (arg1);
+ arg1 = SCM_CDR (arg1);
+ }
+ while (SCM_NIMP (arg1));
+ RETURN (SCM_BOOL_T);
+ case scm_tc7_lsubr_2:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2,
+ SCM_CDDR (debug.info->a.args)));
+ case scm_tc7_lsubr:
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args));
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
+ SCM_CDDR (debug.info->a.args)));
+ case scm_tc7_cclo:
+ goto cclon;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+ debug.info->a.proc = proc;
+ if (!SCM_CLOSUREP (proc))
+ goto evap3;
+ if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), debug.info->a.args))
+ goto umwrongnumargs;
+ case scm_tcs_closures:
+ SCM_SET_ARGSREADY (debug);
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ debug.info->a.args,
+ SCM_ENV (proc));
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
+#else /* DEVAL */
+ case scm_tc7_subr_3:
+ if (!SCM_NULLP (SCM_CDR (x)))
+ scm_wrong_num_args (proc);
+ else
+ RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env)));
case scm_tc7_asubr:
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
+ arg1 = SCM_SUBRF (proc) (arg1, arg2);
+ do
+ {
+ arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env));
+ x = SCM_CDR(x);
+ }
+ while (SCM_NIMP (x));
+ RETURN (arg1);
+ case scm_tc7_rpsubr:
+ if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2)))
+ RETURN (SCM_BOOL_F);
+ do
+ {
+ arg1 = EVALCAR (x, env);
+ if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, arg1)))
+ RETURN (SCM_BOOL_F);
+ arg2 = arg1;
+ x = SCM_CDR (x);
+ }
+ while (SCM_NIMP (x));
+ RETURN (SCM_BOOL_T);
+ case scm_tc7_lsubr_2:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc)));
+ case scm_tc7_lsubr:
+ RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1,
+ arg2,
+ scm_eval_args (x, env, proc))));
case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc))
goto badfun;
- RETURN (SCM_SMOB_APPLY_2 (proc, t.arg1, arg2));
- cclon:
+ RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
+ scm_eval_args (x, env, proc)));
case scm_tc7_cclo:
+ goto cclon;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+ if (!SCM_CLOSUREP (proc))
+ goto evap3;
+ {
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (SCM_NULLP (formals)
+ || (SCM_CONSP (formals)
+ && (SCM_NULLP (SCM_CDR (formals))
+ || (SCM_CONSP (SCM_CDR (formals))
+ && scm_badargsp (SCM_CDDR (formals), x)))))
+ goto umwrongnumargs;
+ }
+ case scm_tcs_closures:
#ifdef DEVAL
- RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
- scm_cons (proc, debug.info->a.args),
- SCM_EOL));
-#else
- RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
- scm_cons2 (proc, t.arg1,
- scm_cons (arg2,
- scm_eval_args (x,
- env,
- proc))),
- SCM_EOL));
+ SCM_SET_ARGSREADY (debug);
#endif
- case scm_tcs_cons_gloc:
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ scm_cons2 (arg1,
+ arg2,
+ scm_eval_args (x, env, proc)),
+ SCM_ENV (proc));
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
+#endif /* DEVAL */
+ case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
- x = SCM_ENTITY_PROCEDURE (proc);
#ifdef DEVAL
- arg2 = debug.info->a.args;
+ arg1 = debug.info->a.args;
#else
- arg2 = scm_cons2 (t.arg1, arg2, SCM_EOL);
+ arg1 = scm_cons2 (arg1, arg2, scm_eval_args (x, env, proc));
#endif
+ x = SCM_ENTITY_PROCEDURE (proc);
goto type_dispatch;
}
else if (!SCM_I_OPERATORP (proc))
goto badfun;
else
- {
- operatorn:
-#ifdef DEVAL
- RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROCEDURE (proc)
- : SCM_OPERATOR_PROCEDURE (proc),
- scm_cons (proc, debug.info->a.args),
- SCM_EOL));
-#else
- RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROCEDURE (proc)
- : SCM_OPERATOR_PROCEDURE (proc),
- scm_cons2 (proc, t.arg1,
- scm_cons (arg2,
- scm_eval_args (x,
- env,
- proc))),
- SCM_EOL));
-#endif
- }
+ goto operatorn;
+ 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_1o:
case scm_tc7_subr_1:
- case scm_tc7_subr_3:
- goto wrongnumargs;
+ scm_wrong_num_args (proc);
default:
goto badfun;
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
-#ifdef DEVAL
- debug.info->a.proc = proc;
-#endif
- if (!SCM_CLOSUREP (proc))
- goto evap2;
- if (scm_badformalsp (proc, 2))
- goto umwrongnumargs;
- case scm_tcs_closures:
- /* clos2: */
-#ifdef DEVAL
- env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
- debug.info->a.args,
- SCM_ENV (proc));
-#else
- env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
- scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
-#endif
- x = SCM_CODE (proc);
- goto nontoplevel_cdrxbegin;
}
}
-#ifdef SCM_CAUTIOUS
- if (SCM_IMP (x) || SCM_NECONSP (x))
- goto wrongnumargs;
-#endif
-#ifdef DEVAL
- debug.info->a.args = scm_cons2 (t.arg1, arg2,
- scm_deval_args (x, env, proc,
- SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
-#endif
- ENTER_APPLY;
- evap3:
- 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_CADDR (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))
- 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;
- 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))
- goto umwrongnumargs;
- 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 nontoplevel_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, proc),
- SCM_EOL)));
-#endif /* BUILTIN_RPASUBR */
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env, proc)));
- case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1,
- arg2,
- scm_eval_args (x, env, proc))));
- 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;
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
- if (!SCM_CLOSUREP (proc))
- goto evap3;
- {
- SCM formals = SCM_CAR (SCM_CODE (proc));
- if (SCM_NULLP (formals)
- || (SCM_CONSP (formals)
- && (SCM_NULLP (SCM_CDR (formals))
- || (SCM_CONSP (SCM_CDR (formals))
- && scm_badargsp (SCM_CDDR (formals), x)))))
- goto umwrongnumargs;
- }
- 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, proc)),
- SCM_ENV (proc));
- x = SCM_CODE (proc);
- goto nontoplevel_cdrxbegin;
-#endif /* DEVAL */
- case scm_tcs_cons_gloc:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
-#ifdef DEVAL
- arg2 = debug.info->a.args;
-#else
- arg2 = scm_cons2 (t.arg1, arg2, scm_eval_args (x, env, proc));
-#endif
- x = SCM_ENTITY_PROCEDURE (proc);
- goto type_dispatch;
- }
- else if (!SCM_I_OPERATORP (proc))
- goto badfun;
- else
- goto operatorn;
- 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:
- goto wrongnumargs;
- default:
- goto badfun;
- }
}
#ifdef DEVAL
exit:
- if (CHECK_EXIT && SCM_TRAPS_P)
+ if (scm_check_exit_p && SCM_TRAPS_P)
if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
{
SCM_CLEAR_TRACED_FRAME (debug);
if (SCM_CHEAPTRAPS_P)
- t.arg1 = scm_make_debugobj (&debug);
+ arg1 = scm_make_debugobj (&debug);
else
{
int first;
SCM val = scm_make_continuation (&first);
-
+
if (first)
- t.arg1 = val;
+ arg1 = val;
else
{
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, arg1, proc);
+ SCM_TRAPS_P = 1;
}
ret:
scm_last_debug_frame = debug.prev;
}
-/* SECTION: This code is compiled once.
+/* SECTION: This code is compiled once.
+ */
+
+#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
*/
-#ifndef DEVAL
+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:
#define FUNC_NAME s_scm_nconc2last
{
SCM *lloc;
- SCM_VALIDATE_NONEMPTYLIST (1,lst);
+ SCM_VALIDATE_NONEMPTYLIST (1, lst);
lloc = &lst;
- while (SCM_NNULLP (SCM_CDR (*lloc)))
+ while (!SCM_NULLP (SCM_CDR (*lloc))) /* Perhaps should be
+ SCM_NULL_OR_NIL_P, but not
+ needed in 99.99% of cases,
+ and it could seriously hurt
+ performance. - Neil */
lloc = SCM_CDRLOC (*lloc);
SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
*lloc = SCM_CAR (*lloc);
*/
#if 0
-
SCM
scm_apply (SCM proc, SCM arg1, SCM args)
{}
#endif
#if 0
-
SCM
scm_dapply (SCM proc, SCM arg1, SCM args)
-{ /* empty */ }
+{}
#endif
SCM
SCM_APPLY (SCM proc, SCM arg1, SCM args)
{
-#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
if (SCM_DEBUGGINGP)
return scm_dapply (proc, arg1, args);
-#endif
#endif
SCM_ASRTGO (SCM_NIMP (proc), badproc);
if (!first)
goto entap;
}
- scm_ithrow (scm_sym_enter_frame, scm_cons (tmp, SCM_EOL), 0);
+ SCM_TRAPS_P = 0;
+ scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp);
+ SCM_TRAPS_P = 1;
}
entap:
ENTER_APPLY;
{
case scm_tc7_subr_2o:
args = SCM_NULLP (args) ? SCM_UNDEFINED : SCM_CAR (args);
- RETURN (SCM_SUBRF (proc) (arg1, args))
+ RETURN (SCM_SUBRF (proc) (arg1, args));
case scm_tc7_subr_2:
- SCM_ASRTGO (SCM_NNULLP (args) && SCM_NULLP (SCM_CDR (args)),
- wrongnumargs);
+ if (SCM_NULLP (args) || !SCM_NULLP (SCM_CDR (args)))
+ scm_wrong_num_args (proc);
args = SCM_CAR (args);
- RETURN (SCM_SUBRF (proc) (arg1, args))
+ RETURN (SCM_SUBRF (proc) (arg1, args));
case scm_tc7_subr_0:
- SCM_ASRTGO (SCM_UNBNDP (arg1), wrongnumargs);
- RETURN (SCM_SUBRF (proc) ())
+ if (!SCM_UNBNDP (arg1))
+ scm_wrong_num_args (proc);
+ else
+ RETURN (SCM_SUBRF (proc) ());
case scm_tc7_subr_1:
- SCM_ASRTGO (!SCM_UNBNDP (arg1), wrongnumargs);
+ if (SCM_UNBNDP (arg1))
+ scm_wrong_num_args (proc);
case scm_tc7_subr_1o:
- SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
- RETURN (SCM_SUBRF (proc) (arg1))
+ if (!SCM_NULLP (args))
+ scm_wrong_num_args (proc);
+ else
+ RETURN (SCM_SUBRF (proc) (arg1));
case scm_tc7_cxr:
- SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
+ if (SCM_UNBNDP (arg1) || !SCM_NULLP (args))
+ scm_wrong_num_args (proc);
if (SCM_SUBRF (proc))
{
if (SCM_INUMP (arg1))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
}
- SCM_ASRTGO (SCM_NIMP (arg1), floerr);
- if (SCM_REALP (arg1))
+ else if (SCM_REALP (arg1))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
}
-#ifdef SCM_BIGDIG
- if (SCM_BIGP (arg1))
- RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_big2dbl (arg1))))
-#endif
- floerr:
+ else if (SCM_BIGP (arg1))
+ RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
}
arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc));
arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1);
}
- RETURN (arg1)
+ RETURN (arg1);
}
case scm_tc7_subr_3:
- SCM_ASRTGO (SCM_NNULLP (args)
- && SCM_NNULLP (SCM_CDR (args))
- && SCM_NULLP (SCM_CDDR (args)),
- wrongnumargs);
- RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CAR (SCM_CDR (args))))
+ if (SCM_NULLP (args)
+ || SCM_NULLP (SCM_CDR (args))
+ || !SCM_NULLP (SCM_CDDR (args)))
+ scm_wrong_num_args (proc);
+ else
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args)));
case scm_tc7_lsubr:
#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args))
+ RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args));
#else
- RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)))
+ RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)));
#endif
case scm_tc7_lsubr_2:
- SCM_ASRTGO (SCM_CONSP (args), wrongnumargs);
- RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args)))
+ if (!SCM_CONSP (args))
+ scm_wrong_num_args (proc);
+ else
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args)));
case scm_tc7_asubr:
if (SCM_NULLP (args))
- RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED))
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
while (SCM_NIMP (args))
{
SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply");
#else
arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
#endif
-#ifndef SCM_RECKLESS
- if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), arg1))
- goto wrongnumargs;
-#endif
+ if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1))
+ scm_wrong_num_args (proc);
/* Copy argument list */
if (SCM_IMP (arg1))
else
{
SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED);
- while (arg1 = SCM_CDR (arg1), SCM_CONSP (arg1))
+ for (arg1 = SCM_CDR (arg1); SCM_CONSP (arg1); arg1 = SCM_CDR (arg1))
{
- SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1),
- SCM_UNSPECIFIED));
+ SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED));
tl = SCM_CDR (tl);
}
SCM_SETCDR (tl, arg1);
}
- args = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), args, SCM_ENV (proc));
- proc = SCM_CDR (SCM_CODE (proc));
+ args = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ args,
+ SCM_ENV (proc));
+ proc = SCM_CLOSURE_BODY (proc);
again:
- arg1 = proc;
- while (SCM_NNULLP (arg1 = SCM_CDR (arg1)))
+ arg1 = SCM_CDR (proc);
+ while (!SCM_NULLP (arg1))
{
if (SCM_IMP (SCM_CAR (proc)))
{
if (SCM_ISYMP (SCM_CAR (proc)))
{
- proc = scm_m_expand_body (proc, args);
+ scm_rec_mutex_lock (&source_mutex);
+ /* check for race condition */
+ if (SCM_ISYMP (SCM_CAR (proc)))
+ proc = scm_m_expand_body (proc, args);
+ scm_rec_mutex_unlock (&source_mutex);
goto again;
}
else
- SCM_EVALIM2 (SCM_CAR (proc));
+ SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc));
}
else
SCM_CEVAL (SCM_CAR (proc), args);
proc = arg1;
+ arg1 = SCM_CDR (proc);
}
RETURN (EVALCAR (proc, args));
case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc))
goto badproc;
if (SCM_UNBNDP (arg1))
- RETURN (SCM_SMOB_APPLY_0 (proc))
+ RETURN (SCM_SMOB_APPLY_0 (proc));
else if (SCM_NULLP (args))
- RETURN (SCM_SMOB_APPLY_1 (proc, arg1))
+ RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
else if (SCM_NULLP (SCM_CDR (args)))
- RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args)))
+ RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args)));
else
RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args)));
case scm_tc7_cclo:
debug.vect[0].a.proc = proc;
#endif
goto tail;
- case scm_tcs_cons_gloc:
+ case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
#ifdef DEVAL
goto badproc;
else
{
+ /* operator */
#ifdef DEVAL
args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
#else
else
goto badproc;
}
- wrongnumargs:
- scm_wrong_num_args (proc);
default:
badproc:
scm_wrong_type_arg ("apply", SCM_ARG1, proc);
- RETURN (arg1);
}
#ifdef DEVAL
exit:
- if (CHECK_EXIT && SCM_TRAPS_P)
+ if (scm_check_exit_p && SCM_TRAPS_P)
if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
{
SCM_CLEAR_TRACED_FRAME (debug);
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;
#ifndef DEVAL
+/* Trampolines
+ *
+ * Trampolines make it possible to move procedure application dispatch
+ * outside inner loops. The motivation was clean implementation of
+ * efficient replacements of R5RS primitives in SRFI-1.
+ *
+ * The semantics is clear: scm_trampoline_N returns an optimized
+ * version of scm_call_N (or NULL if the procedure isn't applicable
+ * on N args).
+ *
+ * Applying the optimization to map and for-each increased efficiency
+ * noticeably. For example, (map abs ls) is now 8 times faster than
+ * before.
+ */
+
+static SCM
+call_subr0_0 (SCM proc)
+{
+ return SCM_SUBRF (proc) ();
+}
+
+static SCM
+call_subr1o_0 (SCM proc)
+{
+ return SCM_SUBRF (proc) (SCM_UNDEFINED);
+}
+
+static SCM
+call_lsubr_0 (SCM proc)
+{
+ return SCM_SUBRF (proc) (SCM_EOL);
+}
+
+SCM
+scm_i_call_closure_0 (SCM proc)
+{
+ const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ SCM_EOL,
+ SCM_ENV (proc));
+ const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
+ return result;
+}
+
+scm_t_trampoline_0
+scm_trampoline_0 (SCM proc)
+{
+ if (SCM_IMP (proc))
+ return NULL;
+ if (SCM_DEBUGGINGP)
+ return scm_call_0;
+ switch (SCM_TYP7 (proc))
+ {
+ case scm_tc7_subr_0:
+ return call_subr0_0;
+ case scm_tc7_subr_1o:
+ return call_subr1o_0;
+ case scm_tc7_lsubr:
+ return call_lsubr_0;
+ case scm_tcs_closures:
+ {
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (SCM_NULLP (formals) || !SCM_CONSP (formals))
+ return scm_i_call_closure_0;
+ else
+ return NULL;
+ }
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ return scm_call_generic_0;
+ else if (!SCM_I_OPERATORP (proc))
+ return NULL;
+ return scm_call_0;
+ case scm_tc7_smob:
+ if (SCM_SMOB_APPLICABLE_P (proc))
+ return SCM_SMOB_DESCRIPTOR (proc).apply_0;
+ else
+ return NULL;
+ case scm_tc7_asubr:
+ case scm_tc7_rpsubr:
+ case scm_tc7_cclo:
+ case scm_tc7_pws:
+ return scm_call_0;
+ default:
+ return NULL; /* not applicable on one arg */
+ }
+}
+
+static SCM
+call_subr1_1 (SCM proc, SCM arg1)
+{
+ return SCM_SUBRF (proc) (arg1);
+}
+
+static SCM
+call_subr2o_1 (SCM proc, SCM arg1)
+{
+ return SCM_SUBRF (proc) (arg1, SCM_UNDEFINED);
+}
+
+static SCM
+call_lsubr_1 (SCM proc, SCM arg1)
+{
+ return SCM_SUBRF (proc) (scm_list_1 (arg1));
+}
+
+static SCM
+call_dsubr_1 (SCM proc, SCM arg1)
+{
+ if (SCM_INUMP (arg1))
+ {
+ RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
+ }
+ else if (SCM_REALP (arg1))
+ {
+ RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
+ }
+ else if (SCM_BIGP (arg1))
+ RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
+ SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
+ SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
+}
+
+static SCM
+call_cxr_1 (SCM proc, SCM arg1)
+{
+ proc = SCM_SNAME (proc);
+ {
+ char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1;
+ while ('c' != *--chrs)
+ {
+ SCM_ASSERT (SCM_CONSP (arg1),
+ arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc));
+ arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1);
+ }
+ return (arg1);
+ }
+}
+
+static SCM
+call_closure_1 (SCM proc, SCM arg1)
+{
+ const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ scm_list_1 (arg1),
+ SCM_ENV (proc));
+ const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
+ return result;
+}
+
+scm_t_trampoline_1
+scm_trampoline_1 (SCM proc)
+{
+ if (SCM_IMP (proc))
+ return NULL;
+ if (SCM_DEBUGGINGP)
+ return scm_call_1;
+ switch (SCM_TYP7 (proc))
+ {
+ case scm_tc7_subr_1:
+ case scm_tc7_subr_1o:
+ return call_subr1_1;
+ case scm_tc7_subr_2o:
+ return call_subr2o_1;
+ case scm_tc7_lsubr:
+ return call_lsubr_1;
+ case scm_tc7_cxr:
+ if (SCM_SUBRF (proc))
+ return call_dsubr_1;
+ else
+ return call_cxr_1;
+ case scm_tcs_closures:
+ {
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (!SCM_NULLP (formals)
+ && (!SCM_CONSP (formals) || !SCM_CONSP (SCM_CDR (formals))))
+ return call_closure_1;
+ else
+ return NULL;
+ }
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ return scm_call_generic_1;
+ else if (!SCM_I_OPERATORP (proc))
+ return NULL;
+ return scm_call_1;
+ case scm_tc7_smob:
+ if (SCM_SMOB_APPLICABLE_P (proc))
+ return SCM_SMOB_DESCRIPTOR (proc).apply_1;
+ else
+ return NULL;
+ case scm_tc7_asubr:
+ case scm_tc7_rpsubr:
+ case scm_tc7_cclo:
+ case scm_tc7_pws:
+ return scm_call_1;
+ default:
+ return NULL; /* not applicable on one arg */
+ }
+}
+
+static SCM
+call_subr2_2 (SCM proc, SCM arg1, SCM arg2)
+{
+ return SCM_SUBRF (proc) (arg1, arg2);
+}
+
+static SCM
+call_lsubr2_2 (SCM proc, SCM arg1, SCM arg2)
+{
+ return SCM_SUBRF (proc) (arg1, arg2, SCM_EOL);
+}
+
+static SCM
+call_lsubr_2 (SCM proc, SCM arg1, SCM arg2)
+{
+ return SCM_SUBRF (proc) (scm_list_2 (arg1, arg2));
+}
+
+static SCM
+call_closure_2 (SCM proc, SCM arg1, SCM arg2)
+{
+ const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ scm_list_2 (arg1, arg2),
+ SCM_ENV (proc));
+ const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
+ return result;
+}
+
+scm_t_trampoline_2
+scm_trampoline_2 (SCM proc)
+{
+ if (SCM_IMP (proc))
+ return NULL;
+ if (SCM_DEBUGGINGP)
+ return scm_call_2;
+ switch (SCM_TYP7 (proc))
+ {
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_2o:
+ case scm_tc7_rpsubr:
+ case scm_tc7_asubr:
+ return call_subr2_2;
+ case scm_tc7_lsubr_2:
+ return call_lsubr2_2;
+ case scm_tc7_lsubr:
+ return call_lsubr_2;
+ case scm_tcs_closures:
+ {
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (!SCM_NULLP (formals)
+ && (!SCM_CONSP (formals)
+ || (!SCM_NULLP (SCM_CDR (formals))
+ && (!SCM_CONSP (SCM_CDR (formals))
+ || !SCM_CONSP (SCM_CDDR (formals))))))
+ return call_closure_2;
+ else
+ return NULL;
+ }
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ return scm_call_generic_2;
+ else if (!SCM_I_OPERATORP (proc))
+ return NULL;
+ return scm_call_2;
+ case scm_tc7_smob:
+ if (SCM_SMOB_APPLICABLE_P (proc))
+ return SCM_SMOB_DESCRIPTOR (proc).apply_2;
+ else
+ return NULL;
+ case scm_tc7_cclo:
+ case scm_tc7_pws:
+ return scm_call_2;
+ default:
+ return NULL; /* not applicable on two args */
+ }
+}
+
/* Typechecking for multi-argument MAP and FOR-EACH.
Verify that each element of the vector ARGV, except for the first,
SCM args,
const char *who)
{
- SCM *ve = SCM_VELTS (argv);
- int i;
+ SCM const *ve = SCM_VELTS (argv);
+ long 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)
{
}
if (elt_len != len)
- scm_out_of_range (who, ve[i]);
+ scm_out_of_range_pos (who, ve[i], SCM_MAKINUM (i + 2));
}
scm_remember_upto_here_1 (argv);
long i, len;
SCM res = SCM_EOL;
SCM *pres = &res;
- SCM *ve = &args; /* Keep args from being optimized away. */
+ SCM const *ve = &args; /* Keep args from being optimized away. */
len = scm_ilength (arg1);
SCM_GASSERTn (len >= 0,
SCM_VALIDATE_REST_ARGUMENT (args);
if (SCM_NULLP (args))
{
+ scm_t_trampoline_1 call = scm_trampoline_1 (proc);
+ SCM_GASSERT2 (call, g_map, proc, arg1, SCM_ARG1, s_map);
+ while (SCM_NIMP (arg1))
+ {
+ *pres = scm_list_1 (call (proc, SCM_CAR (arg1)));
+ pres = SCM_CDRLOC (*pres);
+ arg1 = SCM_CDR (arg1);
+ }
+ return res;
+ }
+ if (SCM_NULLP (SCM_CDR (args)))
+ {
+ SCM arg2 = SCM_CAR (args);
+ int len2 = scm_ilength (arg2);
+ scm_t_trampoline_2 call = scm_trampoline_2 (proc);
+ SCM_GASSERTn (call,
+ g_map, scm_cons2 (proc, arg1, args), SCM_ARG1, s_map);
+ SCM_GASSERTn (len2 >= 0,
+ g_map, scm_cons2 (proc, arg1, args), SCM_ARG3, s_map);
+ if (len2 != len)
+ SCM_OUT_OF_RANGE (3, arg2);
while (SCM_NIMP (arg1))
{
- *pres = scm_cons (scm_apply (proc, SCM_CAR (arg1), scm_listofnull),
- SCM_EOL);
+ *pres = scm_list_1 (call (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
pres = SCM_CDRLOC (*pres);
arg1 = SCM_CDR (arg1);
+ arg2 = SCM_CDR (arg2);
}
return res;
}
- args = scm_vector (arg1 = scm_cons (arg1, args));
+ arg1 = scm_cons (arg1, args);
+ args = scm_vector (arg1);
ve = SCM_VELTS (args);
-#ifndef SCM_RECKLESS
check_map_args (args, len, g_map, proc, arg1, s_map);
-#endif
while (1)
{
arg1 = SCM_EOL;
if (SCM_IMP (ve[i]))
return res;
arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
- ve[i] = SCM_CDR (ve[i]);
+ SCM_VECTOR_SET (args, i, SCM_CDR (ve[i]));
}
- *pres = scm_cons (scm_apply (proc, arg1, SCM_EOL), SCM_EOL);
+ *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL));
pres = SCM_CDRLOC (*pres);
}
}
scm_for_each (SCM proc, SCM arg1, SCM args)
#define FUNC_NAME s_for_each
{
- SCM *ve = &args; /* Keep args from being optimized away. */
+ SCM const *ve = &args; /* Keep args from being optimized away. */
long i, len;
len = scm_ilength (arg1);
SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args),
SCM_ARG2, s_for_each);
SCM_VALIDATE_REST_ARGUMENT (args);
- if SCM_NULLP (args)
+ if (SCM_NULLP (args))
+ {
+ scm_t_trampoline_1 call = scm_trampoline_1 (proc);
+ SCM_GASSERT2 (call, g_for_each, proc, arg1, SCM_ARG1, s_for_each);
+ while (SCM_NIMP (arg1))
+ {
+ call (proc, SCM_CAR (arg1));
+ arg1 = SCM_CDR (arg1);
+ }
+ return SCM_UNSPECIFIED;
+ }
+ if (SCM_NULLP (SCM_CDR (args)))
{
- while SCM_NIMP (arg1)
+ SCM arg2 = SCM_CAR (args);
+ int len2 = scm_ilength (arg2);
+ scm_t_trampoline_2 call = scm_trampoline_2 (proc);
+ SCM_GASSERTn (call, g_for_each,
+ scm_cons2 (proc, arg1, args), SCM_ARG1, s_for_each);
+ SCM_GASSERTn (len2 >= 0, g_for_each,
+ scm_cons2 (proc, arg1, args), SCM_ARG3, s_for_each);
+ if (len2 != len)
+ SCM_OUT_OF_RANGE (3, arg2);
+ while (SCM_NIMP (arg1))
{
- scm_apply (proc, SCM_CAR (arg1), scm_listofnull);
+ call (proc, SCM_CAR (arg1), SCM_CAR (arg2));
arg1 = SCM_CDR (arg1);
+ arg2 = SCM_CDR (arg2);
}
return SCM_UNSPECIFIED;
}
- args = scm_vector (arg1 = scm_cons (arg1, args));
+ arg1 = scm_cons (arg1, args);
+ args = scm_vector (arg1);
ve = SCM_VELTS (args);
-#ifndef SCM_RECKLESS
check_map_args (args, len, g_for_each, proc, arg1, s_for_each);
-#endif
while (1)
{
arg1 = SCM_EOL;
for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--)
{
- if SCM_IMP
- (ve[i]) return SCM_UNSPECIFIED;
+ if (SCM_IMP (ve[i]))
+ return SCM_UNSPECIFIED;
arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
- ve[i] = SCM_CDR (ve[i]);
+ SCM_VECTOR_SET (args, i, SCM_CDR (ve[i]));
}
scm_apply (proc, arg1, SCM_EOL);
}
SCM
scm_closure (SCM code, SCM env)
{
- register SCM z;
- SCM_NEWCELL (z);
- SCM_SETCODE (z, code);
- SCM_SETENV (z, env);
+ SCM z;
+ SCM closcar = scm_cons (code, SCM_EOL);
+ z = scm_cell (SCM_UNPACK (closcar) + scm_tc3_closure, (scm_t_bits) env);
+ scm_remember_upto_here (closcar);
return z;
}
-scm_bits_t scm_tc16_promise;
+scm_t_bits scm_tc16_promise;
SCM
scm_makprom (SCM code)
{
- SCM_RETURN_NEWSMOB (scm_tc16_promise, SCM_UNPACK (code));
+ SCM_RETURN_NEWSMOB2 (scm_tc16_promise,
+ SCM_UNPACK (code),
+ scm_make_rec_mutex ());
}
-
+static size_t
+promise_free (SCM promise)
+{
+ scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise));
+ return 0;
+}
static int
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_PROMISE_DATA (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 promise),
+ "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_VALIDATE_SMOB (1, promise, promise);
+ scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise));
+ if (!SCM_PROMISE_COMPUTED_P (promise))
{
- SCM ans = scm_apply (SCM_CELL_OBJECT_1 (x), SCM_EOL, SCM_EOL);
- if (!((1L << 16) & SCM_CELL_WORD_0 (x)))
+ SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise));
+ if (!SCM_PROMISE_COMPUTED_P (promise))
{
- SCM_DEFER_INTS;
- SCM_SET_CELL_OBJECT_1 (x, ans);
- SCM_SET_CELL_WORD_0 (x, SCM_CELL_WORD_0 (x) | (1L << 16));
- SCM_ALLOW_INTS;
+ SCM_SET_PROMISE_DATA (promise, ans);
+ SCM_SET_PROMISE_COMPUTED (promise);
}
}
- return SCM_CELL_OBJECT_1 (x);
+ scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise));
+ return SCM_PROMISE_DATA (promise);
}
#undef FUNC_NAME
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_TYP16_PREDICATE (scm_tc16_promise, x));
+ return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise, obj));
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_cons_source
{
SCM p, z;
- SCM_NEWCELL (z);
- SCM_SET_CELL_OBJECT_0 (z, x);
- SCM_SET_CELL_OBJECT_1 (z, y);
+ z = scm_cons (x, y);
/* Copy source properties possibly associated with xorig. */
p = scm_whash_lookup (scm_source_whash, xorig);
if (!SCM_IMP (p))
return obj;
if (SCM_VECTORP (obj))
{
- scm_sizet i = SCM_VECTOR_LENGTH (obj);
+ 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]);
+ SCM_VECTOR_SET (ans, i, scm_copy_tree (SCM_VELTS (obj)[i]));
return ans;
}
- if (SCM_NCONSP (obj))
+ if (!SCM_CONSP (obj))
return obj;
ans = tl = scm_cons_source (obj,
scm_copy_tree (SCM_CAR (obj)),
SCM_UNSPECIFIED);
- while (obj = SCM_CDR (obj), SCM_CONSP (obj))
+ for (obj = SCM_CDR (obj); SCM_CONSP (obj); obj = SCM_CDR (obj))
{
SCM_SETCDR (tl, scm_cons (scm_copy_tree (SCM_CAR (obj)),
SCM_UNSPECIFIED));
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 modifying ENV so that it continues to be in sync with
+ tracked by updating ENV so that it continues to be in sync with
the current module.
- scm_primitive_eval (exp)
- scm_eval (exp, mod)
- evaluates EXP while MOD is the current module. Thius is done by
+ 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
*/
-SCM scm_system_transformer;
-
-/* XXX - scm_i_eval is meant to be useable for evaluation in
- non-toplevel environments, for example when used by the debugger.
- Can the system transform deal with this? */
-
SCM
scm_i_eval_x (SCM exp, SCM env)
{
- SCM transformer = scm_fluid_ref (SCM_CDR (scm_system_transformer));
- if (SCM_NIMP (transformer))
- exp = scm_apply (transformer, exp, scm_listofnull);
return SCM_XEVAL (exp, env);
}
SCM
scm_i_eval (SCM exp, SCM env)
{
- SCM transformer = scm_fluid_ref (SCM_CDR (scm_system_transformer));
- if (SCM_NIMP (transformer))
- exp = scm_apply (transformer, exp, scm_listofnull);
exp = scm_copy_tree (exp);
return SCM_XEVAL (exp, env);
}
SCM
scm_primitive_eval_x (SCM exp)
{
- SCM env = scm_top_level_env (scm_current_module_lookup_closure ());
+ 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);
}
"the current module.")
#define FUNC_NAME s_scm_primitive_eval
{
- SCM env = scm_top_level_env (scm_current_module_lookup_closure ());
+ 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 exp, SCM module),
"Evaluate @var{exp}, a list representing a Scheme expression,\n"
"in the top-level environment specified by @var{module}.\n"
- "While @var{exp} is evaluated (using @var{primitive-eval}),\n"
+ "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
"@var{module} is made the current module. The current module\n"
"is reset to its previous value when @var{eval} returns.")
#define FUNC_NAME s_scm_eval
}
#undef FUNC_NAME
-#if (SCM_DEBUG_DEPRECATED == 0)
-
-/* Use scm_current_module () or scm_interaction_environment ()
- * instead. The former is the module selected during loading of code.
- * The latter is the module in which the user of this thread currently
- * types expressions.
- */
-
-SCM scm_top_level_lookup_closure_var;
-
-/* Avoid using this functionality altogether (except for implementing
- * libguile, where you can use scm_i_eval or scm_i_eval_x).
- *
- * Applications should use either C level scm_eval_x or Scheme
- * scm_eval; or scm_primitive_eval_x or scm_primitive_eval. */
-
-SCM
-scm_eval_3 (SCM obj, int copyp, SCM env)
-{
- if (copyp)
- return scm_i_eval (obj, env);
- else
- return scm_i_eval_x (obj, env);
-}
-
-SCM_DEFINE (scm_eval2, "eval2", 2, 0, 0,
- (SCM obj, SCM env_thunk),
- "Evaluate @var{exp}, a Scheme expression, in the environment\n"
- "designated by @var{lookup}, a symbol-lookup function."
- "Do not use this version of eval, it does not play well\n"
- "with the module system. Use @code{eval} or\n"
- "@code{primitive-eval} instead.")
-#define FUNC_NAME s_scm_eval2
-{
- return scm_i_eval (obj, scm_top_level_env (env_thunk));
-}
-#undef FUNC_NAME
-
-#endif /* DEPRECATED */
-
/* At this point, scm_deval and scm_dapply are generated.
*/
-#ifdef DEBUG_EXTENSIONS
-# define DEVAL
-# include "eval.c"
-#endif
-
+#define DEVAL
+#include "eval.c"
void
scm_tc16_promise = scm_make_smob_type ("promise", 0);
scm_set_smob_mark (scm_tc16_promise, scm_markcdr);
+ scm_set_smob_free (scm_tc16_promise, promise_free);
scm_set_smob_print (scm_tc16_promise, promise_print);
- scm_f_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply);
- scm_system_transformer = scm_sysintern ("scm:eval-transformer",
- scm_make_fluid ());
+ undefineds = scm_list_1 (SCM_UNDEFINED);
+ SCM_SETCDR (undefineds, undefineds);
+ scm_permanent_object (undefineds);
- 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);
-
- /* acros */
- /* end of acros */
+ scm_listofnull = scm_list_1 (SCM_EOL);
-#if SCM_DEBUG_DEPRECATED == 0
- scm_top_level_lookup_closure_var =
- scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ());
-#endif
+ f_apply = scm_c_define_subr ("apply", scm_tc7_lsubr_2, scm_apply);
+ scm_permanent_object (f_apply);
-#ifndef SCM_MAGIC_SNARFER
#include "libguile/eval.x"
-#endif
-
+
scm_add_feature ("delay");
}
HCoop / bpt / guile.git / blobdiff