-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2003 Free Software Foundation, Inc.
+/* 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
? *scm_lookupcar (x, env, 1) \
: SCM_CEVAL (SCM_CAR (x), env)))
-#define EXTEND_ENV SCM_EXTEND_ENV
-
SCM_REC_MUTEX (source_mutex);
+
+/* Lookup a given local variable in an environment. The local variable is
+ * given as an iloc, that is a triple <frame, binding, last?>, where frame
+ * indicates the relative number of the environment frame (counting upwards
+ * from the innermost environment frame), binding indicates the number of the
+ * binding within the frame, and last? (which is extracted from the iloc using
+ * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
+ * very end of the improper list of bindings. */
SCM *
scm_ilookup (SCM iloc, SCM env)
{
- register long ir = SCM_IFRAME (iloc);
- register SCM er = env;
- for (; 0 != ir; --ir)
- er = SCM_CDR (er);
- er = SCM_CAR (er);
- for (ir = SCM_IDIST (iloc); 0 != ir; --ir)
- er = SCM_CDR (er);
+ unsigned int frame_nr = SCM_IFRAME (iloc);
+ unsigned int binding_nr = SCM_IDIST (iloc);
+ SCM frames = env;
+ SCM bindings;
+
+ for (; 0 != frame_nr; --frame_nr)
+ frames = SCM_CDR (frames);
+
+ bindings = SCM_CAR (frames);
+ for (; 0 != binding_nr; --binding_nr)
+ bindings = SCM_CDR (bindings);
+
if (SCM_ICDRP (iloc))
- return SCM_CDRLOC (er);
- return SCM_CARLOC (SCM_CDR (er));
+ return SCM_CDRLOC (bindings);
+ return SCM_CARLOC (SCM_CDR (bindings));
}
+
/* The Lookup Car Race
- by Eva Luator
}
-SCM_SYNTAX (s_quote, "quote", scm_makmmacro, scm_m_quote);
-SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
-
-SCM
-scm_m_quote (SCM xorig, SCM env SCM_UNUSED)
-{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, s_quote);
- return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig));
-}
-
-
-SCM_SYNTAX (s_begin, "begin", scm_makmmacro, scm_m_begin);
-SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
-
-SCM
-scm_m_begin (SCM xorig, SCM env SCM_UNUSED)
-{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 0, scm_s_expression, s_begin);
- return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig));
-}
-
-
-SCM_SYNTAX (s_if, "if", scm_makmmacro, scm_m_if);
-SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
-
-SCM
-scm_m_if (SCM xorig, SCM env SCM_UNUSED)
-{
- long len = scm_ilength (SCM_CDR (xorig));
- SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, s_if);
- return scm_cons (SCM_IM_IF, SCM_CDR (xorig));
-}
-
-
-/* Will go into the RnRS module when Guile is factorized.
-SCM_SYNTAX (s_set_x, "set!", scm_makmmacro, scm_m_set_x); */
-static const char s_set_x[] = "set!";
-SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x);
-
-SCM
-scm_m_set_x (SCM xorig, SCM env SCM_UNUSED)
-{
- SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, s_set_x);
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), scm_s_variable, s_set_x);
- return scm_cons (SCM_IM_SET_X, x);
-}
+/* Start of the memoizers for the standard R5RS builtin macros. */
SCM_SYNTAX (s_and, "and", scm_makmmacro, scm_m_and);
}
-SCM_SYNTAX (s_or, "or", scm_makmmacro, scm_m_or);
-SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
+SCM_SYNTAX (s_begin, "begin", scm_makmmacro, scm_m_begin);
+SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
SCM
-scm_m_or (SCM xorig, SCM env SCM_UNUSED)
+scm_m_begin (SCM xorig, SCM env SCM_UNUSED)
{
- long len = scm_ilength (SCM_CDR (xorig));
- SCM_ASSYNT (len >= 0, scm_s_test, s_or);
- if (len >= 1)
- return scm_cons (SCM_IM_OR, SCM_CDR (xorig));
- else
- return SCM_BOOL_F;
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 0, scm_s_expression, s_begin);
+ return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig));
}
}
-SCM_SYNTAX (s_lambda, "lambda", scm_makmmacro, scm_m_lambda);
-SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda);
+SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define);
+SCM_GLOBAL_SYMBOL(scm_sym_define, s_define);
-/* Return true if OBJ is `eq?' to one of the elements of LIST or to the
- * cdr of the last cons. (Thus, LIST is not required to be a proper
- * list and OBJ can also be found in the improper ending.) */
-static int
-scm_c_improper_memq (SCM obj, SCM list)
+/* Guile provides an extension to R5RS' define syntax to represent function
+ * currying in a compact way. With this extension, it is allowed to write
+ * (define <nested-variable> <body>), where <nested-variable> has of one of
+ * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
+ * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
+ * should be either a sequence of zero or more variables, or a sequence of one
+ * or more variables followed by a space-delimited period and another
+ * variable. Each level of argument nesting wraps the <body> within another
+ * lambda expression. For example, the following forms are allowed, each one
+ * followed by an equivalent, more explicit implementation.
+ * Example 1:
+ * (define ((a b . c) . d) <body>) is equivalent to
+ * (define a (lambda (b . c) (lambda d <body>)))
+ * Example 2:
+ * (define (((a) b) c . d) <body>) is equivalent to
+ * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
+ */
+/* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
+ * module that does not implement this extension. */
+SCM
+scm_m_define (SCM x, SCM env)
{
- for (; SCM_CONSP (list); list = SCM_CDR (list))
+ SCM name;
+ x = SCM_CDR (x);
+ SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_expression, s_define);
+ name = SCM_CAR (x);
+ x = SCM_CDR (x);
+ while (SCM_CONSP (name))
{
- if (SCM_EQ_P (SCM_CAR (list), obj))
- return 1;
+ /* This while loop realizes function currying by variable nesting. */
+ SCM formals = SCM_CDR (name);
+ x = scm_list_1 (scm_cons2 (scm_sym_lambda, formals, x));
+ name = SCM_CAR (name);
}
- return SCM_EQ_P (list, obj);
-}
-
-SCM
-scm_m_lambda (SCM xorig, SCM env SCM_UNUSED)
-{
- SCM formals;
- SCM x = SCM_CDR (xorig);
-
- SCM_ASSYNT (SCM_CONSP (x), scm_s_formals, s_lambda);
-
- formals = SCM_CAR (x);
- while (SCM_CONSP (formals))
+ SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_variable, s_define);
+ SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_define);
+ if (SCM_TOP_LEVEL (env))
{
- SCM formal = SCM_CAR (formals);
- SCM_ASSYNT (SCM_SYMBOLP (formal), scm_s_formals, s_lambda);
- if (scm_c_improper_memq (formal, SCM_CDR (formals)))
- scm_misc_error (s_lambda, scm_s_duplicate_formals, SCM_EOL);
- formals = SCM_CDR (formals);
+ SCM var;
+ x = scm_eval_car (x, env);
+ if (SCM_REC_PROCNAMES_P)
+ {
+ SCM tmp = x;
+ while (SCM_MACROP (tmp))
+ tmp = SCM_MACRO_CODE (tmp);
+ if (SCM_CLOSUREP (tmp)
+ /* Only the first definition determines the name. */
+ && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name)))
+ scm_set_procedure_property_x (tmp, scm_sym_name, name);
+ }
+ var = scm_sym2var (name, scm_env_top_level (env), SCM_BOOL_T);
+ SCM_VARIABLE_SET (var, x);
+ return SCM_UNSPECIFIED;
}
- if (!SCM_NULLP (formals) && !SCM_SYMBOLP (formals))
- scm_misc_error (s_lambda, scm_s_formals, SCM_EOL);
-
- return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (x),
- scm_m_body (SCM_IM_LAMBDA, SCM_CDR (x), s_lambda));
+ else
+ return scm_cons2 (SCM_IM_DEFINE, name, x);
}
-SCM_SYNTAX (s_letstar, "let*", scm_makmmacro, scm_m_letstar);
-SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);
+SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay);
+SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
-/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
- * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
+/* Promises are implemented as closures with an empty parameter list. Thus,
+ * (delay <expression>) is transformed into (#@delay '() <expression>), where
+ * the empty list represents the empty parameter list. This representation
+ * allows for easy creation of the closure during evaluation. */
SCM
-scm_m_letstar (SCM xorig, SCM env SCM_UNUSED)
+scm_m_delay (SCM xorig, SCM env SCM_UNUSED)
{
- SCM bindings;
- SCM x = SCM_CDR (xorig);
- SCM vars = SCM_EOL;
- SCM *varloc = &vars;
-
- SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letstar);
-
- bindings = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_letstar);
- while (!SCM_NULLP (bindings))
- {
- SCM binding = SCM_CAR (bindings);
- SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, s_letstar);
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, s_letstar);
- *varloc = scm_list_2 (SCM_CAR (binding), SCM_CADR (binding));
- varloc = SCM_CDRLOC (SCM_CDR (*varloc));
- bindings = SCM_CDR (bindings);
- }
-
- return scm_cons2 (SCM_IM_LETSTAR, vars,
- scm_m_body (SCM_IM_LETSTAR, SCM_CDR (x), s_letstar));
+ SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_delay);
+ return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig));
}
}
-SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
-SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);
+SCM_SYNTAX (s_if, "if", scm_makmmacro, scm_m_if);
+SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
-/* Internal function to handle a quasiquotation: 'form' is the parameter in
- * the call (quasiquotation form), 'env' is the environment where unquoted
- * expressions will be evaluated, and 'depth' is the current quasiquotation
- * nesting level and is known to be greater than zero. */
-static SCM
-iqq (SCM form, SCM env, unsigned long int depth)
+SCM
+scm_m_if (SCM xorig, SCM env SCM_UNUSED)
{
- if (SCM_CONSP (form))
- {
- SCM tmp = SCM_CAR (form);
- if (SCM_EQ_P (tmp, scm_sym_quasiquote))
- {
- SCM args = SCM_CDR (form);
- SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote);
- return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1));
- }
- else if (SCM_EQ_P (tmp, scm_sym_unquote))
- {
- SCM args = SCM_CDR (form);
- SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote);
- if (depth - 1 == 0)
- return scm_eval_car (args, env);
- else
- return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth - 1));
- }
- else if (SCM_CONSP (tmp)
- && SCM_EQ_P (SCM_CAR (tmp), scm_sym_uq_splicing))
- {
- SCM args = SCM_CDR (tmp);
- SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote);
- if (depth - 1 == 0)
- {
- SCM list = scm_eval_car (args, env);
- SCM rest = SCM_CDR (form);
- SCM_ASSYNT (scm_ilength (list) >= 0, s_splicing, s_quasiquote);
- return scm_append (scm_list_2 (list, iqq (rest, env, depth)));
- }
- else
- return scm_cons (iqq (SCM_CAR (form), env, depth - 1),
- iqq (SCM_CDR (form), env, depth));
- }
- else
- return scm_cons (iqq (SCM_CAR (form), env, depth),
- iqq (SCM_CDR (form), env, depth));
- }
- else if (SCM_VECTORP (form))
- {
- size_t i = SCM_VECTOR_LENGTH (form);
- SCM const *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;
+ long len = scm_ilength (SCM_CDR (xorig));
+ SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, s_if);
+ return scm_cons (SCM_IM_IF, SCM_CDR (xorig));
}
-SCM
-scm_m_quasiquote (SCM xorig, SCM env)
-{
- SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_quasiquote);
- return iqq (SCM_CAR (x), env, 1);
-}
+SCM_SYNTAX (s_lambda, "lambda", scm_makmmacro, scm_m_lambda);
+SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda);
-SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay);
-SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
+/* 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);
+}
-/* Promises are implemented as closures with an empty parameter list. Thus,
- * (delay <expression>) is transformed into (#@delay '() <expression>), where
- * the empty list represents the empty parameter list. This representation
- * allows for easy creation of the closure during evaluation. */
SCM
-scm_m_delay (SCM xorig, SCM env SCM_UNUSED)
+scm_m_lambda (SCM xorig, SCM env SCM_UNUSED)
{
- SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_delay);
- return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig));
+ SCM formals;
+ SCM x = SCM_CDR (xorig);
+
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_formals, s_lambda);
+
+ formals = SCM_CAR (x);
+ while (SCM_CONSP (formals))
+ {
+ SCM formal = SCM_CAR (formals);
+ SCM_ASSYNT (SCM_SYMBOLP (formal), scm_s_formals, s_lambda);
+ if (scm_c_improper_memq (formal, SCM_CDR (formals)))
+ scm_misc_error (s_lambda, scm_s_duplicate_formals, SCM_EOL);
+ formals = SCM_CDR (formals);
+ }
+ if (!SCM_NULLP (formals) && !SCM_SYMBOLP (formals))
+ scm_misc_error (s_lambda, scm_s_formals, SCM_EOL);
+
+ return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (x),
+ scm_m_body (SCM_IM_LAMBDA, SCM_CDR (x), s_lambda));
}
-SCM_SYNTAX (s_gset_x, "set!", scm_makmmacro, scm_m_generalized_set_x);
-SCM_SYMBOL (scm_sym_setter, "setter");
+/* 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
-scm_m_generalized_set_x (SCM xorig, SCM env SCM_UNUSED)
+ SCM_ASSYNT (scm_ilength (bindings) >= 1, scm_s_bindings, what);
+
+ do
+ {
+ SCM binding = SCM_CAR (bindings);
+ SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, what);
+ SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, what);
+ if (scm_c_improper_memq (SCM_CAR (binding), rvars))
+ scm_misc_error (what, scm_s_duplicate_bindings, SCM_EOL);
+ rvars = scm_cons (SCM_CAR (binding), rvars);
+ *initloc = scm_list_1 (SCM_CADR (binding));
+ initloc = SCM_CDRLOC (*initloc);
+ bindings = SCM_CDR (bindings);
+ }
+ while (!SCM_NULLP (bindings));
+
+ *rvarloc = rvars;
+}
+
+
+SCM_SYNTAX(s_let, "let", scm_makmmacro, 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_ASSYNT (2 == scm_ilength (x), scm_s_expression, s_set_x);
- if (SCM_SYMBOLP (SCM_CAR (x)))
- return scm_cons (SCM_IM_SET_X, x);
- else if (SCM_CONSP (SCM_CAR (x)))
- return scm_cons (scm_list_2 (scm_sym_setter, SCM_CAAR (x)),
- scm_append (scm_list_2 (SCM_CDAR (x), SCM_CDR (x))));
+ SCM temp;
+
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_let);
+ temp = SCM_CAR (x);
+ if (SCM_NULLP (temp)
+ || (scm_ilength (temp) == 1 && SCM_CONSP (SCM_CAR (temp))))
+ {
+ /* null or single binding, let* is faster */
+ SCM bindings = temp;
+ SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (x), s_let);
+ return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), bindings, body), env);
+ }
+ else if (SCM_CONSP (temp))
+ {
+ /* 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
- scm_misc_error (s_set_x, scm_s_variable, SCM_EOL);
+ {
+ /* named let: Transform (let name ((var init) ...) body ...) into
+ * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
+
+ SCM name = temp;
+ SCM vars = SCM_EOL;
+ SCM *varloc = &vars;
+ SCM inits = SCM_EOL;
+ SCM *initloc = &inits;
+ SCM bindings;
+
+ SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_bindings, s_let);
+ x = SCM_CDR (x);
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_let);
+ bindings = SCM_CAR (x);
+ SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_let);
+ while (!SCM_NULLP (bindings))
+ { /* vars and inits both in order */
+ SCM binding = SCM_CAR (bindings);
+ SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, s_let);
+ SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, s_let);
+ *varloc = scm_list_1 (SCM_CAR (binding));
+ varloc = SCM_CDRLOC (*varloc);
+ *initloc = scm_list_1 (SCM_CADR (binding));
+ initloc = SCM_CDRLOC (*initloc);
+ bindings = SCM_CDR (bindings);
+ }
+
+ {
+ SCM lambda_body = scm_m_body (SCM_IM_LET, SCM_CDR (x), "let");
+ SCM lambda_form = scm_cons2 (scm_sym_lambda, vars, lambda_body);
+ SCM rvar = scm_list_1 (name);
+ SCM init = scm_list_1 (lambda_form);
+ SCM body = scm_m_body (SCM_IM_LET, scm_list_1 (name), "let");
+ SCM letrec = scm_cons2 (SCM_IM_LETREC, rvar, scm_cons (init, body));
+ return scm_cons (letrec, inits);
+ }
+ }
}
-SCM_SYNTAX (s_future, "future", scm_makmmacro, scm_m_future);
-SCM_GLOBAL_SYMBOL (scm_sym_future, s_future);
+SCM_SYNTAX (s_letstar, "let*", scm_makmmacro, scm_m_letstar);
+SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);
-/* 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. */
+/* (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_future (SCM xorig, SCM env SCM_UNUSED)
+scm_m_letstar (SCM xorig, SCM env SCM_UNUSED)
{
- SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_future);
- return scm_cons2 (SCM_IM_FUTURE, SCM_EOL, SCM_CDR (xorig));
+ SCM bindings;
+ SCM x = SCM_CDR (xorig);
+ SCM vars = SCM_EOL;
+ SCM *varloc = &vars;
+
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letstar);
+
+ bindings = SCM_CAR (x);
+ SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_letstar);
+ while (!SCM_NULLP (bindings))
+ {
+ SCM binding = SCM_CAR (bindings);
+ SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, s_letstar);
+ SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, s_letstar);
+ *varloc = scm_list_2 (SCM_CAR (binding), SCM_CADR (binding));
+ varloc = SCM_CDRLOC (SCM_CDR (*varloc));
+ bindings = SCM_CDR (bindings);
+ }
+
+ return scm_cons2 (SCM_IM_LETSTAR, vars,
+ scm_m_body (SCM_IM_LETSTAR, SCM_CDR (x), s_letstar));
}
-SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define);
-SCM_GLOBAL_SYMBOL(scm_sym_define, s_define);
+SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec);
+SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
-/* Guile provides an extension to R5RS' define syntax to represent function
- * currying in a compact way. With this extension, it is allowed to write
- * (define <nested-variable> <body>), where <nested-variable> has of one of
- * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
- * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
- * should be either a sequence of zero or more variables, or a sequence of one
- * or more variables followed by a space-delimited period and another
- * variable. Each level of argument nesting wraps the <body> within another
- * lambda expression. For example, the following forms are allowed, each one
- * followed by an equivalent, more explicit implementation.
- * Example 1:
- * (define ((a b . c) . d) <body>) is equivalent to
- * (define a (lambda (b . c) (lambda d <body>)))
- * Example 2:
- * (define (((a) b) c . d) <body>) is equivalent to
- * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
- */
-/* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
- * module that does not implement this extension. */
-SCM
-scm_m_define (SCM x, SCM env)
+SCM
+scm_m_letrec (SCM xorig, SCM env)
{
- SCM name;
- x = SCM_CDR (x);
- SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_expression, s_define);
- name = SCM_CAR (x);
- x = SCM_CDR (x);
- while (SCM_CONSP (name))
+ SCM x = SCM_CDR (xorig);
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letrec);
+
+ if (SCM_NULLP (SCM_CAR (x)))
{
- /* This while loop realizes function currying by variable nesting. */
- SCM formals = SCM_CDR (name);
- x = scm_list_1 (scm_cons2 (scm_sym_lambda, formals, x));
- name = SCM_CAR (name);
+ /* 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);
}
- SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_variable, s_define);
- SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_define);
- if (SCM_TOP_LEVEL (env))
+ else
{
- SCM var;
- x = scm_eval_car (x, env);
- if (SCM_REC_PROCNAMES_P)
+ 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_makmmacro, scm_m_or);
+SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
+
+SCM
+scm_m_or (SCM xorig, SCM env SCM_UNUSED)
+{
+ long len = scm_ilength (SCM_CDR (xorig));
+ SCM_ASSYNT (len >= 0, scm_s_test, s_or);
+ if (len >= 1)
+ return scm_cons (SCM_IM_OR, SCM_CDR (xorig));
+ else
+ return SCM_BOOL_F;
+}
+
+
+SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
+SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);
+
+/* 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 tmp = x;
- while (SCM_MACROP (tmp))
- tmp = SCM_MACRO_CODE (tmp);
- if (SCM_CLOSUREP (tmp)
- /* Only the first definition determines the name. */
- && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name)))
- scm_set_procedure_property_x (tmp, scm_sym_name, name);
+ SCM args = SCM_CDR (form);
+ SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote);
+ return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1));
}
- var = scm_sym2var (name, scm_env_top_level (env), SCM_BOOL_T);
- SCM_VARIABLE_SET (var, x);
- return SCM_UNSPECIFIED;
+ else if (SCM_EQ_P (tmp, scm_sym_unquote))
+ {
+ SCM args = SCM_CDR (form);
+ SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote);
+ if (depth - 1 == 0)
+ return scm_eval_car (args, env);
+ else
+ return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth - 1));
+ }
+ else if (SCM_CONSP (tmp)
+ && SCM_EQ_P (SCM_CAR (tmp), scm_sym_uq_splicing))
+ {
+ SCM args = SCM_CDR (tmp);
+ SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote);
+ if (depth - 1 == 0)
+ {
+ SCM list = scm_eval_car (args, env);
+ SCM rest = SCM_CDR (form);
+ SCM_ASSYNT (scm_ilength (list) >= 0, s_splicing, s_quasiquote);
+ return scm_append (scm_list_2 (list, iqq (rest, env, depth)));
+ }
+ else
+ return scm_cons (iqq (SCM_CAR (form), env, depth - 1),
+ iqq (SCM_CDR (form), env, depth));
+ }
+ else
+ return scm_cons (iqq (SCM_CAR (form), env, depth),
+ iqq (SCM_CDR (form), env, depth));
+ }
+ else if (SCM_VECTORP (form))
+ {
+ size_t i = SCM_VECTOR_LENGTH (form);
+ SCM const *const data = SCM_VELTS (form);
+ SCM tmp = SCM_EOL;
+ while (i != 0)
+ tmp = scm_cons (data[--i], tmp);
+ scm_remember_upto_here_1 (form);
+ return scm_vector (iqq (tmp, env, depth));
}
else
- return scm_cons2 (SCM_IM_DEFINE, name, x);
+ return form;
+}
+
+SCM
+scm_m_quasiquote (SCM xorig, SCM env)
+{
+ SCM x = SCM_CDR (xorig);
+ SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_quasiquote);
+ return iqq (SCM_CAR (x), env, 1);
+}
+
+
+SCM_SYNTAX (s_quote, "quote", scm_makmmacro, scm_m_quote);
+SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
+
+SCM
+scm_m_quote (SCM xorig, SCM env SCM_UNUSED)
+{
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_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_makmmacro, scm_m_set_x); */
+static const char s_set_x[] = "set!";
+SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x);
+
+SCM
+scm_m_set_x (SCM xorig, SCM env SCM_UNUSED)
+{
+ SCM x = SCM_CDR (xorig);
+ SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, s_set_x);
+ SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), scm_s_variable, s_set_x);
+ return scm_cons (SCM_IM_SET_X, x);
+}
+
+
+/* Start of the memoizers for non-R5RS builtin macros. */
+
+
+SCM_SYNTAX (s_atapply, "@apply", scm_makmmacro, scm_m_apply);
+SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply);
+SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
+
+SCM
+scm_m_apply (SCM xorig, SCM env SCM_UNUSED)
+{
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, scm_s_expression, s_atapply);
+ return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig));
+}
+
+
+/* (@bind ((var exp) ...) body ...)
+
+ This will assign the values of the `exp's to the global variables
+ named by `var's (symbols, not evaluated), creating them if they
+ don't exist, executes body, and then restores the previous values of
+ the `var's. Additionally, whenever control leaves body, the values
+ of the `var's are saved and restored when control returns. It is an
+ error when a symbol appears more than once among the `var's.
+ All `exp's are evaluated before any `var' is set.
+
+ Think of this as `let' for dynamic scope.
+
+ It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
+
+ XXX - also implement `@bind*'.
+*/
+
+SCM_SYNTAX (s_atbind, "@bind", scm_makmmacro, scm_m_atbind);
+
+SCM
+scm_m_atbind (SCM xorig, SCM env)
+{
+ SCM x = SCM_CDR (xorig);
+ SCM top_level = scm_env_top_level (env);
+ SCM vars = SCM_EOL, var;
+ SCM exps = SCM_EOL;
+
+ SCM_ASSYNT (scm_ilength (x) > 1, scm_s_expression, s_atbind);
+
+ x = SCM_CAR (x);
+ while (SCM_NIMP (x))
+ {
+ SCM rest;
+ SCM sym_exp = SCM_CAR (x);
+ SCM_ASSYNT (scm_ilength (sym_exp) == 2, scm_s_bindings, s_atbind);
+ SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp)), scm_s_bindings, s_atbind);
+ x = SCM_CDR (x);
+ for (rest = x; SCM_NIMP (rest); rest = SCM_CDR (rest))
+ if (SCM_EQ_P (SCM_CAR (sym_exp), SCM_CAAR (rest)))
+ scm_misc_error (s_atbind, scm_s_duplicate_bindings, SCM_EOL);
+ /* The first call to scm_sym2var will look beyond the current
+ module, while the second call wont. */
+ var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_F);
+ if (SCM_FALSEP (var))
+ var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_T);
+ vars = scm_cons (var, vars);
+ exps = scm_cons (SCM_CADR (sym_exp), exps);
+ }
+ return scm_cons (SCM_IM_BIND,
+ scm_cons (scm_cons (scm_reverse_x (vars, SCM_EOL), exps),
+ SCM_CDDR (xorig)));
}
-/* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
- * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
- * reversed here, the list of inits gets reversed during evaluation. */
-static void
-transform_bindings (SCM bindings, SCM *rvarloc, SCM *initloc, const char *what)
-{
- SCM rvars = SCM_EOL;
- *rvarloc = SCM_EOL;
- *initloc = SCM_EOL;
-
- SCM_ASSYNT (scm_ilength (bindings) >= 1, scm_s_bindings, what);
+SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_makmmacro, scm_m_cont);
+SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc);
- do
- {
- SCM binding = SCM_CAR (bindings);
- SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, what);
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, what);
- if (scm_c_improper_memq (SCM_CAR (binding), rvars))
- scm_misc_error (what, scm_s_duplicate_bindings, SCM_EOL);
- rvars = scm_cons (SCM_CAR (binding), rvars);
- *initloc = scm_list_1 (SCM_CADR (binding));
- initloc = SCM_CDRLOC (*initloc);
- bindings = SCM_CDR (bindings);
- }
- while (!SCM_NULLP (bindings));
- *rvarloc = rvars;
+SCM
+scm_m_cont (SCM xorig, SCM env SCM_UNUSED)
+{
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
+ scm_s_expression, s_atcall_cc);
+ return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));
}
-SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec);
-SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
+SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_makmmacro, scm_m_at_call_with_values);
+SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);
-SCM
-scm_m_letrec (SCM xorig, SCM env)
+SCM
+scm_m_at_call_with_values (SCM xorig, SCM env SCM_UNUSED)
{
- SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letrec);
-
- if (SCM_NULLP (SCM_CAR (x)))
- {
- /* null binding, let* faster */
- SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), s_letrec);
- return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL, body), env);
- }
- else
- {
- SCM rvars, inits, body;
- transform_bindings (SCM_CAR (x), &rvars, &inits, "letrec");
- body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), "letrec");
- return scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body));
- }
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2,
+ scm_s_expression, s_at_call_with_values);
+ return scm_cons (SCM_IM_CALL_WITH_VALUES, SCM_CDR (xorig));
}
-SCM_SYNTAX(s_let, "let", scm_makmmacro, scm_m_let);
-SCM_GLOBAL_SYMBOL(scm_sym_let, s_let);
+SCM_SYNTAX (s_future, "future", scm_makmmacro, scm_m_future);
+SCM_GLOBAL_SYMBOL (scm_sym_future, s_future);
+/* Like promises, futures are implemented as closures with an empty
+ * parameter list. Thus, (future <expression>) is transformed into
+ * (#@future '() <expression>), where the empty list represents the
+ * empty parameter list. This representation allows for easy creation
+ * of the closure during evaluation. */
SCM
-scm_m_let (SCM xorig, SCM env)
+scm_m_future (SCM xorig, SCM env SCM_UNUSED)
{
- SCM x = SCM_CDR (xorig);
- SCM temp;
-
- SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_let);
- temp = SCM_CAR (x);
- if (SCM_NULLP (temp)
- || (scm_ilength (temp) == 1 && SCM_CONSP (SCM_CAR (temp))))
- {
- /* null or single binding, let* is faster */
- SCM bindings = temp;
- SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (x), s_let);
- return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), bindings, body), env);
- }
- else if (SCM_CONSP (temp))
- {
- /* 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_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_future);
+ return scm_cons2 (SCM_IM_FUTURE, SCM_EOL, SCM_CDR (xorig));
+}
- SCM name = temp;
- SCM vars = SCM_EOL;
- SCM *varloc = &vars;
- SCM inits = SCM_EOL;
- SCM *initloc = &inits;
- SCM bindings;
- SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_bindings, s_let);
- x = SCM_CDR (x);
- SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_let);
- bindings = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_let);
- while (!SCM_NULLP (bindings))
- { /* vars and inits both in order */
- SCM binding = SCM_CAR (bindings);
- SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, s_let);
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, s_let);
- *varloc = scm_list_1 (SCM_CAR (binding));
- varloc = SCM_CDRLOC (*varloc);
- *initloc = scm_list_1 (SCM_CADR (binding));
- initloc = SCM_CDRLOC (*initloc);
- bindings = SCM_CDR (bindings);
- }
+SCM_SYNTAX (s_gset_x, "set!", scm_makmmacro, scm_m_generalized_set_x);
+SCM_SYMBOL (scm_sym_setter, "setter");
- {
- 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
+scm_m_generalized_set_x (SCM xorig, SCM env SCM_UNUSED)
+{
+ SCM x = SCM_CDR (xorig);
+ SCM_ASSYNT (2 == scm_ilength (x), scm_s_expression, s_set_x);
+ if (SCM_SYMBOLP (SCM_CAR (x)))
+ return scm_cons (SCM_IM_SET_X, x);
+ else if (SCM_CONSP (SCM_CAR (x)))
+ return scm_cons (scm_list_2 (scm_sym_setter, SCM_CAAR (x)),
+ scm_append (scm_list_2 (SCM_CDAR (x), SCM_CDR (x))));
+ else
+ scm_misc_error (s_set_x, scm_s_variable, SCM_EOL);
}
-SCM_SYNTAX (s_atapply, "@apply", scm_makmmacro, scm_m_apply);
-SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply);
-SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
+static const char* s_atslot_ref = "@slot-ref";
-SCM
-scm_m_apply (SCM xorig, SCM env SCM_UNUSED)
+/* @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_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, scm_s_expression, s_atapply);
- return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig));
+ SCM x = SCM_CDR (xorig);
+ SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, FUNC_NAME);
+ SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x));
+ return scm_cons (SCM_IM_SLOT_REF, x);
}
+#undef FUNC_NAME
-SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_makmmacro, scm_m_cont);
-SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc);
-
+static const char* s_atslot_set_x = "@slot-set!";
-SCM
-scm_m_cont (SCM xorig, SCM env SCM_UNUSED)
+/* @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_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
- scm_s_expression, s_atcall_cc);
- return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));
+ SCM x = SCM_CDR (xorig);
+ SCM_ASSYNT (scm_ilength (x) == 3, scm_s_expression, FUNC_NAME);
+ SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x));
+ return scm_cons (SCM_IM_SLOT_SET_X, x);
}
+#undef FUNC_NAME
+
#if SCM_ENABLE_ELISP
return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig));
}
+
SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop);
SCM
#endif /* SCM_ENABLE_ELISP */
-/* (@bind ((var exp) ...) body ...)
-
- This will assign the values of the `exp's to the global variables
- named by `var's (symbols, not evaluated), creating them if they
- don't exist, executes body, and then restores the previous values of
- the `var's. Additionally, whenever control leaves body, the values
- of the `var's are saved and restored when control returns. It is an
- error when a symbol appears more than once among the `var's.
- All `exp's are evaluated before any `var' is set.
-
- Think of this as `let' for dynamic scope.
-
- It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
-
- XXX - also implement `@bind*'.
-*/
-
-SCM_SYNTAX (s_atbind, "@bind", scm_makmmacro, scm_m_atbind);
-
-SCM
-scm_m_atbind (SCM xorig, SCM env)
-{
- SCM x = SCM_CDR (xorig);
- SCM top_level = scm_env_top_level (env);
- SCM vars = SCM_EOL, var;
- SCM exps = SCM_EOL;
-
- SCM_ASSYNT (scm_ilength (x) > 1, scm_s_expression, s_atbind);
-
- x = SCM_CAR (x);
- while (SCM_NIMP (x))
- {
- SCM rest;
- SCM sym_exp = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (sym_exp) == 2, scm_s_bindings, s_atbind);
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp)), scm_s_bindings, s_atbind);
- x = SCM_CDR (x);
- for (rest = x; SCM_NIMP (rest); rest = SCM_CDR (rest))
- if (SCM_EQ_P (SCM_CAR (sym_exp), SCM_CAAR (rest)))
- scm_misc_error (s_atbind, scm_s_duplicate_bindings, SCM_EOL);
- /* The first call to scm_sym2var will look beyond the current
- module, while the second call wont. */
- var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_F);
- if (SCM_FALSEP (var))
- var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_T);
- vars = scm_cons (var, vars);
- exps = scm_cons (SCM_CADR (sym_exp), exps);
- }
- return scm_cons (SCM_IM_BIND,
- scm_cons (scm_cons (scm_reverse_x (vars, SCM_EOL), exps),
- SCM_CDDR (xorig)));
-}
-
-SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_makmmacro, scm_m_at_call_with_values);
-SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);
-
-SCM
-scm_m_at_call_with_values (SCM xorig, SCM env SCM_UNUSED)
-{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2,
- scm_s_expression, s_at_call_with_values);
- return scm_cons (SCM_IM_CALL_WITH_VALUES, SCM_CDR (xorig));
-}
SCM
scm_m_expand_body (SCM xorig, SCM env)
names = SCM_CAR (x);
x = SCM_CDR (x);
inits = scm_reverse (unmemocopy (SCM_CAR (x), env));
- env = EXTEND_ENV (names, SCM_EOL, env);
+ env = SCM_EXTEND_ENV (names, SCM_EOL, env);
x = SCM_CDR (x);
test = unmemocopy (SCM_CAR (x), env);
x = SCM_CDR (x);
names = SCM_CAR (x);
x = SCM_CDR (x);
inits = scm_reverse (unmemocopy (SCM_CAR (x), env));
- env = EXTEND_ENV (names, SCM_EOL, env);
+ env = SCM_EXTEND_ENV (names, SCM_EOL, env);
bindings = build_binding_list (names, inits);
z = scm_cons (bindings, SCM_UNSPECIFIED);
x = SCM_CDR (x);
names = SCM_CAR (x);
- env = EXTEND_ENV (names, SCM_EOL, env);
+ env = SCM_EXTEND_ENV (names, SCM_EOL, env);
x = SCM_CDR (x);
inits = scm_reverse (unmemocopy (SCM_CAR (x), env));
y = SCM_EOL;
if SCM_IMP (b)
{
- env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
+ env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env);
goto letstar;
}
y = z = scm_acons (SCM_CAR (b),
unmemocar (
scm_cons (unmemocopy (SCM_CADR (b), env), SCM_EOL), env),
SCM_UNSPECIFIED);
- env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
+ env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
b = SCM_CDDR (b);
if (SCM_IMP (b))
{
scm_list_1 (unmemocopy (SCM_CADR (b), env)), env),
SCM_UNSPECIFIED));
z = SCM_CDR (z);
- env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
+ env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
b = SCM_CDDR (b);
}
while (SCM_NIMP (b));
x = SCM_CDR (x);
z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED);
ls = scm_cons (scm_sym_lambda, z);
- env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
+ env = SCM_EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
break;
case SCM_BIT7 (SCM_IM_QUOTE):
ls = z = scm_cons (scm_sym_quote, SCM_UNSPECIFIED);
return results;
}
+
SCM
scm_eval_body (SCM code, SCM env)
{
return SCM_XEVALCAR (code, env);
}
-
#endif /* !DEVAL */
}
#undef FUNC_NAME
+
SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
(SCM setting),
"Option interface for the evaluator trap options.")
}
#undef FUNC_NAME
+
static SCM
deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
{
#define UPDATE_TOPLEVEL_ENV(env) \
do { \
SCM p = scm_current_module_lookup_closure (); \
- if (p != SCM_CAR(env)) \
+ if (p != SCM_CAR (env)) \
env = scm_top_level_env (p); \
} while (0)
init_values = scm_cons (EVALCAR (init_forms, env), init_values);
init_forms = SCM_CDR (init_forms);
}
- env = EXTEND_ENV (SCM_CAR (x), init_values, env);
+ env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
}
x = SCM_CDDR (x);
{
SCM value = EVALCAR (temp_forms, env);
step_values = scm_cons (value, step_values);
}
- env = EXTEND_ENV (SCM_CAAR (env), step_values, SCM_CDR (env));
+ env = SCM_EXTEND_ENV (SCM_CAAR (env),
+ step_values,
+ SCM_CDR (env));
}
test_result = EVALCAR (test_form, env);
init_forms = SCM_CDR (init_forms);
}
while (!SCM_NULLP (init_forms));
- env = EXTEND_ENV (SCM_CAR (x), init_values, env);
+ env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
}
x = SCM_CDDR (x);
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
case SCM_BIT7 (SCM_IM_LETREC):
x = SCM_CDR (x);
- env = EXTEND_ENV (SCM_CAR (x), undefineds, env);
+ env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env);
x = SCM_CDR (x);
{
SCM init_forms = SCM_CAR (x);
{
SCM bindings = SCM_CAR (x);
if (SCM_NULLP (bindings))
- env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
+ env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env);
else
{
do
{
SCM name = SCM_CAR (bindings);
SCM init = SCM_CDR (bindings);
- env = EXTEND_ENV (name, EVALCAR (init, env), env);
+ env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env);
bindings = SCM_CDR (init);
}
while (!SCM_NULLP (bindings));
ENTER_APPLY;
/* Copy argument list */
if (SCM_NULL_OR_NIL_P (arg1))
- env = EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
+ env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
else
{
SCM args = scm_list_1 (SCM_CAR (arg1));
tail = new_tail;
arg1 = SCM_CDR (arg1);
}
- env = EXTEND_ENV (formals, args, SCM_ENV (proc));
+ env = SCM_EXTEND_ENV (formals, args, SCM_ENV (proc));
}
x = SCM_CLOSURE_BODY (proc);
RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env)));
- case (SCM_ISYMNUM (SCM_IM_DISPATCH)):
- {
- /* If not done yet, evaluate the operand forms. The result is a
- * list of arguments stored in arg1, which is used to perform the
- * function dispatch. */
- SCM operand_forms = SCM_CADR (x);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- if (SCM_ILOCP (operand_forms))
- arg1 = *scm_ilookup (operand_forms, env);
- else if (SCM_VARIABLEP (operand_forms))
- arg1 = SCM_VARIABLE_REF (operand_forms);
- else if (!SCM_CONSP (operand_forms))
- arg1 = *scm_lookupcar (SCM_CDR (x), env, 1);
- else
- {
- SCM tail = arg1 = scm_list_1 (EVALCAR (operand_forms, env));
- operand_forms = SCM_CDR (operand_forms);
- while (!SCM_NULLP (operand_forms))
- {
- SCM new_tail = scm_list_1 (EVALCAR (operand_forms, env));
- SCM_SETCDR (tail, new_tail);
- tail = new_tail;
- operand_forms = SCM_CDR (operand_forms);
- }
- }
- }
-
+ /* 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%. */
apply_cmethod: /* inputs: z, arg1 */
{
SCM formals = SCM_CMETHOD_FORMALS (z);
- env = EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
+ env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
x = SCM_CMETHOD_BODY (z);
goto nontoplevel_begin;
}
goto umwrongnumargs;
case scm_tcs_closures:
x = SCM_CLOSURE_BODY (proc);
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), SCM_EOL, SCM_ENV (proc));
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ SCM_EOL,
+ SCM_ENV (proc));
goto nontoplevel_begin;
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
/* clos1: */
x = SCM_CLOSURE_BODY (proc);
#ifdef DEVAL
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc));
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ debug.info->a.args,
+ SCM_ENV (proc));
#else
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_list_1 (arg1), SCM_ENV (proc));
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ scm_list_1 (arg1),
+ SCM_ENV (proc));
#endif
goto nontoplevel_begin;
case scm_tcs_struct:
case scm_tcs_closures:
/* clos2: */
#ifdef DEVAL
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- debug.info->a.args,
- SCM_ENV (proc));
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ debug.info->a.args,
+ SCM_ENV (proc));
#else
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- scm_list_2 (arg1, arg2), SCM_ENV (proc));
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ scm_list_2 (arg1, arg2),
+ SCM_ENV (proc));
#endif
x = SCM_CLOSURE_BODY (proc);
goto nontoplevel_begin;
goto umwrongnumargs;
case scm_tcs_closures:
SCM_SET_ARGSREADY (debug);
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- debug.info->a.args,
- SCM_ENV (proc));
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ debug.info->a.args,
+ SCM_ENV (proc));
x = SCM_CLOSURE_BODY (proc);
goto nontoplevel_begin;
#else /* DEVAL */
#ifdef DEVAL
SCM_SET_ARGSREADY (debug);
#endif
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- scm_cons2 (arg1,
- arg2,
- scm_eval_args (x, env, proc)),
- SCM_ENV (proc));
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ scm_cons2 (arg1,
+ arg2,
+ scm_eval_args (x, env, proc)),
+ SCM_ENV (proc));
x = SCM_CLOSURE_BODY (proc);
goto nontoplevel_begin;
#endif /* DEVAL */
#ifndef DEVAL
\f
+
/* Simple procedure calls
*/
#if 0
SCM
scm_dapply (SCM proc, SCM arg1, SCM args)
-{ /* empty */ }
+{}
#endif
SCM_SETCDR (tl, arg1);
}
- args = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), args, SCM_ENV (proc));
+ args = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ args,
+ SCM_ENV (proc));
proc = SCM_CLOSURE_BODY (proc);
again:
arg1 = SCM_CDR (proc);
SCM
scm_i_call_closure_0 (SCM proc)
{
- return scm_eval_body (SCM_CLOSURE_BODY (proc),
- SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- SCM_EOL,
- SCM_ENV (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 0;
+ return NULL;
if (SCM_DEBUGGINGP)
return scm_call_0;
switch (SCM_TYP7 (proc))
if (SCM_NULLP (formals) || !SCM_CONSP (formals))
return scm_i_call_closure_0;
else
- return 0;
+ 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 0;
+ return NULL;
return scm_call_0;
case scm_tc7_smob:
if (SCM_SMOB_APPLICABLE_P (proc))
return SCM_SMOB_DESCRIPTOR (proc).apply_0;
else
- return 0;
- /* fall through */
+ return NULL;
case scm_tc7_asubr:
case scm_tc7_rpsubr:
case scm_tc7_cclo:
case scm_tc7_pws:
return scm_call_0;
default:
- return 0; /* not applicable on one arg */
+ return NULL; /* not applicable on one arg */
}
}
static SCM
call_closure_1 (SCM proc, SCM arg1)
{
- return scm_eval_body (SCM_CLOSURE_BODY (proc),
- SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- scm_list_1 (arg1),
- SCM_ENV (proc)));
+ 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 0;
+ return NULL;
if (SCM_DEBUGGINGP)
return scm_call_1;
switch (SCM_TYP7 (proc))
&& (!SCM_CONSP (formals) || !SCM_CONSP (SCM_CDR (formals))))
return call_closure_1;
else
- return 0;
+ 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 0;
+ return NULL;
return scm_call_1;
case scm_tc7_smob:
if (SCM_SMOB_APPLICABLE_P (proc))
return SCM_SMOB_DESCRIPTOR (proc).apply_1;
else
- return 0;
- /* fall through */
+ return NULL;
case scm_tc7_asubr:
case scm_tc7_rpsubr:
case scm_tc7_cclo:
case scm_tc7_pws:
return scm_call_1;
default:
- return 0; /* not applicable on one arg */
+ return NULL; /* not applicable on one arg */
}
}
static SCM
call_closure_2 (SCM proc, SCM arg1, SCM arg2)
{
- return scm_eval_body (SCM_CLOSURE_BODY (proc),
- SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- scm_list_2 (arg1, arg2),
- SCM_ENV (proc)));
+ 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 0;
+ return NULL;
if (SCM_DEBUGGINGP)
return scm_call_2;
switch (SCM_TYP7 (proc))
|| !SCM_CONSP (SCM_CDDR (formals))))))
return call_closure_2;
else
- return 0;
+ 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 0;
+ return NULL;
return scm_call_2;
case scm_tc7_smob:
if (SCM_SMOB_APPLICABLE_P (proc))
return SCM_SMOB_DESCRIPTOR (proc).apply_2;
else
- return 0;
- /* fall through */
+ return NULL;
case scm_tc7_cclo:
case scm_tc7_pws:
return scm_call_2;
default:
- return 0; /* not applicable on two args */
+ return NULL; /* not applicable on two args */
}
}
HCoop / bpt / guile.git / blobdiff