mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
a954ce1d25
static identifiers. (scm_m_do): Use ASSERT_SYNTAX to signal syntax errors. Be more specific about the kind of error that was detected. Avoid use of SCM_CDRLOC. Avoid unnecessary consing when creating the memoized code, this way also making sure that file name, line number information etc. remain available.
4991 lines
141 KiB
C
4991 lines
141 KiB
C
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003 Free Software Foundation, Inc.
|
||
*
|
||
* 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.
|
||
*
|
||
* 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.
|
||
*
|
||
* 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
|
||
*/
|
||
|
||
|
||
|
||
/* This file is read twice in order to produce debugging versions of
|
||
* scm_ceval and scm_apply. These functions, scm_deval and
|
||
* scm_dapply, are produced when we define the preprocessor macro
|
||
* DEVAL. The file is divided into sections which are treated
|
||
* differently with respect to DEVAL. The heads of these sections are
|
||
* marked with the string "SECTION:".
|
||
*/
|
||
|
||
/* SECTION: This code is compiled once.
|
||
*/
|
||
|
||
#if HAVE_CONFIG_H
|
||
# include <config.h>
|
||
#endif
|
||
|
||
#include "libguile/__scm.h"
|
||
|
||
#ifndef DEVAL
|
||
|
||
/* AIX requires this to be the first thing in the file. The #pragma
|
||
directive is indented so pre-ANSI compilers will ignore it, rather
|
||
than choke on it. */
|
||
#ifndef __GNUC__
|
||
# if HAVE_ALLOCA_H
|
||
# include <alloca.h>
|
||
# else
|
||
# ifdef _AIX
|
||
# pragma alloca
|
||
# else
|
||
# ifndef alloca /* predefined by HP cc +Olibcalls */
|
||
char *alloca ();
|
||
# endif
|
||
# endif
|
||
# endif
|
||
#endif
|
||
|
||
#include "libguile/_scm.h"
|
||
#include "libguile/debug.h"
|
||
#include "libguile/dynwind.h"
|
||
#include "libguile/alist.h"
|
||
#include "libguile/eq.h"
|
||
#include "libguile/continuations.h"
|
||
#include "libguile/futures.h"
|
||
#include "libguile/strings.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/modules.h"
|
||
#include "libguile/ports.h"
|
||
#include "libguile/root.h"
|
||
#include "libguile/vectors.h"
|
||
#include "libguile/fluids.h"
|
||
#include "libguile/goops.h"
|
||
#include "libguile/values.h"
|
||
|
||
#include "libguile/validate.h"
|
||
#include "libguile/eval.h"
|
||
#include "libguile/lang.h"
|
||
|
||
|
||
|
||
/* {Syntax Errors}
|
||
*
|
||
* 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 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";
|
||
|
||
/* 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";
|
||
|
||
/* 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";
|
||
|
||
|
||
/* 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.
|
||
*
|
||
* <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); }
|
||
|
||
|
||
|
||
/* {Ilocs}
|
||
*
|
||
* 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_IDINC (0x00100000L)
|
||
#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 )
|
||
|
||
#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
|
||
|
||
|
||
|
||
#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
|
||
do { \
|
||
if (SCM_EQ_P ((x), SCM_EOL)) \
|
||
scm_misc_error (NULL, s_expression, SCM_EOL); \
|
||
} while (0)
|
||
|
||
|
||
|
||
/* The evaluator contains a plethora of EVAL symbols.
|
||
* This is an attempt at explanation.
|
||
*
|
||
* The following macros should be used in code which is read twice
|
||
* (where the choice of evaluator is hard soldered):
|
||
*
|
||
* SCM_CEVAL is the symbol used within one evaluator to call itself.
|
||
* Originally, it is defined to scm_ceval, but is redefined to
|
||
* scm_deval during the second pass.
|
||
*
|
||
* 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):
|
||
*
|
||
* 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.
|
||
*
|
||
* The main motivation for keeping this plethora is efficiency
|
||
* together with maintainability (=> locality of code).
|
||
*/
|
||
|
||
#define SCM_CEVAL scm_ceval
|
||
|
||
#define SCM_EVALIM2(x) \
|
||
((SCM_EQ_P ((x), SCM_EOL) \
|
||
? scm_misc_error (NULL, s_expression, SCM_EOL), 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_ceval_ptr) ((x), (env)))
|
||
|
||
#define SCM_XEVALCAR(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_ptr) (SCM_CAR (x), env)))
|
||
|
||
#define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
|
||
? SCM_EVALIM (SCM_CAR (x), env) \
|
||
: (SCM_SYMBOLP (SCM_CAR (x)) \
|
||
? *scm_lookupcar (x, env, 1) \
|
||
: SCM_CEVAL (SCM_CAR (x), env)))
|
||
|
||
SCM_REC_MUTEX (source_mutex);
|
||
|
||
|
||
static const char s_expression[] = "missing or extra expression";
|
||
static const char s_test[] = "bad test";
|
||
static const char s_body[] = "bad body";
|
||
static const char s_bindings[] = "bad bindings";
|
||
static const char s_duplicate_bindings[] = "duplicate bindings";
|
||
static const char s_variable[] = "bad variable";
|
||
static const char s_clauses[] = "bad or missing clauses";
|
||
static const char s_formals[] = "bad formals";
|
||
static const char s_duplicate_formals[] = "duplicate formals";
|
||
static const char s_splicing[] = "bad (non-list) result for unquote-splicing";
|
||
|
||
|
||
/* 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)
|
||
{
|
||
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 (bindings);
|
||
return SCM_CARLOC (SCM_CDR (bindings));
|
||
}
|
||
|
||
|
||
/* The Lookup Car Race
|
||
- by Eva Luator
|
||
|
||
Memoization of variables and special forms is done while executing
|
||
the code for the first time. As long as there is only one thread
|
||
everything is fine, but as soon as two threads execute the same
|
||
code concurrently `for the first time' they can come into conflict.
|
||
|
||
This memoization includes rewriting variable references into more
|
||
efficient forms and expanding macros. Furthermore, macro expansion
|
||
includes `compiling' special forms like `let', `cond', etc. into
|
||
tree-code instructions.
|
||
|
||
There shouldn't normally be a problem with memoizing local and
|
||
global variable references (into ilocs and variables), because all
|
||
threads will mutate the code in *exactly* the same way and (if I
|
||
read the C code correctly) it is not possible to observe a half-way
|
||
mutated cons cell. The lookup procedure can handle this
|
||
transparently without any critical sections.
|
||
|
||
It is different with macro expansion, because macro expansion
|
||
happens outside of the lookup procedure and can't be
|
||
undone. Therefore the lookup procedure can't cope with it. It has
|
||
to indicate failure when it detects a lost race and hope that the
|
||
caller can handle it. Luckily, it turns out that this is the case.
|
||
|
||
An example to illustrate this: Suppose that the following form will
|
||
be memoized concurrently by two threads
|
||
|
||
(let ((x 12)) x)
|
||
|
||
Let's first examine the lookup of X in the body. The first thread
|
||
decides that it has to find the symbol "x" in the environment and
|
||
starts to scan it. Then the other thread takes over and actually
|
||
overtakes the first. It looks up "x" and substitutes an
|
||
appropriate iloc for it. Now the first thread continues and
|
||
completes its lookup. It comes to exactly the same conclusions as
|
||
the second one and could - without much ado - just overwrite the
|
||
iloc with the same iloc.
|
||
|
||
But let's see what will happen when the race occurs while looking
|
||
up the symbol "let" at the start of the form. It could happen that
|
||
the second thread interrupts the lookup of the first thread and not
|
||
only substitutes a variable for it but goes right ahead and
|
||
replaces it with the compiled form (#@let* (x 12) x). Now, when
|
||
the first thread completes its lookup, it would replace the #@let*
|
||
with a variable containing the "let" binding, effectively reverting
|
||
the form to (let (x 12) x). This is wrong. It has to detect that
|
||
it has lost the race and the evaluator has to reconsider the
|
||
changed form completely.
|
||
|
||
This race condition could be resolved with some kind of traffic
|
||
light (like mutexes) around scm_lookupcar, but I think that it is
|
||
best to avoid them in this case. They would serialize memoization
|
||
completely and because lookup involves calling arbitrary Scheme
|
||
code (via the lookup-thunk), threads could be blocked for an
|
||
arbitrary amount of time or even deadlock. But with the current
|
||
solution a lot of unnecessary work is potentially done. */
|
||
|
||
/* 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.)
|
||
In that case the whole lookup is bogus and the caller has to
|
||
reconsider the complete special form.
|
||
|
||
SCM_LOOKUPCAR is still there, of course. It just calls
|
||
SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
|
||
should only be called when it is known that VLOC is not the first
|
||
pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
|
||
for NULL. I think I've found the only places where this
|
||
applies. */
|
||
|
||
SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
|
||
|
||
static SCM *
|
||
scm_lookupcar1 (SCM vloc, SCM genv, int check)
|
||
{
|
||
SCM env = genv;
|
||
register SCM *al, fl, var = SCM_CAR (vloc);
|
||
register SCM iloc = SCM_ILOC00;
|
||
for (; SCM_NIMP (env); env = SCM_CDR (env))
|
||
{
|
||
if (!SCM_CONSP (SCM_CAR (env)))
|
||
break;
|
||
al = SCM_CARLOC (env);
|
||
for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl))
|
||
{
|
||
if (!SCM_CONSP (fl))
|
||
{
|
||
if (SCM_EQ_P (fl, var))
|
||
{
|
||
if (! SCM_EQ_P (SCM_CAR (vloc), var))
|
||
goto race;
|
||
SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (iloc) + SCM_ICDR);
|
||
return SCM_CDRLOC (*al);
|
||
}
|
||
else
|
||
break;
|
||
}
|
||
al = SCM_CDRLOC (*al);
|
||
if (SCM_EQ_P (SCM_CAR (fl), var))
|
||
{
|
||
if (SCM_UNBNDP (SCM_CAR (*al)))
|
||
{
|
||
env = SCM_EOL;
|
||
goto errout;
|
||
}
|
||
if (!SCM_EQ_P (SCM_CAR (vloc), var))
|
||
goto race;
|
||
SCM_SETCAR (vloc, iloc);
|
||
return SCM_CARLOC (*al);
|
||
}
|
||
iloc = SCM_PACK (SCM_UNPACK (iloc) + SCM_IDINC);
|
||
}
|
||
iloc = SCM_PACK ((~SCM_IDSTMSK) & (SCM_UNPACK(iloc) + SCM_IFRINC));
|
||
}
|
||
{
|
||
SCM top_thunk, real_var;
|
||
if (SCM_NIMP (env))
|
||
{
|
||
top_thunk = SCM_CAR (env); /* env now refers to a
|
||
top level env thunk */
|
||
env = SCM_CDR (env);
|
||
}
|
||
else
|
||
top_thunk = SCM_BOOL_F;
|
||
real_var = scm_sym2var (var, top_thunk, SCM_BOOL_F);
|
||
if (SCM_FALSEP (real_var))
|
||
goto errout;
|
||
|
||
if (!SCM_NULLP (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var)))
|
||
{
|
||
errout:
|
||
if (check)
|
||
{
|
||
if (SCM_NULLP (env))
|
||
scm_error (scm_unbound_variable_key, NULL,
|
||
"Unbound variable: ~S",
|
||
scm_list_1 (var), SCM_BOOL_F);
|
||
else
|
||
scm_misc_error (NULL, "Damaged environment: ~S",
|
||
scm_list_1 (var));
|
||
}
|
||
else
|
||
{
|
||
/* A variable could not be found, but we shall
|
||
not throw an error. */
|
||
static SCM undef_object = SCM_UNDEFINED;
|
||
return &undef_object;
|
||
}
|
||
}
|
||
|
||
if (!SCM_EQ_P (SCM_CAR (vloc), var))
|
||
{
|
||
/* Some other thread has changed the very cell we are working
|
||
on. In effect, it must have done our job or messed it up
|
||
completely. */
|
||
race:
|
||
var = SCM_CAR (vloc);
|
||
if (SCM_VARIABLEP (var))
|
||
return SCM_VARIABLE_LOC (var);
|
||
if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00))
|
||
return scm_ilookup (var, genv);
|
||
/* We can't cope with anything else than variables and ilocs. When
|
||
a special form has been memoized (i.e. `let' into `#@let') we
|
||
return NULL and expect the calling function to do the right
|
||
thing. For the evaluator, this means going back and redoing
|
||
the dispatch on the car of the form. */
|
||
return NULL;
|
||
}
|
||
|
||
SCM_SETCAR (vloc, real_var);
|
||
return SCM_VARIABLE_LOC (real_var);
|
||
}
|
||
}
|
||
|
||
SCM *
|
||
scm_lookupcar (SCM vloc, SCM genv, int check)
|
||
{
|
||
SCM *loc = scm_lookupcar1 (vloc, genv, check);
|
||
if (loc == NULL)
|
||
abort ();
|
||
return loc;
|
||
}
|
||
|
||
/* 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 x = scm_cons (symbol, SCM_UNDEFINED);
|
||
const SCM value = *scm_lookupcar (x, env, 0);
|
||
if (SCM_UNBNDP (value) || SCM_MACROP (value))
|
||
return 1;
|
||
else
|
||
return 0;
|
||
}
|
||
|
||
#define unmemocar scm_unmemocar
|
||
|
||
SCM_SYMBOL (sym_three_question_marks, "???");
|
||
|
||
SCM
|
||
scm_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_eval_car (SCM pair, SCM env)
|
||
{
|
||
return SCM_XEVALCAR (pair, env);
|
||
}
|
||
|
||
|
||
/*
|
||
* The following rewrite expressions and
|
||
* some memoized forms have different syntax
|
||
*/
|
||
|
||
SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
|
||
SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
|
||
SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
|
||
|
||
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");
|
||
|
||
|
||
/* 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. */
|
||
|
||
static SCM
|
||
scm_m_body (SCM op, SCM xorig, const char *what)
|
||
{
|
||
SCM_ASSYNT (scm_ilength (xorig) >= 1, s_body, what);
|
||
|
||
/* Don't add another ISYM if one is present already. */
|
||
if (SCM_ISYMP (SCM_CAR (xorig)))
|
||
return xorig;
|
||
|
||
/* Retain possible doc string. */
|
||
if (!SCM_CONSP (SCM_CAR (xorig)))
|
||
{
|
||
if (!SCM_NULLP (SCM_CDR (xorig)))
|
||
return scm_cons (SCM_CAR (xorig),
|
||
scm_m_body (op, SCM_CDR (xorig), what));
|
||
return xorig;
|
||
}
|
||
|
||
return scm_cons (op, xorig);
|
||
}
|
||
|
||
|
||
/* Start of the memoizers for the standard R5RS builtin macros. */
|
||
|
||
|
||
SCM_SYNTAX (s_and, "and", scm_i_makbimacro, scm_m_and);
|
||
SCM_GLOBAL_SYMBOL (scm_sym_and, s_and);
|
||
|
||
SCM
|
||
scm_m_and (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: (and) is replaced by #t. */
|
||
return SCM_BOOL_T;
|
||
}
|
||
else
|
||
{
|
||
SCM_SETCAR (expr, SCM_IM_AND);
|
||
return expr;
|
||
}
|
||
}
|
||
|
||
|
||
SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
|
||
SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
|
||
|
||
SCM
|
||
scm_m_begin (SCM expr, SCM env SCM_UNUSED)
|
||
{
|
||
const SCM cdr_expr = SCM_CDR (expr);
|
||
|
||
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
|
||
|
||
SCM_SETCAR (expr, SCM_IM_BEGIN);
|
||
return expr;
|
||
}
|
||
|
||
|
||
SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case);
|
||
SCM_GLOBAL_SYMBOL (scm_sym_case, s_case);
|
||
|
||
SCM
|
||
scm_m_case (SCM expr, SCM env)
|
||
{
|
||
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);
|
||
SCM label_idx = SCM_CDR (all_labels);
|
||
for (; !SCM_NULLP (label_idx); label_idx = SCM_CDR (label_idx))
|
||
{
|
||
ASSERT_SYNTAX_2 (!SCM_EQ_P (SCM_CAR (label_idx), label),
|
||
s_duplicate_case_label, label, expr);
|
||
}
|
||
}
|
||
|
||
SCM_SETCAR (expr, SCM_IM_CASE);
|
||
return expr;
|
||
}
|
||
|
||
|
||
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_cond (SCM expr, SCM env)
|
||
{
|
||
/* 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;
|
||
}
|
||
|
||
|
||
SCM_SYNTAX(s_define, "define", scm_i_makbimacro, scm_m_define);
|
||
SCM_GLOBAL_SYMBOL(scm_sym_define, s_define);
|
||
|
||
/* 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 expr, SCM env)
|
||
{
|
||
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);
|
||
|
||
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. */
|
||
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);
|
||
|
||
if (SCM_TOP_LEVEL (env))
|
||
{
|
||
SCM var;
|
||
const SCM value = scm_eval_car (body, 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);
|
||
}
|
||
var = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T);
|
||
SCM_VARIABLE_SET (var, value);
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
else
|
||
{
|
||
SCM_SETCAR (expr, SCM_IM_DEFINE);
|
||
SCM_SETCAR (cdr_expr, variable);
|
||
SCM_SETCDR (cdr_expr, body);
|
||
return expr;
|
||
}
|
||
}
|
||
|
||
|
||
/* 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_delay (SCM expr, SCM env)
|
||
{
|
||
const SCM new_expr = memoize_as_thunk_prototype (expr, env);
|
||
SCM_SETCAR (new_expr, SCM_IM_DELAY);
|
||
return new_expr;
|
||
}
|
||
|
||
|
||
SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do);
|
||
SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
|
||
|
||
/* DO gets the most radically altered syntax. The order of the vars is
|
||
* reversed here. In contrast, the order of the inits and steps is reversed
|
||
* during the evaluation:
|
||
|
||
(do ((<var1> <init1> <step1>)
|
||
(<var2> <init2>)
|
||
... )
|
||
(<test> <return>)
|
||
<body>)
|
||
|
||
;; becomes
|
||
|
||
(#@do (<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 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))
|
||
{
|
||
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);
|
||
variables = scm_cons (name, variables);
|
||
init_forms = scm_cons (init, init_forms);
|
||
step_forms = scm_cons (step, step_forms);
|
||
}
|
||
}
|
||
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_if, "if", scm_i_makbimacro, scm_m_if);
|
||
SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
|
||
|
||
SCM
|
||
scm_m_if (SCM xorig, SCM env SCM_UNUSED)
|
||
{
|
||
long len = scm_ilength (SCM_CDR (xorig));
|
||
SCM_ASSYNT (len >= 2 && len <= 3, s_expression, s_if);
|
||
return scm_cons (SCM_IM_IF, SCM_CDR (xorig));
|
||
}
|
||
|
||
|
||
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.) */
|
||
static int
|
||
scm_c_improper_memq (SCM obj, SCM list)
|
||
{
|
||
for (; SCM_CONSP (list); list = SCM_CDR (list))
|
||
{
|
||
if (SCM_EQ_P (SCM_CAR (list), obj))
|
||
return 1;
|
||
}
|
||
return SCM_EQ_P (list, obj);
|
||
}
|
||
|
||
SCM
|
||
scm_m_lambda (SCM xorig, SCM env SCM_UNUSED)
|
||
{
|
||
SCM formals;
|
||
SCM x = SCM_CDR (xorig);
|
||
|
||
SCM_ASSYNT (SCM_CONSP (x), s_formals, s_lambda);
|
||
|
||
formals = SCM_CAR (x);
|
||
while (SCM_CONSP (formals))
|
||
{
|
||
SCM formal = SCM_CAR (formals);
|
||
SCM_ASSYNT (SCM_SYMBOLP (formal), s_formals, s_lambda);
|
||
if (scm_c_improper_memq (formal, SCM_CDR (formals)))
|
||
scm_misc_error (s_lambda, s_duplicate_formals, SCM_EOL);
|
||
formals = SCM_CDR (formals);
|
||
}
|
||
if (!SCM_NULLP (formals) && !SCM_SYMBOLP (formals))
|
||
scm_misc_error (s_lambda, 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 ((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, s_bindings, what);
|
||
|
||
do
|
||
{
|
||
SCM binding = SCM_CAR (bindings);
|
||
SCM_ASSYNT (scm_ilength (binding) == 2, s_bindings, what);
|
||
SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), s_variable, what);
|
||
if (scm_c_improper_memq (SCM_CAR (binding), rvars))
|
||
scm_misc_error (what, 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;
|
||
}
|
||
|
||
|
||
SCM_SYNTAX(s_let, "let", scm_i_makbimacro, scm_m_let);
|
||
SCM_GLOBAL_SYMBOL(scm_sym_let, s_let);
|
||
|
||
SCM
|
||
scm_m_let (SCM xorig, SCM env)
|
||
{
|
||
SCM x = SCM_CDR (xorig);
|
||
SCM temp;
|
||
|
||
SCM_ASSYNT (SCM_CONSP (x), 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))
|
||
{
|
||
/* plain let */
|
||
SCM bindings = temp;
|
||
SCM rvars, inits, body;
|
||
transform_bindings (bindings, &rvars, &inits, "let");
|
||
body = scm_m_body (SCM_IM_LET, SCM_CDR (x), "let");
|
||
return scm_cons2 (SCM_IM_LET, rvars, scm_cons (inits, body));
|
||
}
|
||
else
|
||
{
|
||
/* named let: Transform (let name ((var init) ...) body ...) into
|
||
* ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
|
||
|
||
SCM name = temp;
|
||
SCM vars = SCM_EOL;
|
||
SCM *varloc = &vars;
|
||
SCM inits = SCM_EOL;
|
||
SCM *initloc = &inits;
|
||
SCM bindings;
|
||
|
||
SCM_ASSYNT (SCM_SYMBOLP (name), s_bindings, s_let);
|
||
x = SCM_CDR (x);
|
||
SCM_ASSYNT (SCM_CONSP (x), s_bindings, s_let);
|
||
bindings = SCM_CAR (x);
|
||
SCM_ASSYNT (scm_ilength (bindings) >= 0, 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, s_bindings, s_let);
|
||
SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), s_variable, s_let);
|
||
*varloc = scm_list_1 (SCM_CAR (binding));
|
||
varloc = SCM_CDRLOC (*varloc);
|
||
*initloc = scm_list_1 (SCM_CADR (binding));
|
||
initloc = SCM_CDRLOC (*initloc);
|
||
bindings = SCM_CDR (bindings);
|
||
}
|
||
|
||
{
|
||
SCM lambda_body = scm_m_body (SCM_IM_LET, SCM_CDR (x), "let");
|
||
SCM lambda_form = scm_cons2 (scm_sym_lambda, vars, lambda_body);
|
||
SCM rvar = scm_list_1 (name);
|
||
SCM init = scm_list_1 (lambda_form);
|
||
SCM body = scm_m_body (SCM_IM_LET, scm_list_1 (name), "let");
|
||
SCM letrec = scm_cons2 (SCM_IM_LETREC, rvar, scm_cons (init, body));
|
||
return scm_cons (letrec, inits);
|
||
}
|
||
}
|
||
}
|
||
|
||
|
||
SCM_SYNTAX (s_letstar, "let*", scm_i_makbimacro, scm_m_letstar);
|
||
SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);
|
||
|
||
/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
|
||
* i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
|
||
SCM
|
||
scm_m_letstar (SCM xorig, SCM env SCM_UNUSED)
|
||
{
|
||
SCM bindings;
|
||
SCM x = SCM_CDR (xorig);
|
||
SCM vars = SCM_EOL;
|
||
SCM *varloc = &vars;
|
||
|
||
SCM_ASSYNT (SCM_CONSP (x), s_bindings, s_letstar);
|
||
|
||
bindings = SCM_CAR (x);
|
||
SCM_ASSYNT (scm_ilength (bindings) >= 0, s_bindings, s_letstar);
|
||
while (!SCM_NULLP (bindings))
|
||
{
|
||
SCM binding = SCM_CAR (bindings);
|
||
SCM_ASSYNT (scm_ilength (binding) == 2, s_bindings, s_letstar);
|
||
SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), s_variable, s_letstar);
|
||
*varloc = scm_list_2 (SCM_CAR (binding), SCM_CADR (binding));
|
||
varloc = SCM_CDRLOC (SCM_CDR (*varloc));
|
||
bindings = SCM_CDR (bindings);
|
||
}
|
||
|
||
return scm_cons2 (SCM_IM_LETSTAR, vars,
|
||
scm_m_body (SCM_IM_LETSTAR, SCM_CDR (x), s_letstar));
|
||
}
|
||
|
||
|
||
SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec);
|
||
SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
|
||
|
||
SCM
|
||
scm_m_letrec (SCM xorig, SCM env)
|
||
{
|
||
SCM x = SCM_CDR (xorig);
|
||
SCM_ASSYNT (SCM_CONSP (x), s_bindings, s_letrec);
|
||
|
||
if (SCM_NULLP (SCM_CAR (x)))
|
||
{
|
||
/* null binding, let* faster */
|
||
SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), s_letrec);
|
||
return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL, body), env);
|
||
}
|
||
else
|
||
{
|
||
SCM rvars, inits, body;
|
||
transform_bindings (SCM_CAR (x), &rvars, &inits, "letrec");
|
||
body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), "letrec");
|
||
return scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body));
|
||
}
|
||
}
|
||
|
||
|
||
SCM_SYNTAX (s_or, "or", scm_i_makbimacro, scm_m_or);
|
||
SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
|
||
|
||
SCM
|
||
scm_m_or (SCM xorig, SCM env SCM_UNUSED)
|
||
{
|
||
long len = scm_ilength (SCM_CDR (xorig));
|
||
SCM_ASSYNT (len >= 0, s_test, s_or);
|
||
if (len >= 1)
|
||
return scm_cons (SCM_IM_OR, SCM_CDR (xorig));
|
||
else
|
||
return SCM_BOOL_F;
|
||
}
|
||
|
||
|
||
SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
|
||
SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);
|
||
|
||
/* Internal function to handle a quasiquotation: 'form' is the parameter in
|
||
* the call (quasiquotation form), 'env' is the environment where unquoted
|
||
* expressions will be evaluated, and 'depth' is the current quasiquotation
|
||
* nesting level and is known to be greater than zero. */
|
||
static SCM
|
||
iqq (SCM form, SCM env, unsigned long int depth)
|
||
{
|
||
if (SCM_CONSP (form))
|
||
{
|
||
SCM tmp = SCM_CAR (form);
|
||
if (SCM_EQ_P (tmp, scm_sym_quasiquote))
|
||
{
|
||
SCM args = SCM_CDR (form);
|
||
SCM_ASSYNT (scm_ilength (args) == 1, s_expression, s_quasiquote);
|
||
return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1));
|
||
}
|
||
else if (SCM_EQ_P (tmp, scm_sym_unquote))
|
||
{
|
||
SCM args = SCM_CDR (form);
|
||
SCM_ASSYNT (scm_ilength (args) == 1, s_expression, s_quasiquote);
|
||
if (depth - 1 == 0)
|
||
return scm_eval_car (args, env);
|
||
else
|
||
return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth - 1));
|
||
}
|
||
else if (SCM_CONSP (tmp)
|
||
&& SCM_EQ_P (SCM_CAR (tmp), scm_sym_uq_splicing))
|
||
{
|
||
SCM args = SCM_CDR (tmp);
|
||
SCM_ASSYNT (scm_ilength (args) == 1, s_expression, s_quasiquote);
|
||
if (depth - 1 == 0)
|
||
{
|
||
SCM list = scm_eval_car (args, env);
|
||
SCM rest = SCM_CDR (form);
|
||
SCM_ASSYNT (scm_ilength (list) >= 0, s_splicing, s_quasiquote);
|
||
return scm_append (scm_list_2 (list, iqq (rest, env, depth)));
|
||
}
|
||
else
|
||
return scm_cons (iqq (SCM_CAR (form), env, depth - 1),
|
||
iqq (SCM_CDR (form), env, depth));
|
||
}
|
||
else
|
||
return scm_cons (iqq (SCM_CAR (form), env, depth),
|
||
iqq (SCM_CDR (form), env, depth));
|
||
}
|
||
else if (SCM_VECTORP (form))
|
||
{
|
||
size_t i = SCM_VECTOR_LENGTH (form);
|
||
SCM const *const data = SCM_VELTS (form);
|
||
SCM tmp = SCM_EOL;
|
||
while (i != 0)
|
||
tmp = scm_cons (data[--i], tmp);
|
||
scm_remember_upto_here_1 (form);
|
||
return scm_vector (iqq (tmp, env, depth));
|
||
}
|
||
else
|
||
return form;
|
||
}
|
||
|
||
SCM
|
||
scm_m_quasiquote (SCM xorig, SCM env)
|
||
{
|
||
SCM x = SCM_CDR (xorig);
|
||
SCM_ASSYNT (scm_ilength (x) == 1, s_expression, s_quasiquote);
|
||
return iqq (SCM_CAR (x), env, 1);
|
||
}
|
||
|
||
|
||
SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote);
|
||
SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
|
||
|
||
SCM
|
||
scm_m_quote (SCM xorig, SCM env SCM_UNUSED)
|
||
{
|
||
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, s_expression, s_quote);
|
||
return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig));
|
||
}
|
||
|
||
|
||
/* 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);
|
||
|
||
SCM
|
||
scm_m_set_x (SCM xorig, SCM env SCM_UNUSED)
|
||
{
|
||
SCM x = SCM_CDR (xorig);
|
||
SCM_ASSYNT (scm_ilength (x) == 2, s_expression, s_set_x);
|
||
SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), s_variable, s_set_x);
|
||
return scm_cons (SCM_IM_SET_X, x);
|
||
}
|
||
|
||
|
||
/* Start of the memoizers for non-R5RS builtin macros. */
|
||
|
||
|
||
SCM_SYNTAX (s_atapply, "@apply", scm_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_apply (SCM xorig, SCM env SCM_UNUSED)
|
||
{
|
||
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, s_expression, s_atapply);
|
||
return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig));
|
||
}
|
||
|
||
|
||
/* (@bind ((var exp) ...) body ...)
|
||
|
||
This will assign the values of the `exp's to the global variables
|
||
named by `var's (symbols, not evaluated), creating them if they
|
||
don't exist, executes body, and then restores the previous values of
|
||
the `var's. Additionally, whenever control leaves body, the values
|
||
of the `var's are saved and restored when control returns. It is an
|
||
error when a symbol appears more than once among the `var's.
|
||
All `exp's are evaluated before any `var' is set.
|
||
|
||
Think of this as `let' for dynamic scope.
|
||
|
||
It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
|
||
|
||
XXX - also implement `@bind*'.
|
||
*/
|
||
|
||
SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind);
|
||
|
||
SCM
|
||
scm_m_atbind (SCM xorig, SCM env)
|
||
{
|
||
SCM x = SCM_CDR (xorig);
|
||
SCM top_level = scm_env_top_level (env);
|
||
SCM vars = SCM_EOL, var;
|
||
SCM exps = SCM_EOL;
|
||
|
||
SCM_ASSYNT (scm_ilength (x) > 1, s_expression, s_atbind);
|
||
|
||
x = SCM_CAR (x);
|
||
while (SCM_NIMP (x))
|
||
{
|
||
SCM rest;
|
||
SCM sym_exp = SCM_CAR (x);
|
||
SCM_ASSYNT (scm_ilength (sym_exp) == 2, s_bindings, s_atbind);
|
||
SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp)), 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, s_duplicate_bindings, SCM_EOL);
|
||
/* The first call to scm_sym2var will look beyond the current
|
||
module, while the second call wont. */
|
||
var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_F);
|
||
if (SCM_FALSEP (var))
|
||
var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_T);
|
||
vars = scm_cons (var, vars);
|
||
exps = scm_cons (SCM_CADR (sym_exp), exps);
|
||
}
|
||
return scm_cons (SCM_IM_BIND,
|
||
scm_cons (scm_cons (scm_reverse_x (vars, SCM_EOL), exps),
|
||
SCM_CDDR (xorig)));
|
||
}
|
||
|
||
|
||
SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont);
|
||
SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc);
|
||
|
||
|
||
SCM
|
||
scm_m_cont (SCM xorig, SCM env SCM_UNUSED)
|
||
{
|
||
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
|
||
s_expression, s_atcall_cc);
|
||
return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));
|
||
}
|
||
|
||
|
||
SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_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_at_call_with_values (SCM xorig, SCM env SCM_UNUSED)
|
||
{
|
||
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2,
|
||
s_expression, s_at_call_with_values);
|
||
return scm_cons (SCM_IM_CALL_WITH_VALUES, SCM_CDR (xorig));
|
||
}
|
||
|
||
|
||
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_future (SCM expr, SCM env)
|
||
{
|
||
const SCM new_expr = memoize_as_thunk_prototype (expr, env);
|
||
SCM_SETCAR (new_expr, SCM_IM_FUTURE);
|
||
return new_expr;
|
||
}
|
||
|
||
|
||
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 xorig, SCM env SCM_UNUSED)
|
||
{
|
||
SCM x = SCM_CDR (xorig);
|
||
SCM_ASSYNT (2 == scm_ilength (x), s_expression, s_set_x);
|
||
if (SCM_SYMBOLP (SCM_CAR (x)))
|
||
return scm_cons (SCM_IM_SET_X, x);
|
||
else if (SCM_CONSP (SCM_CAR (x)))
|
||
return scm_cons (scm_list_2 (scm_sym_setter, SCM_CAAR (x)),
|
||
scm_append (scm_list_2 (SCM_CDAR (x), SCM_CDR (x))));
|
||
else
|
||
scm_misc_error (s_set_x, s_variable, SCM_EOL);
|
||
}
|
||
|
||
|
||
static const char* s_atslot_ref = "@slot-ref";
|
||
|
||
/* @slot-ref is bound privately in the (oop goops) module from goops.c. As
|
||
* soon as the module system allows us to more freely create bindings in
|
||
* arbitrary modules during the startup phase, the code from goops.c should be
|
||
* moved here. */
|
||
SCM
|
||
scm_m_atslot_ref (SCM xorig, SCM env SCM_UNUSED)
|
||
#define FUNC_NAME s_atslot_ref
|
||
{
|
||
SCM x = SCM_CDR (xorig);
|
||
SCM_ASSYNT (scm_ilength (x) == 2, s_expression, FUNC_NAME);
|
||
SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x));
|
||
return scm_cons (SCM_IM_SLOT_REF, x);
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
static const char* s_atslot_set_x = "@slot-set!";
|
||
|
||
/* @slot-set! is bound privately in the (oop goops) module from goops.c. As
|
||
* soon as the module system allows us to more freely create bindings in
|
||
* arbitrary modules during the startup phase, the code from goops.c should be
|
||
* moved here. */
|
||
SCM
|
||
scm_m_atslot_set_x (SCM xorig, SCM env SCM_UNUSED)
|
||
#define FUNC_NAME s_atslot_set_x
|
||
{
|
||
SCM x = SCM_CDR (xorig);
|
||
SCM_ASSYNT (scm_ilength (x) == 3, s_expression, FUNC_NAME);
|
||
SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x));
|
||
return scm_cons (SCM_IM_SLOT_SET_X, x);
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
#if SCM_ENABLE_ELISP
|
||
|
||
SCM_SYNTAX (s_nil_cond, "nil-cond", scm_i_makbimacro, scm_m_nil_cond);
|
||
|
||
SCM
|
||
scm_m_nil_cond (SCM xorig, SCM env SCM_UNUSED)
|
||
{
|
||
long len = scm_ilength (SCM_CDR (xorig));
|
||
SCM_ASSYNT (len >= 1 && (len & 1) == 1, s_expression, "nil-cond");
|
||
return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig));
|
||
}
|
||
|
||
|
||
SCM_SYNTAX (s_atfop, "@fop", scm_i_makbimacro, scm_m_atfop);
|
||
|
||
SCM
|
||
scm_m_atfop (SCM xorig, SCM env SCM_UNUSED)
|
||
{
|
||
SCM x = SCM_CDR (xorig), var;
|
||
SCM_ASSYNT (scm_ilength (x) >= 1, s_expression, "@fop");
|
||
var = scm_symbol_fref (SCM_CAR (x));
|
||
/* Passing the symbol name as the `subr' arg here isn't really
|
||
right, but without it it can be very difficult to work out from
|
||
the error message which function definition was missing. In any
|
||
case, we shouldn't really use SCM_ASSYNT here at all, but instead
|
||
something equivalent to (signal void-function (list SYM)) in
|
||
Elisp. */
|
||
SCM_ASSYNT (SCM_VARIABLEP (var),
|
||
"Symbol's function definition is void",
|
||
SCM_SYMBOL_CHARS (SCM_CAR (x)));
|
||
/* Support `defalias'. */
|
||
while (SCM_SYMBOLP (SCM_VARIABLE_REF (var)))
|
||
{
|
||
var = scm_symbol_fref (SCM_VARIABLE_REF (var));
|
||
SCM_ASSYNT (SCM_VARIABLEP (var),
|
||
"Symbol's function definition is void",
|
||
SCM_SYMBOL_CHARS (SCM_CAR (x)));
|
||
}
|
||
/* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
|
||
former allows for automatically picking up redefinitions of the
|
||
corresponding symbol. */
|
||
SCM_SETCAR (x, var);
|
||
/* If the variable contains a procedure, leave the
|
||
`transformer-macro' in place so that the procedure's arguments
|
||
get properly transformed, and change the initial @fop to
|
||
SCM_IM_APPLY. */
|
||
if (!SCM_MACROP (SCM_VARIABLE_REF (var)))
|
||
{
|
||
SCM_SETCAR (xorig, SCM_IM_APPLY);
|
||
return xorig;
|
||
}
|
||
/* Otherwise (the variable contains a macro), the arguments should
|
||
not be transformed, so cut the `transformer-macro' out and return
|
||
the resulting expression starting with the variable. */
|
||
SCM_SETCDR (x, SCM_CDADR (x));
|
||
return x;
|
||
}
|
||
|
||
#endif /* SCM_ENABLE_ELISP */
|
||
|
||
|
||
/* Start of the memoizers for deprecated macros. */
|
||
|
||
|
||
#if (SCM_ENABLE_DEPRECATED == 1)
|
||
|
||
SCM_SYNTAX (s_undefine, "undefine", scm_makacro, scm_m_undefine);
|
||
|
||
SCM
|
||
scm_m_undefine (SCM x, SCM env)
|
||
{
|
||
SCM arg1 = x;
|
||
x = SCM_CDR (x);
|
||
SCM_ASSYNT (SCM_TOP_LEVEL (env), "bad placement ", s_undefine);
|
||
SCM_ASSYNT (SCM_CONSP (x) && SCM_NULLP (SCM_CDR (x)),
|
||
s_expression, s_undefine);
|
||
x = SCM_CAR (x);
|
||
SCM_ASSYNT (SCM_SYMBOLP (x), s_variable, s_undefine);
|
||
arg1 = scm_sym2var (x, scm_env_top_level (env), SCM_BOOL_F);
|
||
SCM_ASSYNT (!SCM_FALSEP (arg1) && !SCM_UNBNDP (SCM_VARIABLE_REF (arg1)),
|
||
"variable already unbound ", s_undefine);
|
||
SCM_VARIABLE_SET (arg1, SCM_UNDEFINED);
|
||
#ifdef SICP
|
||
return x;
|
||
#else
|
||
return SCM_UNSPECIFIED;
|
||
#endif
|
||
}
|
||
|
||
#endif
|
||
|
||
|
||
SCM
|
||
scm_m_expand_body (SCM xorig, SCM env)
|
||
{
|
||
SCM x = SCM_CDR (xorig), defs = SCM_EOL;
|
||
char *what = SCM_ISYMCHARS (SCM_CAR (xorig)) + 2;
|
||
|
||
while (SCM_NIMP (x))
|
||
{
|
||
SCM form = SCM_CAR (x);
|
||
if (!SCM_CONSP (form))
|
||
break;
|
||
if (!SCM_SYMBOLP (SCM_CAR (form)))
|
||
break;
|
||
|
||
form = scm_macroexp (scm_cons_source (form,
|
||
SCM_CAR (form),
|
||
SCM_CDR (form)),
|
||
env);
|
||
|
||
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;
|
||
}
|
||
}
|
||
|
||
if (!SCM_NULLP (defs))
|
||
{
|
||
SCM rvars, inits, body, letrec;
|
||
transform_bindings (defs, &rvars, &inits, what);
|
||
body = scm_m_body (SCM_IM_DEFINE, x, what);
|
||
letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body));
|
||
SCM_SETCAR (xorig, letrec);
|
||
SCM_SETCDR (xorig, SCM_EOL);
|
||
}
|
||
else
|
||
{
|
||
SCM_ASSYNT (SCM_CONSP (x), s_body, what);
|
||
SCM_SETCAR (xorig, SCM_CAR (x));
|
||
SCM_SETCDR (xorig, SCM_CDR (x));
|
||
}
|
||
|
||
return xorig;
|
||
}
|
||
|
||
SCM
|
||
scm_macroexp (SCM x, SCM env)
|
||
{
|
||
SCM res, proc, orig_sym;
|
||
|
||
/* Don't bother to produce error messages here. We get them when we
|
||
eventually execute the code for real. */
|
||
|
||
macro_tail:
|
||
orig_sym = SCM_CAR (x);
|
||
if (!SCM_SYMBOLP (orig_sym))
|
||
return x;
|
||
|
||
{
|
||
SCM *proc_ptr = scm_lookupcar1 (x, env, 0);
|
||
if (proc_ptr == NULL)
|
||
{
|
||
/* We have lost the race. */
|
||
goto macro_tail;
|
||
}
|
||
proc = *proc_ptr;
|
||
}
|
||
|
||
/* 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 && !SCM_BUILTIN_MACRO_P (proc)))
|
||
return x;
|
||
|
||
SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */
|
||
res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
|
||
|
||
if (scm_ilength (res) <= 0)
|
||
res = scm_list_2 (SCM_IM_BEGIN, res);
|
||
|
||
SCM_DEFER_INTS;
|
||
SCM_SETCAR (x, SCM_CAR (res));
|
||
SCM_SETCDR (x, SCM_CDR (res));
|
||
SCM_ALLOW_INTS;
|
||
|
||
goto macro_tail;
|
||
}
|
||
|
||
#define SCM_BIT7(x) (127 & SCM_UNPACK (x))
|
||
|
||
/* A function object to implement "apply" for non-closure functions. */
|
||
static SCM f_apply;
|
||
/* An endless list consisting of #<undefined> objects: */
|
||
static SCM undefineds;
|
||
|
||
/* scm_unmemocopy takes a memoized expression together with its
|
||
* environment and rewrites it to its original form. Thus, it is the
|
||
* inversion of the rewrite rules above. The procedure is not
|
||
* optimized for speed. It's used in scm_iprin1 when printing the
|
||
* code of a closure, in scm_procedure_source, in display_frame when
|
||
* generating the source for a stackframe in a backtrace, and in
|
||
* display_expression.
|
||
*
|
||
* Unmemoizing is not a reliable process. You cannot in general
|
||
* expect to get the original source back.
|
||
*
|
||
* However, GOOPS currently relies on this for method compilation.
|
||
* This ought to change.
|
||
*/
|
||
|
||
static SCM
|
||
build_binding_list (SCM names, SCM inits)
|
||
{
|
||
SCM bindings = SCM_EOL;
|
||
while (!SCM_NULLP (names))
|
||
{
|
||
SCM binding = scm_list_2 (SCM_CAR (names), SCM_CAR (inits));
|
||
bindings = scm_cons (binding, bindings);
|
||
names = SCM_CDR (names);
|
||
inits = SCM_CDR (inits);
|
||
}
|
||
return bindings;
|
||
}
|
||
|
||
static SCM
|
||
unmemocopy (SCM x, SCM env)
|
||
{
|
||
SCM ls, z;
|
||
SCM p;
|
||
if (!SCM_CONSP (x))
|
||
return x;
|
||
p = scm_whash_lookup (scm_source_whash, x);
|
||
switch (SCM_ITAG7 (SCM_CAR (x)))
|
||
{
|
||
case SCM_BIT7 (SCM_IM_AND):
|
||
ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED);
|
||
break;
|
||
case SCM_BIT7 (SCM_IM_BEGIN):
|
||
ls = z = scm_cons (scm_sym_begin, SCM_UNSPECIFIED);
|
||
break;
|
||
case SCM_BIT7 (SCM_IM_CASE):
|
||
ls = z = scm_cons (scm_sym_case, SCM_UNSPECIFIED);
|
||
break;
|
||
case SCM_BIT7 (SCM_IM_COND):
|
||
ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED);
|
||
break;
|
||
case SCM_BIT7 (SCM_IM_DO):
|
||
{
|
||
/* format: (#@do (i1 ... ik) (nk nk-1 ...) (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 (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 = 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_BIT7 (SCM_IM_IF):
|
||
ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED);
|
||
break;
|
||
case SCM_BIT7 (SCM_IM_LET):
|
||
{
|
||
/* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
|
||
* where nx is the name of a local variable, ix is an initializer for
|
||
* the local variable and by are the body clauses. */
|
||
SCM names, inits, bindings;
|
||
|
||
x = SCM_CDR (x);
|
||
names = SCM_CAR (x);
|
||
x = SCM_CDR (x);
|
||
inits = scm_reverse (unmemocopy (SCM_CAR (x), env));
|
||
env = SCM_EXTEND_ENV (names, SCM_EOL, env);
|
||
|
||
bindings = build_binding_list (names, inits);
|
||
z = scm_cons (bindings, SCM_UNSPECIFIED);
|
||
ls = scm_cons (scm_sym_let, z);
|
||
break;
|
||
}
|
||
case SCM_BIT7 (SCM_IM_LETREC):
|
||
{
|
||
/* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
|
||
* where nx is the name of a local variable, ix is an initializer for
|
||
* the local variable and by are the body clauses. */
|
||
SCM names, inits, bindings;
|
||
|
||
x = SCM_CDR (x);
|
||
names = SCM_CAR (x);
|
||
env = SCM_EXTEND_ENV (names, SCM_EOL, env);
|
||
x = SCM_CDR (x);
|
||
inits = scm_reverse (unmemocopy (SCM_CAR (x), env));
|
||
|
||
bindings = build_binding_list (names, inits);
|
||
z = scm_cons (bindings, SCM_UNSPECIFIED);
|
||
ls = scm_cons (scm_sym_letrec, z);
|
||
break;
|
||
}
|
||
case SCM_BIT7 (SCM_IM_LETSTAR):
|
||
{
|
||
SCM b, y;
|
||
x = SCM_CDR (x);
|
||
b = SCM_CAR (x);
|
||
y = SCM_EOL;
|
||
if SCM_IMP (b)
|
||
{
|
||
env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env);
|
||
goto letstar;
|
||
}
|
||
y = z = scm_acons (SCM_CAR (b),
|
||
unmemocar (
|
||
scm_cons (unmemocopy (SCM_CADR (b), env), SCM_EOL), env),
|
||
SCM_UNSPECIFIED);
|
||
env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
|
||
b = SCM_CDDR (b);
|
||
if (SCM_IMP (b))
|
||
{
|
||
SCM_SETCDR (y, SCM_EOL);
|
||
z = scm_cons (y, SCM_UNSPECIFIED);
|
||
ls = scm_cons (scm_sym_let, z);
|
||
break;
|
||
}
|
||
do
|
||
{
|
||
SCM_SETCDR (z, scm_acons (SCM_CAR (b),
|
||
unmemocar (
|
||
scm_list_1 (unmemocopy (SCM_CADR (b), env)), env),
|
||
SCM_UNSPECIFIED));
|
||
z = SCM_CDR (z);
|
||
env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
|
||
b = SCM_CDDR (b);
|
||
}
|
||
while (SCM_NIMP (b));
|
||
SCM_SETCDR (z, SCM_EOL);
|
||
letstar:
|
||
z = scm_cons (y, SCM_UNSPECIFIED);
|
||
ls = scm_cons (scm_sym_letstar, z);
|
||
break;
|
||
}
|
||
case SCM_BIT7 (SCM_IM_OR):
|
||
ls = z = scm_cons (scm_sym_or, SCM_UNSPECIFIED);
|
||
break;
|
||
case SCM_BIT7 (SCM_IM_LAMBDA):
|
||
x = SCM_CDR (x);
|
||
z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED);
|
||
ls = scm_cons (scm_sym_lambda, z);
|
||
env = SCM_EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
|
||
break;
|
||
case SCM_BIT7 (SCM_IM_QUOTE):
|
||
ls = z = scm_cons (scm_sym_quote, SCM_UNSPECIFIED);
|
||
break;
|
||
case SCM_BIT7 (SCM_IM_SET_X):
|
||
ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED);
|
||
break;
|
||
case SCM_BIT7 (SCM_MAKISYM (0)):
|
||
z = SCM_CAR (x);
|
||
switch (SCM_ISYMNUM (z))
|
||
{
|
||
case (SCM_ISYMNUM (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_ISYMNUM (SCM_IM_APPLY)):
|
||
ls = z = scm_cons (scm_sym_atapply, SCM_UNSPECIFIED);
|
||
goto loop;
|
||
case (SCM_ISYMNUM (SCM_IM_CONT)):
|
||
ls = z = scm_cons (scm_sym_atcall_cc, SCM_UNSPECIFIED);
|
||
goto loop;
|
||
case (SCM_ISYMNUM (SCM_IM_DELAY)):
|
||
ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED);
|
||
x = SCM_CDR (x);
|
||
goto loop;
|
||
case (SCM_ISYMNUM (SCM_IM_FUTURE)):
|
||
ls = z = scm_cons (scm_sym_future, SCM_UNSPECIFIED);
|
||
x = SCM_CDR (x);
|
||
goto loop;
|
||
case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
|
||
ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED);
|
||
goto loop;
|
||
case (SCM_ISYMNUM (SCM_IM_ELSE)):
|
||
ls = z = scm_cons (scm_sym_else, SCM_UNSPECIFIED);
|
||
goto loop;
|
||
default:
|
||
/* appease the Sun compiler god: */ ;
|
||
}
|
||
default:
|
||
ls = z = unmemocar (scm_cons (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_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);
|
||
if (!SCM_FALSEP (p))
|
||
scm_whash_insert (scm_source_whash, ls, p);
|
||
return ls;
|
||
}
|
||
|
||
|
||
SCM
|
||
scm_unmemocopy (SCM x, 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);
|
||
}
|
||
|
||
|
||
int
|
||
scm_badargsp (SCM formals, SCM args)
|
||
{
|
||
while (!SCM_NULLP (formals))
|
||
{
|
||
if (!SCM_CONSP (formals))
|
||
return 0;
|
||
if (SCM_NULLP (args))
|
||
return 1;
|
||
formals = SCM_CDR (formals);
|
||
args = SCM_CDR (args);
|
||
}
|
||
return !SCM_NULLP (args) ? 1 : 0;
|
||
}
|
||
|
||
|
||
SCM
|
||
scm_eval_args (SCM l, SCM env, SCM proc)
|
||
{
|
||
SCM results = SCM_EOL, *lloc = &results, res;
|
||
while (SCM_CONSP (l))
|
||
{
|
||
res = EVALCAR (l, env);
|
||
|
||
*lloc = scm_list_1 (res);
|
||
lloc = SCM_CDRLOC (*lloc);
|
||
l = SCM_CDR (l);
|
||
}
|
||
if (!SCM_NULLP (l))
|
||
scm_wrong_num_args (proc);
|
||
return results;
|
||
}
|
||
|
||
|
||
SCM
|
||
scm_eval_body (SCM code, SCM env)
|
||
{
|
||
SCM next;
|
||
again:
|
||
next = SCM_CDR (code);
|
||
while (!SCM_NULLP (next))
|
||
{
|
||
if (SCM_IMP (SCM_CAR (code)))
|
||
{
|
||
if (SCM_ISYMP (SCM_CAR (code)))
|
||
{
|
||
scm_rec_mutex_lock (&source_mutex);
|
||
/* check for race condition */
|
||
if (SCM_ISYMP (SCM_CAR (code)))
|
||
code = scm_m_expand_body (code, env);
|
||
scm_rec_mutex_unlock (&source_mutex);
|
||
goto again;
|
||
}
|
||
}
|
||
else
|
||
SCM_XEVAL (SCM_CAR (code), env);
|
||
code = next;
|
||
next = SCM_CDR (code);
|
||
}
|
||
return SCM_XEVALCAR (code, env);
|
||
}
|
||
|
||
#endif /* !DEVAL */
|
||
|
||
|
||
/* SECTION: This code is specific for the debugging support. One
|
||
* branch is read when DEVAL isn't defined, the other when DEVAL is
|
||
* defined.
|
||
*/
|
||
|
||
#ifndef DEVAL
|
||
|
||
#define SCM_APPLY scm_apply
|
||
#define PREP_APPLY(proc, args)
|
||
#define ENTER_APPLY
|
||
#define RETURN(x) do { return x; } while (0)
|
||
#ifdef STACK_CHECKING
|
||
#ifndef NO_CEVAL_STACK_CHECKING
|
||
#define EVAL_STACK_CHECKING
|
||
#endif
|
||
#endif
|
||
|
||
#else /* !DEVAL */
|
||
|
||
#undef SCM_CEVAL
|
||
#define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
|
||
#undef SCM_APPLY
|
||
#define SCM_APPLY scm_dapply
|
||
#undef PREP_APPLY
|
||
#define PREP_APPLY(p, l) \
|
||
{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
|
||
#undef ENTER_APPLY
|
||
#define ENTER_APPLY \
|
||
do { \
|
||
SCM_SET_ARGSREADY (debug);\
|
||
if (scm_check_apply_p && SCM_TRAPS_P)\
|
||
if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
|
||
{\
|
||
SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
|
||
SCM_SET_TRACED_FRAME (debug); \
|
||
SCM_TRAPS_P = 0;\
|
||
if (SCM_CHEAPTRAPS_P)\
|
||
{\
|
||
tmp = scm_make_debugobj (&debug);\
|
||
scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
|
||
}\
|
||
else\
|
||
{\
|
||
int first;\
|
||
tmp = scm_make_continuation (&first);\
|
||
if (first)\
|
||
scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
|
||
}\
|
||
SCM_TRAPS_P = 1;\
|
||
}\
|
||
} while (0)
|
||
#undef RETURN
|
||
#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_debug_eframe_size is the number of slots available for pseudo
|
||
* stack frames at each real stack frame.
|
||
*/
|
||
|
||
long scm_debug_eframe_size;
|
||
|
||
int scm_debug_mode, scm_check_entry_p, scm_check_apply_p, scm_check_exit_p;
|
||
|
||
long scm_eval_stack;
|
||
|
||
scm_t_option scm_eval_opts[] = {
|
||
{ SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." }
|
||
};
|
||
|
||
scm_t_option scm_debug_opts[] = {
|
||
{ SCM_OPTION_BOOLEAN, "cheap", 1,
|
||
"*Flyweight representation of the stack at traps." },
|
||
{ SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." },
|
||
{ SCM_OPTION_BOOLEAN, "trace", 0, "*Trace mode." },
|
||
{ SCM_OPTION_BOOLEAN, "procnames", 1,
|
||
"Record procedure names at definition." },
|
||
{ SCM_OPTION_BOOLEAN, "backwards", 0,
|
||
"Display backtrace in anti-chronological order." },
|
||
{ SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." },
|
||
{ SCM_OPTION_INTEGER, "indent", 10, "Maximal indentation in backtrace." },
|
||
{ SCM_OPTION_INTEGER, "frames", 3,
|
||
"Maximum number of tail-recursive frames in backtrace." },
|
||
{ SCM_OPTION_INTEGER, "maxdepth", 1000,
|
||
"Maximal number of stored backtrace frames." },
|
||
{ SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
|
||
{ SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
|
||
{ SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
|
||
{ SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
|
||
{ SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."}
|
||
};
|
||
|
||
scm_t_option scm_evaluator_trap_table[] = {
|
||
{ SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." },
|
||
{ SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." },
|
||
{ SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." },
|
||
{ SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." },
|
||
{ SCM_OPTION_SCM, "enter-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for enter-frame traps." },
|
||
{ SCM_OPTION_SCM, "apply-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for apply-frame traps." },
|
||
{ SCM_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for exit-frame traps." }
|
||
};
|
||
|
||
SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
|
||
(SCM setting),
|
||
"Option interface for the evaluation options. Instead of using\n"
|
||
"this procedure directly, use the procedures @code{eval-enable},\n"
|
||
"@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
|
||
#define FUNC_NAME s_scm_eval_options_interface
|
||
{
|
||
SCM ans;
|
||
SCM_DEFER_INTS;
|
||
ans = scm_options (setting,
|
||
scm_eval_opts,
|
||
SCM_N_EVAL_OPTIONS,
|
||
FUNC_NAME);
|
||
scm_eval_stack = SCM_EVAL_STACK * sizeof (void *);
|
||
SCM_ALLOW_INTS;
|
||
return ans;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
|
||
(SCM setting),
|
||
"Option interface for the evaluator trap options.")
|
||
#define FUNC_NAME s_scm_evaluator_traps
|
||
{
|
||
SCM ans;
|
||
SCM_DEFER_INTS;
|
||
ans = scm_options (setting,
|
||
scm_evaluator_trap_table,
|
||
SCM_N_EVALUATOR_TRAPS,
|
||
FUNC_NAME);
|
||
SCM_RESET_DEBUG_MODE;
|
||
SCM_ALLOW_INTS;
|
||
return ans;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
static SCM
|
||
deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
|
||
{
|
||
SCM *results = lloc, res;
|
||
while (SCM_CONSP (l))
|
||
{
|
||
res = EVALCAR (l, env);
|
||
|
||
*lloc = scm_list_1 (res);
|
||
lloc = SCM_CDRLOC (*lloc);
|
||
l = SCM_CDR (l);
|
||
}
|
||
if (!SCM_NULLP (l))
|
||
scm_wrong_num_args (proc);
|
||
return *results;
|
||
}
|
||
|
||
#endif /* !DEVAL */
|
||
|
||
|
||
/* SECTION: This code is compiled twice.
|
||
*/
|
||
|
||
|
||
/* Update the toplevel environment frame ENV so that it refers to the
|
||
* current module. */
|
||
#define UPDATE_TOPLEVEL_ENV(env) \
|
||
do { \
|
||
SCM p = scm_current_module_lookup_closure (); \
|
||
if (p != SCM_CAR (env)) \
|
||
env = scm_top_level_env (p); \
|
||
} while (0)
|
||
|
||
|
||
/* This is the evaluator. Like any real monster, it has three heads:
|
||
*
|
||
* scm_ceval is the non-debugging evaluator, scm_deval is the debugging
|
||
* version. Both are implemented using a common code base, using the
|
||
* following mechanism: SCM_CEVAL is a macro, which is either defined to
|
||
* scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
|
||
* for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
|
||
* SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
|
||
* defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
|
||
* known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
|
||
* are enclosed within #ifdef DEVAL ... #endif.
|
||
*
|
||
* All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
|
||
* take two input parameters, x and env: x is a single expression to be
|
||
* evalutated. env is the environment in which bindings are searched.
|
||
*
|
||
* x is known to be a cell (i. e. a pair or any other non-immediate). Since x
|
||
* is a single expression, it is necessarily in a tail position. If x is just
|
||
* a call to another function like in the expression (foo exp1 exp2 ...), the
|
||
* realization of that call therefore _must_not_ increase stack usage (the
|
||
* evaluation of exp1, exp2 etc., however, may do so). This is realized by
|
||
* making extensive use of 'goto' statements within the evaluator: The gotos
|
||
* replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
|
||
* that SCM_CEVAL was already using. If, however, x represents some form that
|
||
* requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
|
||
* then recursive calls to SCM_CEVAL are performed for all but the last
|
||
* expression of that sequence. */
|
||
|
||
#if 0
|
||
SCM
|
||
scm_ceval (SCM x, SCM env)
|
||
{}
|
||
#endif
|
||
|
||
#if 0
|
||
SCM
|
||
scm_deval (SCM x, SCM env)
|
||
{}
|
||
#endif
|
||
|
||
SCM
|
||
SCM_CEVAL (SCM x, SCM env)
|
||
{
|
||
SCM proc, arg1;
|
||
#ifdef DEVAL
|
||
scm_t_debug_frame debug;
|
||
scm_t_debug_info *debug_info_end;
|
||
debug.prev = scm_last_debug_frame;
|
||
debug.status = 0;
|
||
/*
|
||
* The debug.vect contains twice as much scm_t_debug_info frames as the
|
||
* user has specified with (debug-set! frames <n>).
|
||
*
|
||
* Even frames are eval frames, odd frames are apply frames.
|
||
*/
|
||
debug.vect = (scm_t_debug_info *) alloca (scm_debug_eframe_size
|
||
* sizeof (scm_t_debug_info));
|
||
debug.info = debug.vect;
|
||
debug_info_end = debug.vect + scm_debug_eframe_size;
|
||
scm_last_debug_frame = &debug;
|
||
#endif
|
||
#ifdef EVAL_STACK_CHECKING
|
||
if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc))
|
||
{
|
||
#ifdef DEVAL
|
||
debug.info->e.exp = x;
|
||
debug.info->e.env = env;
|
||
#endif
|
||
scm_report_stack_overflow ();
|
||
}
|
||
#endif
|
||
|
||
#ifdef DEVAL
|
||
goto start;
|
||
#endif
|
||
|
||
loop:
|
||
#ifdef DEVAL
|
||
SCM_CLEAR_ARGSREADY (debug);
|
||
if (SCM_OVERFLOWP (debug))
|
||
--debug.info;
|
||
/*
|
||
* In theory, this should be the only place where it is necessary to
|
||
* check for space in debug.vect since both eval frames and
|
||
* available space are even.
|
||
*
|
||
* For this to be the case, however, it is necessary that primitive
|
||
* special forms which jump back to `loop', `begin' or some similar
|
||
* label call PREP_APPLY.
|
||
*/
|
||
else if (++debug.info >= debug_info_end)
|
||
{
|
||
SCM_SET_OVERFLOW (debug);
|
||
debug.info -= 2;
|
||
}
|
||
|
||
start:
|
||
debug.info->e.exp = x;
|
||
debug.info->e.env = env;
|
||
if (scm_check_entry_p && SCM_TRAPS_P)
|
||
{
|
||
if (SCM_ENTER_FRAME_P
|
||
|| (SCM_BREAKPOINTS_P && scm_c_source_property_breakpoint_p (x)))
|
||
{
|
||
SCM stackrep;
|
||
SCM tail = SCM_BOOL (SCM_TAILRECP (debug));
|
||
SCM_SET_TAILREC (debug);
|
||
if (SCM_CHEAPTRAPS_P)
|
||
stackrep = scm_make_debugobj (&debug);
|
||
else
|
||
{
|
||
int first;
|
||
SCM val = scm_make_continuation (&first);
|
||
|
||
if (first)
|
||
stackrep = val;
|
||
else
|
||
{
|
||
x = val;
|
||
if (SCM_IMP (x))
|
||
RETURN (x);
|
||
else
|
||
/* This gives the possibility for the debugger to
|
||
modify the source expression before evaluation. */
|
||
goto dispatch;
|
||
}
|
||
}
|
||
SCM_TRAPS_P = 0;
|
||
scm_call_4 (SCM_ENTER_FRAME_HDLR,
|
||
scm_sym_enter_frame,
|
||
stackrep,
|
||
tail,
|
||
scm_unmemocopy (x, env));
|
||
SCM_TRAPS_P = 1;
|
||
}
|
||
}
|
||
#endif
|
||
dispatch:
|
||
SCM_TICK;
|
||
switch (SCM_TYP7 (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_BIT7 (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_BIT7 (SCM_IM_BEGIN):
|
||
x = SCM_CDR (x);
|
||
if (SCM_NULLP (x))
|
||
RETURN (SCM_UNSPECIFIED);
|
||
|
||
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
|
||
|
||
begin:
|
||
/* If we are on toplevel with a lookup closure, we need to sync
|
||
with the current module. */
|
||
if (SCM_CONSP (env) && !SCM_CONSP (SCM_CAR (env)))
|
||
{
|
||
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))
|
||
{
|
||
scm_rec_mutex_lock (&source_mutex);
|
||
/* check for race condition */
|
||
if (SCM_ISYMP (SCM_CAR (x)))
|
||
x = scm_m_expand_body (x, env);
|
||
scm_rec_mutex_unlock (&source_mutex);
|
||
goto nontoplevel_begin;
|
||
}
|
||
else
|
||
SCM_VALIDATE_NON_EMPTY_COMBINATION (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_BIT7 (SCM_IM_CASE):
|
||
x = SCM_CDR (x);
|
||
{
|
||
SCM key = EVALCAR (x, env);
|
||
x = SCM_CDR (x);
|
||
while (!SCM_NULLP (x))
|
||
{
|
||
SCM clause = SCM_CAR (x);
|
||
SCM labels = SCM_CAR (clause);
|
||
if (SCM_EQ_P (labels, SCM_IM_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_BIT7 (SCM_IM_COND):
|
||
x = SCM_CDR (x);
|
||
while (!SCM_NULLP (x))
|
||
{
|
||
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 SCM_BIT7 (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. 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 = 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 SCM_BIT7 (SCM_IM_IF):
|
||
x = SCM_CDR (x);
|
||
{
|
||
SCM test_result = EVALCAR (x, env);
|
||
if (!SCM_FALSEP (test_result) && !SCM_NILP (test_result))
|
||
x = SCM_CDR (x);
|
||
else
|
||
{
|
||
x = SCM_CDDR (x);
|
||
if (SCM_NULLP (x))
|
||
RETURN (SCM_UNSPECIFIED);
|
||
}
|
||
}
|
||
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
|
||
goto carloop;
|
||
|
||
|
||
case SCM_BIT7 (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 SCM_BIT7 (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 SCM_BIT7 (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 SCM_BIT7 (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_BIT7 (SCM_IM_LAMBDA):
|
||
RETURN (scm_closure (SCM_CDR (x), env));
|
||
|
||
|
||
case SCM_BIT7 (SCM_IM_QUOTE):
|
||
RETURN (SCM_CADR (x));
|
||
|
||
|
||
case SCM_BIT7 (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);
|
||
|
||
|
||
/* new syntactic forms go here. */
|
||
case SCM_BIT7 (SCM_MAKISYM (0)):
|
||
proc = SCM_CAR (x);
|
||
switch (SCM_ISYMNUM (proc))
|
||
{
|
||
|
||
|
||
case (SCM_ISYMNUM (SCM_IM_DEFINE)):
|
||
/* Top level defines are handled directly by the memoizer and thus
|
||
* will never generate memoized code with SCM_IM_DEFINE. Internal
|
||
* defines which occur at valid positions will be transformed into
|
||
* letrec expressions. Thus, whenever the executor detects
|
||
* SCM_IM_DEFINE, this must come from an internal definition at an
|
||
* illegal position. */
|
||
scm_misc_error (NULL, "Bad define placement", SCM_EOL);
|
||
|
||
|
||
case (SCM_ISYMNUM (SCM_IM_APPLY)):
|
||
x = SCM_CDR (x);
|
||
proc = EVALCAR (x, env);
|
||
PREP_APPLY (proc, SCM_EOL);
|
||
x = SCM_CDR (x);
|
||
arg1 = EVALCAR (x, env);
|
||
|
||
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))
|
||
{
|
||
SCM formals = SCM_CLOSURE_FORMALS (proc);
|
||
#ifdef DEVAL
|
||
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 = 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
|
||
{
|
||
ENTER_APPLY;
|
||
RETURN (SCM_APPLY (proc, arg1, SCM_EOL));
|
||
}
|
||
|
||
|
||
case (SCM_ISYMNUM (SCM_IM_CONT)):
|
||
{
|
||
int first;
|
||
SCM val = scm_make_continuation (&first);
|
||
|
||
if (!first)
|
||
RETURN (val);
|
||
else
|
||
{
|
||
arg1 = val;
|
||
proc = SCM_CDR (x);
|
||
proc = scm_eval_car (proc, env);
|
||
PREP_APPLY (proc, scm_list_1 (arg1));
|
||
ENTER_APPLY;
|
||
goto evap1;
|
||
}
|
||
}
|
||
|
||
|
||
case (SCM_ISYMNUM (SCM_IM_DELAY)):
|
||
RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));
|
||
|
||
|
||
case (SCM_ISYMNUM (SCM_IM_FUTURE)):
|
||
RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env)));
|
||
|
||
|
||
/* PLACEHOLDER for case (SCM_ISYMNUM (SCM_IM_DISPATCH)): The
|
||
following code (type_dispatch) is intended to be the tail
|
||
of the case clause for the internal macro
|
||
SCM_IM_DISPATCH. Please don't remove it from this
|
||
location without discussing it with Mikael
|
||
<djurfeldt@nada.kth.se> */
|
||
|
||
/* The type dispatch code is duplicated below
|
||
* (c.f. objects.c:scm_mcache_compute_cmethod) since that
|
||
* cuts down execution time for type dispatch to 50%. */
|
||
type_dispatch: /* inputs: x, arg1 */
|
||
/* Type dispatch means to determine from the types of the function
|
||
* arguments (i. e. the 'signature' of the call), which method from
|
||
* a generic function is to be called. This process of selecting
|
||
* the right method takes some time. To speed it up, guile uses
|
||
* caching: Together with the macro call to dispatch the signatures
|
||
* of some previous calls to that generic function from the same
|
||
* place are stored (in the code!) in a cache that we call the
|
||
* 'method cache'. This is done since it is likely, that
|
||
* consecutive calls to dispatch from that position in the code will
|
||
* have the same signature. Thus, the type dispatch works as
|
||
* follows: First, determine a hash value from the signature of the
|
||
* actual arguments. Second, use this hash value as an index to
|
||
* find that same signature in the method cache stored at this
|
||
* position in the code. If found, you have also found the
|
||
* corresponding method that belongs to that signature. If the
|
||
* signature is not found in the method cache, you have to perform a
|
||
* full search over all signatures stored with the generic
|
||
* function. */
|
||
{
|
||
unsigned long int specializers;
|
||
unsigned long int hash_value;
|
||
unsigned long int cache_end_pos;
|
||
unsigned long int mask;
|
||
SCM method_cache;
|
||
|
||
{
|
||
SCM z = SCM_CDDR (x);
|
||
SCM tmp = SCM_CADR (z);
|
||
specializers = SCM_INUM (SCM_CAR (z));
|
||
|
||
/* Compute a hash value for searching the method cache. There
|
||
* are two variants for computing the hash value, a (rather)
|
||
* complicated one, and a simple one. For the complicated one
|
||
* explained below, tmp holds a number that is used in the
|
||
* computation. */
|
||
if (SCM_INUMP (tmp))
|
||
{
|
||
/* Use the signature of the actual arguments to determine
|
||
* the hash value. This is done as follows: Each class has
|
||
* an array of random numbers, that are determined when the
|
||
* class is created. The integer 'hashset' is an index into
|
||
* that array of random numbers. Now, from all classes that
|
||
* are part of the signature of the actual arguments, the
|
||
* random numbers at index 'hashset' are taken and summed
|
||
* up, giving the hash value. The value of 'hashset' is
|
||
* stored at the call to dispatch. This allows to have
|
||
* different 'formulas' for calculating the hash value at
|
||
* different places where dispatch is called. This allows
|
||
* to optimize the hash formula at every individual place
|
||
* where dispatch is called, such that hopefully the hash
|
||
* value that is computed will directly point to the right
|
||
* method in the method cache. */
|
||
unsigned long int hashset = SCM_INUM (tmp);
|
||
unsigned long int counter = specializers + 1;
|
||
SCM tmp_arg = arg1;
|
||
hash_value = 0;
|
||
while (!SCM_NULLP (tmp_arg) && counter != 0)
|
||
{
|
||
SCM class = scm_class_of (SCM_CAR (tmp_arg));
|
||
hash_value += SCM_INSTANCE_HASH (class, hashset);
|
||
tmp_arg = SCM_CDR (tmp_arg);
|
||
counter--;
|
||
}
|
||
z = SCM_CDDR (z);
|
||
method_cache = SCM_CADR (z);
|
||
mask = SCM_INUM (SCM_CAR (z));
|
||
hash_value &= mask;
|
||
cache_end_pos = hash_value;
|
||
}
|
||
else
|
||
{
|
||
/* This method of determining the hash value is much
|
||
* simpler: Set the hash value to zero and just perform a
|
||
* linear search through the method cache. */
|
||
method_cache = tmp;
|
||
mask = (unsigned long int) ((long) -1);
|
||
hash_value = 0;
|
||
cache_end_pos = SCM_VECTOR_LENGTH (method_cache);
|
||
}
|
||
}
|
||
|
||
{
|
||
/* Search the method cache for a method with a matching
|
||
* signature. Start the search at position 'hash_value'. The
|
||
* hashing implementation uses linear probing for conflict
|
||
* resolution, that is, if the signature in question is not
|
||
* found at the starting index in the hash table, the next table
|
||
* entry is tried, and so on, until in the worst case the whole
|
||
* cache has been searched, but still the signature has not been
|
||
* found. */
|
||
SCM z;
|
||
do
|
||
{
|
||
SCM args = arg1; /* list of arguments */
|
||
z = SCM_VELTS (method_cache)[hash_value];
|
||
while (!SCM_NULLP (args))
|
||
{
|
||
/* More arguments than specifiers => CLASS != ENV */
|
||
SCM class_of_arg = scm_class_of (SCM_CAR (args));
|
||
if (!SCM_EQ_P (class_of_arg, SCM_CAR (z)))
|
||
goto next_method;
|
||
args = SCM_CDR (args);
|
||
z = SCM_CDR (z);
|
||
}
|
||
/* Fewer arguments than specifiers => CAR != ENV */
|
||
if (SCM_NULLP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z)))
|
||
goto apply_cmethod;
|
||
next_method:
|
||
hash_value = (hash_value + 1) & mask;
|
||
} while (hash_value != cache_end_pos);
|
||
|
||
/* No appropriate method was found in the cache. */
|
||
z = scm_memoize_method (x, arg1);
|
||
|
||
apply_cmethod: /* inputs: z, arg1 */
|
||
{
|
||
SCM formals = SCM_CMETHOD_FORMALS (z);
|
||
env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
|
||
x = SCM_CMETHOD_BODY (z);
|
||
goto nontoplevel_begin;
|
||
}
|
||
}
|
||
}
|
||
|
||
|
||
case (SCM_ISYMNUM (SCM_IM_SLOT_REF)):
|
||
x = SCM_CDR (x);
|
||
{
|
||
SCM instance = EVALCAR (x, env);
|
||
unsigned long int slot = SCM_INUM (SCM_CADR (x));
|
||
RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
|
||
}
|
||
|
||
|
||
case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X)):
|
||
x = SCM_CDR (x);
|
||
{
|
||
SCM instance = EVALCAR (x, env);
|
||
unsigned long int slot = SCM_INUM (SCM_CADR (x));
|
||
SCM value = EVALCAR (SCM_CDDR (x), env);
|
||
SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (value);
|
||
RETURN (SCM_UNSPECIFIED);
|
||
}
|
||
|
||
|
||
#if SCM_ENABLE_ELISP
|
||
|
||
case (SCM_ISYMNUM (SCM_IM_NIL_COND)):
|
||
{
|
||
SCM test_form = SCM_CDR (x);
|
||
x = SCM_CDR (test_form);
|
||
while (!SCM_NULL_OR_NIL_P (x))
|
||
{
|
||
SCM test_result = EVALCAR (test_form, env);
|
||
if (!(SCM_FALSEP (test_result)
|
||
|| SCM_NULL_OR_NIL_P (test_result)))
|
||
{
|
||
if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED))
|
||
RETURN (test_result);
|
||
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
|
||
goto carloop;
|
||
}
|
||
else
|
||
{
|
||
test_form = SCM_CDR (x);
|
||
x = SCM_CDR (test_form);
|
||
}
|
||
}
|
||
x = test_form;
|
||
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
|
||
goto carloop;
|
||
}
|
||
|
||
#endif /* SCM_ENABLE_ELISP */
|
||
|
||
case (SCM_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))
|
||
{
|
||
vals = scm_cons (EVALCAR (exps, env), vals);
|
||
exps = SCM_CDR (exps);
|
||
}
|
||
|
||
scm_swap_bindings (vars, vals);
|
||
scm_dynwinds = scm_acons (vars, vals, scm_dynwinds);
|
||
|
||
/* Ignore all but the last evaluation result. */
|
||
for (x = SCM_CDR (x); !SCM_NULLP (SCM_CDR (x)); x = SCM_CDR (x))
|
||
{
|
||
if (SCM_CONSP (SCM_CAR (x)))
|
||
SCM_CEVAL (SCM_CAR (x), env);
|
||
}
|
||
proc = EVALCAR (x, env);
|
||
|
||
scm_dynwinds = SCM_CDR (scm_dynwinds);
|
||
scm_swap_bindings (vars, vals);
|
||
|
||
RETURN (proc);
|
||
}
|
||
|
||
|
||
case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
|
||
{
|
||
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);
|
||
else
|
||
arg1 = scm_list_1 (arg1);
|
||
PREP_APPLY (proc, arg1);
|
||
goto apply_proc;
|
||
}
|
||
|
||
|
||
default:
|
||
goto evapply;
|
||
}
|
||
|
||
default:
|
||
proc = x;
|
||
goto evapply;
|
||
case scm_tc7_vector:
|
||
case scm_tc7_wvect:
|
||
#if SCM_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:
|
||
#if SCM_SIZEOF_LONG_LONG != 0
|
||
case scm_tc7_llvect:
|
||
#endif
|
||
#endif
|
||
case scm_tc7_number:
|
||
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_BIT7 (SCM_ILOC00):
|
||
proc = *scm_ilookup (SCM_CAR (x), env);
|
||
goto checkmacro;
|
||
|
||
case scm_tcs_cons_nimcar:
|
||
if (SCM_SYMBOLP (SCM_CAR (x)))
|
||
{
|
||
SCM orig_sym = SCM_CAR (x);
|
||
{
|
||
SCM *location = scm_lookupcar1 (x, env, 1);
|
||
if (location == NULL)
|
||
{
|
||
/* we have lost the race, start again. */
|
||
goto dispatch;
|
||
}
|
||
proc = *location;
|
||
}
|
||
|
||
if (SCM_MACROP (proc))
|
||
{
|
||
SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of
|
||
lookupcar */
|
||
handle_a_macro: /* inputs: x, env, proc */
|
||
#ifdef DEVAL
|
||
/* Set a flag during macro expansion so that macro
|
||
application frames can be deleted from the backtrace. */
|
||
SCM_SET_MACROEXP (debug);
|
||
#endif
|
||
arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,
|
||
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);
|
||
#ifdef DEVAL
|
||
if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
|
||
{
|
||
SCM_DEFER_INTS;
|
||
SCM_SETCAR (x, SCM_CAR (arg1));
|
||
SCM_SETCDR (x, SCM_CDR (arg1));
|
||
SCM_ALLOW_INTS;
|
||
goto dispatch;
|
||
}
|
||
/* Prevent memoizing of debug info expression. */
|
||
debug.info->e.exp = scm_cons_source (debug.info->e.exp,
|
||
SCM_CAR (x),
|
||
SCM_CDR (x));
|
||
#endif
|
||
SCM_DEFER_INTS;
|
||
SCM_SETCAR (x, SCM_CAR (arg1));
|
||
SCM_SETCDR (x, SCM_CDR (arg1));
|
||
SCM_ALLOW_INTS;
|
||
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
|
||
goto loop;
|
||
#if SCM_ENABLE_DEPRECATED == 1
|
||
case 1:
|
||
x = arg1;
|
||
if (SCM_NIMP (x))
|
||
{
|
||
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
|
||
goto loop;
|
||
}
|
||
else
|
||
RETURN (arg1);
|
||
#endif
|
||
case 0:
|
||
RETURN (arg1);
|
||
}
|
||
}
|
||
}
|
||
else
|
||
proc = SCM_CEVAL (SCM_CAR (x), env);
|
||
|
||
checkmacro:
|
||
if (SCM_MACROP (proc))
|
||
goto handle_a_macro;
|
||
}
|
||
|
||
|
||
evapply: /* inputs: x, proc */
|
||
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:
|
||
RETURN (SCM_SUBRF (proc) ());
|
||
case scm_tc7_subr_1o:
|
||
RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED));
|
||
case scm_tc7_lsubr:
|
||
RETURN (SCM_SUBRF (proc) (SCM_EOL));
|
||
case scm_tc7_rpsubr:
|
||
RETURN (SCM_BOOL_T);
|
||
case scm_tc7_asubr:
|
||
RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
|
||
case scm_tc7_smob:
|
||
if (!SCM_SMOB_APPLICABLE_P (proc))
|
||
goto badfun;
|
||
RETURN (SCM_SMOB_APPLY_0 (proc));
|
||
case scm_tc7_cclo:
|
||
arg1 = proc;
|
||
proc = SCM_CCLO_SUBR (proc);
|
||
#ifdef DEVAL
|
||
debug.info->a.proc = proc;
|
||
debug.info->a.args = scm_list_1 (arg1);
|
||
#endif
|
||
goto evap1;
|
||
case scm_tc7_pws:
|
||
proc = SCM_PROCEDURE (proc);
|
||
#ifdef DEVAL
|
||
debug.info->a.proc = proc;
|
||
#endif
|
||
if (!SCM_CLOSUREP (proc))
|
||
goto evap0;
|
||
/* fallthrough */
|
||
case scm_tcs_closures:
|
||
{
|
||
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)
|
||
{
|
||
x = SCM_ENTITY_PROCEDURE (proc);
|
||
arg1 = SCM_EOL;
|
||
goto type_dispatch;
|
||
}
|
||
else if (SCM_I_OPERATORP (proc))
|
||
{
|
||
arg1 = proc;
|
||
proc = (SCM_I_ENTITYP (proc)
|
||
? SCM_ENTITY_PROCEDURE (proc)
|
||
: SCM_OPERATOR_PROCEDURE (proc));
|
||
#ifdef DEVAL
|
||
debug.info->a.proc = proc;
|
||
debug.info->a.args = scm_list_1 (arg1);
|
||
#endif
|
||
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:
|
||
umwrongnumargs:
|
||
unmemocar (x, env);
|
||
scm_wrong_num_args (proc);
|
||
default:
|
||
badfun:
|
||
scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc));
|
||
}
|
||
}
|
||
|
||
/* must handle macros by here */
|
||
x = SCM_CDR (x);
|
||
if (SCM_CONSP (x))
|
||
arg1 = EVALCAR (x, env);
|
||
else
|
||
scm_wrong_num_args (proc);
|
||
#ifdef DEVAL
|
||
debug.info->a.args = scm_list_1 (arg1);
|
||
#endif
|
||
x = SCM_CDR (x);
|
||
{
|
||
SCM arg2;
|
||
if (SCM_NULLP (x))
|
||
{
|
||
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:
|
||
RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
|
||
case scm_tc7_subr_1:
|
||
case scm_tc7_subr_1o:
|
||
RETURN (SCM_SUBRF (proc) (arg1));
|
||
case scm_tc7_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))));
|
||
}
|
||
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
|
||
SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
|
||
case scm_tc7_cxr:
|
||
{
|
||
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:
|
||
RETURN (SCM_BOOL_T);
|
||
case scm_tc7_asubr:
|
||
RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
|
||
case scm_tc7_lsubr:
|
||
#ifdef DEVAL
|
||
RETURN (SCM_SUBRF (proc) (debug.info->a.args));
|
||
#else
|
||
RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1)));
|
||
#endif
|
||
case scm_tc7_smob:
|
||
if (!SCM_SMOB_APPLICABLE_P (proc))
|
||
goto badfun;
|
||
RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
|
||
case scm_tc7_cclo:
|
||
arg2 = arg1;
|
||
arg1 = proc;
|
||
proc = SCM_CCLO_SUBR (proc);
|
||
#ifdef DEVAL
|
||
debug.info->a.args = scm_cons (arg1, debug.info->a.args);
|
||
debug.info->a.proc = proc;
|
||
#endif
|
||
goto evap2;
|
||
case scm_tc7_pws:
|
||
proc = SCM_PROCEDURE (proc);
|
||
#ifdef DEVAL
|
||
debug.info->a.proc = proc;
|
||
#endif
|
||
if (!SCM_CLOSUREP (proc))
|
||
goto evap1;
|
||
/* fallthrough */
|
||
case scm_tcs_closures:
|
||
{
|
||
/* 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 = SCM_EXTEND_ENV (formals,
|
||
debug.info->a.args,
|
||
SCM_ENV (proc));
|
||
#else
|
||
env = SCM_EXTEND_ENV (formals,
|
||
scm_list_1 (arg1),
|
||
SCM_ENV (proc));
|
||
#endif
|
||
goto nontoplevel_begin;
|
||
}
|
||
case scm_tcs_struct:
|
||
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
|
||
{
|
||
x = SCM_ENTITY_PROCEDURE (proc);
|
||
#ifdef DEVAL
|
||
arg1 = debug.info->a.args;
|
||
#else
|
||
arg1 = scm_list_1 (arg1);
|
||
#endif
|
||
goto type_dispatch;
|
||
}
|
||
else if (SCM_I_OPERATORP (proc))
|
||
{
|
||
arg2 = arg1;
|
||
arg1 = proc;
|
||
proc = (SCM_I_ENTITYP (proc)
|
||
? SCM_ENTITY_PROCEDURE (proc)
|
||
: SCM_OPERATOR_PROCEDURE (proc));
|
||
#ifdef DEVAL
|
||
debug.info->a.args = scm_cons (arg1, debug.info->a.args);
|
||
debug.info->a.proc = proc;
|
||
#endif
|
||
goto evap2;
|
||
}
|
||
else
|
||
goto badfun;
|
||
case scm_tc7_subr_2:
|
||
case scm_tc7_subr_0:
|
||
case scm_tc7_subr_3:
|
||
case scm_tc7_lsubr_2:
|
||
scm_wrong_num_args (proc);
|
||
default:
|
||
goto badfun;
|
||
}
|
||
}
|
||
if (SCM_CONSP (x))
|
||
arg2 = EVALCAR (x, env);
|
||
else
|
||
scm_wrong_num_args (proc);
|
||
|
||
{ /* have two or more arguments */
|
||
#ifdef DEVAL
|
||
debug.info->a.args = scm_list_2 (arg1, arg2);
|
||
#endif
|
||
x = SCM_CDR (x);
|
||
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:
|
||
case scm_tc7_subr_2o:
|
||
RETURN (SCM_SUBRF (proc) (arg1, arg2));
|
||
case scm_tc7_lsubr:
|
||
#ifdef DEVAL
|
||
RETURN (SCM_SUBRF (proc) (debug.info->a.args));
|
||
#else
|
||
RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)));
|
||
#endif
|
||
case scm_tc7_lsubr_2:
|
||
RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL));
|
||
case scm_tc7_rpsubr:
|
||
case scm_tc7_asubr:
|
||
RETURN (SCM_SUBRF (proc) (arg1, arg2));
|
||
case scm_tc7_smob:
|
||
if (!SCM_SMOB_APPLICABLE_P (proc))
|
||
goto badfun;
|
||
RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
|
||
cclon:
|
||
case scm_tc7_cclo:
|
||
#ifdef DEVAL
|
||
RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
|
||
scm_cons (proc, debug.info->a.args),
|
||
SCM_EOL));
|
||
#else
|
||
RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
|
||
scm_cons2 (proc, arg1,
|
||
scm_cons (arg2,
|
||
scm_eval_args (x,
|
||
env,
|
||
proc))),
|
||
SCM_EOL));
|
||
#endif
|
||
case scm_tcs_struct:
|
||
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
|
||
{
|
||
x = SCM_ENTITY_PROCEDURE (proc);
|
||
#ifdef DEVAL
|
||
arg1 = debug.info->a.args;
|
||
#else
|
||
arg1 = scm_list_2 (arg1, arg2);
|
||
#endif
|
||
goto type_dispatch;
|
||
}
|
||
else if (SCM_I_OPERATORP (proc))
|
||
{
|
||
operatorn:
|
||
#ifdef DEVAL
|
||
RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
|
||
? SCM_ENTITY_PROCEDURE (proc)
|
||
: SCM_OPERATOR_PROCEDURE (proc),
|
||
scm_cons (proc, debug.info->a.args),
|
||
SCM_EOL));
|
||
#else
|
||
RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
|
||
? SCM_ENTITY_PROCEDURE (proc)
|
||
: SCM_OPERATOR_PROCEDURE (proc),
|
||
scm_cons2 (proc, arg1,
|
||
scm_cons (arg2,
|
||
scm_eval_args (x,
|
||
env,
|
||
proc))),
|
||
SCM_EOL));
|
||
#endif
|
||
}
|
||
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:
|
||
case scm_tc7_subr_3:
|
||
scm_wrong_num_args (proc);
|
||
default:
|
||
goto badfun;
|
||
case scm_tc7_pws:
|
||
proc = SCM_PROCEDURE (proc);
|
||
#ifdef DEVAL
|
||
debug.info->a.proc = proc;
|
||
#endif
|
||
if (!SCM_CLOSUREP (proc))
|
||
goto evap2;
|
||
/* fallthrough */
|
||
case scm_tcs_closures:
|
||
{
|
||
/* 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 = SCM_EXTEND_ENV (formals,
|
||
debug.info->a.args,
|
||
SCM_ENV (proc));
|
||
#else
|
||
env = SCM_EXTEND_ENV (formals,
|
||
scm_list_2 (arg1, arg2),
|
||
SCM_ENV (proc));
|
||
#endif
|
||
x = SCM_CLOSURE_BODY (proc);
|
||
goto nontoplevel_begin;
|
||
}
|
||
}
|
||
}
|
||
if (!SCM_CONSP (x))
|
||
scm_wrong_num_args (proc);
|
||
#ifdef DEVAL
|
||
debug.info->a.args = scm_cons2 (arg1, arg2,
|
||
deval_args (x, env, proc,
|
||
SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
|
||
#endif
|
||
ENTER_APPLY;
|
||
evap3:
|
||
SCM_ASRTGO (!SCM_IMP (proc), badfun);
|
||
switch (SCM_TYP7 (proc))
|
||
{ /* have 3 or more arguments */
|
||
#ifdef DEVAL
|
||
case scm_tc7_subr_3:
|
||
if (!SCM_NULLP (SCM_CDR (x)))
|
||
scm_wrong_num_args (proc);
|
||
else
|
||
RETURN (SCM_SUBRF (proc) (arg1, arg2,
|
||
SCM_CADDR (debug.info->a.args)));
|
||
case scm_tc7_asubr:
|
||
arg1 = SCM_SUBRF(proc)(arg1, arg2);
|
||
arg2 = SCM_CDDR (debug.info->a.args);
|
||
do
|
||
{
|
||
arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2));
|
||
arg2 = SCM_CDR (arg2);
|
||
}
|
||
while (SCM_NIMP (arg2));
|
||
RETURN (arg1);
|
||
case scm_tc7_rpsubr:
|
||
if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2)))
|
||
RETURN (SCM_BOOL_F);
|
||
arg1 = SCM_CDDR (debug.info->a.args);
|
||
do
|
||
{
|
||
if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1))))
|
||
RETURN (SCM_BOOL_F);
|
||
arg2 = SCM_CAR (arg1);
|
||
arg1 = SCM_CDR (arg1);
|
||
}
|
||
while (SCM_NIMP (arg1));
|
||
RETURN (SCM_BOOL_T);
|
||
case scm_tc7_lsubr_2:
|
||
RETURN (SCM_SUBRF (proc) (arg1, arg2,
|
||
SCM_CDDR (debug.info->a.args)));
|
||
case scm_tc7_lsubr:
|
||
RETURN (SCM_SUBRF (proc) (debug.info->a.args));
|
||
case scm_tc7_smob:
|
||
if (!SCM_SMOB_APPLICABLE_P (proc))
|
||
goto badfun;
|
||
RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
|
||
SCM_CDDR (debug.info->a.args)));
|
||
case scm_tc7_cclo:
|
||
goto cclon;
|
||
case scm_tc7_pws:
|
||
proc = SCM_PROCEDURE (proc);
|
||
debug.info->a.proc = proc;
|
||
if (!SCM_CLOSUREP (proc))
|
||
goto evap3;
|
||
/* fallthrough */
|
||
case scm_tcs_closures:
|
||
{
|
||
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)))
|
||
scm_wrong_num_args (proc);
|
||
else
|
||
RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env)));
|
||
case scm_tc7_asubr:
|
||
arg1 = SCM_SUBRF (proc) (arg1, arg2);
|
||
do
|
||
{
|
||
arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env));
|
||
x = SCM_CDR(x);
|
||
}
|
||
while (SCM_NIMP (x));
|
||
RETURN (arg1);
|
||
case scm_tc7_rpsubr:
|
||
if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2)))
|
||
RETURN (SCM_BOOL_F);
|
||
do
|
||
{
|
||
arg1 = EVALCAR (x, env);
|
||
if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, arg1)))
|
||
RETURN (SCM_BOOL_F);
|
||
arg2 = arg1;
|
||
x = SCM_CDR (x);
|
||
}
|
||
while (SCM_NIMP (x));
|
||
RETURN (SCM_BOOL_T);
|
||
case scm_tc7_lsubr_2:
|
||
RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc)));
|
||
case scm_tc7_lsubr:
|
||
RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1,
|
||
arg2,
|
||
scm_eval_args (x, env, proc))));
|
||
case scm_tc7_smob:
|
||
if (!SCM_SMOB_APPLICABLE_P (proc))
|
||
goto badfun;
|
||
RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
|
||
scm_eval_args (x, env, proc)));
|
||
case scm_tc7_cclo:
|
||
goto cclon;
|
||
case scm_tc7_pws:
|
||
proc = SCM_PROCEDURE (proc);
|
||
if (!SCM_CLOSUREP (proc))
|
||
goto evap3;
|
||
/* fallthrough */
|
||
case scm_tcs_closures:
|
||
{
|
||
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;
|
||
}
|
||
#endif /* DEVAL */
|
||
case scm_tcs_struct:
|
||
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
|
||
{
|
||
#ifdef DEVAL
|
||
arg1 = debug.info->a.args;
|
||
#else
|
||
arg1 = scm_cons2 (arg1, arg2, scm_eval_args (x, env, proc));
|
||
#endif
|
||
x = SCM_ENTITY_PROCEDURE (proc);
|
||
goto type_dispatch;
|
||
}
|
||
else if (SCM_I_OPERATORP (proc))
|
||
goto 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);
|
||
default:
|
||
goto badfun;
|
||
}
|
||
}
|
||
}
|
||
#ifdef DEVAL
|
||
exit:
|
||
if (scm_check_exit_p && SCM_TRAPS_P)
|
||
if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
|
||
{
|
||
SCM_CLEAR_TRACED_FRAME (debug);
|
||
if (SCM_CHEAPTRAPS_P)
|
||
arg1 = scm_make_debugobj (&debug);
|
||
else
|
||
{
|
||
int first;
|
||
SCM val = scm_make_continuation (&first);
|
||
|
||
if (first)
|
||
arg1 = val;
|
||
else
|
||
{
|
||
proc = val;
|
||
goto ret;
|
||
}
|
||
}
|
||
SCM_TRAPS_P = 0;
|
||
scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
|
||
SCM_TRAPS_P = 1;
|
||
}
|
||
ret:
|
||
scm_last_debug_frame = debug.prev;
|
||
return proc;
|
||
#endif
|
||
}
|
||
|
||
|
||
/* SECTION: This code is compiled once.
|
||
*/
|
||
|
||
#ifndef DEVAL
|
||
|
||
|
||
|
||
/* Simple procedure calls
|
||
*/
|
||
|
||
SCM
|
||
scm_call_0 (SCM proc)
|
||
{
|
||
return scm_apply (proc, SCM_EOL, SCM_EOL);
|
||
}
|
||
|
||
SCM
|
||
scm_call_1 (SCM proc, SCM arg1)
|
||
{
|
||
return scm_apply (proc, arg1, scm_listofnull);
|
||
}
|
||
|
||
SCM
|
||
scm_call_2 (SCM proc, SCM arg1, SCM arg2)
|
||
{
|
||
return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull));
|
||
}
|
||
|
||
SCM
|
||
scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
|
||
{
|
||
return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull));
|
||
}
|
||
|
||
SCM
|
||
scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
|
||
{
|
||
return scm_apply (proc, arg1, scm_cons2 (arg2, arg3,
|
||
scm_cons (arg4, scm_listofnull)));
|
||
}
|
||
|
||
/* Simple procedure applies
|
||
*/
|
||
|
||
SCM
|
||
scm_apply_0 (SCM proc, SCM args)
|
||
{
|
||
return scm_apply (proc, args, SCM_EOL);
|
||
}
|
||
|
||
SCM
|
||
scm_apply_1 (SCM proc, SCM arg1, SCM args)
|
||
{
|
||
return scm_apply (proc, scm_cons (arg1, args), SCM_EOL);
|
||
}
|
||
|
||
SCM
|
||
scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
|
||
{
|
||
return scm_apply (proc, scm_cons2 (arg1, arg2, args), SCM_EOL);
|
||
}
|
||
|
||
SCM
|
||
scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)
|
||
{
|
||
return scm_apply (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)),
|
||
SCM_EOL);
|
||
}
|
||
|
||
/* This code processes the arguments to apply:
|
||
|
||
(apply PROC ARG1 ... ARGS)
|
||
|
||
Given a list (ARG1 ... ARGS), this function conses the ARG1
|
||
... arguments onto the front of ARGS, and returns the resulting
|
||
list. Note that ARGS is a list; thus, the argument to this
|
||
function is a list whose last element is a list.
|
||
|
||
Apply calls this function, and applies PROC to the elements of the
|
||
result. apply:nconc2last takes care of building the list of
|
||
arguments, given (ARG1 ... ARGS).
|
||
|
||
Rather than do new consing, apply:nconc2last destroys its argument.
|
||
On that topic, this code came into my care with the following
|
||
beautifully cryptic comment on that topic: "This will only screw
|
||
you if you do (scm_apply scm_apply '( ... ))" If you know what
|
||
they're referring to, send me a patch to this comment. */
|
||
|
||
SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
|
||
(SCM lst),
|
||
"Given a list (@var{arg1} @dots{} @var{args}), this function\n"
|
||
"conses the @var{arg1} @dots{} arguments onto the front of\n"
|
||
"@var{args}, and returns the resulting list. Note that\n"
|
||
"@var{args} is a list; thus, the argument to this function is\n"
|
||
"a list whose last element is a list.\n"
|
||
"Note: Rather than do new consing, @code{apply:nconc2last}\n"
|
||
"destroys its argument, so use with care.")
|
||
#define FUNC_NAME s_scm_nconc2last
|
||
{
|
||
SCM *lloc;
|
||
SCM_VALIDATE_NONEMPTYLIST (1, lst);
|
||
lloc = &lst;
|
||
while (!SCM_NULLP (SCM_CDR (*lloc))) /* Perhaps should be
|
||
SCM_NULL_OR_NIL_P, but not
|
||
needed in 99.99% of cases,
|
||
and it could seriously hurt
|
||
performance. - Neil */
|
||
lloc = SCM_CDRLOC (*lloc);
|
||
SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
|
||
*lloc = SCM_CAR (*lloc);
|
||
return lst;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
#endif /* !DEVAL */
|
||
|
||
|
||
/* SECTION: When DEVAL is defined this code yields scm_dapply.
|
||
* It is compiled twice.
|
||
*/
|
||
|
||
#if 0
|
||
SCM
|
||
scm_apply (SCM proc, SCM arg1, SCM args)
|
||
{}
|
||
#endif
|
||
|
||
#if 0
|
||
SCM
|
||
scm_dapply (SCM proc, SCM arg1, SCM args)
|
||
{}
|
||
#endif
|
||
|
||
|
||
/* Apply a function to a list of arguments.
|
||
|
||
This function is exported to the Scheme level as taking two
|
||
required arguments and a tail argument, as if it were:
|
||
(lambda (proc arg1 . args) ...)
|
||
Thus, if you just have a list of arguments to pass to a procedure,
|
||
pass the list as ARG1, and '() for ARGS. If you have some fixed
|
||
args, pass the first as ARG1, then cons any remaining fixed args
|
||
onto the front of your argument list, and pass that as ARGS. */
|
||
|
||
SCM
|
||
SCM_APPLY (SCM proc, SCM arg1, SCM args)
|
||
{
|
||
#ifdef DEVAL
|
||
scm_t_debug_frame debug;
|
||
scm_t_debug_info debug_vect_body;
|
||
debug.prev = scm_last_debug_frame;
|
||
debug.status = SCM_APPLYFRAME;
|
||
debug.vect = &debug_vect_body;
|
||
debug.vect[0].a.proc = proc;
|
||
debug.vect[0].a.args = SCM_EOL;
|
||
scm_last_debug_frame = &debug;
|
||
#else
|
||
if (SCM_DEBUGGINGP)
|
||
return scm_dapply (proc, arg1, args);
|
||
#endif
|
||
|
||
SCM_ASRTGO (SCM_NIMP (proc), badproc);
|
||
|
||
/* If ARGS is the empty list, then we're calling apply with only two
|
||
arguments --- ARG1 is the list of arguments for PROC. Whatever
|
||
the case, futz with things so that ARG1 is the first argument to
|
||
give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
|
||
rest.
|
||
|
||
Setting the debug apply frame args this way is pretty messy.
|
||
Perhaps we should store arg1 and args directly in the frame as
|
||
received, and let scm_frame_arguments unpack them, because that's
|
||
a relatively rare operation. This works for now; if the Guile
|
||
developer archives are still around, see Mikael's post of
|
||
11-Apr-97. */
|
||
if (SCM_NULLP (args))
|
||
{
|
||
if (SCM_NULLP (arg1))
|
||
{
|
||
arg1 = SCM_UNDEFINED;
|
||
#ifdef DEVAL
|
||
debug.vect[0].a.args = SCM_EOL;
|
||
#endif
|
||
}
|
||
else
|
||
{
|
||
#ifdef DEVAL
|
||
debug.vect[0].a.args = arg1;
|
||
#endif
|
||
args = SCM_CDR (arg1);
|
||
arg1 = SCM_CAR (arg1);
|
||
}
|
||
}
|
||
else
|
||
{
|
||
args = scm_nconc2last (args);
|
||
#ifdef DEVAL
|
||
debug.vect[0].a.args = scm_cons (arg1, args);
|
||
#endif
|
||
}
|
||
#ifdef DEVAL
|
||
if (SCM_ENTER_FRAME_P && SCM_TRAPS_P)
|
||
{
|
||
SCM tmp;
|
||
if (SCM_CHEAPTRAPS_P)
|
||
tmp = scm_make_debugobj (&debug);
|
||
else
|
||
{
|
||
int first;
|
||
|
||
tmp = scm_make_continuation (&first);
|
||
if (!first)
|
||
goto entap;
|
||
}
|
||
SCM_TRAPS_P = 0;
|
||
scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp);
|
||
SCM_TRAPS_P = 1;
|
||
}
|
||
entap:
|
||
ENTER_APPLY;
|
||
#endif
|
||
tail:
|
||
switch (SCM_TYP7 (proc))
|
||
{
|
||
case scm_tc7_subr_2o:
|
||
args = SCM_NULLP (args) ? SCM_UNDEFINED : SCM_CAR (args);
|
||
RETURN (SCM_SUBRF (proc) (arg1, args));
|
||
case scm_tc7_subr_2:
|
||
if (SCM_NULLP (args) || !SCM_NULLP (SCM_CDR (args)))
|
||
scm_wrong_num_args (proc);
|
||
args = SCM_CAR (args);
|
||
RETURN (SCM_SUBRF (proc) (arg1, args));
|
||
case scm_tc7_subr_0:
|
||
if (!SCM_UNBNDP (arg1))
|
||
scm_wrong_num_args (proc);
|
||
else
|
||
RETURN (SCM_SUBRF (proc) ());
|
||
case scm_tc7_subr_1:
|
||
if (SCM_UNBNDP (arg1))
|
||
scm_wrong_num_args (proc);
|
||
case scm_tc7_subr_1o:
|
||
if (!SCM_NULLP (args))
|
||
scm_wrong_num_args (proc);
|
||
else
|
||
RETURN (SCM_SUBRF (proc) (arg1));
|
||
case scm_tc7_dsubr:
|
||
if (SCM_UNBNDP (arg1) || !SCM_NULLP (args))
|
||
scm_wrong_num_args (proc);
|
||
if (SCM_INUMP (arg1))
|
||
{
|
||
RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
|
||
}
|
||
else if (SCM_REALP (arg1))
|
||
{
|
||
RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
|
||
}
|
||
else if (SCM_BIGP (arg1))
|
||
RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
|
||
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
|
||
SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
|
||
case scm_tc7_cxr:
|
||
if (SCM_UNBNDP (arg1) || !SCM_NULLP (args))
|
||
scm_wrong_num_args (proc);
|
||
{
|
||
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)
|
||
|| SCM_NULLP (SCM_CDR (args))
|
||
|| !SCM_NULLP (SCM_CDDR (args)))
|
||
scm_wrong_num_args (proc);
|
||
else
|
||
RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args)));
|
||
case scm_tc7_lsubr:
|
||
#ifdef DEVAL
|
||
RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args));
|
||
#else
|
||
RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)));
|
||
#endif
|
||
case scm_tc7_lsubr_2:
|
||
if (!SCM_CONSP (args))
|
||
scm_wrong_num_args (proc);
|
||
else
|
||
RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args)));
|
||
case scm_tc7_asubr:
|
||
if (SCM_NULLP (args))
|
||
RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
|
||
while (SCM_NIMP (args))
|
||
{
|
||
SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply");
|
||
arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args));
|
||
args = SCM_CDR (args);
|
||
}
|
||
RETURN (arg1);
|
||
case scm_tc7_rpsubr:
|
||
if (SCM_NULLP (args))
|
||
RETURN (SCM_BOOL_T);
|
||
while (SCM_NIMP (args))
|
||
{
|
||
SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply");
|
||
if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, SCM_CAR (args))))
|
||
RETURN (SCM_BOOL_F);
|
||
arg1 = SCM_CAR (args);
|
||
args = SCM_CDR (args);
|
||
}
|
||
RETURN (SCM_BOOL_T);
|
||
case scm_tcs_closures:
|
||
#ifdef DEVAL
|
||
arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args);
|
||
#else
|
||
arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
|
||
#endif
|
||
if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1))
|
||
scm_wrong_num_args (proc);
|
||
|
||
/* Copy argument list */
|
||
if (SCM_IMP (arg1))
|
||
args = arg1;
|
||
else
|
||
{
|
||
SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED);
|
||
for (arg1 = SCM_CDR (arg1); SCM_CONSP (arg1); arg1 = SCM_CDR (arg1))
|
||
{
|
||
SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED));
|
||
tl = SCM_CDR (tl);
|
||
}
|
||
SCM_SETCDR (tl, arg1);
|
||
}
|
||
|
||
args = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
|
||
args,
|
||
SCM_ENV (proc));
|
||
proc = SCM_CLOSURE_BODY (proc);
|
||
again:
|
||
arg1 = SCM_CDR (proc);
|
||
while (!SCM_NULLP (arg1))
|
||
{
|
||
if (SCM_IMP (SCM_CAR (proc)))
|
||
{
|
||
if (SCM_ISYMP (SCM_CAR (proc)))
|
||
{
|
||
scm_rec_mutex_lock (&source_mutex);
|
||
/* check for race condition */
|
||
if (SCM_ISYMP (SCM_CAR (proc)))
|
||
proc = scm_m_expand_body (proc, args);
|
||
scm_rec_mutex_unlock (&source_mutex);
|
||
goto again;
|
||
}
|
||
else
|
||
SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc));
|
||
}
|
||
else
|
||
SCM_CEVAL (SCM_CAR (proc), args);
|
||
proc = arg1;
|
||
arg1 = SCM_CDR (proc);
|
||
}
|
||
RETURN (EVALCAR (proc, args));
|
||
case scm_tc7_smob:
|
||
if (!SCM_SMOB_APPLICABLE_P (proc))
|
||
goto badproc;
|
||
if (SCM_UNBNDP (arg1))
|
||
RETURN (SCM_SMOB_APPLY_0 (proc));
|
||
else if (SCM_NULLP (args))
|
||
RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
|
||
else if (SCM_NULLP (SCM_CDR (args)))
|
||
RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args)));
|
||
else
|
||
RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args)));
|
||
case scm_tc7_cclo:
|
||
#ifdef DEVAL
|
||
args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
|
||
arg1 = proc;
|
||
proc = SCM_CCLO_SUBR (proc);
|
||
debug.vect[0].a.proc = proc;
|
||
debug.vect[0].a.args = scm_cons (arg1, args);
|
||
#else
|
||
args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
|
||
arg1 = proc;
|
||
proc = SCM_CCLO_SUBR (proc);
|
||
#endif
|
||
goto tail;
|
||
case scm_tc7_pws:
|
||
proc = SCM_PROCEDURE (proc);
|
||
#ifdef DEVAL
|
||
debug.vect[0].a.proc = proc;
|
||
#endif
|
||
goto tail;
|
||
case scm_tcs_struct:
|
||
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
|
||
{
|
||
#ifdef DEVAL
|
||
args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
|
||
#else
|
||
args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
|
||
#endif
|
||
RETURN (scm_apply_generic (proc, args));
|
||
}
|
||
else if (SCM_I_OPERATORP (proc))
|
||
{
|
||
/* operator */
|
||
#ifdef DEVAL
|
||
args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
|
||
#else
|
||
args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
|
||
#endif
|
||
arg1 = proc;
|
||
proc = (SCM_I_ENTITYP (proc)
|
||
? SCM_ENTITY_PROCEDURE (proc)
|
||
: SCM_OPERATOR_PROCEDURE (proc));
|
||
#ifdef DEVAL
|
||
debug.vect[0].a.proc = proc;
|
||
debug.vect[0].a.args = scm_cons (arg1, args);
|
||
#endif
|
||
if (SCM_NIMP (proc))
|
||
goto tail;
|
||
else
|
||
goto badproc;
|
||
}
|
||
else
|
||
goto badproc;
|
||
default:
|
||
badproc:
|
||
scm_wrong_type_arg ("apply", SCM_ARG1, proc);
|
||
}
|
||
#ifdef DEVAL
|
||
exit:
|
||
if (scm_check_exit_p && SCM_TRAPS_P)
|
||
if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
|
||
{
|
||
SCM_CLEAR_TRACED_FRAME (debug);
|
||
if (SCM_CHEAPTRAPS_P)
|
||
arg1 = scm_make_debugobj (&debug);
|
||
else
|
||
{
|
||
int first;
|
||
SCM val = scm_make_continuation (&first);
|
||
|
||
if (first)
|
||
arg1 = val;
|
||
else
|
||
{
|
||
proc = val;
|
||
goto ret;
|
||
}
|
||
}
|
||
SCM_TRAPS_P = 0;
|
||
scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
|
||
SCM_TRAPS_P = 1;
|
||
}
|
||
ret:
|
||
scm_last_debug_frame = debug.prev;
|
||
return proc;
|
||
#endif
|
||
}
|
||
|
||
|
||
/* SECTION: The rest of this file is only read once.
|
||
*/
|
||
|
||
#ifndef DEVAL
|
||
|
||
/* Trampolines
|
||
*
|
||
* Trampolines make it possible to move procedure application dispatch
|
||
* outside inner loops. The motivation was clean implementation of
|
||
* efficient replacements of R5RS primitives in SRFI-1.
|
||
*
|
||
* The semantics is clear: scm_trampoline_N returns an optimized
|
||
* version of scm_call_N (or NULL if the procedure isn't applicable
|
||
* on N args).
|
||
*
|
||
* Applying the optimization to map and for-each increased efficiency
|
||
* noticeably. For example, (map abs ls) is now 8 times faster than
|
||
* before.
|
||
*/
|
||
|
||
static SCM
|
||
call_subr0_0 (SCM proc)
|
||
{
|
||
return SCM_SUBRF (proc) ();
|
||
}
|
||
|
||
static SCM
|
||
call_subr1o_0 (SCM proc)
|
||
{
|
||
return SCM_SUBRF (proc) (SCM_UNDEFINED);
|
||
}
|
||
|
||
static SCM
|
||
call_lsubr_0 (SCM proc)
|
||
{
|
||
return SCM_SUBRF (proc) (SCM_EOL);
|
||
}
|
||
|
||
SCM
|
||
scm_i_call_closure_0 (SCM proc)
|
||
{
|
||
const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
|
||
SCM_EOL,
|
||
SCM_ENV (proc));
|
||
const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
|
||
return result;
|
||
}
|
||
|
||
scm_t_trampoline_0
|
||
scm_trampoline_0 (SCM proc)
|
||
{
|
||
if (SCM_IMP (proc))
|
||
return NULL;
|
||
if (SCM_DEBUGGINGP)
|
||
return scm_call_0;
|
||
switch (SCM_TYP7 (proc))
|
||
{
|
||
case scm_tc7_subr_0:
|
||
return call_subr0_0;
|
||
case scm_tc7_subr_1o:
|
||
return call_subr1o_0;
|
||
case scm_tc7_lsubr:
|
||
return call_lsubr_0;
|
||
case scm_tcs_closures:
|
||
{
|
||
SCM formals = SCM_CLOSURE_FORMALS (proc);
|
||
if (SCM_NULLP (formals) || !SCM_CONSP (formals))
|
||
return scm_i_call_closure_0;
|
||
else
|
||
return NULL;
|
||
}
|
||
case scm_tcs_struct:
|
||
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
|
||
return scm_call_generic_0;
|
||
else if (SCM_I_OPERATORP (proc))
|
||
return scm_call_0;
|
||
return NULL;
|
||
case scm_tc7_smob:
|
||
if (SCM_SMOB_APPLICABLE_P (proc))
|
||
return SCM_SMOB_DESCRIPTOR (proc).apply_0;
|
||
else
|
||
return NULL;
|
||
case scm_tc7_asubr:
|
||
case scm_tc7_rpsubr:
|
||
case scm_tc7_cclo:
|
||
case scm_tc7_pws:
|
||
return scm_call_0;
|
||
default:
|
||
return NULL; /* not applicable on one arg */
|
||
}
|
||
}
|
||
|
||
static SCM
|
||
call_subr1_1 (SCM proc, SCM arg1)
|
||
{
|
||
return SCM_SUBRF (proc) (arg1);
|
||
}
|
||
|
||
static SCM
|
||
call_subr2o_1 (SCM proc, SCM arg1)
|
||
{
|
||
return SCM_SUBRF (proc) (arg1, SCM_UNDEFINED);
|
||
}
|
||
|
||
static SCM
|
||
call_lsubr_1 (SCM proc, SCM arg1)
|
||
{
|
||
return SCM_SUBRF (proc) (scm_list_1 (arg1));
|
||
}
|
||
|
||
static SCM
|
||
call_dsubr_1 (SCM proc, SCM arg1)
|
||
{
|
||
if (SCM_INUMP (arg1))
|
||
{
|
||
RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
|
||
}
|
||
else if (SCM_REALP (arg1))
|
||
{
|
||
RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
|
||
}
|
||
else if (SCM_BIGP (arg1))
|
||
RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
|
||
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
|
||
SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
|
||
}
|
||
|
||
static SCM
|
||
call_cxr_1 (SCM proc, SCM arg1)
|
||
{
|
||
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)
|
||
{
|
||
if (SCM_IMP (proc))
|
||
return NULL;
|
||
if (SCM_DEBUGGINGP)
|
||
return scm_call_1;
|
||
switch (SCM_TYP7 (proc))
|
||
{
|
||
case scm_tc7_subr_1:
|
||
case scm_tc7_subr_1o:
|
||
return call_subr1_1;
|
||
case scm_tc7_subr_2o:
|
||
return call_subr2o_1;
|
||
case scm_tc7_lsubr:
|
||
return call_lsubr_1;
|
||
case scm_tc7_dsubr:
|
||
return call_dsubr_1;
|
||
case scm_tc7_cxr:
|
||
return call_cxr_1;
|
||
case scm_tcs_closures:
|
||
{
|
||
SCM formals = SCM_CLOSURE_FORMALS (proc);
|
||
if (!SCM_NULLP (formals)
|
||
&& (!SCM_CONSP (formals) || !SCM_CONSP (SCM_CDR (formals))))
|
||
return call_closure_1;
|
||
else
|
||
return NULL;
|
||
}
|
||
case scm_tcs_struct:
|
||
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
|
||
return scm_call_generic_1;
|
||
else if (SCM_I_OPERATORP (proc))
|
||
return scm_call_1;
|
||
return NULL;
|
||
case scm_tc7_smob:
|
||
if (SCM_SMOB_APPLICABLE_P (proc))
|
||
return SCM_SMOB_DESCRIPTOR (proc).apply_1;
|
||
else
|
||
return NULL;
|
||
case scm_tc7_asubr:
|
||
case scm_tc7_rpsubr:
|
||
case scm_tc7_cclo:
|
||
case scm_tc7_pws:
|
||
return scm_call_1;
|
||
default:
|
||
return NULL; /* not applicable on one arg */
|
||
}
|
||
}
|
||
|
||
static SCM
|
||
call_subr2_2 (SCM proc, SCM arg1, SCM arg2)
|
||
{
|
||
return SCM_SUBRF (proc) (arg1, arg2);
|
||
}
|
||
|
||
static SCM
|
||
call_lsubr2_2 (SCM proc, SCM arg1, SCM arg2)
|
||
{
|
||
return SCM_SUBRF (proc) (arg1, arg2, SCM_EOL);
|
||
}
|
||
|
||
static SCM
|
||
call_lsubr_2 (SCM proc, SCM arg1, SCM arg2)
|
||
{
|
||
return SCM_SUBRF (proc) (scm_list_2 (arg1, arg2));
|
||
}
|
||
|
||
static SCM
|
||
call_closure_2 (SCM proc, SCM arg1, SCM arg2)
|
||
{
|
||
const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
|
||
scm_list_2 (arg1, arg2),
|
||
SCM_ENV (proc));
|
||
const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
|
||
return result;
|
||
}
|
||
|
||
scm_t_trampoline_2
|
||
scm_trampoline_2 (SCM proc)
|
||
{
|
||
if (SCM_IMP (proc))
|
||
return NULL;
|
||
if (SCM_DEBUGGINGP)
|
||
return scm_call_2;
|
||
switch (SCM_TYP7 (proc))
|
||
{
|
||
case scm_tc7_subr_2:
|
||
case scm_tc7_subr_2o:
|
||
case scm_tc7_rpsubr:
|
||
case scm_tc7_asubr:
|
||
return call_subr2_2;
|
||
case scm_tc7_lsubr_2:
|
||
return call_lsubr2_2;
|
||
case scm_tc7_lsubr:
|
||
return call_lsubr_2;
|
||
case scm_tcs_closures:
|
||
{
|
||
SCM formals = SCM_CLOSURE_FORMALS (proc);
|
||
if (!SCM_NULLP (formals)
|
||
&& (!SCM_CONSP (formals)
|
||
|| (!SCM_NULLP (SCM_CDR (formals))
|
||
&& (!SCM_CONSP (SCM_CDR (formals))
|
||
|| !SCM_CONSP (SCM_CDDR (formals))))))
|
||
return call_closure_2;
|
||
else
|
||
return NULL;
|
||
}
|
||
case scm_tcs_struct:
|
||
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
|
||
return scm_call_generic_2;
|
||
else if (SCM_I_OPERATORP (proc))
|
||
return scm_call_2;
|
||
return NULL;
|
||
case scm_tc7_smob:
|
||
if (SCM_SMOB_APPLICABLE_P (proc))
|
||
return SCM_SMOB_DESCRIPTOR (proc).apply_2;
|
||
else
|
||
return NULL;
|
||
case scm_tc7_cclo:
|
||
case scm_tc7_pws:
|
||
return scm_call_2;
|
||
default:
|
||
return NULL; /* not applicable on two args */
|
||
}
|
||
}
|
||
|
||
/* Typechecking for multi-argument MAP and FOR-EACH.
|
||
|
||
Verify that each element of the vector ARGV, except for the first,
|
||
is a proper list whose length is LEN. Attribute errors to WHO,
|
||
and claim that the i'th element of ARGV is WHO's i+2'th argument. */
|
||
static inline void
|
||
check_map_args (SCM argv,
|
||
long len,
|
||
SCM gf,
|
||
SCM proc,
|
||
SCM args,
|
||
const char *who)
|
||
{
|
||
SCM const *ve = SCM_VELTS (argv);
|
||
long i;
|
||
|
||
for (i = SCM_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
|
||
{
|
||
long elt_len = scm_ilength (ve[i]);
|
||
|
||
if (elt_len < 0)
|
||
{
|
||
if (gf)
|
||
scm_apply_generic (gf, scm_cons (proc, args));
|
||
else
|
||
scm_wrong_type_arg (who, i + 2, ve[i]);
|
||
}
|
||
|
||
if (elt_len != len)
|
||
scm_out_of_range_pos (who, ve[i], SCM_MAKINUM (i + 2));
|
||
}
|
||
|
||
scm_remember_upto_here_1 (argv);
|
||
}
|
||
|
||
|
||
SCM_GPROC (s_map, "map", 2, 0, 1, scm_map, g_map);
|
||
|
||
/* Note: Currently, scm_map applies PROC to the argument list(s)
|
||
sequentially, starting with the first element(s). This is used in
|
||
evalext.c where the Scheme procedure `map-in-order', which guarantees
|
||
sequential behaviour, is implemented using scm_map. If the
|
||
behaviour changes, we need to update `map-in-order'.
|
||
*/
|
||
|
||
SCM
|
||
scm_map (SCM proc, SCM arg1, SCM args)
|
||
#define FUNC_NAME s_map
|
||
{
|
||
long i, len;
|
||
SCM res = SCM_EOL;
|
||
SCM *pres = &res;
|
||
SCM const *ve = &args; /* Keep args from being optimized away. */
|
||
|
||
len = scm_ilength (arg1);
|
||
SCM_GASSERTn (len >= 0,
|
||
g_map, scm_cons2 (proc, arg1, args), SCM_ARG2, s_map);
|
||
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 (call (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
|
||
pres = SCM_CDRLOC (*pres);
|
||
arg1 = SCM_CDR (arg1);
|
||
arg2 = SCM_CDR (arg2);
|
||
}
|
||
return res;
|
||
}
|
||
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)
|
||
{
|
||
arg1 = SCM_EOL;
|
||
for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--)
|
||
{
|
||
if (SCM_IMP (ve[i]))
|
||
return res;
|
||
arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
|
||
SCM_VECTOR_SET (args, i, SCM_CDR (ve[i]));
|
||
}
|
||
*pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL));
|
||
pres = SCM_CDRLOC (*pres);
|
||
}
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
SCM_GPROC (s_for_each, "for-each", 2, 0, 1, scm_for_each, g_for_each);
|
||
|
||
SCM
|
||
scm_for_each (SCM proc, SCM arg1, SCM args)
|
||
#define FUNC_NAME s_for_each
|
||
{
|
||
SCM const *ve = &args; /* Keep args from being optimized away. */
|
||
long i, len;
|
||
len = scm_ilength (arg1);
|
||
SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args),
|
||
SCM_ARG2, s_for_each);
|
||
SCM_VALIDATE_REST_ARGUMENT (args);
|
||
if (SCM_NULLP (args))
|
||
{
|
||
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))
|
||
{
|
||
call (proc, SCM_CAR (arg1), SCM_CAR (arg2));
|
||
arg1 = SCM_CDR (arg1);
|
||
arg2 = SCM_CDR (arg2);
|
||
}
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
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)
|
||
{
|
||
arg1 = SCM_EOL;
|
||
for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--)
|
||
{
|
||
if (SCM_IMP (ve[i]))
|
||
return SCM_UNSPECIFIED;
|
||
arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
|
||
SCM_VECTOR_SET (args, i, SCM_CDR (ve[i]));
|
||
}
|
||
scm_apply (proc, arg1, SCM_EOL);
|
||
}
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
SCM
|
||
scm_closure (SCM code, SCM env)
|
||
{
|
||
SCM z;
|
||
SCM closcar = scm_cons (code, SCM_EOL);
|
||
z = scm_cell (SCM_UNPACK (closcar) + scm_tc3_closure, (scm_t_bits) env);
|
||
scm_remember_upto_here (closcar);
|
||
return z;
|
||
}
|
||
|
||
|
||
scm_t_bits scm_tc16_promise;
|
||
|
||
SCM
|
||
scm_makprom (SCM 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_PROMISE_DATA (exp), port, pstate);
|
||
SCM_SET_WRITINGP (pstate, writingp);
|
||
scm_putc ('>', port);
|
||
return !0;
|
||
}
|
||
|
||
SCM_DEFINE (scm_force, "force", 1, 0, 0,
|
||
(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, promise, promise);
|
||
scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise));
|
||
if (!SCM_PROMISE_COMPUTED_P (promise))
|
||
{
|
||
SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise));
|
||
if (!SCM_PROMISE_COMPUTED_P (promise))
|
||
{
|
||
SCM_SET_PROMISE_DATA (promise, ans);
|
||
SCM_SET_PROMISE_COMPUTED (promise);
|
||
}
|
||
}
|
||
scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise));
|
||
return SCM_PROMISE_DATA (promise);
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0,
|
||
(SCM obj),
|
||
"Return true if @var{obj} is a promise, i.e. a delayed computation\n"
|
||
"(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
|
||
#define FUNC_NAME s_scm_promise_p
|
||
{
|
||
return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise, obj));
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0,
|
||
(SCM xorig, SCM x, SCM y),
|
||
"Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
|
||
"Any source properties associated with @var{xorig} are also associated\n"
|
||
"with the new pair.")
|
||
#define FUNC_NAME s_scm_cons_source
|
||
{
|
||
SCM p, z;
|
||
z = scm_cons (x, y);
|
||
/* Copy source properties possibly associated with xorig. */
|
||
p = scm_whash_lookup (scm_source_whash, xorig);
|
||
if (!SCM_IMP (p))
|
||
scm_whash_insert (scm_source_whash, z, p);
|
||
return z;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
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"
|
||
"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);
|
||
for (obj = SCM_CDR (obj); SCM_CONSP (obj); obj = SCM_CDR (obj))
|
||
{
|
||
SCM_SETCDR (tl, scm_cons (scm_copy_tree (SCM_CAR (obj)),
|
||
SCM_UNSPECIFIED));
|
||
tl = SCM_CDR (tl);
|
||
}
|
||
SCM_SETCDR (tl, obj);
|
||
return ans;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
/* We have three levels of EVAL here:
|
||
|
||
- scm_i_eval (exp, env)
|
||
|
||
evaluates EXP in environment ENV. ENV is a lexical environment
|
||
structure as used by the actual tree code evaluator. When ENV is
|
||
a top-level environment, then changes to the current module are
|
||
tracked by updating ENV so that it continues to be in sync with
|
||
the current module.
|
||
|
||
- scm_primitive_eval (exp)
|
||
|
||
evaluates EXP in the top-level environment as determined by the
|
||
current module. This is done by constructing a suitable
|
||
environment and calling scm_i_eval. Thus, changes to the
|
||
top-level module are tracked normally.
|
||
|
||
- scm_eval (exp, mod)
|
||
|
||
evaluates EXP while MOD is the current module. This is done by
|
||
setting the current module to MOD, invoking scm_primitive_eval on
|
||
EXP, and then restoring the current module to the value it had
|
||
previously. That is, while EXP is evaluated, changes to the
|
||
current module are tracked, but these changes do not persist when
|
||
scm_eval returns.
|
||
|
||
For each level of evals, there are two variants, distinguished by a
|
||
_x suffix: the ordinary variant does not modify EXP while the _x
|
||
variant can destructively modify EXP into something completely
|
||
unintelligible. A Scheme data structure passed as EXP to one of the
|
||
_x variants should not ever be used again for anything. So when in
|
||
doubt, use the ordinary variant.
|
||
|
||
*/
|
||
|
||
SCM
|
||
scm_i_eval_x (SCM exp, SCM env)
|
||
{
|
||
return SCM_XEVAL (exp, env);
|
||
}
|
||
|
||
SCM
|
||
scm_i_eval (SCM exp, SCM env)
|
||
{
|
||
exp = scm_copy_tree (exp);
|
||
return SCM_XEVAL (exp, env);
|
||
}
|
||
|
||
SCM
|
||
scm_primitive_eval_x (SCM exp)
|
||
{
|
||
SCM env;
|
||
SCM transformer = scm_current_module_transformer ();
|
||
if (SCM_NIMP (transformer))
|
||
exp = scm_call_1 (transformer, exp);
|
||
env = scm_top_level_env (scm_current_module_lookup_closure ());
|
||
return scm_i_eval_x (exp, env);
|
||
}
|
||
|
||
SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0,
|
||
(SCM exp),
|
||
"Evaluate @var{exp} in the top-level environment specified by\n"
|
||
"the current module.")
|
||
#define FUNC_NAME s_scm_primitive_eval
|
||
{
|
||
SCM env;
|
||
SCM transformer = scm_current_module_transformer ();
|
||
if (SCM_NIMP (transformer))
|
||
exp = scm_call_1 (transformer, exp);
|
||
env = scm_top_level_env (scm_current_module_lookup_closure ());
|
||
return scm_i_eval (exp, env);
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
/* Eval does not take the second arg optionally. This is intentional
|
||
* in order to be R5RS compatible, and to prepare for the new module
|
||
* system, where we would like to make the choice of evaluation
|
||
* environment explicit. */
|
||
|
||
static void
|
||
change_environment (void *data)
|
||
{
|
||
SCM pair = SCM_PACK (data);
|
||
SCM new_module = SCM_CAR (pair);
|
||
SCM old_module = scm_current_module ();
|
||
SCM_SETCDR (pair, old_module);
|
||
scm_set_current_module (new_module);
|
||
}
|
||
|
||
|
||
static void
|
||
restore_environment (void *data)
|
||
{
|
||
SCM pair = SCM_PACK (data);
|
||
SCM old_module = SCM_CDR (pair);
|
||
SCM new_module = scm_current_module ();
|
||
SCM_SETCAR (pair, new_module);
|
||
scm_set_current_module (old_module);
|
||
}
|
||
|
||
static SCM
|
||
inner_eval_x (void *data)
|
||
{
|
||
return scm_primitive_eval_x (SCM_PACK(data));
|
||
}
|
||
|
||
SCM
|
||
scm_eval_x (SCM exp, SCM module)
|
||
#define FUNC_NAME "eval!"
|
||
{
|
||
SCM_VALIDATE_MODULE (2, module);
|
||
|
||
return scm_internal_dynamic_wind
|
||
(change_environment, inner_eval_x, restore_environment,
|
||
(void *) SCM_UNPACK (exp),
|
||
(void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F)));
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
static SCM
|
||
inner_eval (void *data)
|
||
{
|
||
return scm_primitive_eval (SCM_PACK(data));
|
||
}
|
||
|
||
SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
|
||
(SCM exp, SCM module),
|
||
"Evaluate @var{exp}, a list representing a Scheme expression,\n"
|
||
"in the top-level environment specified by @var{module}.\n"
|
||
"While @var{exp} is evaluated (using @code{primitive-eval}),\n"
|
||
"@var{module} is made the current module. The current module\n"
|
||
"is reset to its previous value when @var{eval} returns.")
|
||
#define FUNC_NAME s_scm_eval
|
||
{
|
||
SCM_VALIDATE_MODULE (2, module);
|
||
|
||
return scm_internal_dynamic_wind
|
||
(change_environment, inner_eval, restore_environment,
|
||
(void *) SCM_UNPACK (exp),
|
||
(void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F)));
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
/* At this point, scm_deval and scm_dapply are generated.
|
||
*/
|
||
|
||
#define DEVAL
|
||
#include "eval.c"
|
||
|
||
|
||
void
|
||
scm_init_eval ()
|
||
{
|
||
scm_init_opts (scm_evaluator_traps,
|
||
scm_evaluator_trap_table,
|
||
SCM_N_EVALUATOR_TRAPS);
|
||
scm_init_opts (scm_eval_options_interface,
|
||
scm_eval_opts,
|
||
SCM_N_EVAL_OPTIONS);
|
||
|
||
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);
|
||
|
||
undefineds = scm_list_1 (SCM_UNDEFINED);
|
||
SCM_SETCDR (undefineds, undefineds);
|
||
scm_permanent_object (undefineds);
|
||
|
||
scm_listofnull = scm_list_1 (SCM_EOL);
|
||
|
||
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");
|
||
}
|
||
|
||
#endif /* !DEVAL */
|
||
|
||
/*
|
||
Local Variables:
|
||
c-file-style: "gnu"
|
||
End:
|
||
*/
|