-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004
+ * 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
-/* This file is read twice in order to produce debugging versions of
- * scm_ceval and scm_apply. These functions, scm_deval and
- * scm_dapply, are produced when we define the preprocessor macro
- * DEVAL. The file is divided into sections which are treated
- * differently with respect to DEVAL. The heads of these sections are
- * marked with the string "SECTION:".
- */
+/* This file is read twice in order to produce debugging versions of ceval and
+ * scm_apply. These functions, deval and scm_dapply, are produced when we
+ * define the preprocessor macro DEVAL. The file is divided into sections
+ * which are treated differently with respect to DEVAL. The heads of these
+ * sections are marked with the string "SECTION:". */
/* SECTION: This code is compiled once.
*/
-#ifndef DEVAL
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/__scm.h"
-/* We need this to get the definitions for HAVE_ALLOCA_H, etc. */
-#include "libguile/scmconfig.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
#endif
#include "libguile/_scm.h"
+#include "libguile/alist.h"
+#include "libguile/async.h"
+#include "libguile/continuations.h"
#include "libguile/debug.h"
+#include "libguile/deprecation.h"
#include "libguile/dynwind.h"
-#include "libguile/alist.h"
#include "libguile/eq.h"
-#include "libguile/continuations.h"
-#include "libguile/throw.h"
-#include "libguile/smob.h"
-#include "libguile/macros.h"
-#include "libguile/procprop.h"
-#include "libguile/hashtab.h"
-#include "libguile/hash.h"
-#include "libguile/srcprop.h"
-#include "libguile/stackchk.h"
-#include "libguile/objects.h"
-#include "libguile/async.h"
#include "libguile/feature.h"
+#include "libguile/fluids.h"
+#include "libguile/futures.h"
+#include "libguile/goops.h"
+#include "libguile/hash.h"
+#include "libguile/hashtab.h"
+#include "libguile/lang.h"
+#include "libguile/list.h"
+#include "libguile/macros.h"
#include "libguile/modules.h"
+#include "libguile/objects.h"
#include "libguile/ports.h"
+#include "libguile/print.h"
+#include "libguile/procprop.h"
#include "libguile/root.h"
-#include "libguile/vectors.h"
-#include "libguile/fluids.h"
-#include "libguile/goops.h"
+#include "libguile/smob.h"
+#include "libguile/srcprop.h"
+#include "libguile/stackchk.h"
+#include "libguile/strings.h"
+#include "libguile/throw.h"
+#include "libguile/validate.h"
#include "libguile/values.h"
+#include "libguile/vectors.h"
-#include "libguile/validate.h"
#include "libguile/eval.h"
-#include "libguile/lang.h"
\f
-#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
- do { \
- if (SCM_EQ_P ((x), SCM_EOL)) \
- scm_misc_error (NULL, scm_s_expression, SCM_EOL); \
- } while (0)
+static SCM canonicalize_define (SCM expr);
\f
-/* The evaluator contains a plethora of EVAL symbols.
- * This is an attempt at explanation.
+/* {Syntax Errors}
*
- * The following macros should be used in code which is read twice
- * (where the choice of evaluator is hard soldered):
- *
- * SCM_CEVAL is the symbol used within one evaluator to call itself.
- * Originally, it is defined to scm_ceval, but is redefined to
- * scm_deval during the second pass.
- *
- * 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.
- *
- * The following macros should be used in code which is read once
- * (where the choice of evaluator is dynamic):
+ * This section defines the message strings for the syntax errors that can be
+ * detected during memoization and the functions and macros that shall be
+ * called by the memoizer code to signal syntax errors. */
+
+
+/* Syntax errors that can be detected during memoization: */
+
+/* Circular or improper lists do not form valid scheme expressions. If a
+ * circular list or an improper list is detected in a place where a scheme
+ * expression is expected, a 'Bad expression' error is signalled. */
+static const char s_bad_expression[] = "Bad expression";
+
+/* If a form is detected that holds a different number of expressions than are
+ * required in that context, a 'Missing or extra expression' error is
+ * signalled. */
+static const char s_expression[] = "Missing or extra expression in";
+
+/* If a form is detected that holds less expressions than are required in that
+ * context, a 'Missing expression' error is signalled. */
+static const char s_missing_expression[] = "Missing expression in";
+
+/* If a form is detected that holds more expressions than are allowed in that
+ * context, an 'Extra expression' error is signalled. */
+static const char s_extra_expression[] = "Extra expression in";
+
+/* The empty combination '()' is not allowed as an expression in scheme. If
+ * it is detected in a place where an expression is expected, an 'Illegal
+ * empty combination' error is signalled. Note: If you encounter this error
+ * message, it is very likely that you intended to denote the empty list. To
+ * do so, you need to quote the empty list like (quote ()) or '(). */
+static const char s_empty_combination[] = "Illegal empty combination";
+
+/* A body may hold an arbitrary number of internal defines, followed by a
+ * non-empty sequence of expressions. If a body with an empty sequence of
+ * expressions is detected, a 'Missing body expression' error is signalled.
+ */
+static const char s_missing_body_expression[] = "Missing body expression in";
+
+/* A body may hold an arbitrary number of internal defines, followed by a
+ * non-empty sequence of expressions. Each the definitions and the
+ * expressions may be grouped arbitraryly with begin, but it is not allowed to
+ * mix definitions and expressions. If a define form in a body mixes
+ * definitions and expressions, a 'Mixed definitions and expressions' error is
+ * signalled. */
+static const char s_mixed_body_forms[] = "Mixed definitions and expressions in";
+/* Definitions are only allowed on the top level and at the start of a body.
+ * If a definition is detected anywhere else, a 'Bad define placement' error
+ * is signalled. */
+static const char s_bad_define[] = "Bad define placement";
+
+/* If a macro keyword is detected in a place where macro keywords are not
+ * allowed, a 'Misplaced syntactic keyword' error is signalled. */
+static const char s_macro_keyword[] = "Misplaced syntactic keyword";
+
+/* Case or cond expressions must have at least one clause. If a case or cond
+ * expression without any clauses is detected, a 'Missing clauses' error is
+ * signalled. */
+static const char s_missing_clauses[] = "Missing clauses";
+
+/* If there is an 'else' clause in a case or a cond statement, it must be the
+ * last clause. If after the 'else' case clause further clauses are detected,
+ * a 'Misplaced else clause' error is signalled. */
+static const char s_misplaced_else_clause[] = "Misplaced else clause";
+
+/* If a case clause is detected that is not in the format
+ * (<label(s)> <expression1> <expression2> ...)
+ * a 'Bad case clause' error is signalled. */
+static const char s_bad_case_clause[] = "Bad case clause";
+
+/* If a case clause is detected where the <label(s)> element is neither a
+ * proper list nor (in case of the last clause) the syntactic keyword 'else',
+ * a 'Bad case labels' error is signalled. Note: If you encounter this error
+ * for an else-clause which seems to be syntactically correct, check if 'else'
+ * is really a syntactic keyword in that context. If 'else' is bound in the
+ * local or global environment, it is not considered a syntactic keyword, but
+ * will be treated as any other variable. */
+static const char s_bad_case_labels[] = "Bad case labels";
+
+/* In a case statement all labels have to be distinct. If in a case statement
+ * a label occurs more than once, a 'Duplicate case label' error is
+ * signalled. */
+static const char s_duplicate_case_label[] = "Duplicate case label";
+
+/* If a cond clause is detected that is not in one of the formats
+ * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
+ * a 'Bad cond clause' error is signalled. */
+static const char s_bad_cond_clause[] = "Bad cond clause";
+
+/* If a cond clause is detected that uses the alternate '=>' form, but does
+ * not hold a recipient element for the test result, a 'Missing recipient'
+ * error is signalled. */
+static const char s_missing_recipient[] = "Missing recipient in";
+
+/* If in a position where a variable name is required some other object is
+ * detected, a 'Bad variable' error is signalled. */
+static const char s_bad_variable[] = "Bad variable";
+
+/* Bindings for forms like 'let' and 'do' have to be given in a proper,
+ * possibly empty list. If any other object is detected in a place where a
+ * list of bindings was required, a 'Bad bindings' error is signalled. */
+static const char s_bad_bindings[] = "Bad bindings";
+
+/* Depending on the syntactic context, a binding has to be in the format
+ * (<variable> <expression>) or (<variable> <expression1> <expression2>).
+ * If anything else is detected in a place where a binding was expected, a
+ * 'Bad binding' error is signalled. */
+static const char s_bad_binding[] = "Bad binding";
+
+/* Some syntactic forms don't allow variable names to appear more than once in
+ * a list of bindings. If such a situation is nevertheless detected, a
+ * 'Duplicate binding' error is signalled. */
+static const char s_duplicate_binding[] = "Duplicate binding";
+
+/* If the exit form of a 'do' expression is not in the format
+ * (<test> <expression> ...)
+ * a 'Bad exit clause' error is signalled. */
+static const char s_bad_exit_clause[] = "Bad exit clause";
+
+/* The formal function arguments of a lambda expression have to be either a
+ * single symbol or a non-cyclic list. For anything else a 'Bad formals'
+ * error is signalled. */
+static const char s_bad_formals[] = "Bad formals";
+
+/* If in a lambda expression something else than a symbol is detected at a
+ * place where a formal function argument is required, a 'Bad formal' error is
+ * signalled. */
+static const char s_bad_formal[] = "Bad formal";
+
+/* If in the arguments list of a lambda expression an argument name occurs
+ * more than once, a 'Duplicate formal' error is signalled. */
+static const char s_duplicate_formal[] = "Duplicate formal";
+
+/* If the evaluation of an unquote-splicing expression gives something else
+ * than a proper list, a 'Non-list result for unquote-splicing' error is
+ * signalled. */
+static const char s_splicing[] = "Non-list result for unquote-splicing";
+
+/* If something else than an exact integer is detected as the argument for
+ * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
+static const char s_bad_slot_number[] = "Bad slot number";
+
+
+/* Signal a syntax error. We distinguish between the form that caused the
+ * error and the enclosing expression. The error message will print out as
+ * shown in the following pattern. The file name and line number are only
+ * given when they can be determined from the erroneous form or from the
+ * enclosing expression.
*
- * SCM_XEVAL takes care of immediates without calling an evaluator. It
- * then calls scm_ceval *or* scm_deval, depending on the debugging
- * mode.
- *
- * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
- * depending on the debugging mode.
+ * <filename>: In procedure memoization:
+ * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
+
+SCM_SYMBOL (syntax_error_key, "syntax-error");
+
+/* The prototype is needed to indicate that the function does not return. */
+static void
+syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN;
+
+static void
+syntax_error (const char* const msg, const SCM form, const SCM expr)
+{
+ const SCM msg_string = scm_makfrom0str (msg);
+ SCM filename = SCM_BOOL_F;
+ SCM linenr = SCM_BOOL_F;
+ const char *format;
+ SCM args;
+
+ if (SCM_CONSP (form))
+ {
+ filename = scm_source_property (form, scm_sym_filename);
+ linenr = scm_source_property (form, scm_sym_line);
+ }
+
+ if (SCM_FALSEP (filename) && SCM_FALSEP (linenr) && SCM_CONSP (expr))
+ {
+ filename = scm_source_property (expr, scm_sym_filename);
+ linenr = scm_source_property (expr, scm_sym_line);
+ }
+
+ if (!SCM_UNBNDP (expr))
+ {
+ if (!SCM_FALSEP (filename))
+ {
+ format = "In file ~S, line ~S: ~A ~S in expression ~S.";
+ args = scm_list_5 (filename, linenr, msg_string, form, expr);
+ }
+ else if (!SCM_FALSEP (linenr))
+ {
+ format = "In line ~S: ~A ~S in expression ~S.";
+ args = scm_list_4 (linenr, msg_string, form, expr);
+ }
+ else
+ {
+ format = "~A ~S in expression ~S.";
+ args = scm_list_3 (msg_string, form, expr);
+ }
+ }
+ else
+ {
+ if (!SCM_FALSEP (filename))
+ {
+ format = "In file ~S, line ~S: ~A ~S.";
+ args = scm_list_4 (filename, linenr, msg_string, form);
+ }
+ else if (!SCM_FALSEP (linenr))
+ {
+ format = "In line ~S: ~A ~S.";
+ args = scm_list_3 (linenr, msg_string, form);
+ }
+ else
+ {
+ format = "~A ~S.";
+ args = scm_list_2 (msg_string, form);
+ }
+ }
+
+ scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
+}
+
+
+/* Shortcut macros to simplify syntax error handling. */
+#define ASSERT_SYNTAX(cond, message, form) \
+ { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
+#define ASSERT_SYNTAX_2(cond, message, form, expr) \
+ { if (!(cond)) syntax_error (message, form, expr); }
+
+\f
+
+/* {Ilocs}
*
- * The main motivation for keeping this plethora is efficiency
- * together with maintainability (=> locality of code).
+ * Ilocs are memoized references to variables in local environment frames.
+ * They are represented as three values: The relative offset of the
+ * environment frame, the number of the binding within that frame, and a
+ * boolean value indicating whether the binding is the last binding in the
+ * frame.
+ */
+
+#define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
+#define SCM_IFRINC (0x00000100L)
+#define SCM_ICDR (0x00080000L)
+#define SCM_IDINC (0x00100000L)
+#define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
+ & (SCM_UNPACK (n) >> 8))
+#define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
+#define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
+#define SCM_IDSTMSK (-SCM_IDINC)
+#define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
+ SCM_PACK ( \
+ ((frame_nr) << 8) \
+ + ((binding_nr) << 20) \
+ + ((last_p) ? SCM_ICDR : 0) \
+ + scm_tc8_iloc )
+
+void
+scm_i_print_iloc (SCM iloc, SCM port)
+{
+ scm_puts ("#@", port);
+ scm_intprint ((long) SCM_IFRAME (iloc), 10, port);
+ scm_putc (SCM_ICDRP (iloc) ? '-' : '+', port);
+ scm_intprint ((long) SCM_IDIST (iloc), 10, port);
+}
+
+#if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
+
+SCM scm_dbg_make_iloc (SCM frame, SCM binding, SCM cdrp);
+SCM_DEFINE (scm_dbg_make_iloc, "dbg-make-iloc", 3, 0, 0,
+ (SCM frame, SCM binding, SCM cdrp),
+ "Return a new iloc with frame offset @var{frame}, binding\n"
+ "offset @var{binding} and the cdr flag @var{cdrp}.")
+#define FUNC_NAME s_scm_dbg_make_iloc
+{
+ SCM_VALIDATE_INUM (1, frame);
+ SCM_VALIDATE_INUM (2, binding);
+ return SCM_MAKE_ILOC (SCM_INUM (frame),
+ SCM_INUM (binding),
+ !SCM_FALSEP (cdrp));
+}
+#undef FUNC_NAME
+
+SCM scm_dbg_iloc_p (SCM obj);
+SCM_DEFINE (scm_dbg_iloc_p, "dbg-iloc?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is an iloc.")
+#define FUNC_NAME s_scm_dbg_iloc_p
+{
+ return SCM_BOOL (SCM_ILOCP (obj));
+}
+#undef FUNC_NAME
+
+#endif
+
+\f
+
+/* {Evaluator byte codes (isyms)}
+ */
+
+#define ISYMNUM(n) (SCM_ITAG8_DATA (n))
+
+/* This table must agree with the list of SCM_IM_ constants in tags.h */
+static const char *const isymnames[] =
+{
+ "#@and",
+ "#@begin",
+ "#@case",
+ "#@cond",
+ "#@do",
+ "#@if",
+ "#@lambda",
+ "#@let",
+ "#@let*",
+ "#@letrec",
+ "#@or",
+ "#@quote",
+ "#@set!",
+ "#@define",
+ "#@apply",
+ "#@call-with-current-continuation",
+ "#@dispatch",
+ "#@slot-ref",
+ "#@slot-set!",
+ "#@delay",
+ "#@future",
+ "#@call-with-values",
+ "#@else",
+ "#@arrow",
+ "#@nil-cond",
+ "#@bind"
+};
+
+void
+scm_i_print_isym (SCM isym, SCM port)
+{
+ const size_t isymnum = ISYMNUM (isym);
+ if (isymnum < (sizeof isymnames / sizeof (char *)))
+ scm_puts (isymnames[isymnum], port);
+ else
+ scm_ipruk ("isym", isym, port);
+}
+
+\f
+
+/* The function lookup_symbol is used during memoization: Lookup the symbol
+ * in the environment. If there is no binding for the symbol, SCM_UNDEFINED
+ * is returned. If the symbol is a syntactic keyword, the macro object to
+ * which the symbol is bound is returned. If the symbol is a global variable,
+ * the variable object to which the symbol is bound is returned. Finally, if
+ * the symbol is a local variable the corresponding iloc object is returned.
*/
-#define SCM_CEVAL scm_ceval
+/* A helper function for lookup_symbol: Try to find the symbol in the top
+ * level environment frame. The function returns SCM_UNDEFINED if the symbol
+ * is unbound, it returns a macro object if the symbol is a syntactic keyword
+ * and it returns a variable object if the symbol is a global variable. */
+static SCM
+lookup_global_symbol (const SCM symbol, const SCM top_level)
+{
+ const SCM variable = scm_sym2var (symbol, top_level, SCM_BOOL_F);
+ if (SCM_FALSEP (variable))
+ {
+ return SCM_UNDEFINED;
+ }
+ else
+ {
+ const SCM value = SCM_VARIABLE_REF (variable);
+ if (SCM_MACROP (value))
+ return value;
+ else
+ return variable;
+ }
+}
+
+static SCM
+lookup_symbol (const SCM symbol, const SCM env)
+{
+ SCM frame_idx;
+ unsigned int frame_nr;
+
+ for (frame_idx = env, frame_nr = 0;
+ !SCM_NULLP (frame_idx);
+ frame_idx = SCM_CDR (frame_idx), ++frame_nr)
+ {
+ const SCM frame = SCM_CAR (frame_idx);
+ if (SCM_CONSP (frame))
+ {
+ /* frame holds a local environment frame */
+ SCM symbol_idx;
+ unsigned int symbol_nr;
+
+ for (symbol_idx = SCM_CAR (frame), symbol_nr = 0;
+ SCM_CONSP (symbol_idx);
+ symbol_idx = SCM_CDR (symbol_idx), ++symbol_nr)
+ {
+ if (SCM_EQ_P (SCM_CAR (symbol_idx), symbol))
+ /* found the symbol, therefore return the iloc */
+ return SCM_MAKE_ILOC (frame_nr, symbol_nr, 0);
+ }
+ if (SCM_EQ_P (symbol_idx, symbol))
+ /* found the symbol as the last element of the current frame */
+ return SCM_MAKE_ILOC (frame_nr, symbol_nr, 1);
+ }
+ else
+ {
+ /* no more local environment frames */
+ return lookup_global_symbol (symbol, frame);
+ }
+ }
+
+ return lookup_global_symbol (symbol, SCM_BOOL_F);
+}
+
+
+/* Return true if the symbol is - from the point of view of a macro
+ * transformer - a literal in the sense specified in chapter "pattern
+ * language" of R5RS. In the code below, however, we don't match the
+ * definition of R5RS exactly: It returns true if the identifier has no
+ * binding or if it is a syntactic keyword. */
+static int
+literal_p (const SCM symbol, const SCM env)
+{
+ const SCM value = lookup_symbol (symbol, env);
+ if (SCM_UNBNDP (value) || SCM_MACROP (value))
+ return 1;
+ else
+ return 0;
+}
+
-#define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
- ? SCM_EVALIM (SCM_CAR (x), env) \
- : (SCM_SYMBOLP (SCM_CAR (x)) \
- ? *scm_lookupcar (x, env, 1) \
- : SCM_CEVAL (SCM_CAR (x), env)))
+/* Return true if the expression is self-quoting in the memoized code. Thus,
+ * some other objects (like e. g. vectors) are reported as self-quoting, which
+ * according to R5RS would need to be quoted. */
+static int
+is_self_quoting_p (const SCM expr)
+{
+ if (SCM_CONSP (expr))
+ return 0;
+ else if (SCM_SYMBOLP (expr))
+ return 0;
+ else if (SCM_NULLP (expr))
+ return 0;
+ else return 1;
+}
-#define EXTEND_ENV SCM_EXTEND_ENV
+\f
+/* 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));
+}
+
+
+SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
+
+static void error_unbound_variable (SCM symbol) SCM_NORETURN;
+static void
+error_unbound_variable (SCM symbol)
+{
+ scm_error (scm_unbound_variable_key, NULL,
+ "Unbound variable: ~S",
+ scm_list_1 (symbol), SCM_BOOL_F);
}
+
/* 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.)
for NULL. I think I've found the only places where this
applies. */
-SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
-
static SCM *
scm_lookupcar1 (SCM vloc, SCM genv, int check)
{
if (check)
{
if (SCM_NULLP (env))
- scm_error (scm_unbound_variable_key, NULL,
- "Unbound variable: ~S",
- scm_list_1 (var), SCM_BOOL_F);
+ error_unbound_variable (var);
else
scm_misc_error (NULL, "Damaged environment: ~S",
scm_list_1 (var));
var = SCM_CAR (vloc);
if (SCM_VARIABLEP (var))
return SCM_VARIABLE_LOC (var);
- if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00))
+ if (SCM_ILOCP (var))
return scm_ilookup (var, genv);
/* We can't cope with anything else than variables and ilocs. When
a special form has been memoized (i.e. `let' into `#@let') we
return loc;
}
-#define unmemocar scm_unmemocar
+\f
-SCM_SYMBOL (sym_three_question_marks, "???");
+/* Rewrite the body (which is given as the list of expressions forming the
+ * body) into its internal form. The internal form of a body (<expr> ...) is
+ * just the body itself, but prefixed with an ISYM that denotes to what kind
+ * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
+ * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
+ * SCM_IM_LET, etc.
+ *
+ * It is assumed that the calling expression has already made sure that the
+ * body is a proper list. */
+static SCM
+m_body (SCM op, SCM exprs)
+{
+ /* Don't add another ISYM if one is present already. */
+ if (SCM_ISYMP (SCM_CAR (exprs)))
+ return exprs;
+ else
+ return scm_cons (op, exprs);
+}
-SCM
-scm_unmemocar (SCM form, SCM env)
+
+/* The function m_expand_body memoizes a proper list of expressions
+ * forming a body. This function takes care of dealing with internal
+ * defines and transforming them into an equivalent letrec expression.
+ * The list of expressions is rewritten in place. */
+
+/* This is a helper function for m_expand_body. It helps to figure out whether
+ * an expression denotes a syntactic keyword. */
+static SCM
+try_macro_lookup (const SCM expr, const SCM env)
{
- if (!SCM_CONSP (form))
- return form;
+ if (SCM_SYMBOLP (expr))
+ {
+ const SCM value = lookup_symbol (expr, env);
+ return value;
+ }
else
{
- SCM c = SCM_CAR (form);
- if (SCM_VARIABLEP (c))
+ return SCM_UNDEFINED;
+ }
+}
+
+/* This is a helper function for m_expand_body. It expands user macros,
+ * because for the correct translation of a body we need to know whether they
+ * expand to a definition. */
+static SCM
+expand_user_macros (SCM expr, const SCM env)
+{
+ while (SCM_CONSP (expr))
+ {
+ const SCM car_expr = SCM_CAR (expr);
+ const SCM new_car = expand_user_macros (car_expr, env);
+ const SCM value = try_macro_lookup (new_car, env);
+
+ if (SCM_MACROP (value) && SCM_MACRO_TYPE (value) == 2)
{
- SCM sym = scm_module_reverse_lookup (scm_env_module (env), c);
- if (SCM_FALSEP (sym))
- sym = sym_three_question_marks;
- SCM_SETCAR (form, sym);
+ /* User macros transform code into code. */
+ expr = scm_call_2 (SCM_MACRO_CODE (value), expr, env);
+ /* We need to reiterate on the transformed code. */
}
- else if (SCM_ILOCP (c))
+ else
{
- 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));
+ /* No user macro: return. */
+ SCM_SETCAR (expr, new_car);
+ return expr;
}
- return form;
}
-}
+ return expr;
+}
-SCM
-scm_eval_car (SCM pair, SCM env)
+/* This is a helper function for m_expand_body. It determines if a given form
+ * represents an application of a given built-in macro. The built-in macro to
+ * check for is identified by its syntactic keyword. The form is an
+ * application of the given macro if looking up the car of the form in the
+ * given environment actually returns the built-in macro. */
+static int
+is_system_macro_p (const SCM syntactic_keyword, const SCM form, const SCM env)
{
- return SCM_XEVALCAR (pair, env);
+ if (SCM_CONSP (form))
+ {
+ const SCM car_form = SCM_CAR (form);
+ const SCM value = try_macro_lookup (car_form, env);
+ if (SCM_BUILTIN_MACRO_P (value))
+ {
+ const SCM macro_name = scm_macro_name (value);
+ return SCM_EQ_P (macro_name, syntactic_keyword);
+ }
+ }
+
+ return 0;
}
-\f
-/*
- * The following rewrite expressions and
- * some memoized forms have different syntax
- */
+static void
+m_expand_body (const SCM forms, const SCM env)
+{
+ /* The first body form can be skipped since it is known to be the ISYM that
+ * was prepended to the body by m_body. */
+ SCM cdr_forms = SCM_CDR (forms);
+ SCM form_idx = cdr_forms;
+ SCM definitions = SCM_EOL;
+ SCM sequence = SCM_EOL;
+
+ /* According to R5RS, the list of body forms consists of two parts: a number
+ * (maybe zero) of definitions, followed by a non-empty sequence of
+ * expressions. Each the definitions and the expressions may be grouped
+ * arbitrarily with begin, but it is not allowed to mix definitions and
+ * expressions. The task of the following loop therefore is to split the
+ * list of body forms into the list of definitions and the sequence of
+ * expressions. */
+ while (!SCM_NULLP (form_idx))
+ {
+ const SCM form = SCM_CAR (form_idx);
+ const SCM new_form = expand_user_macros (form, env);
+ if (is_system_macro_p (scm_sym_define, new_form, env))
+ {
+ definitions = scm_cons (new_form, definitions);
+ form_idx = SCM_CDR (form_idx);
+ }
+ else if (is_system_macro_p (scm_sym_begin, new_form, env))
+ {
+ /* We have encountered a group of forms. This has to be either a
+ * (possibly empty) group of (possibly further grouped) definitions,
+ * or a non-empty group of (possibly further grouped)
+ * expressions. */
+ const SCM grouped_forms = SCM_CDR (new_form);
+ unsigned int found_definition = 0;
+ unsigned int found_expression = 0;
+ SCM grouped_form_idx = grouped_forms;
+ while (!found_expression && !SCM_NULLP (grouped_form_idx))
+ {
+ const SCM inner_form = SCM_CAR (grouped_form_idx);
+ const SCM new_inner_form = expand_user_macros (inner_form, env);
+ if (is_system_macro_p (scm_sym_define, new_inner_form, env))
+ {
+ found_definition = 1;
+ definitions = scm_cons (new_inner_form, definitions);
+ grouped_form_idx = SCM_CDR (grouped_form_idx);
+ }
+ else if (is_system_macro_p (scm_sym_begin, new_inner_form, env))
+ {
+ const SCM inner_group = SCM_CDR (new_inner_form);
+ grouped_form_idx
+ = scm_append (scm_list_2 (inner_group,
+ SCM_CDR (grouped_form_idx)));
+ }
+ else
+ {
+ /* The group marks the start of the expressions of the body.
+ * We have to make sure that within the same group we have
+ * not encountered a definition before. */
+ ASSERT_SYNTAX (!found_definition, s_mixed_body_forms, form);
+ found_expression = 1;
+ grouped_form_idx = SCM_EOL;
+ }
+ }
+
+ /* We have finished processing the group. If we have not yet
+ * encountered an expression we continue processing the forms of the
+ * body to collect further definition forms. Otherwise, the group
+ * marks the start of the sequence of expressions of the body. */
+ if (!found_expression)
+ {
+ form_idx = SCM_CDR (form_idx);
+ }
+ else
+ {
+ sequence = form_idx;
+ form_idx = SCM_EOL;
+ }
+ }
+ else
+ {
+ /* We have detected a form which is no definition. This marks the
+ * start of the sequence of expressions of the body. */
+ sequence = form_idx;
+ form_idx = SCM_EOL;
+ }
+ }
-const char scm_s_expression[] = "missing or extra expression";
-const char scm_s_test[] = "bad test";
-const char scm_s_body[] = "bad body";
-const char scm_s_bindings[] = "bad bindings";
-const char scm_s_duplicate_bindings[] = "duplicate bindings";
-const char scm_s_variable[] = "bad variable";
-const char scm_s_clauses[] = "bad or missing clauses";
-const char scm_s_formals[] = "bad formals";
-const char scm_s_duplicate_formals[] = "duplicate formals";
-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_else, "else");
-SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
-SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
+ /* FIXME: forms does not hold information about the file location. */
+ ASSERT_SYNTAX (SCM_CONSP (sequence), s_missing_body_expression, cdr_forms);
-SCM scm_f_apply;
+ if (!SCM_NULLP (definitions))
+ {
+ SCM definition_idx;
+ SCM letrec_tail;
+ SCM letrec_expression;
+ SCM new_letrec_expression;
+
+ SCM bindings = SCM_EOL;
+ for (definition_idx = definitions;
+ !SCM_NULLP (definition_idx);
+ definition_idx = SCM_CDR (definition_idx))
+ {
+ const SCM definition = SCM_CAR (definition_idx);
+ const SCM canonical_definition = canonicalize_define (definition);
+ const SCM binding = SCM_CDR (canonical_definition);
+ bindings = scm_cons (binding, bindings);
+ };
+
+ letrec_tail = scm_cons (bindings, sequence);
+ /* FIXME: forms does not hold information about the file location. */
+ letrec_expression = scm_cons_source (forms, scm_sym_letrec, letrec_tail);
+ new_letrec_expression = scm_m_letrec (letrec_expression, env);
+ SCM_SETCAR (forms, new_letrec_expression);
+ SCM_SETCDR (forms, SCM_EOL);
+ }
+ else
+ {
+ SCM_SETCAR (forms, SCM_CAR (sequence));
+ SCM_SETCDR (forms, SCM_CDR (sequence));
+ }
+}
-#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
+/* Start of the memoizers for the standard R5RS builtin macros. */
-/* Check that the body denoted by XORIG is valid and rewrite it into
- its internal form. The internal form of a body is just the body
- itself, but prefixed with an ISYM that denotes to what kind of
- outer construct this body belongs. A lambda body starts with
- SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
- etc. The one exception is a body that belongs to a letrec that has
- been formed by rewriting internal defines: it starts with
- SCM_IM_DEFINE. */
-/* XXX - Besides controlling the rewriting of internal defines, the
- additional ISYM could be used for improved error messages.
- This is not done yet. */
+SCM_SYNTAX (s_and, "and", scm_i_makbimacro, scm_m_and);
+SCM_GLOBAL_SYMBOL (scm_sym_and, s_and);
-static SCM
-scm_m_body (SCM op, SCM xorig, const char *what)
+SCM
+scm_m_and (SCM expr, SCM env SCM_UNUSED)
{
- SCM_ASSYNT (scm_ilength (xorig) >= 1, scm_s_body, what);
+ const SCM cdr_expr = SCM_CDR (expr);
+ const long length = scm_ilength (cdr_expr);
- /* Don't add another ISYM if one is present already. */
- if (SCM_ISYMP (SCM_CAR (xorig)))
- return xorig;
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
- /* Retain possible doc string. */
- if (!SCM_CONSP (SCM_CAR (xorig)))
+ if (length == 0)
{
- if (!SCM_NULLP (SCM_CDR (xorig)))
- return scm_cons (SCM_CAR (xorig),
- scm_m_body (op, SCM_CDR (xorig), what));
- return xorig;
+ /* Special case: (and) is replaced by #t. */
+ return SCM_BOOL_T;
+ }
+ else
+ {
+ SCM_SETCAR (expr, SCM_IM_AND);
+ return expr;
}
-
- return scm_cons (op, xorig);
}
-SCM_SYNTAX (s_quote, "quote", scm_makmmacro, scm_m_quote);
-SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
+SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
+SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
SCM
-scm_m_quote (SCM xorig, SCM env SCM_UNUSED)
+scm_m_begin (SCM expr, SCM env SCM_UNUSED)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, s_quote);
- return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig));
+ const SCM cdr_expr = SCM_CDR (expr);
+ /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
+ * That means, there should be a distinction between uses of begin where an
+ * empty clause is OK and where it is not. */
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+
+ SCM_SETCAR (expr, SCM_IM_BEGIN);
+ return expr;
}
-SCM_SYNTAX (s_begin, "begin", scm_makmmacro, scm_m_begin);
-SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
+SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case);
+SCM_GLOBAL_SYMBOL (scm_sym_case, s_case);
+SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
SCM
-scm_m_begin (SCM xorig, SCM env SCM_UNUSED)
+scm_m_case (SCM expr, SCM env)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 0, scm_s_expression, s_begin);
- return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig));
+ SCM clauses;
+ SCM all_labels = SCM_EOL;
+
+ /* Check, whether 'else is a literal, i. e. not bound to a value. */
+ const int else_literal_p = literal_p (scm_sym_else, env);
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_clauses, expr);
+
+ clauses = SCM_CDR (cdr_expr);
+ while (!SCM_NULLP (clauses))
+ {
+ SCM labels;
+
+ const SCM clause = SCM_CAR (clauses);
+ ASSERT_SYNTAX_2 (scm_ilength (clause) >= 2,
+ s_bad_case_clause, clause, expr);
+
+ labels = SCM_CAR (clause);
+ if (SCM_CONSP (labels))
+ {
+ ASSERT_SYNTAX_2 (scm_ilength (labels) >= 0,
+ s_bad_case_labels, labels, expr);
+ all_labels = scm_append_x (scm_list_2 (labels, all_labels));
+ }
+ else if (SCM_NULLP (labels))
+ {
+ /* The list of labels is empty. According to R5RS this is allowed.
+ * It means that the sequence of expressions will never be executed.
+ * Therefore, as an optimization, we could remove the whole
+ * clause. */
+ }
+ else
+ {
+ ASSERT_SYNTAX_2 (SCM_EQ_P (labels, scm_sym_else) && else_literal_p,
+ s_bad_case_labels, labels, expr);
+ ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses)),
+ s_misplaced_else_clause, clause, expr);
+ }
+
+ /* build the new clause */
+ if (SCM_EQ_P (labels, scm_sym_else))
+ SCM_SETCAR (clause, SCM_IM_ELSE);
+
+ clauses = SCM_CDR (clauses);
+ }
+
+ /* Check whether all case labels are distinct. */
+ for (; !SCM_NULLP (all_labels); all_labels = SCM_CDR (all_labels))
+ {
+ const SCM label = SCM_CAR (all_labels);
+ ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (label, SCM_CDR (all_labels))),
+ s_duplicate_case_label, label, expr);
+ }
+
+ SCM_SETCAR (expr, SCM_IM_CASE);
+ return expr;
}
-SCM_SYNTAX (s_if, "if", scm_makmmacro, scm_m_if);
-SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
+SCM_SYNTAX (s_cond, "cond", scm_i_makbimacro, scm_m_cond);
+SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond);
+SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
SCM
-scm_m_if (SCM xorig, SCM env SCM_UNUSED)
+scm_m_cond (SCM expr, SCM env)
{
- 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));
+ /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
+ const int else_literal_p = literal_p (scm_sym_else, env);
+ const int arrow_literal_p = literal_p (scm_sym_arrow, env);
+
+ const SCM clauses = SCM_CDR (expr);
+ SCM clause_idx;
+
+ ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr);
+
+ for (clause_idx = clauses;
+ !SCM_NULLP (clause_idx);
+ clause_idx = SCM_CDR (clause_idx))
+ {
+ SCM test;
+
+ const SCM clause = SCM_CAR (clause_idx);
+ const long length = scm_ilength (clause);
+ ASSERT_SYNTAX_2 (length >= 1, s_bad_cond_clause, clause, expr);
+
+ test = SCM_CAR (clause);
+ if (SCM_EQ_P (test, scm_sym_else) && else_literal_p)
+ {
+ const int last_clause_p = SCM_NULLP (SCM_CDR (clause_idx));
+ ASSERT_SYNTAX_2 (length >= 2,
+ s_bad_cond_clause, clause, expr);
+ ASSERT_SYNTAX_2 (last_clause_p,
+ s_misplaced_else_clause, clause, expr);
+ SCM_SETCAR (clause, SCM_IM_ELSE);
+ }
+ else if (length >= 2
+ && SCM_EQ_P (SCM_CADR (clause), scm_sym_arrow)
+ && arrow_literal_p)
+ {
+ ASSERT_SYNTAX_2 (length > 2, s_missing_recipient, clause, expr);
+ ASSERT_SYNTAX_2 (length == 3, s_extra_expression, clause, expr);
+ SCM_SETCAR (SCM_CDR (clause), SCM_IM_ARROW);
+ }
+ }
+
+ SCM_SETCAR (expr, SCM_IM_COND);
+ return expr;
}
-/* 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_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define);
+SCM_GLOBAL_SYMBOL (scm_sym_define, s_define);
-SCM
-scm_m_set_x (SCM xorig, SCM env SCM_UNUSED)
+/* 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. */
+static SCM
+canonicalize_define (const SCM expr)
{
- 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);
-}
+ SCM body;
+ SCM variable;
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
-SCM_SYNTAX (s_and, "and", scm_makmmacro, scm_m_and);
-SCM_GLOBAL_SYMBOL (scm_sym_and, s_and);
+ body = SCM_CDR (cdr_expr);
+ variable = SCM_CAR (cdr_expr);
+ while (SCM_CONSP (variable))
+ {
+ /* This while loop realizes function currying by variable nesting.
+ * Variable is known to be a nested-variable. In every iteration of the
+ * loop another level of lambda expression is created, starting with the
+ * innermost one. Note that we don't check for duplicate formals here:
+ * This will be done by the memoizer of the lambda expression. */
+ const SCM formals = SCM_CDR (variable);
+ const SCM tail = scm_cons (formals, body);
+
+ /* Add source properties to each new lambda expression: */
+ const SCM lambda = scm_cons_source (variable, scm_sym_lambda, tail);
+
+ body = scm_list_1 (lambda);
+ variable = SCM_CAR (variable);
+ }
+ ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr);
+ ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
+
+ SCM_SETCAR (cdr_expr, variable);
+ SCM_SETCDR (cdr_expr, body);
+ return expr;
+}
+/* According to section 5.2.1 of R5RS we first have to make sure that the
+ * variable is bound, and then perform the (set! variable expression)
+ * operation. This means, that within the expression we may already assign
+ * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
SCM
-scm_m_and (SCM xorig, SCM env SCM_UNUSED)
+scm_m_define (SCM expr, SCM env)
{
- long len = scm_ilength (SCM_CDR (xorig));
- SCM_ASSYNT (len >= 0, scm_s_test, s_and);
- if (len >= 1)
- return scm_cons (SCM_IM_AND, SCM_CDR (xorig));
- else
- return SCM_BOOL_T;
+ ASSERT_SYNTAX (SCM_TOP_LEVEL (env), s_bad_define, expr);
+
+ {
+ const SCM canonical_definition = canonicalize_define (expr);
+ const SCM cdr_canonical_definition = SCM_CDR (canonical_definition);
+ const SCM variable = SCM_CAR (cdr_canonical_definition);
+ const SCM location
+ = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T);
+ const SCM value = scm_eval_car (SCM_CDR (cdr_canonical_definition), env);
+
+ if (SCM_REC_PROCNAMES_P)
+ {
+ SCM tmp = value;
+ 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, variable);
+ }
+
+ SCM_VARIABLE_SET (location, value);
+
+ return SCM_UNSPECIFIED;
+ }
}
-SCM_SYNTAX (s_or, "or", scm_makmmacro, scm_m_or);
-SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
+/* This is a helper function for forms (<keyword> <expression>) that are
+ * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
+ * for easy creation of a thunk (i. e. a closure without arguments) using the
+ * ('() <memoized_expression>) tail of the memoized form. */
+static SCM
+memoize_as_thunk_prototype (const SCM expr, const SCM env SCM_UNUSED)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
+
+ SCM_SETCDR (expr, scm_cons (SCM_EOL, cdr_expr));
+ return expr;
+}
+
+
+SCM_SYNTAX (s_delay, "delay", scm_i_makbimacro, scm_m_delay);
+SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
+
+/* 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_or (SCM xorig, SCM env SCM_UNUSED)
+scm_m_delay (SCM expr, SCM env)
{
- 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;
+ const SCM new_expr = memoize_as_thunk_prototype (expr, env);
+ SCM_SETCAR (new_expr, SCM_IM_DELAY);
+ return new_expr;
}
-SCM_SYNTAX (s_case, "case", scm_makmmacro, scm_m_case);
-SCM_GLOBAL_SYMBOL (scm_sym_case, s_case);
+SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do);
+SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
-SCM
-scm_m_case (SCM xorig, SCM env SCM_UNUSED)
+/* DO gets the most radically altered syntax. The order of the vars is
+ * reversed here. During the evaluation this allows for simple consing of the
+ * results of the inits and steps:
+
+ (do ((<var1> <init1> <step1>)
+ (<var2> <init2>)
+ ... )
+ (<test> <return>)
+ <body>)
+
+ ;; becomes
+
+ (#@do (<init1> <init2> ... <initn>)
+ (varn ... var2 var1)
+ (<test> <return>)
+ (<body>)
+ <step1> <step2> ... <stepn>) ;; missing steps replaced by var
+ */
+SCM
+scm_m_do (SCM expr, SCM env SCM_UNUSED)
{
- SCM clauses;
- SCM cdrx = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (cdrx) >= 2, scm_s_clauses, s_case);
- clauses = SCM_CDR (cdrx);
- while (!SCM_NULLP (clauses))
+ SCM variables = SCM_EOL;
+ SCM init_forms = SCM_EOL;
+ SCM step_forms = SCM_EOL;
+ SCM binding_idx;
+ SCM cddr_expr;
+ SCM exit_clause;
+ SCM commands;
+ SCM tail;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+
+ /* Collect variables, init and step forms. */
+ binding_idx = SCM_CAR (cdr_expr);
+ ASSERT_SYNTAX_2 (scm_ilength (binding_idx) >= 0,
+ s_bad_bindings, binding_idx, expr);
+ for (; !SCM_NULLP (binding_idx); binding_idx = SCM_CDR (binding_idx))
{
- SCM clause = SCM_CAR (clauses);
- SCM_ASSYNT (scm_ilength (clause) >= 2, scm_s_clauses, s_case);
- SCM_ASSYNT (scm_ilength (SCM_CAR (clause)) >= 0
- || (SCM_EQ_P (scm_sym_else, SCM_CAR (clause))
- && SCM_NULLP (SCM_CDR (clauses))),
- scm_s_clauses, s_case);
- clauses = SCM_CDR (clauses);
+ const SCM binding = SCM_CAR (binding_idx);
+ const long length = scm_ilength (binding);
+ ASSERT_SYNTAX_2 (length == 2 || length == 3,
+ s_bad_binding, binding, expr);
+
+ {
+ const SCM name = SCM_CAR (binding);
+ const SCM init = SCM_CADR (binding);
+ const SCM step = (length == 2) ? name : SCM_CADDR (binding);
+ ASSERT_SYNTAX_2 (SCM_SYMBOLP (name), s_bad_variable, name, expr);
+ ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name, variables)),
+ s_duplicate_binding, name, expr);
+
+ variables = scm_cons (name, variables);
+ init_forms = scm_cons (init, init_forms);
+ step_forms = scm_cons (step, step_forms);
+ }
}
- return scm_cons (SCM_IM_CASE, cdrx);
+ init_forms = scm_reverse_x (init_forms, SCM_UNDEFINED);
+ step_forms = scm_reverse_x (step_forms, SCM_UNDEFINED);
+
+ /* Memoize the test form and the exit sequence. */
+ cddr_expr = SCM_CDR (cdr_expr);
+ exit_clause = SCM_CAR (cddr_expr);
+ ASSERT_SYNTAX_2 (scm_ilength (exit_clause) >= 1,
+ s_bad_exit_clause, exit_clause, expr);
+
+ commands = SCM_CDR (cddr_expr);
+ tail = scm_cons2 (exit_clause, commands, step_forms);
+ tail = scm_cons2 (init_forms, variables, tail);
+ SCM_SETCAR (expr, SCM_IM_DO);
+ SCM_SETCDR (expr, tail);
+ return expr;
}
-SCM_SYNTAX (s_cond, "cond", scm_makmmacro, scm_m_cond);
-SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond);
+SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if);
+SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
SCM
-scm_m_cond (SCM xorig, SCM env SCM_UNUSED)
+scm_m_if (SCM expr, SCM env SCM_UNUSED)
{
- SCM cdrx = SCM_CDR (xorig);
- SCM clauses = cdrx;
- SCM_ASSYNT (scm_ilength (clauses) >= 1, scm_s_clauses, s_cond);
- while (!SCM_NULLP (clauses))
- {
- SCM clause = SCM_CAR (clauses);
- long len = scm_ilength (clause);
- SCM_ASSYNT (len >= 1, scm_s_clauses, s_cond);
- if (SCM_EQ_P (scm_sym_else, SCM_CAR (clause)))
- {
- int last_clause_p = SCM_NULLP (SCM_CDR (clauses));
- SCM_ASSYNT (len >= 2 && last_clause_p, "bad ELSE clause", s_cond);
- }
- else if (len >= 2 && SCM_EQ_P (scm_sym_arrow, SCM_CADR (clause)))
- {
- SCM_ASSYNT (len > 2, "missing recipient", s_cond);
- SCM_ASSYNT (len == 3, "bad recipient", s_cond);
- }
- clauses = SCM_CDR (clauses);
- }
- return scm_cons (SCM_IM_COND, cdrx);
+ const SCM cdr_expr = SCM_CDR (expr);
+ const long length = scm_ilength (cdr_expr);
+ ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
+ SCM_SETCAR (expr, SCM_IM_IF);
+ return expr;
}
-SCM_SYNTAX (s_lambda, "lambda", scm_makmmacro, scm_m_lambda);
+SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, 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.) */
+/* A helper function for memoize_lambda to support checking for duplicate
+ * formal arguments: Return true if OBJ is `eq?' to one of the elements of
+ * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
+ * forms that a formal argument can have:
+ * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
static int
-scm_c_improper_memq (SCM obj, SCM list)
+c_improper_memq (SCM obj, SCM list)
{
for (; SCM_CONSP (list); list = SCM_CDR (list))
{
if (SCM_EQ_P (SCM_CAR (list), obj))
- return 1;
+ return 1;
}
return SCM_EQ_P (list, obj);
}
SCM
-scm_m_lambda (SCM xorig, SCM env SCM_UNUSED)
+scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
{
SCM formals;
- SCM x = SCM_CDR (xorig);
+ SCM formals_idx;
+ SCM cddr_expr;
+ int documentation;
+ SCM body;
+ SCM new_body;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ const long length = scm_ilength (cdr_expr);
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
+
+ /* Before iterating the list of formal arguments, make sure the formals
+ * actually are given as either a symbol or a non-cyclic list. */
+ formals = SCM_CAR (cdr_expr);
+ if (SCM_CONSP (formals))
+ {
+ /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
+ * detected, report a 'Bad formals' error. */
+ }
+ else
+ {
+ ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals) || SCM_NULLP (formals),
+ s_bad_formals, formals, expr);
+ }
- SCM_ASSYNT (SCM_CONSP (x), scm_s_formals, s_lambda);
+ /* Now iterate the list of formal arguments to check if all formals are
+ * symbols, and that there are no duplicates. */
+ formals_idx = formals;
+ while (SCM_CONSP (formals_idx))
+ {
+ const SCM formal = SCM_CAR (formals_idx);
+ const SCM next_idx = SCM_CDR (formals_idx);
+ ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal), s_bad_formal, formal, expr);
+ ASSERT_SYNTAX_2 (!c_improper_memq (formal, next_idx),
+ s_duplicate_formal, formal, expr);
+ formals_idx = next_idx;
+ }
+ ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx) || SCM_SYMBOLP (formals_idx),
+ s_bad_formal, formals_idx, expr);
+
+ /* Memoize the body. Keep a potential documentation string. */
+ /* Dirk:FIXME:: We should probably extract the documentation string to
+ * some external database. Otherwise it will slow down execution, since
+ * the documentation string will have to be skipped with every execution
+ * of the closure. */
+ cddr_expr = SCM_CDR (cdr_expr);
+ documentation = (length >= 3 && SCM_STRINGP (SCM_CAR (cddr_expr)));
+ body = documentation ? SCM_CDR (cddr_expr) : cddr_expr;
+ new_body = m_body (SCM_IM_LAMBDA, body);
+
+ SCM_SETCAR (expr, SCM_IM_LAMBDA);
+ if (documentation)
+ SCM_SETCDR (cddr_expr, new_body);
+ else
+ SCM_SETCDR (cdr_expr, new_body);
+ return expr;
+}
+
+
+/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
+static void
+check_bindings (const SCM bindings, const SCM expr)
+{
+ SCM binding_idx;
- formals = SCM_CAR (x);
- while (SCM_CONSP (formals))
+ ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
+ s_bad_bindings, bindings, expr);
+
+ binding_idx = bindings;
+ for (; !SCM_NULLP (binding_idx); binding_idx = SCM_CDR (binding_idx))
{
- 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 name; /* const */
+
+ const SCM binding = SCM_CAR (binding_idx);
+ ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
+ s_bad_binding, binding, expr);
+
+ name = SCM_CAR (binding);
+ ASSERT_SYNTAX_2 (SCM_SYMBOLP (name), s_bad_variable, name, expr);
}
- 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));
+/* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
+ * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
+ * variables are returned in a list with their order reversed, and the init
+ * forms are returned in a list in the same order as they are given in the
+ * bindings. If a duplicate variable name is detected, an error is
+ * signalled. */
+static void
+transform_bindings (
+ const SCM bindings, const SCM expr,
+ SCM *const rvarptr, SCM *const initptr )
+{
+ SCM rvariables = SCM_EOL;
+ SCM rinits = SCM_EOL;
+ SCM binding_idx = bindings;
+ for (; !SCM_NULLP (binding_idx); binding_idx = SCM_CDR (binding_idx))
+ {
+ const SCM binding = SCM_CAR (binding_idx);
+ const SCM cdr_binding = SCM_CDR (binding);
+ const SCM name = SCM_CAR (binding);
+ ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name, rvariables)),
+ s_duplicate_binding, name, expr);
+ rvariables = scm_cons (name, rvariables);
+ rinits = scm_cons (SCM_CAR (cdr_binding), rinits);
+ }
+ *rvarptr = rvariables;
+ *initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
}
-SCM_SYNTAX (s_letstar, "let*", scm_makmmacro, scm_m_letstar);
-SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);
+SCM_SYNTAX(s_let, "let", scm_i_makbimacro, scm_m_let);
+SCM_GLOBAL_SYMBOL(scm_sym_let, s_let);
+
+/* This function is a helper function for memoize_let. It transforms
+ * (let name ((var init) ...) body ...) into
+ * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
+ * and memoizes the expression. It is assumed that the caller has checked
+ * that name is a symbol and that there are bindings and a body. */
+static SCM
+memoize_named_let (const SCM expr, const SCM env SCM_UNUSED)
+{
+ SCM rvariables;
+ SCM variables;
+ SCM inits;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ const SCM name = SCM_CAR (cdr_expr);
+ const SCM cddr_expr = SCM_CDR (cdr_expr);
+ const SCM bindings = SCM_CAR (cddr_expr);
+ check_bindings (bindings, expr);
+
+ transform_bindings (bindings, expr, &rvariables, &inits);
+ variables = scm_reverse_x (rvariables, SCM_UNDEFINED);
-/* (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*). */
+ {
+ const SCM let_body = SCM_CDR (cddr_expr);
+ const SCM lambda_body = m_body (SCM_IM_LET, let_body);
+ const SCM lambda_tail = scm_cons (variables, lambda_body);
+ const SCM lambda_form = scm_cons_source (expr, scm_sym_lambda, lambda_tail);
+
+ const SCM rvar = scm_list_1 (name);
+ const SCM init = scm_list_1 (lambda_form);
+ const SCM body = m_body (SCM_IM_LET, scm_list_1 (name));
+ const SCM letrec_tail = scm_cons (rvar, scm_cons (init, body));
+ const SCM letrec_form = scm_cons_source (expr, SCM_IM_LETREC, letrec_tail);
+ return scm_cons_source (expr, letrec_form, inits);
+ }
+}
+
+/* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
+ * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
SCM
-scm_m_letstar (SCM xorig, SCM env SCM_UNUSED)
+scm_m_let (SCM expr, SCM env)
{
SCM bindings;
- SCM x = SCM_CDR (xorig);
- SCM vars = SCM_EOL;
- SCM *varloc = &vars;
- SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letstar);
+ const SCM cdr_expr = SCM_CDR (expr);
+ const long length = scm_ilength (cdr_expr);
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
- bindings = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_letstar);
- while (!SCM_NULLP (bindings))
+ bindings = SCM_CAR (cdr_expr);
+ if (SCM_SYMBOLP (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);
+ ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
+ return memoize_named_let (expr, env);
}
- return scm_cons2 (SCM_IM_LETSTAR, vars,
- scm_m_body (SCM_IM_LETSTAR, SCM_CDR (x), s_letstar));
+ check_bindings (bindings, expr);
+ if (SCM_NULLP (bindings) || SCM_NULLP (SCM_CDR (bindings)))
+ {
+ /* Special case: no bindings or single binding => let* is faster. */
+ const SCM body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr));
+ return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env);
+ }
+ else
+ {
+ /* plain let */
+ SCM rvariables;
+ SCM inits;
+ transform_bindings (bindings, expr, &rvariables, &inits);
+
+ {
+ const SCM new_body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr));
+ const SCM new_tail = scm_cons2 (rvariables, inits, new_body);
+ SCM_SETCAR (expr, SCM_IM_LET);
+ SCM_SETCDR (expr, new_tail);
+ return expr;
+ }
+ }
}
-/* 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:
+SCM_SYNTAX (s_letstar, "let*", scm_i_makbimacro, scm_m_letstar);
+SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);
- (do ((<var1> <init1> <step1>)
- (<var2> <init2>)
- ... )
- (<test> <return>)
- <body>)
+/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
+ * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
+SCM
+scm_m_letstar (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM binding_idx;
+ SCM new_body;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+
+ binding_idx = SCM_CAR (cdr_expr);
+ check_bindings (binding_idx, expr);
+
+ /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
+ * transformation is done in place. At the beginning of one iteration of
+ * the loop the variable binding_idx holds the form
+ * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
+ * where P1, P2 and P3 indicate the pairs, that are relevant for the
+ * transformation. P1 and P2 are modified in the loop, P3 remains
+ * untouched. After the execution of the loop, P1 will hold
+ * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
+ * and binding_idx will hold P3. */
+ while (!SCM_NULLP (binding_idx))
+ {
+ const SCM cdr_binding_idx = SCM_CDR (binding_idx); /* remember P3 */
+ const SCM binding = SCM_CAR (binding_idx);
+ const SCM name = SCM_CAR (binding);
+ const SCM cdr_binding = SCM_CDR (binding);
- ;; becomes
+ SCM_SETCDR (cdr_binding, cdr_binding_idx); /* update P2 */
+ SCM_SETCAR (binding_idx, name); /* update P1 */
+ SCM_SETCDR (binding_idx, cdr_binding); /* update P1 */
- (#@do (varn ... var2 var1)
- (<init1> <init2> ... <initn>)
- (<test> <return>)
- (<body>)
- <step1> <step2> ... <stepn>) ;; missing steps replaced by var
- */
+ binding_idx = cdr_binding_idx; /* continue with P3 */
+ }
+
+ new_body = m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr));
+ SCM_SETCAR (expr, SCM_IM_LETSTAR);
+ /* the bindings have been changed in place */
+ SCM_SETCDR (cdr_expr, new_body);
+ return expr;
+}
-SCM_SYNTAX(s_do, "do", scm_makmmacro, scm_m_do);
-SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
+
+SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec);
+SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
SCM
-scm_m_do (SCM xorig, SCM env SCM_UNUSED)
+scm_m_letrec (SCM expr, SCM env)
{
SCM bindings;
- SCM x = SCM_CDR (xorig);
- SCM vars = SCM_EOL;
- SCM inits = SCM_EOL;
- SCM *initloc = &inits;
- SCM steps = SCM_EOL;
- SCM *steploc = &steps;
- SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_test, "do");
- bindings = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, "do");
- while (!SCM_NULLP (bindings))
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+
+ bindings = SCM_CAR (cdr_expr);
+ if (SCM_NULLP (bindings))
{
- SCM binding = SCM_CAR (bindings);
- long len = scm_ilength (binding);
- SCM_ASSYNT (len == 2 || len == 3, scm_s_bindings, "do");
- {
- SCM name = SCM_CAR (binding);
- SCM init = SCM_CADR (binding);
- SCM step = (len == 2) ? name : SCM_CADDR (binding);
- SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_variable, "do");
- vars = scm_cons (name, vars);
- *initloc = scm_list_1 (init);
- initloc = SCM_CDRLOC (*initloc);
- *steploc = scm_list_1 (step);
- steploc = SCM_CDRLOC (*steploc);
- bindings = SCM_CDR (bindings);
- }
+ /* no bindings, let* is executed faster */
+ SCM body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
+ return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env);
+ }
+ else
+ {
+ SCM rvariables;
+ SCM inits;
+ SCM new_body;
+
+ check_bindings (bindings, expr);
+ transform_bindings (bindings, expr, &rvariables, &inits);
+ new_body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
+ return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body));
+ }
+}
+
+
+SCM_SYNTAX (s_or, "or", scm_i_makbimacro, scm_m_or);
+SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
+
+SCM
+scm_m_or (SCM expr, SCM env SCM_UNUSED)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ const long length = scm_ilength (cdr_expr);
+
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+
+ if (length == 0)
+ {
+ /* Special case: (or) is replaced by #f. */
+ return SCM_BOOL_F;
+ }
+ else
+ {
+ SCM_SETCAR (expr, SCM_IM_OR);
+ return expr;
}
- x = SCM_CDR (x);
- SCM_ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, scm_s_test, "do");
- x = scm_cons2 (SCM_CAR (x), SCM_CDR (x), steps);
- x = scm_cons2 (vars, inits, x);
- return scm_cons (SCM_IM_DO, x);
}
SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);
+SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
+SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
/* Internal function to handle a quasiquotation: 'form' is the parameter in
* the call (quasiquotation form), 'env' is the environment where unquoted
{
if (SCM_CONSP (form))
{
- SCM tmp = SCM_CAR (form);
+ const 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);
+ const SCM args = SCM_CDR (form);
+ ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
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);
+ const SCM args = SCM_CDR (form);
+ ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
if (depth - 1 == 0)
return scm_eval_car (args, env);
else
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);
+ const SCM args = SCM_CDR (tmp);
+ ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
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);
+ const SCM list = scm_eval_car (args, env);
+ const SCM rest = SCM_CDR (form);
+ ASSERT_SYNTAX_2 (scm_ilength (list) >= 0,
+ s_splicing, list, form);
return scm_append (scm_list_2 (list, iqq (rest, env, depth)));
}
else
else if (SCM_VECTORP (form))
{
size_t i = SCM_VECTOR_LENGTH (form);
- SCM const *data = SCM_VELTS (form);
+ SCM const *const data = SCM_VELTS (form);
SCM tmp = SCM_EOL;
while (i != 0)
tmp = scm_cons (data[--i], tmp);
}
SCM
-scm_m_quasiquote (SCM xorig, SCM env)
+scm_m_quasiquote (SCM expr, SCM env)
{
- SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_quasiquote);
- return iqq (SCM_CAR (x), env, 1);
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
+ return iqq (SCM_CAR (cdr_expr), env, 1);
}
-SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay);
-SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
+SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote);
+SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
-/* Promises are implemented as closures with an empty parameter list. Thus,
- * (delay <expression>) is transformed into (#@delay '() <expression>), where
- * the empty list represents the empty parameter list. This representation
- * allows for easy creation of the closure during evaluation. */
SCM
-scm_m_delay (SCM xorig, SCM env SCM_UNUSED)
+scm_m_quote (SCM expr, 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));
+ SCM quotee;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
+ quotee = SCM_CAR (cdr_expr);
+ if (is_self_quoting_p (quotee))
+ return quotee;
+ SCM_SETCAR (expr, SCM_IM_QUOTE);
+ return expr;
}
-SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define);
-SCM_GLOBAL_SYMBOL(scm_sym_define, s_define);
+/* Will go into the RnRS module when Guile is factorized.
+SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
+static const char s_set_x[] = "set!";
+SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x);
-/* Guile provides an extension to R5RS' define syntax to represent function
- * currying in a compact way. With this extension, it is allowed to write
- * (define <nested-variable> <body>), where <nested-variable> has of one of
- * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
- * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
- * should be either a sequence of zero or more variables, or a sequence of one
- * or more variables followed by a space-delimited period and another
- * variable. Each level of argument nesting wraps the <body> within another
- * lambda expression. For example, the following forms are allowed, each one
- * followed by an equivalent, more explicit implementation.
- * Example 1:
- * (define ((a b . c) . d) <body>) is equivalent to
- * (define a (lambda (b . c) (lambda d <body>)))
- * Example 2:
- * (define (((a) b) c . d) <body>) is equivalent to
- * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
- */
-/* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
- * module that does not implement this extension. */
SCM
-scm_m_define (SCM x, SCM env)
+scm_m_set_x (SCM expr, SCM env SCM_UNUSED)
{
- 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))
- {
- /* This while loop realizes function currying by variable nesting. */
- SCM formals = SCM_CDR (name);
- x = scm_list_1 (scm_cons2 (scm_sym_lambda, formals, x));
- name = SCM_CAR (name);
- }
- SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_variable, s_define);
- SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_define);
- if (SCM_TOP_LEVEL (env))
- {
- 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;
- }
- else
- return scm_cons2 (SCM_IM_DEFINE, name, x);
+ SCM variable;
+ SCM new_variable;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
+ variable = SCM_CAR (cdr_expr);
+
+ /* Memoize the variable form. */
+ ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr);
+ new_variable = lookup_symbol (variable, env);
+ ASSERT_SYNTAX (!SCM_MACROP (new_variable), s_macro_keyword, variable);
+ /* Leave the memoization of unbound symbols to lazy memoization: */
+ if (SCM_UNBNDP (new_variable))
+ new_variable = variable;
+
+ SCM_SETCAR (expr, SCM_IM_SET_X);
+ SCM_SETCAR (cdr_expr, new_variable);
+ return expr;
}
-/* 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 rvars = SCM_EOL;
- *rvarloc = SCM_EOL;
- *initloc = SCM_EOL;
-
- SCM_ASSYNT (scm_ilength (bindings) >= 1, scm_s_bindings, what);
-
- do
- {
- 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);
- rvars = scm_cons (SCM_CAR (binding), rvars);
- *initloc = scm_list_1 (SCM_CADR (binding));
- initloc = SCM_CDRLOC (*initloc);
- bindings = SCM_CDR (bindings);
- }
- while (!SCM_NULLP (bindings));
-
- *rvarloc = rvars;
-}
+/* Start of the memoizers for non-R5RS builtin macros. */
-SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec);
-SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
+SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply);
+SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply);
+SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
SCM
-scm_m_letrec (SCM xorig, SCM env)
+scm_m_apply (SCM expr, SCM env SCM_UNUSED)
{
- 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));
- }
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_missing_expression, expr);
+
+ SCM_SETCAR (expr, SCM_IM_APPLY);
+ return expr;
}
-SCM_SYNTAX(s_let, "let", scm_makmmacro, scm_m_let);
-SCM_GLOBAL_SYMBOL(scm_sym_let, s_let);
+SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind);
+
+/* FIXME: The following explanation should go into the documentation: */
+/* (@bind ((var init) ...) body ...) will assign the values of the `init's to
+ * the global variables named by `var's (symbols, not evaluated), creating
+ * them if they don't exist, executes body, and then restores the previous
+ * values of the `var's. Additionally, whenever control leaves body, the
+ * values of the `var's are saved and restored when control returns. It is an
+ * error when a symbol appears more than once among the `var's. All `init's
+ * are evaluated before any `var' is set.
+ *
+ * Think of this as `let' for dynamic scope.
+ */
+/* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
+ * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
+ *
+ * FIXME - also implement `@bind*'.
+ */
SCM
-scm_m_let (SCM xorig, SCM env)
+scm_m_atbind (SCM expr, SCM env)
{
- 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 */
- 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);
- }
- else if (SCM_CONSP (temp))
+ SCM bindings;
+ SCM rvariables;
+ SCM inits;
+ SCM variable_idx;
+
+ const SCM top_level = scm_env_top_level (env);
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+ bindings = SCM_CAR (cdr_expr);
+ check_bindings (bindings, expr);
+ transform_bindings (bindings, expr, &rvariables, &inits);
+
+ for (variable_idx = rvariables;
+ !SCM_NULLP (variable_idx);
+ variable_idx = SCM_CDR (variable_idx))
{
- /* 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));
+ /* The first call to scm_sym2var will look beyond the current module,
+ * while the second call wont. */
+ const SCM variable = SCM_CAR (variable_idx);
+ SCM new_variable = scm_sym2var (variable, top_level, SCM_BOOL_F);
+ if (SCM_FALSEP (new_variable))
+ new_variable = scm_sym2var (variable, top_level, SCM_BOOL_T);
+ SCM_SETCAR (variable_idx, new_variable);
}
- else
- {
- /* named let: Transform (let name ((var init) ...) body ...) into
- * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
-
- 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);
- }
- {
- 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_SETCAR (expr, SCM_IM_BIND);
+ SCM_SETCAR (cdr_expr, scm_cons (rvariables, inits));
+ return expr;
}
-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_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont);
+SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc);
SCM
-scm_m_apply (SCM xorig, SCM env SCM_UNUSED)
+scm_m_cont (SCM expr, 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));
-}
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
+ SCM_SETCAR (expr, SCM_IM_CONT);
+ return expr;
+}
-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_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_at_call_with_values);
+SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);
-SCM
-scm_m_cont (SCM xorig, SCM env SCM_UNUSED)
+SCM
+scm_m_at_call_with_values (SCM expr, 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));
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
+
+ SCM_SETCAR (expr, SCM_IM_CALL_WITH_VALUES);
+ return expr;
}
-#ifdef SCM_ENABLE_ELISP
-SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond);
+SCM_SYNTAX (s_future, "future", scm_i_makbimacro, 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_nil_cond (SCM xorig, SCM env SCM_UNUSED)
+scm_m_future (SCM expr, SCM env)
{
- 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));
+ const SCM new_expr = memoize_as_thunk_prototype (expr, env);
+ SCM_SETCAR (new_expr, SCM_IM_FUTURE);
+ return new_expr;
}
-SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop);
-SCM
-scm_m_atfop (SCM xorig, SCM env SCM_UNUSED)
+SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x);
+SCM_SYMBOL (scm_sym_setter, "setter");
+
+SCM
+scm_m_generalized_set_x (SCM expr, SCM env)
{
- 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)))
+ SCM target, exp_target;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
+
+ target = SCM_CAR (cdr_expr);
+ if (!SCM_CONSP (target))
{
- 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)));
+ /* R5RS usage */
+ return scm_m_set_x (expr, env);
}
- /* 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)))
+ else
{
- 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;
-}
+ /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
+ /* Macroexpanding the target might return things of the form
+ (begin <atom>). In that case, <atom> must be a symbol or a
+ variable and we memoize to (set! <atom> ...).
+ */
+ exp_target = scm_macroexp (target, env);
+ if (SCM_EQ_P (SCM_CAR (exp_target), SCM_IM_BEGIN)
+ && !SCM_NULLP (SCM_CDR (exp_target))
+ && SCM_NULLP (SCM_CDDR (exp_target)))
+ {
+ exp_target= SCM_CADR (exp_target);
+ ASSERT_SYNTAX_2 (SCM_SYMBOLP (exp_target)
+ || SCM_VARIABLEP (exp_target),
+ s_bad_variable, exp_target, expr);
+ return scm_cons (SCM_IM_SET_X, scm_cons (exp_target,
+ SCM_CDR (cdr_expr)));
+ }
+ else
+ {
+ const SCM setter_proc_tail = scm_list_1 (SCM_CAR (target));
+ const SCM setter_proc = scm_cons_source (expr, scm_sym_setter,
+ setter_proc_tail);
-#endif /* SCM_ENABLE_ELISP */
+ const SCM cddr_expr = SCM_CDR (cdr_expr);
+ const SCM setter_args = scm_append_x (scm_list_2 (SCM_CDR (target),
+ cddr_expr));
-/* (@bind ((var exp) ...) body ...)
+ SCM_SETCAR (expr, setter_proc);
+ SCM_SETCDR (expr, setter_args);
+ return expr;
+ }
+ }
+}
- This will assign the values of the `exp's to the global variables
- named by `var's (symbols, not evaluated), creating them if they
- don't exist, executes body, and then restores the previous values of
- the `var's. Additionally, whenever control leaves body, the values
- of the `var's are saved and restored when control returns. It is an
- error when a symbol appears more than once among the `var's.
- All `exp's are evaluated before any `var' is set.
- Think of this as `let' for dynamic scope.
+/* @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 expr, SCM env SCM_UNUSED)
+{
+ SCM slot_nr;
- It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
+ slot_nr = SCM_CADR (cdr_expr);
+ ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr);
- XXX - also implement `@bind*'.
-*/
+ SCM_SETCAR (expr, SCM_IM_SLOT_REF);
+ return expr;
+}
-SCM_SYNTAX (s_atbind, "@bind", scm_makmmacro, scm_m_atbind);
+/* @slot-set! is bound privately in the (oop goops) module from goops.c. As
+ * soon as the module system allows us to more freely create bindings in
+ * arbitrary modules during the startup phase, the code from goops.c should be
+ * moved here. */
SCM
-scm_m_atbind (SCM xorig, SCM env)
+scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED)
{
- SCM x = SCM_CDR (xorig);
- SCM top_level = scm_env_top_level (env);
- SCM vars = SCM_EOL, var;
- SCM exps = SCM_EOL;
+ SCM slot_nr;
- SCM_ASSYNT (scm_ilength (x) > 1, scm_s_expression, s_atbind);
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 3, s_expression, expr);
+ slot_nr = SCM_CADR (cdr_expr);
+ ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr);
- x = SCM_CAR (x);
- while (SCM_NIMP (x))
- {
- SCM rest;
- SCM sym_exp = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (sym_exp) == 2, scm_s_bindings, s_atbind);
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp)), scm_s_bindings, s_atbind);
- x = SCM_CDR (x);
- for (rest = x; SCM_NIMP (rest); rest = SCM_CDR (rest))
- if (SCM_EQ_P (SCM_CAR (sym_exp), SCM_CAAR (rest)))
- scm_misc_error (s_atbind, scm_s_duplicate_bindings, SCM_EOL);
- /* The first call to scm_sym2var will look beyond the current
- module, while the second call wont. */
- var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_F);
- if (SCM_FALSEP (var))
- var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_T);
- vars = scm_cons (var, vars);
- exps = scm_cons (SCM_CADR (sym_exp), exps);
- }
- return scm_cons (SCM_IM_BIND,
- scm_cons (scm_cons (scm_reverse_x (vars, SCM_EOL), exps),
- SCM_CDDR (xorig)));
+ SCM_SETCAR (expr, SCM_IM_SLOT_SET_X);
+ return expr;
}
-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);
+#if SCM_ENABLE_ELISP
+
+static const char s_defun[] = "Symbol's function definition is void";
+
+SCM_SYNTAX (s_nil_cond, "nil-cond", scm_i_makbimacro, scm_m_nil_cond);
+
+/* nil-cond expressions have the form
+ * (nil-cond COND VAL COND VAL ... ELSEVAL) */
SCM
-scm_m_at_call_with_values (SCM xorig, SCM env SCM_UNUSED)
+scm_m_nil_cond (SCM expr, SCM env SCM_UNUSED)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2,
- scm_s_expression, s_at_call_with_values);
- return scm_cons (SCM_IM_CALL_WITH_VALUES, SCM_CDR (xorig));
+ const long length = scm_ilength (SCM_CDR (expr));
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (length >= 1 && (length % 2) == 1, s_expression, expr);
+
+ SCM_SETCAR (expr, SCM_IM_NIL_COND);
+ return expr;
}
+
+SCM_SYNTAX (s_atfop, "@fop", scm_i_makbimacro, scm_m_atfop);
+
+/* The @fop-macro handles procedure and macro applications for elisp. The
+ * input expression must have the form
+ * (@fop <var> (transformer-macro <expr> ...))
+ * where <var> must be a symbol. The expression is transformed into the
+ * memoized form of either
+ * (apply <un-aliased var> (transformer-macro <expr> ...))
+ * if the value of var (across all aliasing) is not a macro, or
+ * (<un-aliased var> <expr> ...)
+ * if var is a macro. */
SCM
-scm_m_expand_body (SCM xorig, SCM env)
+scm_m_atfop (SCM expr, SCM env SCM_UNUSED)
{
- SCM x = SCM_CDR (xorig), defs = SCM_EOL;
- char *what = SCM_ISYMCHARS (SCM_CAR (xorig)) + 2;
+ SCM location;
+ SCM symbol;
- while (SCM_NIMP (x))
- {
- SCM form = SCM_CAR (x);
- if (!SCM_CONSP (form))
- break;
- if (!SCM_SYMBOLP (SCM_CAR (form)))
- break;
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_missing_expression, expr);
- form = scm_macroexp (scm_cons_source (form,
- SCM_CAR (form),
- SCM_CDR (form)),
- env);
+ symbol = SCM_CAR (cdr_expr);
+ ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol), s_bad_variable, symbol, expr);
- if (SCM_EQ_P (SCM_IM_DEFINE, SCM_CAR (form)))
- {
- defs = scm_cons (SCM_CDR (form), defs);
- x = SCM_CDR (x);
- }
- else if (!SCM_IMP (defs))
- {
- break;
- }
- else if (SCM_EQ_P (SCM_IM_BEGIN, SCM_CAR (form)))
- {
- x = scm_append (scm_list_2 (SCM_CDR (form), SCM_CDR (x)));
- }
- else
- {
- x = scm_cons (form, SCM_CDR (x));
- break;
- }
+ location = scm_symbol_fref (symbol);
+ ASSERT_SYNTAX_2 (SCM_VARIABLEP (location), s_defun, symbol, expr);
+
+ /* The elisp function `defalias' allows to define aliases for symbols. To
+ * look up such definitions, the chain of symbol definitions has to be
+ * followed up to the terminal symbol. */
+ while (SCM_SYMBOLP (SCM_VARIABLE_REF (location)))
+ {
+ const SCM alias = SCM_VARIABLE_REF (location);
+ location = scm_symbol_fref (alias);
+ ASSERT_SYNTAX_2 (SCM_VARIABLEP (location), s_defun, symbol, expr);
}
- if (!SCM_NULLP (defs))
+ /* Memoize the value location belonging to the terminal symbol. */
+ SCM_SETCAR (cdr_expr, location);
+
+ if (!SCM_MACROP (SCM_VARIABLE_REF (location)))
{
- 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);
+ /* Since the location does not contain a macro, the form is a procedure
+ * application. Replace `@fop' by `@apply' and transform the expression
+ * including the `transformer-macro'. */
+ SCM_SETCAR (expr, SCM_IM_APPLY);
+ return expr;
}
else
{
- SCM_ASSYNT (SCM_CONSP (x), scm_s_body, what);
- SCM_SETCAR (xorig, SCM_CAR (x));
- SCM_SETCDR (xorig, SCM_CDR (x));
+ /* Since the location contains a macro, the arguments should not be
+ * transformed, so the `transformer-macro' is cut out. The resulting
+ * expression starts with the memoized variable, that is at the cdr of
+ * the input expression. */
+ SCM_SETCDR (cdr_expr, SCM_CDADR (cdr_expr));
+ return cdr_expr;
}
+}
+
+#endif /* SCM_ENABLE_ELISP */
+
+
+#if (SCM_ENABLE_DEPRECATED == 1)
- return xorig;
+/* Deprecated in guile 1.7.0 on 2003-11-09. */
+SCM
+scm_m_expand_body (SCM exprs, SCM env)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_m_expand_body' is deprecated.");
+ m_expand_body (exprs, env);
+ return exprs;
+}
+
+
+SCM_SYNTAX (s_undefine, "undefine", scm_makacro, scm_m_undefine);
+
+SCM
+scm_m_undefine (SCM expr, SCM env)
+{
+ SCM variable;
+ SCM location;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (SCM_TOP_LEVEL (env), "Bad undefine placement in", expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
+
+ variable = SCM_CAR (cdr_expr);
+ ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr);
+ location = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_F);
+ ASSERT_SYNTAX_2 (!SCM_FALSEP (location)
+ && !SCM_UNBNDP (SCM_VARIABLE_REF (location)),
+ "variable already unbound ", variable, expr);
+ SCM_VARIABLE_SET (location, SCM_UNDEFINED);
+ return SCM_UNSPECIFIED;
}
+
SCM
scm_macroexp (SCM x, SCM env)
{
/* Only handle memoizing macros. `Acros' and `macros' are really
special forms and should not be evaluated here. */
- if (!SCM_MACROP (proc) || SCM_MACRO_TYPE (proc) != 2)
+ if (!SCM_MACROP (proc)
+ || (SCM_MACRO_TYPE (proc) != 2 && !SCM_BUILTIN_MACRO_P (proc)))
return x;
SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */
goto macro_tail;
}
+#endif
+
+/*****************************************************************************/
+/*****************************************************************************/
+/* The definitions for unmemoization start here. */
+/*****************************************************************************/
+/*****************************************************************************/
+
+#define SCM_BIT7(x) (127 & SCM_UNPACK (x))
+
+SCM_SYMBOL (sym_three_question_marks, "???");
+
+
/* 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
* This ought to change.
*/
-#define SCM_BIT8(x) (127 & SCM_UNPACK (x))
-
static SCM
-build_binding_list (SCM names, SCM inits)
+build_binding_list (SCM rnames, SCM rinits)
{
SCM bindings = SCM_EOL;
- while (!SCM_NULLP (names))
+ while (!SCM_NULLP (rnames))
{
- SCM binding = scm_list_2 (SCM_CAR (names), SCM_CAR (inits));
+ SCM binding = scm_list_2 (SCM_CAR (rnames), SCM_CAR (rinits));
bindings = scm_cons (binding, bindings);
- names = SCM_CDR (names);
- inits = SCM_CDR (inits);
+ rnames = SCM_CDR (rnames);
+ rinits = SCM_CDR (rinits);
}
return bindings;
}
+
static SCM
-unmemocopy (SCM x, SCM env)
+unmemocar (SCM form, SCM env)
+{
+ if (!SCM_CONSP (form))
+ return form;
+ else
+ {
+ 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;
+ }
+}
+
+
+SCM
+scm_unmemocopy (SCM x, SCM env)
{
SCM ls, z;
-#ifdef DEBUG_EXTENSIONS
SCM p;
-#endif
- if (!SCM_CONSP (x))
+
+ if (SCM_VECTORP (x))
+ {
+ return scm_list_2 (scm_sym_quote, x);
+ }
+ else if (!SCM_CONSP (x))
return x;
-#ifdef DEBUG_EXTENSIONS
+
p = scm_whash_lookup (scm_source_whash, x);
-#endif
- switch (SCM_ITAG7 (SCM_CAR (x)))
+ if (SCM_ISYMP (SCM_CAR (x)))
{
- case SCM_BIT8(SCM_IM_AND):
- ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED);
- break;
- case SCM_BIT8(SCM_IM_BEGIN):
- ls = z = scm_cons (scm_sym_begin, SCM_UNSPECIFIED);
- break;
- case SCM_BIT8(SCM_IM_CASE):
- ls = z = scm_cons (scm_sym_case, SCM_UNSPECIFIED);
- break;
- case SCM_BIT8(SCM_IM_COND):
- ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED);
- break;
- case SCM_BIT8 (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
- * the local variable, test is the test clause of the do loop, body is
- * the body of the do loop and sx are the step clauses for the local
- * variables. */
- SCM names, inits, test, memoized_body, steps, bindings;
-
- x = SCM_CDR (x);
- names = SCM_CAR (x);
- x = SCM_CDR (x);
- inits = scm_reverse (unmemocopy (SCM_CAR (x), env));
- env = EXTEND_ENV (names, SCM_EOL, env);
- x = SCM_CDR (x);
- test = unmemocopy (SCM_CAR (x), env);
- x = SCM_CDR (x);
- memoized_body = SCM_CAR (x);
- x = SCM_CDR (x);
- steps = scm_reverse (unmemocopy (x, env));
-
- /* build transformed binding list */
- bindings = SCM_EOL;
- while (!SCM_NULLP (names))
- {
- SCM name = SCM_CAR (names);
- SCM init = SCM_CAR (inits);
- SCM step = SCM_CAR (steps);
- step = SCM_EQ_P (step, name) ? SCM_EOL : scm_list_1 (step);
-
- bindings = scm_cons (scm_cons2 (name, init, step), bindings);
-
- names = SCM_CDR (names);
- inits = SCM_CDR (inits);
- steps = SCM_CDR (steps);
- }
- z = scm_cons (test, SCM_UNSPECIFIED);
- ls = scm_cons2 (scm_sym_do, bindings, z);
-
- x = scm_cons (SCM_BOOL_F, memoized_body);
- break;
- }
- case SCM_BIT8(SCM_IM_IF):
- ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED);
- break;
- case SCM_BIT8 (SCM_IM_LET):
- {
- /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
- * where nx is the name of a local variable, ix is an initializer for
- * the local variable and by are the body clauses. */
- SCM names, inits, bindings;
-
- x = SCM_CDR (x);
- names = SCM_CAR (x);
- x = SCM_CDR (x);
- inits = scm_reverse (unmemocopy (SCM_CAR (x), env));
- env = EXTEND_ENV (names, SCM_EOL, env);
-
- bindings = build_binding_list (names, inits);
- z = scm_cons (bindings, SCM_UNSPECIFIED);
- ls = scm_cons (scm_sym_let, z);
- break;
- }
- case SCM_BIT8 (SCM_IM_LETREC):
- {
- /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
- * where nx is the name of a local variable, ix is an initializer for
- * the local variable and by are the body clauses. */
- SCM names, inits, bindings;
-
- x = SCM_CDR (x);
- names = SCM_CAR (x);
- env = EXTEND_ENV (names, SCM_EOL, env);
- x = SCM_CDR (x);
- inits = scm_reverse (unmemocopy (SCM_CAR (x), env));
-
- bindings = build_binding_list (names, inits);
- z = scm_cons (bindings, SCM_UNSPECIFIED);
- ls = scm_cons (scm_sym_letrec, z);
- break;
- }
- case SCM_BIT8(SCM_IM_LETSTAR):
- {
- SCM b, y;
- x = SCM_CDR (x);
- b = SCM_CAR (x);
- y = SCM_EOL;
- if SCM_IMP (b)
- {
- env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
- goto letstar;
- }
- y = z = scm_acons (SCM_CAR (b),
- unmemocar (
- scm_cons (unmemocopy (SCM_CADR (b), env), SCM_EOL), env),
- SCM_UNSPECIFIED);
- env = 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));
- break;
- }
- do
- {
- SCM_SETCDR (z, scm_acons (SCM_CAR (b),
- unmemocar (
- scm_list_1 (unmemocopy (SCM_CADR (b), env)), env),
- SCM_UNSPECIFIED));
- z = SCM_CDR (z);
- env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
- b = SCM_CDDR (b);
- }
- while (SCM_NIMP (b));
- SCM_SETCDR (z, SCM_EOL);
- letstar:
- ls = scm_cons (scm_sym_letstar, z = scm_cons (y, SCM_UNSPECIFIED));
- break;
- }
- case SCM_BIT8(SCM_IM_OR):
- ls = z = scm_cons (scm_sym_or, SCM_UNSPECIFIED);
- break;
- case SCM_BIT8(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);
- break;
- case SCM_BIT8(SCM_IM_QUOTE):
- ls = z = scm_cons (scm_sym_quote, SCM_UNSPECIFIED);
- break;
- case SCM_BIT8(SCM_IM_SET_X):
- ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED);
- break;
- case SCM_BIT8(SCM_IM_DEFINE):
- {
- SCM n;
- x = SCM_CDR (x);
- n = SCM_CAR (x);
- z = scm_cons (n, SCM_UNSPECIFIED);
- ls = scm_cons (scm_sym_define, z);
- if (!SCM_NULLP (env))
- env = scm_cons (scm_cons (scm_cons (n, SCM_CAAR (env)),
- SCM_CDAR (env)),
- SCM_CDR (env));
- break;
- }
- case SCM_BIT8(SCM_MAKISYM (0)):
- z = SCM_CAR (x);
- if (!SCM_ISYMP (z))
- goto unmemo;
- switch (SCM_ISYMNUM (z))
- {
- case (SCM_ISYMNUM (SCM_IM_APPLY)):
+ switch (ISYMNUM (SCM_CAR (x)))
+ {
+ case (ISYMNUM (SCM_IM_AND)):
+ ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED);
+ break;
+ case (ISYMNUM (SCM_IM_BEGIN)):
+ ls = z = scm_cons (scm_sym_begin, SCM_UNSPECIFIED);
+ break;
+ case (ISYMNUM (SCM_IM_CASE)):
+ ls = z = scm_cons (scm_sym_case, SCM_UNSPECIFIED);
+ break;
+ case (ISYMNUM (SCM_IM_COND)):
+ ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED);
+ break;
+ case (ISYMNUM (SCM_IM_DO)):
+ {
+ /* format: (#@do (i1 ... ik) (nk ... n1) (test) (body) s1 ... sk),
+ * where ix is an initializer for a local variable, nx is the name
+ * of the local variable, test is the test clause of the do loop,
+ * body is the body of the do loop and sx are the step clauses for
+ * the local variables. */
+ SCM names, inits, test, memoized_body, steps, bindings;
+
+ x = SCM_CDR (x);
+ inits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env));
+ x = SCM_CDR (x);
+ names = SCM_CAR (x);
+ env = SCM_EXTEND_ENV (names, SCM_EOL, env);
+ x = SCM_CDR (x);
+ test = scm_unmemocopy (SCM_CAR (x), env);
+ x = SCM_CDR (x);
+ memoized_body = SCM_CAR (x);
+ x = SCM_CDR (x);
+ steps = scm_reverse (scm_unmemocopy (x, env));
+
+ /* build transformed binding list */
+ bindings = SCM_EOL;
+ while (!SCM_NULLP (names))
+ {
+ SCM name = SCM_CAR (names);
+ SCM init = SCM_CAR (inits);
+ SCM step = SCM_CAR (steps);
+ step = SCM_EQ_P (step, name) ? SCM_EOL : scm_list_1 (step);
+
+ bindings = scm_cons (scm_cons2 (name, init, step), bindings);
+
+ names = SCM_CDR (names);
+ inits = SCM_CDR (inits);
+ steps = SCM_CDR (steps);
+ }
+ z = scm_cons (test, SCM_UNSPECIFIED);
+ ls = scm_cons2 (scm_sym_do, bindings, z);
+
+ x = scm_cons (SCM_BOOL_F, memoized_body);
+ break;
+ }
+ case (ISYMNUM (SCM_IM_IF)):
+ ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED);
+ break;
+ case (ISYMNUM (SCM_IM_LET)):
+ {
+ /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
+ * where nx is the name of a local variable, ix is an initializer
+ * for the local variable and by are the body clauses. */
+ SCM rnames, rinits, bindings;
+
+ x = SCM_CDR (x);
+ rnames = SCM_CAR (x);
+ x = SCM_CDR (x);
+ rinits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env));
+ env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);
+
+ bindings = build_binding_list (rnames, rinits);
+ z = scm_cons (bindings, SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_let, z);
+ break;
+ }
+ case (ISYMNUM (SCM_IM_LETREC)):
+ {
+ /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...),
+ * where vx is the name of a local variable, ix is an initializer
+ * for the local variable and by are the body clauses. */
+ SCM rnames, rinits, bindings;
+
+ x = SCM_CDR (x);
+ rnames = SCM_CAR (x);
+ env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);
+ x = SCM_CDR (x);
+ rinits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env));
+
+ bindings = build_binding_list (rnames, rinits);
+ z = scm_cons (bindings, SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_letrec, z);
+ break;
+ }
+ case (ISYMNUM (SCM_IM_LETSTAR)):
+ {
+ SCM b, y;
+ x = SCM_CDR (x);
+ b = SCM_CAR (x);
+ y = SCM_EOL;
+ if (SCM_NULLP (b))
+ {
+ env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env);
+ }
+ else
+ {
+ SCM copy = scm_unmemocopy (SCM_CADR (b), env);
+ SCM initializer = unmemocar (scm_list_1 (copy), env);
+ y = z = scm_acons (SCM_CAR (b), initializer, SCM_UNSPECIFIED);
+ env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
+ b = SCM_CDDR (b);
+ if (SCM_NULLP (b))
+ {
+ SCM_SETCDR (y, SCM_EOL);
+ z = scm_cons (y, SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_let, z);
+ break;
+ }
+ do
+ {
+ copy = scm_unmemocopy (SCM_CADR (b), env);
+ initializer = unmemocar (scm_list_1 (copy), env);
+ SCM_SETCDR (z, scm_acons (SCM_CAR (b),
+ initializer,
+ SCM_UNSPECIFIED));
+ z = SCM_CDR (z);
+ env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
+ b = SCM_CDDR (b);
+ }
+ while (!SCM_NULLP (b));
+ SCM_SETCDR (z, SCM_EOL);
+ }
+ z = scm_cons (y, SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_letstar, z);
+ break;
+ }
+ case (ISYMNUM (SCM_IM_OR)):
+ ls = z = scm_cons (scm_sym_or, SCM_UNSPECIFIED);
+ break;
+ case (ISYMNUM (SCM_IM_LAMBDA)):
+ x = SCM_CDR (x);
+ z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_lambda, z);
+ env = SCM_EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
+ break;
+ case (ISYMNUM (SCM_IM_QUOTE)):
+ ls = z = scm_cons (scm_sym_quote, SCM_UNSPECIFIED);
+ break;
+ case (ISYMNUM (SCM_IM_SET_X)):
+ ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED);
+ break;
+ case (ISYMNUM (SCM_IM_APPLY)):
ls = z = scm_cons (scm_sym_atapply, SCM_UNSPECIFIED);
- goto loop;
- case (SCM_ISYMNUM (SCM_IM_CONT)):
+ break;
+ case (ISYMNUM (SCM_IM_CONT)):
ls = z = scm_cons (scm_sym_atcall_cc, SCM_UNSPECIFIED);
- goto loop;
- case (SCM_ISYMNUM (SCM_IM_DELAY)):
+ break;
+ case (ISYMNUM (SCM_IM_DELAY)):
ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED);
x = SCM_CDR (x);
- goto loop;
- case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
+ break;
+ case (ISYMNUM (SCM_IM_FUTURE)):
+ ls = z = scm_cons (scm_sym_future, SCM_UNSPECIFIED);
+ x = SCM_CDR (x);
+ break;
+ case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED);
- goto loop;
- default:
- /* appease the Sun compiler god: */ ;
- }
- unmemo:
- default:
- ls = z = unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env),
+ break;
+ case (ISYMNUM (SCM_IM_ELSE)):
+ ls = z = scm_cons (scm_sym_else, SCM_UNSPECIFIED);
+ break;
+ default:
+ ls = z = unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x), env),
+ SCM_UNSPECIFIED),
+ env);
+ }
+ }
+ else
+ {
+ ls = z = unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x), env),
SCM_UNSPECIFIED),
env);
}
-loop:
+
x = SCM_CDR (x);
while (SCM_CONSP (x))
{
SCM form = SCM_CAR (x);
if (!SCM_ISYMP (form))
{
- SCM copy = scm_cons (unmemocopy (form, env), SCM_UNSPECIFIED);
+ SCM copy = scm_cons (scm_unmemocopy (form, env), SCM_UNSPECIFIED);
SCM_SETCDR (z, unmemocar (copy, env));
z = SCM_CDR (z);
}
+ else if (SCM_EQ_P (form, SCM_IM_ARROW))
+ {
+ SCM_SETCDR (z, scm_cons (scm_sym_arrow, SCM_UNSPECIFIED));
+ z = SCM_CDR (z);
+ }
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;
}
+#if (SCM_ENABLE_DEPRECATED == 1)
+
SCM
-scm_unmemocopy (SCM x, SCM env)
+scm_unmemocar (SCM form, SCM env)
{
- if (!SCM_NULLP (env))
- /* Make a copy of the lowest frame to protect it from
- modifications by SCM_IM_DEFINE */
- return unmemocopy (x, scm_cons (SCM_CAR (env), SCM_CDR (env)));
- else
- return unmemocopy (x, env);
+ return unmemocar (form, env);
}
+#endif
+
+/*****************************************************************************/
+/*****************************************************************************/
+/* The definitions for execution start here. */
+/*****************************************************************************/
+/*****************************************************************************/
+
+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");
+
+/* A function object to implement "apply" for non-closure functions. */
+static SCM f_apply;
+/* An endless list consisting of #<undefined> objects: */
+static SCM undefineds;
-int
+
+int
scm_badargsp (SCM formals, SCM args)
{
while (!SCM_NULLP (formals))
return !SCM_NULLP (args) ? 1 : 0;
}
+\f
-static int
-scm_badformalsp (SCM closure, int n)
+/* The evaluator contains a plethora of EVAL symbols. This is an attempt at
+ * explanation.
+ *
+ * The following macros should be used in code which is read twice (where the
+ * choice of evaluator is hard soldered):
+ *
+ * CEVAL is the symbol used within one evaluator to call itself.
+ * Originally, it is defined to ceval, but is redefined to deval during the
+ * second pass.
+ *
+ * SCM_EVALIM is used when it is known that the expression is an
+ * immediate. (This macro never calls an evaluator.)
+ *
+ * EVAL evaluates an expression that is expected to have its symbols already
+ * memoized. Expressions that are not of the form '(<form> <form> ...)' are
+ * evaluated inline without calling an evaluator.
+ *
+ * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
+ * potentially replacing a symbol at the position Y:<form> by its memoized
+ * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
+ * evaluation is performed inline without calling an evaluator.
+ *
+ * The following macros should be used in code which is read once
+ * (where the choice of evaluator is dynamic):
+ *
+ * SCM_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
+ * debugging mode.
+ *
+ * SCM_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
+ * on the debugging mode.
+ *
+ * The main motivation for keeping this plethora is efficiency
+ * together with maintainability (=> locality of code).
+ */
+
+static SCM ceval (SCM x, SCM env);
+static SCM deval (SCM x, SCM env);
+#define CEVAL ceval
+
+
+#define SCM_EVALIM2(x) \
+ ((SCM_EQ_P ((x), SCM_EOL) \
+ ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
+ : 0), \
+ (x))
+
+#define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
+ ? *scm_ilookup ((x), (env)) \
+ : SCM_EVALIM2(x))
+
+#define SCM_XEVAL(x, env) \
+ (SCM_IMP (x) \
+ ? SCM_EVALIM2 (x) \
+ : (SCM_VARIABLEP (x) \
+ ? SCM_VARIABLE_REF (x) \
+ : (SCM_CONSP (x) \
+ ? (scm_debug_mode_p \
+ ? deval ((x), (env)) \
+ : ceval ((x), (env))) \
+ : (x))))
+
+#define SCM_XEVALCAR(x, env) \
+ (SCM_IMP (SCM_CAR (x)) \
+ ? SCM_EVALIM (SCM_CAR (x), (env)) \
+ : (SCM_VARIABLEP (SCM_CAR (x)) \
+ ? SCM_VARIABLE_REF (SCM_CAR (x)) \
+ : (SCM_CONSP (SCM_CAR (x)) \
+ ? (scm_debug_mode_p \
+ ? deval (SCM_CAR (x), (env)) \
+ : ceval (SCM_CAR (x), (env))) \
+ : (!SCM_SYMBOLP (SCM_CAR (x)) \
+ ? SCM_CAR (x) \
+ : *scm_lookupcar ((x), (env), 1)))))
+
+#define EVAL(x, env) \
+ (SCM_IMP (x) \
+ ? SCM_EVALIM ((x), (env)) \
+ : (SCM_VARIABLEP (x) \
+ ? SCM_VARIABLE_REF (x) \
+ : (SCM_CONSP (x) \
+ ? CEVAL ((x), (env)) \
+ : (x))))
+
+#define EVALCAR(x, env) \
+ (SCM_IMP (SCM_CAR (x)) \
+ ? SCM_EVALIM (SCM_CAR (x), (env)) \
+ : (SCM_VARIABLEP (SCM_CAR (x)) \
+ ? SCM_VARIABLE_REF (SCM_CAR (x)) \
+ : (SCM_CONSP (SCM_CAR (x)) \
+ ? CEVAL (SCM_CAR (x), (env)) \
+ : (!SCM_SYMBOLP (SCM_CAR (x)) \
+ ? SCM_CAR (x) \
+ : *scm_lookupcar ((x), (env), 1)))))
+
+SCM_REC_MUTEX (source_mutex);
+
+
+/* During execution, look up a symbol in the top level of the given local
+ * environment and return the corresponding variable object. If no binding
+ * for the symbol can be found, an 'Unbound variable' error is signalled. */
+static SCM
+lazy_memoize_variable (const SCM symbol, const SCM environment)
{
- SCM formals = SCM_CLOSURE_FORMALS (closure);
- while (!SCM_NULLP (formals))
- {
- if (!SCM_CONSP (formals))
- return 0;
- if (n == 0)
- return 1;
- --n;
- formals = SCM_CDR (formals);
- }
- return n;
+ const SCM top_level = scm_env_top_level (environment);
+ const SCM variable = scm_sym2var (symbol, top_level, SCM_BOOL_F);
+
+ if (SCM_FALSEP (variable))
+ error_unbound_variable (symbol);
+ else
+ return variable;
}
-\f
+
+SCM
+scm_eval_car (SCM pair, SCM env)
+{
+ return SCM_XEVALCAR (pair, env);
+}
+
+
SCM
scm_eval_args (SCM l, SCM env, SCM proc)
{
return results;
}
+
SCM
scm_eval_body (SCM code, SCM env)
{
SCM next;
+
again:
next = SCM_CDR (code);
while (!SCM_NULLP (next))
{
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)))
+ m_expand_body (code, env);
+ scm_rec_mutex_unlock (&source_mutex);
goto again;
}
}
return SCM_XEVALCAR (code, env);
}
-
#endif /* !DEVAL */
#else /* !DEVAL */
-#undef SCM_CEVAL
-#define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
+#undef CEVAL
+#define CEVAL deval /* Substitute all uses of ceval */
+
#undef SCM_APPLY
#define SCM_APPLY scm_dapply
+
#undef PREP_APPLY
#define PREP_APPLY(p, l) \
{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
+
#undef ENTER_APPLY
#define ENTER_APPLY \
do { \
SCM_TRAPS_P = 1;\
}\
} while (0)
+
#undef RETURN
#define RETURN(e) do { proc = (e); goto exit; } while (0)
+
#ifdef STACK_CHECKING
#ifndef EVAL_STACK_CHECKING
#define EVAL_STACK_CHECKING
#endif
#endif
-/* scm_ceval_ptr points to the currently selected evaluator.
- * *fixme*: Although efficiency is important here, this state variable
- * should probably not be a global. It should be related to the
- * current repl.
- */
-
-
-SCM (*scm_ceval_ptr) (SCM x, SCM env);
-/* scm_last_debug_frame contains a pointer to the last debugging
- * information stack frame. It is accessed very often from the
- * debugging evaluator, so it should probably not be indirectly
- * addressed. Better to save and restore it from the current root at
- * any stack swaps.
+/* scm_last_debug_frame contains a pointer to the last debugging information
+ * stack frame. It is accessed very often from the debugging evaluator, so it
+ * should probably not be indirectly addressed. Better to save and restore it
+ * from the current root at any stack swaps.
*/
/* scm_debug_eframe_size is the number of slots available for pseudo
long scm_debug_eframe_size;
-int scm_debug_mode, scm_check_entry_p, scm_check_apply_p, scm_check_exit_p;
+int scm_debug_mode_p;
+int scm_check_entry_p;
+int scm_check_apply_p;
+int scm_check_exit_p;
long scm_eval_stack;
}
#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
+
static SCM
deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
{
- SCM *results = lloc, res;
+ SCM *results = lloc;
while (SCM_CONSP (l))
{
- res = EVALCAR (l, env);
+ const SCM res = EVALCAR (l, env);
*lloc = scm_list_1 (res);
lloc = SCM_CDRLOC (*lloc);
#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)
+#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
+ ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x)
+
+
/* 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
+ * ceval is the non-debugging evaluator, deval is the debugging version. Both
+ * are implemented using a common code base, using the following mechanism:
+ * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
+ * is no function CEVAL, but the code for CEVAL actually compiles to either
+ * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
+ * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
+ * is known to be defined. Thus, in 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.
+ * All three (ceval, deval and their common implementation 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
-SCM
-scm_deval (SCM x, SCM env)
-{}
-#endif
+ * x is known to be a pair. 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
+ * CEVAL, thus re-using the same stack frame that 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 CEVAL are
+ * performed for all but the last expression of that sequence. */
-SCM
-SCM_CEVAL (SCM x, SCM env)
+static SCM
+CEVAL (SCM x, SCM env)
{
SCM proc, arg1;
#ifdef DEVAL
scm_last_debug_frame = &debug;
#endif
#ifdef EVAL_STACK_CHECKING
- if (scm_stack_checking_enabled_p
- && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM *) &proc))
+ if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc))
{
#ifdef DEVAL
debug.info->e.exp = x;
#endif
dispatch:
SCM_TICK;
- switch (SCM_TYP7 (x))
+ if (SCM_ISYMP (SCM_CAR (x)))
{
- case scm_tc7_symbol:
- /* Only happens when called at top level. */
- x = scm_cons (x, SCM_UNDEFINED);
- RETURN (*scm_lookupcar (x, env, 1));
-
- case SCM_BIT8 (SCM_IM_AND):
- x = SCM_CDR (x);
- 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 = SCM_CDR (x);
- }
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
-
- case SCM_BIT8 (SCM_IM_BEGIN):
- x = SCM_CDR (x);
- if (SCM_NULLP (x))
- RETURN (SCM_UNSPECIFIED);
-
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
-
- begin:
- /* If we are on toplevel with a lookup closure, we need to sync
- with the current module. */
- if (SCM_CONSP (env) && !SCM_CONSP (SCM_CAR (env)))
- {
- UPDATE_TOPLEVEL_ENV (env);
- while (!SCM_NULLP (SCM_CDR (x)))
- {
- EVALCAR (x, env);
- UPDATE_TOPLEVEL_ENV (env);
- x = SCM_CDR (x);
- }
- goto carloop;
- }
- else
- goto nontoplevel_begin;
-
- nontoplevel_begin:
- while (!SCM_NULLP (SCM_CDR (x)))
- {
- SCM form = SCM_CAR (x);
- if (SCM_IMP (form))
- {
- if (SCM_ISYMP (form))
- {
- x = scm_m_expand_body (x, env);
- goto nontoplevel_begin;
- }
- else
- SCM_VALIDATE_NON_EMPTY_COMBINATION (form);
- }
- else
- SCM_CEVAL (form, env);
- x = SCM_CDR (x);
- }
-
- 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);
- }
-
-
- case SCM_BIT8 (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_COND):
- x = SCM_CDR (x);
- while (!SCM_NULLP (x))
- {
- SCM clause = SCM_CAR (x);
- if (SCM_EQ_P (SCM_CAR (clause), scm_sym_else))
- {
- x = SCM_CDR (clause);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
- }
- else
- {
- arg1 = EVALCAR (clause, env);
- if (!SCM_FALSEP (arg1) && !SCM_NILP (arg1))
- {
- 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;
- }
- }
- x = SCM_CDR (x);
- }
- }
- RETURN (SCM_UNSPECIFIED);
-
-
- case SCM_BIT8 (SCM_IM_DO):
- x = SCM_CDR (x);
- {
- /* Compute the initialization values and the initial environment. */
- SCM init_forms = SCM_CADR (x);
- SCM init_values = SCM_EOL;
- while (!SCM_NULLP (init_forms))
- {
- init_values = scm_cons (EVALCAR (init_forms, env), init_values);
- init_forms = SCM_CDR (init_forms);
- }
- env = 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))
- {
- {
- /* Evaluate body forms. */
- SCM temp_forms;
- for (temp_forms = body_forms;
- !SCM_NULLP (temp_forms);
- temp_forms = SCM_CDR (temp_forms))
- {
- 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);
- }
- }
-
- {
- /* 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 = EXTEND_ENV (SCM_CAAR (env), step_values, SCM_CDR (env));
- }
-
- 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):
- x = SCM_CDR (x);
- {
- SCM test_result = EVALCAR (x, env);
- if (!SCM_FALSEP (test_result) && !SCM_NILP (test_result))
+ switch (ISYMNUM (SCM_CAR (x)))
+ {
+ case (ISYMNUM (SCM_IM_AND)):
+ x = SCM_CDR (x);
+ 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 = SCM_CDR (x);
+ }
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto carloop;
+
+ case (ISYMNUM (SCM_IM_BEGIN)):
+ x = SCM_CDR (x);
+ if (SCM_NULLP (x))
+ RETURN (SCM_UNSPECIFIED);
+
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+
+ begin:
+ /* If we are on toplevel with a lookup closure, we need to sync
+ with the current module. */
+ if (SCM_CONSP (env) && !SCM_CONSP (SCM_CAR (env)))
+ {
+ UPDATE_TOPLEVEL_ENV (env);
+ while (!SCM_NULLP (SCM_CDR (x)))
+ {
+ EVALCAR (x, env);
+ UPDATE_TOPLEVEL_ENV (env);
+ x = SCM_CDR (x);
+ }
+ goto carloop;
+ }
+ else
+ goto nontoplevel_begin;
+
+ nontoplevel_begin:
+ while (!SCM_NULLP (SCM_CDR (x)))
+ {
+ const SCM form = SCM_CAR (x);
+ if (SCM_IMP (form))
+ {
+ if (SCM_ISYMP (form))
+ {
+ scm_rec_mutex_lock (&source_mutex);
+ /* check for race condition */
+ if (SCM_ISYMP (SCM_CAR (x)))
+ m_expand_body (x, env);
+ scm_rec_mutex_unlock (&source_mutex);
+ goto nontoplevel_begin;
+ }
+ else
+ SCM_VALIDATE_NON_EMPTY_COMBINATION (form);
+ }
+ else
+ (void) EVAL (form, env);
+ x = SCM_CDR (x);
+ }
+
+ carloop:
+ {
+ /* scm_eval last form in list */
+ const 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);
+ }
+
+
+ case (ISYMNUM (SCM_IM_CASE)):
+ x = SCM_CDR (x);
+ {
+ const SCM key = EVALCAR (x, env);
+ x = SCM_CDR (x);
+ while (!SCM_NULLP (x))
+ {
+ const SCM clause = SCM_CAR (x);
+ SCM labels = SCM_CAR (clause);
+ if (SCM_EQ_P (labels, SCM_IM_ELSE))
+ {
+ x = SCM_CDR (clause);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
+ while (!SCM_NULLP (labels))
+ {
+ const 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 (ISYMNUM (SCM_IM_COND)):
+ x = SCM_CDR (x);
+ while (!SCM_NULLP (x))
+ {
+ const SCM clause = SCM_CAR (x);
+ if (SCM_EQ_P (SCM_CAR (clause), SCM_IM_ELSE))
+ {
+ x = SCM_CDR (clause);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
+ else
+ {
+ arg1 = EVALCAR (clause, env);
+ if (!SCM_FALSEP (arg1) && !SCM_NILP (arg1))
+ {
+ x = SCM_CDR (clause);
+ if (SCM_NULLP (x))
+ RETURN (arg1);
+ else if (!SCM_EQ_P (SCM_CAR (x), SCM_IM_ARROW))
+ {
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
+ else
+ {
+ proc = SCM_CDR (x);
+ proc = EVALCAR (proc, env);
+ PREP_APPLY (proc, scm_list_1 (arg1));
+ ENTER_APPLY;
+ goto evap1;
+ }
+ }
+ x = SCM_CDR (x);
+ }
+ }
+ RETURN (SCM_UNSPECIFIED);
+
+
+ case (ISYMNUM (SCM_IM_DO)):
+ x = SCM_CDR (x);
+ {
+ /* Compute the initialization values and the initial environment. */
+ SCM init_forms = SCM_CAR (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);
+ }
+ x = SCM_CDR (x);
+ env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
+ }
+ x = SCM_CDR (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))
+ {
+ {
+ /* Evaluate body forms. */
+ SCM temp_forms;
+ for (temp_forms = body_forms;
+ !SCM_NULLP (temp_forms);
+ temp_forms = SCM_CDR (temp_forms))
+ {
+ 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.
+ * Since with the current memoizer 'form' may hold a
+ * constant, we call EVAL here to handle the constant
+ * cases. In the long run it would make sense to have
+ * the macro transformer of 'do' eliminate all forms
+ * that have no sideeffect. Then instead of EVAL we
+ * could call CEVAL directly here. */
+ (void) EVAL (form, 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))
+ {
+ const 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));
+ }
+
+ 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 (ISYMNUM (SCM_IM_IF)):
+ x = SCM_CDR (x);
+ {
+ SCM test_result = EVALCAR (x, env);
+ x = SCM_CDR (x); /* then expression */
+ if (SCM_FALSEP (test_result) || SCM_NILP (test_result))
+ {
+ x = SCM_CDR (x); /* else expression */
+ if (SCM_NULLP (x))
+ RETURN (SCM_UNSPECIFIED);
+ }
+ }
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto carloop;
+
+
+ case (ISYMNUM (SCM_IM_LET)):
+ x = SCM_CDR (x);
+ {
+ 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 (ISYMNUM (SCM_IM_LETREC)):
+ x = SCM_CDR (x);
+ env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env);
+ x = SCM_CDR (x);
+ {
+ 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 (ISYMNUM (SCM_IM_LETSTAR)):
+ x = SCM_CDR (x);
+ {
+ 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 (ISYMNUM (SCM_IM_OR)):
+ x = SCM_CDR (x);
+ while (!SCM_NULLP (SCM_CDR (x)))
+ {
+ 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 (ISYMNUM (SCM_IM_LAMBDA)):
+ RETURN (scm_closure (SCM_CDR (x), env));
+
+
+ case (ISYMNUM (SCM_IM_QUOTE)):
+ RETURN (SCM_CADR (x));
+
+
+ case (ISYMNUM (SCM_IM_SET_X)):
+ x = SCM_CDR (x);
+ {
+ 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 */
+ variable = lazy_memoize_variable (variable, env);
+ SCM_SETCAR (x, variable);
+ location = SCM_VARIABLE_LOC (variable);
+ }
+ x = SCM_CDR (x);
+ *location = EVALCAR (x, env);
+ }
+ RETURN (SCM_UNSPECIFIED);
+
+
+ case (ISYMNUM (SCM_IM_APPLY)):
+ /* Evaluate the procedure to be applied. */
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);
- {
- 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 = 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):
- x = SCM_CDR (x);
- env = EXTEND_ENV (SCM_CAR (x), scm_undefineds, env);
- x = SCM_CDR (x);
- {
- 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):
- x = SCM_CDR (x);
- {
- SCM bindings = SCM_CAR (x);
- if (SCM_NULLP (bindings))
- env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
- else
- {
- do
- {
- SCM name = SCM_CAR (bindings);
- SCM init = SCM_CDR (bindings);
- env = EXTEND_ENV (name, EVALCAR (init, env), env);
- bindings = SCM_CDR (init);
- }
- while (!SCM_NULLP (bindings));
- }
- }
- x = SCM_CDR (x);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto nontoplevel_begin;
-
-
- case SCM_BIT8 (SCM_IM_OR):
- x = SCM_CDR (x);
- while (!SCM_NULLP (SCM_CDR (x)))
- {
- 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):
- RETURN (scm_closure (SCM_CDR (x), env));
-
-
- case SCM_BIT8 (SCM_IM_QUOTE):
- RETURN (SCM_CADR (x));
-
-
- case SCM_BIT8 (SCM_IM_SET_X):
- x = SCM_CDR (x);
- {
- 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);
-
-
- case SCM_BIT8(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)):
- proc = SCM_CAR (x);
- SCM_ASRTGO (SCM_ISYMP (proc), badfun);
- switch (SCM_ISYMNUM (proc))
- {
+ proc = EVALCAR (x, env);
+ PREP_APPLY (proc, SCM_EOL);
+ /* Evaluate the argument holding the list of arguments */
+ x = SCM_CDR (x);
+ arg1 = EVALCAR (x, env);
- case (SCM_ISYMNUM (SCM_IM_APPLY)):
- proc = SCM_CDR (x);
- proc = EVALCAR (proc, env);
- SCM_ASRTGO (!SCM_IMP (proc), badfun);
+ apply_proc:
+ /* Go here to tail-apply a procedure. PROC is the procedure and
+ * ARG1 is the list of arguments. PREP_APPLY must have been called
+ * before jumping to apply_proc. */
if (SCM_CLOSUREP (proc))
{
- PREP_APPLY (proc, SCM_EOL);
- arg1 = SCM_CDDR (x);
- arg1 = EVALCAR (arg1, env);
- apply_closure:
- /* Go here to tail-call a closure. PROC is the closure
- and ARG1 is the list of arguments. Do not forget to
- call PREP_APPLY. */
- {
- SCM formals = SCM_CLOSURE_FORMALS (proc);
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
#ifdef DEVAL
- debug.info->a.args = arg1;
+ debug.info->a.args = arg1;
#endif
- if (scm_badargsp (formals, arg1))
- scm_wrong_num_args (proc);
- ENTER_APPLY;
- /* Copy argument list */
- if (SCM_NULL_OR_NIL_P (arg1))
- env = 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 = EXTEND_ENV (formals, args, SCM_ENV (proc));
- }
-
- x = SCM_CLOSURE_BODY (proc);
- goto nontoplevel_begin;
- }
+ 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));
+ }
+
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
}
else
{
- proc = scm_f_apply;
- goto evapply;
+ ENTER_APPLY;
+ RETURN (SCM_APPLY (proc, arg1, SCM_EOL));
}
- case (SCM_ISYMNUM (SCM_IM_CONT)):
+ case (ISYMNUM (SCM_IM_CONT)):
{
int first;
SCM val = scm_make_continuation (&first);
{
arg1 = val;
proc = SCM_CDR (x);
- proc = scm_eval_car (proc, env);
- SCM_ASRTGO (SCM_NIMP (proc), badfun);
+ proc = EVALCAR (proc, env);
PREP_APPLY (proc, scm_list_1 (arg1));
ENTER_APPLY;
- if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))
- goto umwrongnumargs;
goto evap1;
}
}
- case (SCM_ISYMNUM (SCM_IM_DELAY)):
+ case (ISYMNUM (SCM_IM_DELAY)):
RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));
- case (SCM_ISYMNUM (SCM_IM_DISPATCH)):
- {
- /* If not done yet, evaluate the operand forms. The result is a
- * list of arguments stored in arg1, which is used to perform the
- * function dispatch. */
- SCM operand_forms = SCM_CADR (x);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- if (SCM_ILOCP (operand_forms))
- arg1 = *scm_ilookup (operand_forms, env);
- else if (SCM_VARIABLEP (operand_forms))
- arg1 = SCM_VARIABLE_REF (operand_forms);
- else if (!SCM_CONSP (operand_forms))
- arg1 = *scm_lookupcar (SCM_CDR (x), env, 1);
- else
- {
- SCM tail = arg1 = scm_list_1 (EVALCAR (operand_forms, env));
- operand_forms = SCM_CDR (operand_forms);
- while (!SCM_NULLP (operand_forms))
- {
- SCM new_tail = scm_list_1 (EVALCAR (operand_forms, env));
- SCM_SETCDR (tail, new_tail);
- tail = new_tail;
- operand_forms = SCM_CDR (operand_forms);
- }
- }
- }
+ case (ISYMNUM (SCM_IM_FUTURE)):
+ RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env)));
+
+ /* PLACEHOLDER for case (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%. */
apply_cmethod: /* inputs: z, arg1 */
{
SCM formals = SCM_CMETHOD_FORMALS (z);
- env = EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (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)):
+ case (ISYMNUM (SCM_IM_SLOT_REF)):
x = SCM_CDR (x);
{
SCM instance = EVALCAR (x, env);
}
- case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X)):
+ case (ISYMNUM (SCM_IM_SLOT_SET_X)):
x = SCM_CDR (x);
{
SCM instance = EVALCAR (x, env);
}
-#ifdef SCM_ENABLE_ELISP
+#if SCM_ENABLE_ELISP
- case (SCM_ISYMNUM (SCM_IM_NIL_COND)):
+ case (ISYMNUM (SCM_IM_NIL_COND)):
{
SCM test_form = SCM_CDR (x);
x = SCM_CDR (test_form);
#endif /* SCM_ENABLE_ELISP */
- case (SCM_ISYMNUM (SCM_IM_BIND)):
+ case (ISYMNUM (SCM_IM_BIND)):
{
SCM vars, exps, vals;
x = SCM_CDR (x);
vars = SCM_CAAR (x);
exps = SCM_CDAR (x);
-
vals = SCM_EOL;
-
- while (SCM_NIMP (exps))
+ while (!SCM_NULLP (exps))
{
vals = scm_cons (EVALCAR (exps, env), vals);
exps = SCM_CDR (exps);
for (x = SCM_CDR (x); !SCM_NULLP (SCM_CDR (x)); x = SCM_CDR (x))
{
if (SCM_CONSP (SCM_CAR (x)))
- SCM_CEVAL (SCM_CAR (x), env);
+ CEVAL (SCM_CAR (x), env);
}
proc = EVALCAR (x, env);
}
- case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
+ case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
{
- proc = SCM_CDR (x);
- x = EVALCAR (proc, env);
- proc = SCM_CDR (proc);
- proc = EVALCAR (proc, env);
- arg1 = SCM_APPLY (x, SCM_EOL, SCM_EOL);
+ SCM producer;
+
+ x = SCM_CDR (x);
+ producer = EVALCAR (x, env);
+ x = SCM_CDR (x);
+ proc = EVALCAR (x, env); /* proc is the consumer. */
+ arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL);
if (SCM_VALUESP (arg1))
- arg1 = scm_struct_ref (arg1, SCM_INUM0);
+ {
+ /* The list of arguments is not copied. Rather, it is assumed
+ * that this has been done by the 'values' procedure. */
+ arg1 = scm_struct_ref (arg1, SCM_INUM0);
+ }
else
- arg1 = scm_list_1 (arg1);
- if (SCM_CLOSUREP (proc))
- {
- PREP_APPLY (proc, arg1);
- goto apply_closure;
- }
- return SCM_APPLY (proc, arg1, SCM_EOL);
+ {
+ arg1 = scm_list_1 (arg1);
+ }
+ PREP_APPLY (proc, arg1);
+ goto apply_proc;
}
default:
- goto badfun;
+ break;
}
-
- default:
- proc = x;
- badfun:
- scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc));
- case scm_tc7_vector:
- case scm_tc7_wvect:
-#ifdef HAVE_ARRAYS
- case scm_tc7_bvect:
- case scm_tc7_byvect:
- case scm_tc7_svect:
- case scm_tc7_ivect:
- case scm_tc7_uvect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
-#endif
-#endif
- case scm_tc7_string:
- case scm_tc7_smob:
- case scm_tcs_closures:
- case scm_tc7_cclo:
- case scm_tc7_pws:
- case scm_tcs_subrs:
- case scm_tcs_struct:
- RETURN (x);
-
- case scm_tc7_variable:
- RETURN (SCM_VARIABLE_REF(x));
-
- case SCM_BIT8(SCM_ILOC00):
- proc = *scm_ilookup (SCM_CAR (x), env);
- SCM_ASRTGO (SCM_NIMP (proc), badfun);
- goto checkargs;
-
- case scm_tcs_cons_nimcar:
- if (SCM_SYMBOLP (SCM_CAR (x)))
+ }
+ else
+ {
+ if (SCM_VARIABLEP (SCM_CAR (x)))
+ proc = SCM_VARIABLE_REF (SCM_CAR (x));
+ else if (SCM_ILOCP (SCM_CAR (x)))
+ proc = *scm_ilookup (SCM_CAR (x), env);
+ else if (SCM_CONSP (SCM_CAR (x)))
+ proc = CEVAL (SCM_CAR (x), env);
+ else if (SCM_SYMBOLP (SCM_CAR (x)))
{
SCM orig_sym = SCM_CAR (x);
{
proc = *location;
}
- if (SCM_IMP (proc))
- {
- SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of
- lookupcar */
- goto badfun;
- }
if (SCM_MACROP (proc))
{
SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of
SCM_SET_MACROEXP (debug);
#endif
arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,
- scm_cons (env, scm_listofnull));
-
+ scm_cons (env, scm_listofnull));
#ifdef DEVAL
SCM_CLEAR_MACROEXP (debug);
#endif
switch (SCM_MACRO_TYPE (proc))
{
+ case 3:
case 2:
if (scm_ilength (arg1) <= 0)
arg1 = scm_list_2 (SCM_IM_BEGIN, arg1);
}
}
else
- proc = SCM_CEVAL (SCM_CAR (x), env);
- SCM_ASRTGO (!SCM_IMP (proc), badfun);
+ proc = SCM_CAR (x);
- checkargs:
- if (SCM_CLOSUREP (proc))
- {
- SCM formals = SCM_CLOSURE_FORMALS (proc);
- SCM args = SCM_CDR (x);
- while (!SCM_NULLP (formals))
- {
- if (!SCM_CONSP (formals))
- goto evapply;
- if (SCM_IMP (args))
- goto umwrongnumargs;
- formals = SCM_CDR (formals);
- args = SCM_CDR (args);
- }
- if (!SCM_NULLP (args))
- goto umwrongnumargs;
- }
- else if (SCM_MACROP (proc))
+ if (SCM_MACROP (proc))
goto handle_a_macro;
}
-evapply: /* inputs: x, proc */
+ /* When reaching this part of the code, the following is granted: Variable x
+ * holds the first pair of an expression of the form (<function> arg ...).
+ * Variable proc holds the object that resulted from the evaluation of
+ * <function>. In the following, the arguments (if any) will be evaluated,
+ * and proc will be applied to them. If proc does not really hold a
+ * function object, this will be signalled as an error on the scheme
+ * level. If the number of arguments does not match the number of arguments
+ * that are allowed to be passed to proc, also an error on the scheme level
+ * will be signalled. */
PREP_APPLY (proc, SCM_EOL);
if (SCM_NULLP (SCM_CDR (x))) {
ENTER_APPLY;
evap0:
+ SCM_ASRTGO (!SCM_IMP (proc), badfun);
switch (SCM_TYP7 (proc))
{ /* no arguments given */
case scm_tc7_subr_0:
#endif
if (!SCM_CLOSUREP (proc))
goto evap0;
- if (scm_badformalsp (proc, 0))
- goto umwrongnumargs;
+ /* fallthrough */
case scm_tcs_closures:
- x = SCM_CLOSURE_BODY (proc);
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), SCM_EOL, SCM_ENV (proc));
- goto nontoplevel_begin;
+ {
+ const SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (SCM_CONSP (formals))
+ goto umwrongnumargs;
+ x = SCM_CLOSURE_BODY (proc);
+ env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
+ goto nontoplevel_begin;
+ }
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
arg1 = SCM_EOL;
goto type_dispatch;
}
- else if (!SCM_I_OPERATORP (proc))
- goto badfun;
- else
+ else if (SCM_I_OPERATORP (proc))
{
arg1 = proc;
proc = (SCM_I_ENTITYP (proc)
debug.info->a.proc = proc;
debug.info->a.args = scm_list_1 (arg1);
#endif
- if (SCM_NIMP (proc))
- goto evap1;
- else
- goto badfun;
+ goto evap1;
}
+ else
+ goto badfun;
case scm_tc7_subr_1:
case scm_tc7_subr_2:
case scm_tc7_subr_2o:
+ case scm_tc7_dsubr:
case scm_tc7_cxr:
case scm_tc7_subr_3:
case scm_tc7_lsubr_2:
unmemocar (x, env);
scm_wrong_num_args (proc);
default:
- /* handle macros here */
- goto badfun;
+ badfun:
+ scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc));
}
}
{
ENTER_APPLY;
evap1: /* inputs: proc, arg1 */
+ SCM_ASRTGO (!SCM_IMP (proc), badfun);
switch (SCM_TYP7 (proc))
{ /* have one argument in arg1 */
case scm_tc7_subr_2o:
case scm_tc7_subr_1:
case scm_tc7_subr_1o:
RETURN (SCM_SUBRF (proc) (arg1));
- case scm_tc7_cxr:
- if (SCM_SUBRF (proc))
+ case scm_tc7_dsubr:
+ 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))));
+ }
+ else if (SCM_FRACTIONP (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))));
- }
-#ifdef SCM_BIGDIG
- else if (SCM_BIGP (arg1))
- {
- RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
- }
-#endif
- SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
- SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
+ RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
}
- proc = SCM_SNAME (proc);
+ SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
+ SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
+ case scm_tc7_cxr:
{
- 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);
- }
+ unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc);
+ do
+ {
+ SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1,
+ SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
+ arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1);
+ pattern >>= 2;
+ } while (pattern);
RETURN (arg1);
}
case scm_tc7_rpsubr:
#endif
if (!SCM_CLOSUREP (proc))
goto evap1;
- if (scm_badformalsp (proc, 1))
- goto umwrongnumargs;
+ /* fallthrough */
case scm_tcs_closures:
- /* clos1: */
- x = SCM_CLOSURE_BODY (proc);
+ {
+ /* clos1: */
+ const SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (SCM_NULLP (formals)
+ || (SCM_CONSP (formals) && SCM_CONSP (SCM_CDR (formals))))
+ goto umwrongnumargs;
+ 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 (formals,
+ debug.info->a.args,
+ SCM_ENV (proc));
#else
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_list_1 (arg1), SCM_ENV (proc));
+ env = SCM_EXTEND_ENV (formals,
+ scm_list_1 (arg1),
+ SCM_ENV (proc));
#endif
- goto nontoplevel_begin;
+ goto nontoplevel_begin;
+ }
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
#endif
goto type_dispatch;
}
- else if (!SCM_I_OPERATORP (proc))
- goto badfun;
- else
+ else if (SCM_I_OPERATORP (proc))
{
arg2 = arg1;
arg1 = 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;
+ goto evap2;
}
+ else
+ goto badfun;
case scm_tc7_subr_2:
case scm_tc7_subr_0:
case scm_tc7_subr_3:
if (SCM_NULLP (x)) {
ENTER_APPLY;
evap2:
+ SCM_ASRTGO (!SCM_IMP (proc), badfun);
switch (SCM_TYP7 (proc))
{ /* have two arguments */
case scm_tc7_subr_2:
#endif
goto type_dispatch;
}
- else if (!SCM_I_OPERATORP (proc))
- goto badfun;
- else
+ else if (SCM_I_OPERATORP (proc))
{
operatorn:
#ifdef DEVAL
SCM_EOL));
#endif
}
+ else
+ goto badfun;
case scm_tc7_subr_0:
+ case scm_tc7_dsubr:
case scm_tc7_cxr:
case scm_tc7_subr_1o:
case scm_tc7_subr_1:
#endif
if (!SCM_CLOSUREP (proc))
goto evap2;
- if (scm_badformalsp (proc, 2))
- goto umwrongnumargs;
+ /* fallthrough */
case scm_tcs_closures:
- /* clos2: */
+ {
+ /* clos2: */
+ const 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))))))
+ goto umwrongnumargs;
#ifdef DEVAL
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- debug.info->a.args,
- SCM_ENV (proc));
+ env = SCM_EXTEND_ENV (formals,
+ debug.info->a.args,
+ SCM_ENV (proc));
#else
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- scm_list_2 (arg1, arg2), SCM_ENV (proc));
+ env = SCM_EXTEND_ENV (formals,
+ scm_list_2 (arg1, arg2),
+ SCM_ENV (proc));
#endif
- x = SCM_CLOSURE_BODY (proc);
- goto nontoplevel_begin;
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
+ }
}
}
if (!SCM_CONSP (x))
#endif
ENTER_APPLY;
evap3:
+ SCM_ASRTGO (!SCM_IMP (proc), badfun);
switch (SCM_TYP7 (proc))
{ /* have 3 or more arguments */
#ifdef DEVAL
debug.info->a.proc = proc;
if (!SCM_CLOSUREP (proc))
goto evap3;
- if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), debug.info->a.args))
- goto umwrongnumargs;
+ /* fallthrough */
case scm_tcs_closures:
- SCM_SET_ARGSREADY (debug);
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- debug.info->a.args,
- SCM_ENV (proc));
- x = SCM_CLOSURE_BODY (proc);
- goto nontoplevel_begin;
+ {
+ const 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;
+ SCM_SET_ARGSREADY (debug);
+ env = SCM_EXTEND_ENV (formals,
+ debug.info->a.args,
+ SCM_ENV (proc));
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
+ }
#else /* DEVAL */
case scm_tc7_subr_3:
if (!SCM_NULLP (SCM_CDR (x)))
arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env));
x = SCM_CDR(x);
}
- while (SCM_NIMP (x));
+ while (!SCM_NULLP (x));
RETURN (arg1);
case scm_tc7_rpsubr:
if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2)))
arg2 = arg1;
x = SCM_CDR (x);
}
- while (SCM_NIMP (x));
+ while (!SCM_NULLP (x));
RETURN (SCM_BOOL_T);
case scm_tc7_lsubr_2:
RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc)));
proc = SCM_PROCEDURE (proc);
if (!SCM_CLOSUREP (proc))
goto evap3;
+ /* fallthrough */
+ case scm_tcs_closures:
{
- SCM formals = SCM_CLOSURE_FORMALS (proc);
+ const 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;
+ env = SCM_EXTEND_ENV (formals,
+ scm_cons2 (arg1,
+ arg2,
+ scm_eval_args (x, env, proc)),
+ SCM_ENV (proc));
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
}
- case scm_tcs_closures:
-#ifdef DEVAL
- SCM_SET_ARGSREADY (debug);
-#endif
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- scm_cons2 (arg1,
- arg2,
- scm_eval_args (x, env, proc)),
- SCM_ENV (proc));
- x = SCM_CLOSURE_BODY (proc);
- goto nontoplevel_begin;
#endif /* DEVAL */
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
x = SCM_ENTITY_PROCEDURE (proc);
goto type_dispatch;
}
- else if (!SCM_I_OPERATORP (proc))
- goto badfun;
- else
+ else if (SCM_I_OPERATORP (proc))
goto operatorn;
+ else
+ goto badfun;
case scm_tc7_subr_2:
case scm_tc7_subr_1o:
case scm_tc7_subr_2o:
case scm_tc7_subr_0:
+ case scm_tc7_dsubr:
case scm_tc7_cxr:
case scm_tc7_subr_1:
scm_wrong_num_args (proc);
#ifndef DEVAL
\f
+
/* Simple procedure calls
*/
#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;
debug.vect[0].a.args = SCM_EOL;
scm_last_debug_frame = &debug;
#else
- if (SCM_DEBUGGINGP)
+ if (scm_debug_mode_p)
return scm_dapply (proc, arg1, args);
-#endif
#endif
SCM_ASRTGO (SCM_NIMP (proc), badproc);
scm_wrong_num_args (proc);
else
RETURN (SCM_SUBRF (proc) (arg1));
- case scm_tc7_cxr:
+ case scm_tc7_dsubr:
if (SCM_UNBNDP (arg1) || !SCM_NULLP (args))
scm_wrong_num_args (proc);
- if (SCM_SUBRF (proc))
+ if (SCM_INUMP (arg1))
+ {
+ RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
+ }
+ else if (SCM_REALP (arg1))
+ {
+ RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
+ }
+ else if (SCM_BIGP (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))));
- }
-#ifdef SCM_BIGDIG
- else if (SCM_BIGP (arg1))
- RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
-#endif
- SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
- SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
+ RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
+ }
+ else if (SCM_FRACTIONP (arg1))
+ {
+ RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
}
- proc = SCM_SNAME (proc);
+ SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
+ SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
+ case scm_tc7_cxr:
+ if (SCM_UNBNDP (arg1) || !SCM_NULLP (args))
+ scm_wrong_num_args (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);
+ unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc);
+ do
+ {
+ SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1,
+ SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
+ arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1);
+ pattern >>= 2;
+ } while (pattern);
+ RETURN (arg1);
}
case scm_tc7_subr_3:
if (SCM_NULLP (args)
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));
+ 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)))
+ m_expand_body (proc, args);
+ scm_rec_mutex_unlock (&source_mutex);
goto again;
}
else
SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc));
}
else
- SCM_CEVAL (SCM_CAR (proc), args);
+ (void) EVAL (SCM_CAR (proc), args);
proc = arg1;
+ arg1 = SCM_CDR (proc);
}
RETURN (EVALCAR (proc, args));
case scm_tc7_smob:
#endif
RETURN (scm_apply_generic (proc, args));
}
- else if (!SCM_I_OPERATORP (proc))
- goto badproc;
- else
+ else if (SCM_I_OPERATORP (proc))
{
+ /* operator */
#ifdef DEVAL
args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
#else
else
goto badproc;
}
+ else
+ goto badproc;
default:
badproc:
scm_wrong_type_arg ("apply", SCM_ARG1, proc);
#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)
+{
+ scm_t_trampoline_0 trampoline;
+
+ if (SCM_IMP (proc))
+ return NULL;
+
+ switch (SCM_TYP7 (proc))
+ {
+ case scm_tc7_subr_0:
+ trampoline = call_subr0_0;
+ break;
+ case scm_tc7_subr_1o:
+ trampoline = call_subr1o_0;
+ break;
+ case scm_tc7_lsubr:
+ trampoline = call_lsubr_0;
+ break;
+ case scm_tcs_closures:
+ {
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (SCM_NULLP (formals) || !SCM_CONSP (formals))
+ trampoline = scm_i_call_closure_0;
+ else
+ return NULL;
+ break;
+ }
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ trampoline = scm_call_generic_0;
+ else if (SCM_I_OPERATORP (proc))
+ trampoline = scm_call_0;
+ else
+ return NULL;
+ break;
+ case scm_tc7_smob:
+ if (SCM_SMOB_APPLICABLE_P (proc))
+ trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_0;
+ else
+ return NULL;
+ break;
+ case scm_tc7_asubr:
+ case scm_tc7_rpsubr:
+ case scm_tc7_cclo:
+ case scm_tc7_pws:
+ trampoline = scm_call_0;
+ break;
+ default:
+ return NULL; /* not applicable on zero arguments */
+ }
+ /* We only reach this point if a valid trampoline was determined. */
+
+ /* If debugging is enabled, we want to see all calls to proc on the stack.
+ * Thus, we replace the trampoline shortcut with scm_call_0. */
+ if (scm_debug_mode_p)
+ return scm_call_0;
+ else
+ return trampoline;
+}
+
+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))));
+ }
+ else if (SCM_FRACTIONP (arg1))
+ {
+ RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_fraction2double (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)
+{
+ unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc);
+ do
+ {
+ SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1,
+ SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
+ arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1);
+ pattern >>= 2;
+ } while (pattern);
+ 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)
+{
+ scm_t_trampoline_1 trampoline;
+
+ if (SCM_IMP (proc))
+ return NULL;
+
+ switch (SCM_TYP7 (proc))
+ {
+ case scm_tc7_subr_1:
+ case scm_tc7_subr_1o:
+ trampoline = call_subr1_1;
+ break;
+ case scm_tc7_subr_2o:
+ trampoline = call_subr2o_1;
+ break;
+ case scm_tc7_lsubr:
+ trampoline = call_lsubr_1;
+ break;
+ case scm_tc7_dsubr:
+ trampoline = call_dsubr_1;
+ break;
+ case scm_tc7_cxr:
+ trampoline = call_cxr_1;
+ break;
+ case scm_tcs_closures:
+ {
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (!SCM_NULLP (formals)
+ && (!SCM_CONSP (formals) || !SCM_CONSP (SCM_CDR (formals))))
+ trampoline = call_closure_1;
+ else
+ return NULL;
+ break;
+ }
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ trampoline = scm_call_generic_1;
+ else if (SCM_I_OPERATORP (proc))
+ trampoline = scm_call_1;
+ else
+ return NULL;
+ break;
+ case scm_tc7_smob:
+ if (SCM_SMOB_APPLICABLE_P (proc))
+ trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_1;
+ else
+ return NULL;
+ break;
+ case scm_tc7_asubr:
+ case scm_tc7_rpsubr:
+ case scm_tc7_cclo:
+ case scm_tc7_pws:
+ trampoline = scm_call_1;
+ break;
+ default:
+ return NULL; /* not applicable on one arg */
+ }
+ /* We only reach this point if a valid trampoline was determined. */
+
+ /* If debugging is enabled, we want to see all calls to proc on the stack.
+ * Thus, we replace the trampoline shortcut with scm_call_1. */
+ if (scm_debug_mode_p)
+ return scm_call_1;
+ else
+ return trampoline;
+}
+
+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)
+{
+ scm_t_trampoline_2 trampoline;
+
+ if (SCM_IMP (proc))
+ return NULL;
+
+ switch (SCM_TYP7 (proc))
+ {
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_2o:
+ case scm_tc7_rpsubr:
+ case scm_tc7_asubr:
+ trampoline = call_subr2_2;
+ break;
+ case scm_tc7_lsubr_2:
+ trampoline = call_lsubr2_2;
+ break;
+ case scm_tc7_lsubr:
+ trampoline = call_lsubr_2;
+ break;
+ 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))))))
+ trampoline = call_closure_2;
+ else
+ return NULL;
+ break;
+ }
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ trampoline = scm_call_generic_2;
+ else if (SCM_I_OPERATORP (proc))
+ trampoline = scm_call_2;
+ else
+ return NULL;
+ break;
+ case scm_tc7_smob:
+ if (SCM_SMOB_APPLICABLE_P (proc))
+ trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_2;
+ else
+ return NULL;
+ break;
+ case scm_tc7_cclo:
+ case scm_tc7_pws:
+ trampoline = scm_call_2;
+ break;
+ default:
+ return NULL; /* not applicable on two args */
+ }
+ /* We only reach this point if a valid trampoline was determined. */
+
+ /* If debugging is enabled, we want to see all calls to proc on the stack.
+ * Thus, we replace the trampoline shortcut with scm_call_2. */
+ if (scm_debug_mode_p)
+ return scm_call_2;
+ else
+ return trampoline;
+}
+
/* Typechecking for multi-argument MAP and FOR-EACH.
Verify that each element of the vector ARGV, except for the first,
}
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);
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);
check_map_args (args, len, g_map, proc, arg1, s_map);
while (1)
SCM_VALIDATE_REST_ARGUMENT (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)))
+ {
+ 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);
check_map_args (args, len, g_for_each, proc, arg1, s_for_each);
while (1)
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
#undef FUNC_NAME
+/* The function scm_copy_tree is used to copy an expression tree to allow the
+ * memoizer to modify the expression during memoization. scm_copy_tree
+ * creates deep copies of pairs and vectors, but not of any other data types,
+ * since only pairs and vectors will be parsed by the memoizer.
+ *
+ * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
+ * pattern is used to detect cycles. In fact, the pattern is used in two
+ * dimensions, vertical (indicated in the code by the variable names 'hare'
+ * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
+ * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
+ * takes one.
+ *
+ * The vertical dimension corresponds to recursive calls to function
+ * copy_tree: This happens when descending into vector elements, into cars of
+ * lists and into the cdr of an improper list. In this dimension, the
+ * tortoise follows the hare by using the processor stack: Every stack frame
+ * will hold an instance of struct t_trace. These instances are connected in
+ * a way that represents the trace of the hare, which thus can be followed by
+ * the tortoise. The tortoise will always point to struct t_trace instances
+ * relating to SCM objects that have already been copied. Thus, a cycle is
+ * detected if the tortoise and the hare point to the same object,
+ *
+ * The horizontal dimension is within one execution of copy_tree, when the
+ * function cdr's along the pairs of a list. This is the standard
+ * hare-and-tortoise implementation, found several times in guile. */
+
+struct t_trace {
+ struct t_trace *trace; // These pointers form a trace along the stack.
+ SCM obj; // The object handled at the respective stack frame.
+};
+
+static SCM
+copy_tree (
+ struct t_trace *const hare,
+ struct t_trace *tortoise,
+ unsigned int tortoise_delay )
+{
+ if (!SCM_CONSP (hare->obj) && !SCM_VECTORP (hare->obj))
+ {
+ return hare->obj;
+ }
+ else
+ {
+ /* Prepare the trace along the stack. */
+ struct t_trace new_hare;
+ hare->trace = &new_hare;
+
+ /* The tortoise will make its step after the delay has elapsed. Note
+ * that in contrast to the typical hare-and-tortoise pattern, the step
+ * of the tortoise happens before the hare takes its steps. This is, in
+ * principle, no problem, except for the start of the algorithm: Then,
+ * it has to be made sure that the hare actually gets its advantage of
+ * two steps. */
+ if (tortoise_delay == 0)
+ {
+ tortoise_delay = 1;
+ tortoise = tortoise->trace;
+ ASSERT_SYNTAX (!SCM_EQ_P (hare->obj, tortoise->obj),
+ s_bad_expression, hare->obj);
+ }
+ else
+ {
+ --tortoise_delay;
+ }
+
+ if (SCM_VECTORP (hare->obj))
+ {
+ const unsigned long int length = SCM_VECTOR_LENGTH (hare->obj);
+ const SCM new_vector = scm_c_make_vector (length, SCM_UNSPECIFIED);
+
+ /* Each vector element is copied by recursing into copy_tree, having
+ * the tortoise follow the hare into the depths of the stack. */
+ unsigned long int i;
+ for (i = 0; i < length; ++i)
+ {
+ SCM new_element;
+ new_hare.obj = SCM_VECTOR_REF (hare->obj, i);
+ new_element = copy_tree (&new_hare, tortoise, tortoise_delay);
+ SCM_VECTOR_SET (new_vector, i, new_element);
+ }
+
+ return new_vector;
+ }
+ else // SCM_CONSP (hare->obj)
+ {
+ SCM result;
+ SCM tail;
+
+ SCM rabbit = hare->obj;
+ SCM turtle = hare->obj;
+
+ SCM copy;
+
+ /* The first pair of the list is treated specially, in order to
+ * preserve a potential source code position. */
+ result = tail = scm_cons_source (rabbit, SCM_EOL, SCM_EOL);
+ new_hare.obj = SCM_CAR (rabbit);
+ copy = copy_tree (&new_hare, tortoise, tortoise_delay);
+ SCM_SETCAR (tail, copy);
+
+ /* The remaining pairs of the list are copied by, horizontally,
+ * having the turtle follow the rabbit, and, vertically, having the
+ * tortoise follow the hare into the depths of the stack. */
+ rabbit = SCM_CDR (rabbit);
+ while (SCM_CONSP (rabbit))
+ {
+ new_hare.obj = SCM_CAR (rabbit);
+ copy = copy_tree (&new_hare, tortoise, tortoise_delay);
+ SCM_SETCDR (tail, scm_cons (copy, SCM_UNDEFINED));
+ tail = SCM_CDR (tail);
+
+ rabbit = SCM_CDR (rabbit);
+ if (SCM_CONSP (rabbit))
+ {
+ new_hare.obj = SCM_CAR (rabbit);
+ copy = copy_tree (&new_hare, tortoise, tortoise_delay);
+ SCM_SETCDR (tail, scm_cons (copy, SCM_UNDEFINED));
+ tail = SCM_CDR (tail);
+ rabbit = SCM_CDR (rabbit);
+
+ turtle = SCM_CDR (turtle);
+ ASSERT_SYNTAX (!SCM_EQ_P (rabbit, turtle),
+ s_bad_expression, rabbit);
+ }
+ }
+
+ /* We have to recurse into copy_tree again for the last cdr, in
+ * order to handle the situation that it holds a vector. */
+ new_hare.obj = rabbit;
+ copy = copy_tree (&new_hare, tortoise, tortoise_delay);
+ SCM_SETCDR (tail, copy);
+
+ return result;
+ }
+ }
+}
+
SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0,
(SCM obj),
"Recursively copy the data tree that is bound to @var{obj}, and return a\n"
- "pointer to the new data structure. @code{copy-tree} recurses down the\n"
+ "the new data structure. @code{copy-tree} recurses down the\n"
"contents of both pairs and vectors (since both cons cells and vector\n"
"cells may point to arbitrary objects), and stops recursing when it hits\n"
"any other object.")
#define FUNC_NAME s_scm_copy_tree
{
- SCM ans, tl;
- if (SCM_IMP (obj))
- return obj;
- if (SCM_VECTORP (obj))
- {
- unsigned long i = SCM_VECTOR_LENGTH (obj);
- ans = scm_c_make_vector (i, SCM_UNSPECIFIED);
- while (i--)
- SCM_VECTOR_SET (ans, i, scm_copy_tree (SCM_VELTS (obj)[i]));
- return ans;
- }
- if (!SCM_CONSP (obj))
- return obj;
- ans = tl = scm_cons_source (obj,
- scm_copy_tree (SCM_CAR (obj)),
- SCM_UNSPECIFIED);
- while (obj = SCM_CDR (obj), SCM_CONSP (obj))
- {
- SCM_SETCDR (tl, scm_cons (scm_copy_tree (SCM_CAR (obj)),
- SCM_UNSPECIFIED));
- tl = SCM_CDR (tl);
- }
- SCM_SETCDR (tl, obj);
- return ans;
+ /* Prepare the trace along the stack. */
+ struct t_trace trace;
+ trace.obj = obj;
+
+ /* In function copy_tree, if the tortoise makes its step, it will do this
+ * before the hare has the chance to move. Thus, we have to make sure that
+ * the very first step of the tortoise will not happen after the hare has
+ * really made two steps. This is achieved by passing '2' as the initial
+ * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
+ * a bigger advantage may improve performance slightly. */
+ return copy_tree (&trace, &trace, 2);
}
#undef FUNC_NAME
SCM
scm_i_eval_x (SCM exp, SCM env)
{
- return SCM_XEVAL (exp, env);
+ if (SCM_SYMBOLP (exp))
+ return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1);
+ else
+ return SCM_XEVAL (exp, env);
}
SCM
scm_i_eval (SCM exp, SCM env)
{
exp = scm_copy_tree (exp);
- return SCM_XEVAL (exp, env);
+ if (SCM_SYMBOLP (exp))
+ return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1);
+ else
+ return SCM_XEVAL (exp, env);
}
SCM
}
#undef FUNC_NAME
+
/* Eval does not take the second arg optionally. This is intentional
* in order to be R5RS compatible, and to prepare for the new module
* system, where we would like to make the choice of evaluation
scm_set_current_module (new_module);
}
-
static void
restore_environment (void *data)
{
#undef FUNC_NAME
-/* At this point, scm_deval and scm_dapply are generated.
+/* At this point, deval and scm_dapply are generated.
*/
-#ifdef DEBUG_EXTENSIONS
-# define DEVAL
-# include "eval.c"
-#endif
+#define DEVAL
+#include "eval.c"
+
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+
+/* Deprecated in guile 1.7.0 on 2004-03-29. */
+SCM scm_ceval (SCM x, SCM env)
+{
+ if (SCM_CONSP (x))
+ return ceval (x, env);
+ else if (SCM_SYMBOLP (x))
+ return *scm_lookupcar (scm_cons (x, SCM_UNDEFINED), env, 1);
+ else
+ return SCM_XEVAL (x, env);
+}
+/* Deprecated in guile 1.7.0 on 2004-03-29. */
+SCM scm_deval (SCM x, SCM env)
+{
+ if (SCM_CONSP (x))
+ return deval (x, env);
+ else if (SCM_SYMBOLP (x))
+ return *scm_lookupcar (scm_cons (x, SCM_UNDEFINED), env, 1);
+ else
+ return SCM_XEVAL (x, env);
+}
+
+static SCM
+dispatching_eval (SCM x, SCM env)
+{
+ if (scm_debug_mode_p)
+ return scm_deval (x, env);
+ else
+ return scm_ceval (x, env);
+}
+
+/* Deprecated in guile 1.7.0 on 2004-03-29. */
+SCM (*scm_ceval_ptr) (SCM x, SCM env) = dispatching_eval;
+
+#endif
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);
#include "libguile/eval.x"
-
+
scm_add_feature ("delay");
}
HCoop / bpt / guile.git / blobdiff