-/* Copyright (C) 1995,1996,1997,1998,1999,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. */
+ * 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
/* 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 "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
* 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_IMP (SCM_CAR (x)) \
? SCM_EVALIM (SCM_CAR (x), env) \
- : EVALCELLCAR (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 long 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
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 MEMOIZE_LOCALS
register SCM iloc = SCM_ILOC00;
-#endif
for (; SCM_NIMP (env); env = SCM_CDR (env))
{
if (!SCM_CONSP (SCM_CAR (env)))
{
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_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, real_var;
if (SCM_FALSEP (real_var))
goto errout;
-#ifndef SCM_RECKLESS
if (!SCM_NULLP (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var)))
{
errout:
- /* scm_everr (vloc, genv,...) */
if (check)
{
if (SCM_NULLP (env))
return &undef_object;
}
}
-#endif
-#ifdef USE_THREADS
if (!SCM_EQ_P (SCM_CAR (vloc), var))
{
/* Some other thread has changed the very cell we are working
var = SCM_CAR (vloc);
if (SCM_VARIABLEP (var))
return SCM_VARIABLE_LOC (var);
-#ifdef MEMOIZE_LOCALS
if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00))
return scm_ilookup (var, genv);
-#endif
/* We can't cope with anything else than 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
the dispatch on the car of the form. */
return NULL;
}
-#endif /* USE_THREADS */
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
scm_unmemocar (SCM form, SCM env)
{
- SCM c;
-
- if (SCM_IMP (form))
+ if (!SCM_CONSP (form))
return form;
- c = SCM_CAR (form);
- if (SCM_VARIABLEP (c))
- {
- SCM sym = scm_module_reverse_lookup (scm_env_module (env), c);
- if (SCM_EQ_P (sym, SCM_BOOL_F))
- sym = sym_three_question_marks;
- SCM_SETCAR (form, sym);
- }
-#ifdef MEMOIZE_LOCALS
-#ifdef DEBUG_EXTENSIONS
- else if (SCM_ILOCP (c))
+ else
{
- long 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));
+ 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, 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)))
}
-SCM_SYNTAX (s_quote, "quote", scm_makmmacro, scm_m_quote);
-SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
-
-SCM
-scm_m_quote (SCM xorig, SCM env SCM_UNUSED)
-{
- SCM x = scm_copy_tree (SCM_CDR (xorig));
-
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, s_quote);
- return scm_cons (SCM_IM_QUOTE, x);
-}
-
-
-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)
-{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 0, scm_s_expression, s_begin);
- return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig));
-}
-
-
-SCM_SYNTAX (s_if, "if", scm_makmmacro, scm_m_if);
-SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
-
-SCM
-scm_m_if (SCM xorig, SCM env SCM_UNUSED)
-{
- long len = scm_ilength (SCM_CDR (xorig));
- SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, "if");
- 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_UNUSED)
-{
- SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, scm_s_set_x);
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), scm_s_variable, scm_s_set_x);
- return scm_cons (SCM_IM_SET_X, x);
-}
+/* Start of the memoizers for the standard R5RS builtin macros. */
SCM_SYNTAX (s_and, "and", scm_makmmacro, scm_m_and);
}
-SCM_SYNTAX (s_or, "or", scm_makmmacro, scm_m_or);
-SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
+SCM_SYNTAX (s_begin, "begin", scm_makmmacro, scm_m_begin);
+SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
SCM
-scm_m_or (SCM xorig, SCM env SCM_UNUSED)
+scm_m_begin (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_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 0, scm_s_expression, s_begin);
+ return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig));
}
}
-SCM_SYNTAX (s_lambda, "lambda", scm_makmmacro, scm_m_lambda);
-SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda);
+SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define);
+SCM_GLOBAL_SYMBOL(scm_sym_define, s_define);
-/* 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)
+/* 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 1;
+ /* 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_UNUSED)
-{
- SCM formals;
- SCM x = SCM_CDR (xorig);
- if (scm_ilength (x) < 2)
- scm_misc_error (s_lambda, scm_s_formals, SCM_EOL);
-
- formals = SCM_CAR (x);
- while (SCM_CONSP (formals))
+ 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))
{
- 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);
+ SCM var;
+ x = scm_eval_car (x, env);
+ if (SCM_REC_PROCNAMES_P)
+ {
+ 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);
+ }
+ var = scm_sym2var (name, scm_env_top_level (env), SCM_BOOL_T);
+ SCM_VARIABLE_SET (var, x);
+ return SCM_UNSPECIFIED;
}
- 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));
+ 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);
-/* (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*). */
+/* 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_letstar (SCM xorig, SCM env SCM_UNUSED)
+scm_m_delay (SCM xorig, SCM env SCM_UNUSED)
{
- SCM bindings;
- SCM x = SCM_CDR (xorig);
- SCM vars = SCM_EOL;
- SCM *varloc = &vars;
- SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_body, 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_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_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, "do");
while (!SCM_NULLP (bindings))
{
- SCM arg1 = SCM_CAR (bindings);
- long len = scm_ilength (arg1);
+ SCM binding = SCM_CAR (bindings);
+ long len = scm_ilength (binding);
SCM_ASSYNT (len == 2 || len == 3, scm_s_bindings, "do");
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), scm_s_variable, "do");
- /* vars reversed here, inits and steps reversed at evaluation */
- vars = scm_cons (SCM_CAR (arg1), vars); /* variable */
- arg1 = SCM_CDR (arg1);
- *initloc = scm_list_1 (SCM_CAR (arg1)); /* init */
- initloc = SCM_CDRLOC (*initloc);
- arg1 = SCM_CDR (arg1);
- *steploc = scm_list_1 (len == 2 ? SCM_CAR (vars) : SCM_CAR (arg1));
- steploc = SCM_CDRLOC (*steploc);
- bindings = SCM_CDR (bindings);
+ {
+ SCM name = SCM_CAR (binding);
+ SCM init = SCM_CADR (binding);
+ SCM step = (len == 2) ? name : SCM_CADDR (binding);
+ SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_variable, "do");
+ vars = scm_cons (name, vars);
+ *initloc = scm_list_1 (init);
+ initloc = SCM_CDRLOC (*initloc);
+ *steploc = scm_list_1 (step);
+ steploc = SCM_CDRLOC (*steploc);
+ bindings = SCM_CDR (bindings);
+ }
}
x = SCM_CDR (x);
SCM_ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, scm_s_test, "do");
return scm_cons (SCM_IM_DO, x);
}
-/* evalcar is small version of inline EVALCAR when we don't care about
- * speed
- */
-#define evalcar scm_eval_car
-
-static SCM iqq (SCM form, SCM env, long depth);
-
-SCM_SYNTAX(s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
-SCM_GLOBAL_SYMBOL(scm_sym_quasiquote, s_quasiquote);
+SCM_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, 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, long 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;
- long 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_CONSP (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_CONSP (form) && SCM_NULLP (SCM_CDR (form)),
- form, SCM_ARG1, s_quasiquote);
- if (0 == depth)
- return evalcar (form, env);
- return scm_list_2 (tmp, iqq (SCM_CAR (form), env, depth));
- }
- if (SCM_CONSP (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_list_2 (evalcar (tmp, env), iqq (SCM_CDR (form), env, depth)));
+ 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
+scm_m_lambda (SCM xorig, SCM env SCM_UNUSED)
+{
+ SCM formals;
+ SCM x = SCM_CDR (xorig);
-SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay);
-SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_formals, s_lambda);
-SCM
-scm_m_delay (SCM xorig, SCM env SCM_UNUSED)
-{
- SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_delay);
- return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig));
-}
+ formals = SCM_CAR (x);
+ while (SCM_CONSP (formals))
+ {
+ 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);
+ }
+ 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));
+}
-SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define);
-SCM_GLOBAL_SYMBOL(scm_sym_define, s_define);
-SCM
-scm_m_define (SCM x, 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 proc, arg1 = x;
- x = SCM_CDR (x);
- SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_expression, s_define);
- proc = SCM_CAR (x);
- x = SCM_CDR (x);
- while (SCM_CONSP (proc))
- { /* nested define syntax */
- x = scm_list_1 (scm_cons2 (scm_sym_lambda, SCM_CDR (proc), x));
- proc = SCM_CAR (proc);
- }
- SCM_ASSYNT (SCM_SYMBOLP (proc), scm_s_variable, s_define);
- SCM_ASSYNT (1 == scm_ilength (x), scm_s_expression, s_define);
- if (SCM_TOP_LEVEL (env))
- {
- x = evalcar (x, env);
-#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_MACROP (arg1)
- /* Dirk::FIXME: Does the following test make sense? */
- && !SCM_EQ_P (SCM_MACRO_CODE (arg1), arg1))
- {
- arg1 = SCM_MACRO_CODE (arg1);
- goto proc;
- }
- }
-#endif
- arg1 = scm_sym2var (proc, scm_env_top_level (env), SCM_BOOL_T);
- SCM_VARIABLE_SET (arg1, x);
-#ifdef SICP
- return scm_list_2 (scm_sym_quote, proc);
-#else
- return SCM_UNSPECIFIED;
-#endif
- }
- return scm_cons2 (SCM_IM_DEFINE, proc, x);
-}
-
-/* end of acros */
+ SCM rvars = SCM_EOL;
+ *rvarloc = SCM_EOL;
+ *initloc = SCM_EOL;
-static SCM
-scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env SCM_UNUSED)
-{
- SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */
- char *what = SCM_SYMBOL_CHARS (SCM_CAR (xorig));
- SCM x = cdrx, proc, arg1; /* structure traversers */
- SCM vars = SCM_EOL, inits = SCM_EOL, *initloc = &inits;
+ SCM_ASSYNT (scm_ilength (bindings) >= 1, scm_s_bindings, what);
- proc = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (proc) >= 1, scm_s_bindings, what);
do
{
- /* vars scm_list reversed here, inits reversed at evaluation */
- arg1 = SCM_CAR (proc);
- SCM_ASSYNT (2 == scm_ilength (arg1), scm_s_bindings, what);
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), scm_s_variable, what);
- if (scm_c_improper_memq (SCM_CAR (arg1), vars))
+ SCM binding = SCM_CAR (bindings);
+ SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, what);
+ SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, what);
+ if (scm_c_improper_memq (SCM_CAR (binding), rvars))
scm_misc_error (what, scm_s_duplicate_bindings, SCM_EOL);
- vars = scm_cons (SCM_CAR (arg1), vars);
- *initloc = scm_list_1 (SCM_CADR (arg1));
+ 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, 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, scm_s_body, s_let);
- proc = SCM_CAR (x);
- if (SCM_NULLP (proc)
- || (SCM_CONSP (proc)
- && SCM_CONSP (SCM_CAR (proc)) && SCM_NULLP (SCM_CDR (proc))))
+ SCM x = SCM_CDR (xorig);
+ SCM temp;
+
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_let);
+ temp = SCM_CAR (x);
+ if (SCM_NULLP (temp)
+ || (scm_ilength (temp) == 1 && SCM_CONSP (SCM_CAR (temp))))
{
/* null or single binding, let* is faster */
- return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), proc,
- scm_m_body (SCM_IM_LET,
- SCM_CDR (x),
- s_let)),
- env);
+ SCM bindings = temp;
+ SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (x), s_let);
+ return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), bindings, body), env);
}
-
- SCM_ASSYNT (SCM_NIMP (proc), scm_s_bindings, s_let);
- if (SCM_CONSP (proc))
+ else if (SCM_CONSP (temp))
{
- /* plain let, proc is <bindings> */
- return scm_m_letrec1 (SCM_IM_LET, SCM_IM_LET, xorig, env);
+ /* plain let */
+ SCM bindings = temp;
+ SCM rvars, inits, body;
+ transform_bindings (bindings, &rvars, &inits, "let");
+ body = scm_m_body (SCM_IM_LET, SCM_CDR (x), "let");
+ return scm_cons2 (SCM_IM_LET, rvars, scm_cons (inits, body));
}
+ else
+ {
+ /* named let: Transform (let name ((var init) ...) body ...) into
+ * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
- if (!SCM_SYMBOLP (proc))
- scm_misc_error (s_let, scm_s_bindings, SCM_EOL); /* bad let */
- name = proc; /* named let, build equiv letrec */
- x = SCM_CDR (x);
- SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_body, s_let);
- proc = SCM_CAR (x); /* bindings list */
- SCM_ASSYNT (scm_ilength (proc) >= 0, scm_s_bindings, s_let);
- while (SCM_NIMP (proc))
- { /* vars and inits both in order */
- arg1 = SCM_CAR (proc);
- SCM_ASSYNT (2 == scm_ilength (arg1), scm_s_bindings, s_let);
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), scm_s_variable, s_let);
- *varloc = scm_list_1 (SCM_CAR (arg1));
- varloc = SCM_CDRLOC (*varloc);
- *initloc = scm_list_1 (SCM_CADR (arg1));
- 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;
+
+ 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);
+ }
- proc = scm_cons2 (scm_sym_lambda, vars,
- scm_m_body (SCM_IM_LET, SCM_CDR (x), "let"));
- proc = scm_list_3 (scm_sym_let,
- scm_list_1 (scm_list_2 (name, proc)),
- scm_cons (name, inits));
- return scm_m_letrec1 (SCM_IM_LETREC, SCM_IM_LET, proc, env);
+ {
+ 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);
-SCM
-scm_m_apply (SCM xorig, SCM env SCM_UNUSED)
+/* (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_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, scm_s_expression, s_atapply);
- return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig));
-}
+ 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_atcall_cc,"@call-with-current-continuation", scm_makmmacro, scm_m_cont);
-SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc,s_atcall_cc);
+SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec);
+SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
SCM
-scm_m_cont (SCM xorig, SCM env SCM_UNUSED)
+scm_m_letrec (SCM xorig, SCM env)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
- scm_s_expression, s_atcall_cc);
- return scm_cons (SCM_IM_CONT, 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));
+ }
}
-/* Multi-language support */
-SCM_GLOBAL_SYMBOL (scm_lisp_nil, "nil");
-SCM_GLOBAL_SYMBOL (scm_lisp_t, "t");
-
-SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond);
+SCM_SYNTAX (s_or, "or", scm_makmmacro, scm_m_or);
+SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
SCM
-scm_m_nil_cond (SCM xorig, SCM env SCM_UNUSED)
+scm_m_or (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_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_nil_ify, "nil-ify", scm_makmmacro, scm_m_nil_ify);
-SCM
-scm_m_nil_ify (SCM xorig, SCM env SCM_UNUSED)
+SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
+SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);
+
+/* Internal function to handle a quasiquotation: 'form' is the parameter in
+ * the call (quasiquotation form), 'env' is the environment where unquoted
+ * expressions will be evaluated, and 'depth' is the current quasiquotation
+ * nesting level and is known to be greater than zero. */
+static SCM
+iqq (SCM form, SCM env, unsigned long int depth)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "nil-ify");
- return scm_cons (SCM_IM_NIL_IFY, 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;
}
-SCM_SYNTAX (s_t_ify, "t-ify", scm_makmmacro, scm_m_t_ify);
-
-SCM
-scm_m_t_ify (SCM xorig, SCM env SCM_UNUSED)
+SCM
+scm_m_quasiquote (SCM xorig, SCM env)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "t-ify");
- return scm_cons (SCM_IM_T_IFY, SCM_CDR (xorig));
+ SCM x = SCM_CDR (xorig);
+ SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_quasiquote);
+ return iqq (SCM_CAR (x), env, 1);
}
-SCM_SYNTAX (s_0_cond, "0-cond", scm_makmmacro, scm_m_0_cond);
+
+SCM_SYNTAX (s_quote, "quote", scm_makmmacro, scm_m_quote);
+SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
SCM
-scm_m_0_cond (SCM xorig, SCM env SCM_UNUSED)
+scm_m_quote (SCM xorig, SCM env SCM_UNUSED)
{
- long len = scm_ilength (SCM_CDR (xorig));
- SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "0-cond");
- return scm_cons (SCM_IM_0_COND, SCM_CDR (xorig));
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, s_quote);
+ return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig));
}
-SCM_SYNTAX (s_0_ify, "0-ify", scm_makmmacro, scm_m_0_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_0_ify (SCM xorig, SCM env SCM_UNUSED)
+scm_m_set_x (SCM xorig, SCM env SCM_UNUSED)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "0-ify");
- return scm_cons (SCM_IM_0_IFY, SCM_CDR (xorig));
+ SCM 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);
}
-SCM_SYNTAX (s_1_ify, "1-ify", scm_makmmacro, scm_m_1_ify);
-SCM
-scm_m_1_ify (SCM xorig, SCM env SCM_UNUSED)
-{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "1-ify");
- return scm_cons (SCM_IM_1_IFY, SCM_CDR (xorig));
-}
+/* Start of the memoizers for non-R5RS builtin macros. */
-SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop);
-SCM
-scm_m_atfop (SCM xorig, SCM env SCM_UNUSED)
+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 x = SCM_CDR (xorig), var;
- SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop");
- var = scm_symbol_fref (SCM_CAR (x));
- SCM_ASSYNT (SCM_VARIABLEP (var),
- "Symbol's function definition is void", NULL);
- SCM_SETCAR (x, var);
- return x;
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, scm_s_expression, s_atapply);
+ return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig));
}
+
/* (@bind ((var exp) ...) body ...)
This will assign the values of the `exp's to the global variables
error when a symbol appears more than once among the `var's.
All `exp's are evaluated before any `var' is set.
- This of this as `let' for dynamic scope.
+ Think of this as `let' for dynamic scope.
It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
SCM_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,
+ scm_s_expression, s_atcall_cc);
+ return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));
+}
+
+
SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_makmmacro, scm_m_at_call_with_values);
SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);
return scm_cons (SCM_IM_CALL_WITH_VALUES, SCM_CDR (xorig));
}
+
+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_future (SCM xorig, SCM env SCM_UNUSED)
+{
+ 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_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 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);
+}
+
+
+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_atslot_ref (SCM xorig, SCM env SCM_UNUSED)
+#define FUNC_NAME s_atslot_ref
+{
+ 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
+
+
+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_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) == 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_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)))
+ {
+ var = scm_symbol_fref (SCM_VARIABLE_REF (var));
+ SCM_ASSYNT (SCM_VARIABLEP (var),
+ "Symbol's function definition is void",
+ SCM_SYMBOL_CHARS (SCM_CAR (x)));
+ }
+ /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
+ former allows for automatically picking up redefinitions of the
+ corresponding symbol. */
+ SCM_SETCAR (x, var);
+ /* If the variable contains a procedure, leave the
+ `transformer-macro' in place so that the procedure's arguments
+ get properly transformed, and change the initial @fop to
+ SCM_IM_APPLY. */
+ if (!SCM_MACROP (SCM_VARIABLE_REF (var)))
+ {
+ SCM_SETCAR (xorig, SCM_IM_APPLY);
+ return xorig;
+ }
+ /* Otherwise (the variable contains a macro), the arguments should
+ not be transformed, so cut the `transformer-macro' out and return
+ the resulting expression starting with the variable. */
+ SCM_SETCDR (x, SCM_CDADR (x));
+ return x;
+}
+
+#endif /* SCM_ENABLE_ELISP */
+
+
SCM
scm_m_expand_body (SCM xorig, SCM env)
{
}
}
- SCM_ASSYNT (SCM_NIMP (x), scm_s_body, what);
- if (SCM_NIMP (defs))
+ if (!SCM_NULLP (defs))
{
- x = scm_list_1 (scm_m_letrec1 (SCM_IM_LETREC,
- SCM_IM_DEFINE,
- scm_cons2 (scm_sym_define, defs, x),
- env));
+ 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;
}
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. */
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
* generating the source for a stackframe in a backtrace, and in
* display_expression.
*
- * Unmemoizing is not a realiable process. You can not in general
+ * Unmemoizing is not a reliable process. You cannot in general
* expect to get the original source back.
*
* However, GOOPS currently relies on this for method compilation.
* This ought to change.
*/
-#define SCM_BIT8(x) (127 & SCM_UNPACK (x))
-
static SCM
build_binding_list (SCM names, SCM inits)
{
unmemocopy (SCM x, SCM env)
{
SCM ls, z;
-#ifdef DEBUG_EXTENSIONS
SCM p;
-#endif
if (!SCM_CONSP (x))
return x;
-#ifdef DEBUG_EXTENSIONS
p = scm_whash_lookup (scm_source_whash, x);
-#endif
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):
+ case SCM_BIT7 (SCM_IM_DO):
{
/* 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
names = SCM_CAR (x);
x = SCM_CDR (x);
inits = scm_reverse (unmemocopy (SCM_CAR (x), env));
- env = EXTEND_ENV (names, SCM_EOL, env);
+ env = SCM_EXTEND_ENV (names, SCM_EOL, env);
x = SCM_CDR (x);
test = unmemocopy (SCM_CAR (x), env);
x = SCM_CDR (x);
x = scm_cons (SCM_BOOL_F, memoized_body);
break;
}
- case SCM_BIT8(SCM_IM_IF):
+ case SCM_BIT7 (SCM_IM_IF):
ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED);
break;
- case SCM_BIT8 (SCM_IM_LET):
+ 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
names = SCM_CAR (x);
x = SCM_CDR (x);
inits = scm_reverse (unmemocopy (SCM_CAR (x), env));
- env = EXTEND_ENV (names, SCM_EOL, 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_LETREC):
+ 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
x = SCM_CDR (x);
names = SCM_CAR (x);
- env = EXTEND_ENV (names, SCM_EOL, env);
+ env = SCM_EXTEND_ENV (names, SCM_EOL, env);
x = SCM_CDR (x);
inits = scm_reverse (unmemocopy (SCM_CAR (x), env));
ls = scm_cons (scm_sym_letrec, z);
break;
}
- case SCM_BIT8(SCM_IM_LETSTAR):
+ 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_CADR (b), env), SCM_EOL), env),
SCM_UNSPECIFIED);
- env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
+ 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_list_1 (unmemocopy (SCM_CADR (b), env)), env),
SCM_UNSPECIFIED));
z = SCM_CDR (z);
- env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
+ 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);
z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED);
ls = scm_cons (scm_sym_lambda, z);
- env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
+ 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);
z = scm_cons (n, SCM_UNSPECIFIED);
ls = scm_cons (scm_sym_define, z);
if (!SCM_NULLP (env))
- SCM_SETCAR (SCM_CAR (env), scm_cons (n, SCM_CAAR (env)));
+ 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;
x = SCM_CDR (x);
}
SCM_SETCDR (z, x);
-#ifdef DEBUG_EXTENSIONS
if (!SCM_FALSEP (p))
scm_whash_insert (scm_source_whash, ls, p);
-#endif
return ls;
}
return unmemocopy (x, env);
}
-#ifndef SCM_RECKLESS
int
scm_badargsp (SCM formals, SCM args)
{
- while (SCM_NIMP (formals))
+ while (!SCM_NULLP (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_NULLP (args) ? 1 : 0;
}
-#endif
+
static int
scm_badformalsp (SCM closure, int n)
lloc = SCM_CDRLOC (*lloc);
l = SCM_CDR (l);
}
-#ifdef SCM_CAUTIOUS
if (!SCM_NULLP (l))
scm_wrong_num_args (proc);
-#endif
return results;
}
+
SCM
scm_eval_body (SCM code, SCM env)
{
{
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;
}
}
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)); \
}\
} 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_t_debug_frame *scm_last_debug_frame;
-#endif
-
/* scm_debug_eframe_size is the number of slots available for pseudo
* stack frames at each real stack frame.
*/
(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_CONSP (l))
lloc = SCM_CDRLOC (*lloc);
l = SCM_CDR (l);
}
-#ifdef SCM_CAUTIOUS
if (!SCM_NULLP (l))
scm_wrong_num_args (proc);
-#endif
return *results;
}
#endif /* !DEVAL */
-/* SECTION: Some local definitions for the evaluator.
+/* SECTION: This code is compiled twice.
*/
+
/* Update the toplevel environment frame ENV so that it refers to the
- current module.
-*/
+ * current module. */
#define UPDATE_TOPLEVEL_ENV(env) \
do { \
SCM p = scm_current_module_lookup_closure (); \
- 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_FALSEP (scm_eqv_p ((A), (B)))))
-#endif /* DEVAL */
-
-#define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
-/* SECTION: This is the evaluator. Like any real monster, it has
- * three heads. This code is compiled twice.
- */
+/* This is the evaluator. Like any real monster, it has three heads:
+ *
+ * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
+ * version. Both are implemented using a common code base, using the
+ * following mechanism: SCM_CEVAL is a macro, which is either defined to
+ * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
+ * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
+ * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
+ * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
+ * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
+ * are enclosed within #ifdef DEVAL ... #endif.
+ *
+ * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
+ * take two input parameters, x and env: x is a single expression to be
+ * evalutated. env is the environment in which bindings are searched.
+ *
+ * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
+ * is a single expression, it is necessarily in a tail position. If x is just
+ * a call to another function like in the expression (foo exp1 exp2 ...), the
+ * realization of that call therefore _must_not_ increase stack usage (the
+ * evaluation of exp1, exp2 etc., however, may do so). This is realized by
+ * making extensive use of 'goto' statements within the evaluator: The gotos
+ * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
+ * that SCM_CEVAL was already using. If, however, x represents some form that
+ * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
+ * then recursive calls to SCM_CEVAL are performed for all but the last
+ * expression of that sequence. */
#if 0
-
SCM
scm_ceval (SCM x, SCM env)
{}
#endif
-#if 0
+#if 0
SCM
scm_deval (SCM x, SCM env)
{}
SCM
SCM_CEVAL (SCM x, SCM env)
{
- union
- {
- SCM *lloc;
- SCM arg1;
- } t;
- SCM proc, arg2, orig_sym;
+ SCM proc, arg1;
#ifdef DEVAL
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_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_t_debug_info *) alloca (scm_debug_eframe_size
- * sizeof (debug.vect[0]));
+ * sizeof (scm_t_debug_info));
debug.info = debug.vect;
debug_info_end = debug.vect + scm_debug_eframe_size;
scm_last_debug_frame = &debug;
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_TRAPS_P = 0;
- scm_call_4 (SCM_ENTER_FRAME_HDLR,
- scm_sym_enter_frame,
- t.arg1,
- tail,
- scm_unmemocopy (x, env));
- SCM_TRAPS_P = 1;
- }
+ 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_NULLP (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):
- if (SCM_NULLP (SCM_CDR (x)))
+ case SCM_BIT7 (SCM_IM_BEGIN):
+ x = SCM_CDR (x);
+ if (SCM_NULLP (x))
RETURN (SCM_UNSPECIFIED);
- /* (currently unused)
- cdrxnoap: */
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- /* (currently unused)
- cdrxbegin: */
- x = SCM_CDR (x);
begin:
/* If we are on toplevel with a lookup closure, we need to sync
with the current module. */
if (SCM_CONSP (env) && !SCM_CONSP (SCM_CAR (env)))
{
- t.arg1 = x;
UPDATE_TOPLEVEL_ENV (env);
- while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1)))
+ 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_NULLP (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_VALIDATE_NON_EMPTY_COMBINATION (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_IMP (SCM_CAR (x)))
- {
- x = SCM_CAR (x);
- RETURN (SCM_EVALIM (x, env))
- }
+ carloop:
+ {
+ /* scm_eval last form in list */
+ SCM last_form = SCM_CAR (x);
+
+ 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);
+ }
- if (SCM_SYMBOLP (SCM_CAR (x)))
- {
- retval:
- RETURN (*scm_lookupcar (x, env, 1))
- }
- 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_CDAR (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):
+ case SCM_BIT7 (SCM_IM_DO):
x = SCM_CDR (x);
- while (!SCM_NULLP (x))
- {
- proc = SCM_CAR (x);
- if (SCM_EQ_P (SCM_CAR (proc), scm_sym_else))
- {
- x = SCM_CDR (proc);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
- }
- t.arg1 = EVALCAR (proc, env);
- if (!SCM_FALSEP (t.arg1))
+ {
+ /* 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_list_1 (t.arg1));
- ENTER_APPLY;
- if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))
- goto umwrongnumargs;
- goto evap1;
}
- x = SCM_CDR (x);
- }
- RETURN (SCM_UNSPECIFIED)
-
- case SCM_BIT8(SCM_IM_DO):
- x = SCM_CDR (x);
- proc = SCM_CADR (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_CDDR (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_CAAR (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_FALSEP (EVALCAR (x, env)))
- x = SCM_CDR (x);
- else if (SCM_IMP (x = SCM_CDDR (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):
- x = SCM_CDR (x);
- proc = SCM_CADR (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);
+ case SCM_BIT7 (SCM_IM_LET):
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_NULLP (t.arg1 = SCM_CDR (t.arg1)))
+ while (!SCM_NULLP (SCM_CDR (x)))
{
- x = EVALCAR (x, env);
- if (!SCM_FALSEP (x))
- {
- RETURN (x);
- }
- x = t.arg1;
+ SCM val = EVALCAR (x, env);
+ if (!SCM_FALSEP (val) && !SCM_NILP (val))
+ RETURN (val);
+ else
+ x = SCM_CDR (x);
}
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop;
- case SCM_BIT8(SCM_IM_LAMBDA):
+ case SCM_BIT7 (SCM_IM_LAMBDA):
RETURN (scm_closure (SCM_CDR (x), env));
- case SCM_BIT8(SCM_IM_QUOTE):
+ 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:
- if (SCM_VARIABLEP (proc))
- t.lloc = SCM_VARIABLE_LOC (proc);
- else
- t.lloc = scm_lookupcar (x, env, 1);
- break;
-#ifdef MEMOIZE_LOCALS
- case scm_tc3_imm24:
- 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_CDDR (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 T.ARG1 is the list of arguments. Do not forget to
- call PREP_APPLY. */
+ 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_CLOSURE_FORMALS (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_CLOSURE_FORMALS (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_list_1 (t.arg1));
- ENTER_APPLY;
- if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))
- goto umwrongnumargs;
- goto evap1;
+
case (SCM_ISYMNUM (SCM_IM_DELAY)):
- RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)))
+ RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));
+
+
+ case (SCM_ISYMNUM (SCM_IM_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> */
+
+ /* 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%. */
+ 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;
- 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_CONSP (proc))
{
- if (SCM_VARIABLEP (proc))
- arg2 = SCM_VARIABLE_REF (proc);
+ 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)
+ {
+ SCM class = scm_class_of (SCM_CAR (tmp_arg));
+ hash_value += SCM_INSTANCE_HASH (class, hashset);
+ tmp_arg = SCM_CDR (tmp_arg);
+ counter--;
+ }
+ z = SCM_CDDR (z);
+ method_cache = SCM_CADR (z);
+ mask = SCM_INUM (SCM_CAR (z));
+ hash_value &= mask;
+ cache_end_pos = hash_value;
+ }
else
- arg2 = *scm_lookupcar (SCM_CDR (x), env, 1);
- }
- else
- {
- arg2 = scm_list_1 (EVALCAR (proc, env));
- t.lloc = SCM_CDRLOC (arg2);
- while (SCM_NIMP (proc = SCM_CDR (proc)))
{
- *t.lloc = scm_list_1 (EVALCAR (proc, env));
- t.lloc = SCM_CDRLOC (*t.lloc);
+ /* 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);
}
}
-
- type_dispatch:
- /* The type dispatch code is duplicated here
- * (c.f. objects.c:scm_mcache_compute_cmethod) since that
- * cuts down execution time for type dispatch to 50%.
- */
- {
- long i, n, end, mask;
- SCM z = SCM_CDDR (x);
- n = SCM_INUM (SCM_CAR (z)); /* maximum number of specializers */
- proc = SCM_CADR (z);
- if (SCM_NIMP (proc))
- {
- /* Prepare for linear search */
- mask = -1;
- i = 0;
- end = SCM_VECTOR_LENGTH (proc);
- }
- else
- {
- /* Compute a hash value */
- long hashset = SCM_INUM (proc);
- long j = n;
- z = SCM_CDDR (z);
- mask = SCM_INUM (SCM_CAR (z));
- proc = SCM_CADR (z);
- i = 0;
- t.arg1 = arg2;
- if (SCM_NIMP (t.arg1))
- do
- {
- i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t.arg1)))
- [scm_si_hashsets + hashset];
- t.arg1 = SCM_CDR (t.arg1);
- }
- while (j-- && SCM_NIMP (t.arg1));
- i &= mask;
- end = i;
- }
-
- /* Search for match */
- do
- {
- long 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_FALSEP (EVALCAR (x, env)) ? scm_lisp_t : scm_lisp_nil)
-
- case (SCM_ISYMNUM (SCM_IM_0_COND)):
- proc = SCM_CDR (x);
- while (SCM_NIMP (x = SCM_CDR (proc)))
- {
- if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env))
- || SCM_EQ_P (t.arg1, SCM_INUM0)))
- {
- if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED))
- RETURN (t.arg1);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
- }
- proc = SCM_CDR (x);
- }
- x = proc;
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
+ {
+ 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_FALSEP (EVALCAR (x, env))
- ? SCM_MAKINUM (1)
- : SCM_INUM0)
+#endif /* SCM_ENABLE_ELISP */
case (SCM_ISYMNUM (SCM_IM_BIND)):
{
scm_swap_bindings (vars, vals);
scm_dynwinds = scm_acons (vars, vals, scm_dynwinds);
-
- arg2 = x = SCM_CDR (x);
- while (!SCM_NULLP (arg2 = SCM_CDR (arg2)))
+
+ /* Ignore all but the last evaluation result. */
+ for (x = SCM_CDR (x); !SCM_NULLP (SCM_CDR (x)); x = SCM_CDR (x))
{
- SIDEVAL (SCM_CAR (x), env);
- x = arg2;
+ 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)
+ RETURN (proc);
}
-
+
+
case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
{
proc = SCM_CDR (x);
x = EVALCAR (proc, env);
proc = SCM_CDR (proc);
proc = EVALCAR (proc, env);
- t.arg1 = SCM_APPLY (x, SCM_EOL, SCM_EOL);
- if (SCM_VALUESP (t.arg1))
- t.arg1 = scm_struct_ref (t.arg1, SCM_INUM0);
+ arg1 = SCM_APPLY (x, SCM_EOL, SCM_EOL);
+ if (SCM_VALUESP (arg1))
+ arg1 = scm_struct_ref (arg1, SCM_INUM0);
else
- t.arg1 = scm_list_1 (t.arg1);
+ arg1 = scm_list_1 (arg1);
if (SCM_CLOSUREP (proc))
{
- PREP_APPLY (proc, t.arg1);
+ PREP_APPLY (proc, arg1);
goto apply_closure;
}
- return SCM_APPLY (proc, t.arg1, SCM_EOL);
+ 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_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_variable:
RETURN (SCM_VARIABLE_REF(x));
-#ifdef MEMOIZE_LOCALS
- case SCM_BIT8(SCM_ILOC00):
+ 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_nimcar:
- orig_sym = SCM_CAR (x);
- if (SCM_SYMBOLP (orig_sym))
+ 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))
{
{
SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of
lookupcar */
- handle_a_macro:
+ 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_MACRO_CODE (proc), x,
+ arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,
scm_cons (env, scm_listofnull));
#ifdef DEVAL
switch (SCM_MACRO_TYPE (proc))
{
case 2:
- if (scm_ilength (t.arg1) <= 0)
- t.arg1 = scm_list_2 (SCM_IM_BEGIN, t.arg1);
+ if (scm_ilength (arg1) <= 0)
+ arg1 = scm_list_2 (SCM_IM_BEGIN, arg1);
#ifdef DEVAL
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_IMP (proc), badfun);
-#ifndef SCM_RECKLESS
-#ifdef SCM_CAUTIOUS
+
checkargs:
-#endif
if (SCM_CLOSUREP (proc))
{
- arg2 = SCM_CLOSURE_FORMALS (proc);
- t.arg1 = SCM_CDR (x);
- while (!SCM_NULLP (arg2))
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
+ SCM args = SCM_CDR (x);
+ while (!SCM_NULLP (formals))
{
- if (!SCM_CONSP (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_NULLP (t.arg1))
+ if (!SCM_NULLP (args))
goto umwrongnumargs;
}
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_list_1 (t.arg1);
+ 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_CLOSURE_FORMALS (proc), SCM_EOL, SCM_ENV (proc));
- goto nontoplevel_cdrxbegin;
+ 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_list_1 (t.arg1);
+ 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);
- }
+ 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_list_1 (t.arg1);
+ 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))));
- }
- else if (SCM_REALP (t.arg1))
- {
- RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (t.arg1))));
- }
-#ifdef SCM_BIGDIG
- else 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_i_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
- 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)
- {
- 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:
+ 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))
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args));
#else
- RETURN (SCM_SUBRF (proc) (scm_list_1 (t.arg1)));
+ 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, t.arg1));
- case scm_tc7_cclo:
- arg2 = t.arg1;
- t.arg1 = proc;
- proc = SCM_CCLO_SUBR (proc);
+ 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 (t.arg1, debug.info->a.args);
- debug.info->a.proc = proc;
+ 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);
+ goto evap2;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
#ifdef DEVAL
- debug.info->a.proc = proc;
+ 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_CODE (proc);
+ 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 = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc));
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ debug.info->a.args,
+ SCM_ENV (proc));
#else
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_list_1 (t.arg1), SCM_ENV (proc));
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ scm_list_1 (arg1),
+ SCM_ENV (proc));
#endif
- goto nontoplevel_cdrxbegin;
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- x = SCM_ENTITY_PROCEDURE (proc);
+ goto nontoplevel_begin;
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+ x = SCM_ENTITY_PROCEDURE (proc);
#ifdef DEVAL
- arg2 = debug.info->a.args;
+ arg1 = debug.info->a.args;
#else
- arg2 = scm_list_1 (t.arg1);
+ arg1 = scm_list_1 (arg1);
#endif
- goto type_dispatch;
- }
- else if (!SCM_I_OPERATORP (proc))
- goto badfun;
- else
- {
- arg2 = t.arg1;
- t.arg1 = proc;
- proc = (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROCEDURE (proc)
- : SCM_OPERATOR_PROCEDURE (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 (t.arg1, debug.info->a.args);
- debug.info->a.proc = proc;
+ 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:
- 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
- goto wrongnumargs;
-#else
- arg2 = EVALCAR (x, env);
+ 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;
+ }
+ }
+ 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_list_2 (arg1, arg2);
#endif
- { /* have two or more arguments */
+ 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.args = scm_list_2 (t.arg1, arg2);
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args));
+#else
+ RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)));
#endif
- 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) (t.arg1, arg2));
- case scm_tc7_lsubr:
+ 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
- RETURN (SCM_SUBRF (proc) (debug.info->a.args))
+ RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
+ scm_cons (proc, debug.info->a.args),
+ SCM_EOL));
#else
- RETURN (SCM_SUBRF (proc) (scm_list_2 (t.arg1, arg2)));
+ RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
+ scm_cons2 (proc, arg1,
+ scm_cons (arg2,
+ scm_eval_args (x,
+ env,
+ proc))),
+ SCM_EOL));
#endif
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_EOL));
- case scm_tc7_rpsubr:
- case scm_tc7_asubr:
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badfun;
- RETURN (SCM_SMOB_APPLY_2 (proc, t.arg1, arg2));
- cclon:
- case scm_tc7_cclo:
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+ x = SCM_ENTITY_PROCEDURE (proc);
#ifdef DEVAL
- RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
- scm_cons (proc, debug.info->a.args),
- SCM_EOL));
+ arg1 = debug.info->a.args;
#else
- RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
- scm_cons2 (proc, t.arg1,
- scm_cons (arg2,
- scm_eval_args (x,
- env,
- proc))),
- SCM_EOL));
+ arg1 = scm_list_2 (arg1, arg2);
#endif
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- x = SCM_ENTITY_PROCEDURE (proc);
+ goto type_dispatch;
+ }
+ else if (!SCM_I_OPERATORP (proc))
+ goto badfun;
+ else
+ {
+ operatorn:
#ifdef DEVAL
- arg2 = debug.info->a.args;
+ 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
- arg2 = scm_list_2 (t.arg1, arg2);
+ 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
- goto type_dispatch;
- }
- else if (!SCM_I_OPERATORP (proc))
+ }
+ 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
- {
- operatorn:
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
#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));
+ 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 = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ debug.info->a.args,
+ SCM_ENV (proc));
#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));
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ scm_list_2 (arg1, arg2),
+ SCM_ENV (proc));
#endif
- }
- case scm_tc7_subr_0:
- case scm_tc7_cxr:
- case scm_tc7_subr_1o:
- case scm_tc7_subr_1:
+ 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 (arg1, arg2,
+ 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:
- goto wrongnumargs;
- default:
- goto badfun;
+ 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);
-#ifdef DEVAL
debug.info->a.proc = proc;
-#endif
if (!SCM_CLOSUREP (proc))
- goto evap2;
- if (scm_badformalsp (proc, 2))
+ goto evap3;
+ if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), debug.info->a.args))
goto umwrongnumargs;
case scm_tcs_closures:
- /* clos2: */
-#ifdef DEVAL
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- debug.info->a.args,
- SCM_ENV (proc));
-#else
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- scm_list_2 (t.arg1, arg2), SCM_ENV (proc));
-#endif
- x = SCM_CODE (proc);
- goto nontoplevel_cdrxbegin;
- }
- }
-#ifdef SCM_CAUTIOUS
- if (SCM_IMP (x) || !SCM_CONSP (x))
- goto wrongnumargs;
-#endif
-#ifdef DEVAL
- debug.info->a.args = scm_cons2 (t.arg1, arg2,
- scm_deval_args (x, env, proc,
- SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
-#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_CDDR (debug.info->a.args);
- do
- {
- t.arg1 = SCM_SUBRF(proc)(t.arg1, SCM_CAR (arg2));
- arg2 = SCM_CDR (arg2);
- }
- while (SCM_NIMP (arg2));
- RETURN (t.arg1)
-#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_CDDR (debug.info->a.args);
- do
- {
- if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (t.arg1))))
- RETURN (SCM_BOOL_F)
- arg2 = SCM_CAR (t.arg1);
- 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_CDDR (debug.info->a.args),
- SCM_EOL)))
-#endif /* BUILTIN_RPASUBR */
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (t.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, 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_CLOSURE_FORMALS (proc), debug.info->a.args))
- goto umwrongnumargs;
- case scm_tcs_closures:
- SCM_SET_ARGSREADY (debug);
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- debug.info->a.args,
- SCM_ENV (proc));
- x = SCM_CODE (proc);
- goto nontoplevel_cdrxbegin;
+ 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:
- 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_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:
+ 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:
+ 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_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
- SCM_SET_ARGSREADY (debug);
+ SCM_SET_ARGSREADY (debug);
#endif
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- scm_cons2 (t.arg1,
- arg2,
- scm_eval_args (x, env, proc)),
- SCM_ENV (proc));
- x = SCM_CODE (proc);
- goto nontoplevel_cdrxbegin;
+ 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)
- {
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
#ifdef DEVAL
- arg2 = debug.info->a.args;
+ arg1 = debug.info->a.args;
#else
- arg2 = scm_cons2 (t.arg1, arg2, scm_eval_args (x, env, proc));
+ 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))
+ 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:
+ scm_wrong_num_args (proc);
+ default:
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;
}
}
SCM_TRAPS_P = 0;
- scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, t.arg1, proc);
+ scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
SCM_TRAPS_P = 1;
}
ret:
#ifndef DEVAL
\f
+
/* Simple procedure calls
*/
#define FUNC_NAME s_scm_nconc2last
{
SCM *lloc;
- SCM_VALIDATE_NONEMPTYLIST (1,lst);
+ SCM_VALIDATE_NONEMPTYLIST (1, lst);
lloc = &lst;
- while (!SCM_NULLP (SCM_CDR (*lloc)))
+ while (!SCM_NULLP (SCM_CDR (*lloc))) /* Perhaps should be
+ SCM_NULL_OR_NIL_P, but not
+ needed in 99.99% of cases,
+ and it could seriously hurt
+ performance. - Neil */
lloc = SCM_CDRLOC (*lloc);
SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
*lloc = SCM_CAR (*lloc);
*/
#if 0
-
SCM
scm_apply (SCM proc, SCM arg1, SCM args)
{}
#endif
#if 0
-
SCM
scm_dapply (SCM proc, SCM arg1, SCM args)
-{ /* empty */ }
+{}
#endif
SCM
SCM_APPLY (SCM proc, SCM arg1, SCM args)
{
-#ifdef DEBUG_EXTENSIONS
#ifdef DEVAL
scm_t_debug_frame debug;
scm_t_debug_info debug_vect_body;
#else
if (SCM_DEBUGGINGP)
return scm_dapply (proc, arg1, args);
-#endif
#endif
SCM_ASRTGO (SCM_NIMP (proc), badproc);
{
case scm_tc7_subr_2o:
args = SCM_NULLP (args) ? SCM_UNDEFINED : SCM_CAR (args);
- RETURN (SCM_SUBRF (proc) (arg1, args))
+ RETURN (SCM_SUBRF (proc) (arg1, args));
case scm_tc7_subr_2:
- SCM_ASRTGO (!SCM_NULLP (args) && SCM_NULLP (SCM_CDR (args)),
- wrongnumargs);
+ 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_UNBNDP (arg1) && 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) (SCM_REAL_VALUE (arg1))));
}
-#ifdef SCM_BIGDIG
else if (SCM_BIGP (arg1))
- RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))))
-#endif
+ 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_NULLP (args)
- && !SCM_NULLP (SCM_CDR (args))
- && SCM_NULLP (SCM_CDDR (args)),
- wrongnumargs);
- RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (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_CLOSURE_FORMALS (proc), arg1))
- goto wrongnumargs;
-#endif
+ 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_CLOSURE_FORMALS (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_NULLP (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
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:
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);
#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);
+ SCM const *ve = SCM_VELTS (argv);
long i;
for (i = SCM_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
}
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_list_1 (scm_apply (proc, SCM_CAR (arg1), scm_listofnull));
+ *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_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
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_CELL_OBJECT_1 (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),
+ (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_call_0 (SCM_CELL_OBJECT_1 (x));
- 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
#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))
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_CONSP (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));
(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
/* 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);
- /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
- scm_undefineds = scm_list_1 (SCM_UNDEFINED);
- SCM_SETCDR (scm_undefineds, scm_undefineds);
- scm_listofnull = scm_list_1 (SCM_EOL);
+ undefineds = scm_list_1 (SCM_UNDEFINED);
+ SCM_SETCDR (undefineds, undefineds);
+ scm_permanent_object (undefineds);
- scm_f_apply = scm_c_define_subr ("apply", scm_tc7_lsubr_2, scm_apply);
+ scm_listofnull = scm_list_1 (SCM_EOL);
- /* acros */
- /* end of acros */
+ 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_c_define ("nil", scm_lisp_nil);
- scm_c_define ("t", scm_lisp_t);
scm_add_feature ("delay");
}
HCoop / bpt / guile.git / blobdiff