summaryrefslogtreecommitdiff
path: root/libguile/eval.c
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2009-09-02 00:07:27 +0200
committerLudovic Courtès <ludo@gnu.org>2009-09-02 01:37:37 +0200
commit5f236208d0d864546e59afa0f5a11c9b3ba14b10 (patch)
treeeed5d9203a2633c8efb85c1b36425eab87574299 /libguile/eval.c
parentf0eb5ae6c173aed35965b0561897fda1d8ff0db1 (diff)
parentd7e7a02a6251c8ed4f76933d9d30baeee3f599c0 (diff)
downloadguile-5f236208d0d864546e59afa0f5a11c9b3ba14b10.tar.gz
Merge branch 'boehm-demers-weiser-gc' into bdw-gc-static-alloc
Conflicts: acinclude.m4 libguile/strings.c
Diffstat (limited to 'libguile/eval.c')
-rw-r--r--libguile/eval.c473
1 files changed, 284 insertions, 189 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index 18cd3b11f..e58c05410 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -2,18 +2,19 @@
* 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.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 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
+ * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -52,6 +53,7 @@
#include "libguile/ports.h"
#include "libguile/print.h"
#include "libguile/procprop.h"
+#include "libguile/programs.h"
#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/srcprop.h"
@@ -62,6 +64,7 @@
#include "libguile/validate.h"
#include "libguile/values.h"
#include "libguile/vectors.h"
+#include "libguile/vm.h"
#include "libguile/eval.h"
#include "libguile/private-options.h"
@@ -304,6 +307,9 @@ syntax_error (const char* const msg, const SCM form, const SCM expr)
{ if (SCM_UNLIKELY (!(cond))) \
syntax_error (message, form, expr); }
+static void error_unbound_variable (SCM symbol) SCM_NORETURN;
+static void error_defined_variable (SCM symbol) SCM_NORETURN;
+
/* {Ilocs}
@@ -704,6 +710,101 @@ is_system_macro_p (const SCM syntactic_keyword, const SCM form, const SCM env)
return 0;
}
+static 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_is_symbol (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)
+ /* Result of expansion is not a list. */
+ return (scm_list_2 (SCM_IM_BEGIN, res));
+ else
+ {
+ /* njrev: Several queries here: (1) I don't see how it can be
+ correct that the SCM_SETCAR 2 lines below this comment needs
+ protection, but the SCM_SETCAR 6 lines above does not, so
+ something here is probably wrong. (2) macroexp() is now only
+ used in one place - scm_m_generalized_set_x - whereas all other
+ macro expansion happens through expand_user_macros. Therefore
+ (2.1) perhaps macroexp() could be eliminated completely now?
+ (2.2) Does expand_user_macros need any critical section
+ protection? */
+
+ SCM_CRITICAL_SECTION_START;
+ SCM_SETCAR (x, SCM_CAR (res));
+ SCM_SETCDR (x, SCM_CDR (res));
+ SCM_CRITICAL_SECTION_END;
+
+ goto macro_tail;
+ }
+}
+
+
+/* Start of the memoizers for the standard R5RS builtin macros. */
+
+static SCM scm_m_quote (SCM xorig, SCM env);
+static SCM scm_m_begin (SCM xorig, SCM env);
+static SCM scm_m_if (SCM xorig, SCM env);
+static SCM scm_m_set_x (SCM xorig, SCM env);
+static SCM scm_m_and (SCM xorig, SCM env);
+static SCM scm_m_or (SCM xorig, SCM env);
+static SCM scm_m_case (SCM xorig, SCM env);
+static SCM scm_m_cond (SCM xorig, SCM env);
+static SCM scm_m_lambda (SCM xorig, SCM env);
+static SCM scm_m_letstar (SCM xorig, SCM env);
+static SCM scm_m_do (SCM xorig, SCM env);
+static SCM scm_m_quasiquote (SCM xorig, SCM env);
+static SCM scm_m_delay (SCM xorig, SCM env);
+static SCM scm_m_generalized_set_x (SCM xorig, SCM env);
+#if 0 /* Futures are disabled, see "futures.h". */
+static SCM scm_m_future (SCM xorig, SCM env);
+#endif
+static SCM scm_m_define (SCM x, SCM env);
+static SCM scm_m_letrec (SCM xorig, SCM env);
+static SCM scm_m_let (SCM xorig, SCM env);
+static SCM scm_m_at (SCM xorig, SCM env);
+static SCM scm_m_atat (SCM xorig, SCM env);
+static SCM scm_m_atslot_ref (SCM xorig, SCM env);
+static SCM scm_m_atslot_set_x (SCM xorig, SCM env);
+static SCM scm_m_apply (SCM xorig, SCM env);
+static SCM scm_m_cont (SCM xorig, SCM env);
+#if SCM_ENABLE_ELISP
+static SCM scm_m_nil_cond (SCM xorig, SCM env);
+static SCM scm_m_atfop (SCM xorig, SCM env);
+#endif /* SCM_ENABLE_ELISP */
+static SCM scm_m_atbind (SCM xorig, SCM env);
+static SCM scm_m_at_call_with_values (SCM xorig, SCM env);
+static SCM scm_m_eval_when (SCM xorig, SCM env);
+
+
static void
m_expand_body (const SCM forms, const SCM env)
{
@@ -826,70 +927,10 @@ m_expand_body (const SCM forms, const SCM env)
}
}
-static 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_is_symbol (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)
- /* Result of expansion is not a list. */
- return (scm_list_2 (SCM_IM_BEGIN, res));
- else
- {
- /* njrev: Several queries here: (1) I don't see how it can be
- correct that the SCM_SETCAR 2 lines below this comment needs
- protection, but the SCM_SETCAR 6 lines above does not, so
- something here is probably wrong. (2) macroexp() is now only
- used in one place - scm_m_generalized_set_x - whereas all other
- macro expansion happens through expand_user_macros. Therefore
- (2.1) perhaps macroexp() could be eliminated completely now?
- (2.2) Does expand_user_macros need any critical section
- protection? */
-
- SCM_CRITICAL_SECTION_START;
- SCM_SETCAR (x, SCM_CAR (res));
- SCM_SETCDR (x, SCM_CDR (res));
- SCM_CRITICAL_SECTION_END;
-
- goto macro_tail;
- }
-}
-
-/* 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_GLOBAL_SYMBOL (scm_sym_and, "and");
-SCM
+static SCM
scm_m_and (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -917,9 +958,9 @@ unmemoize_and (const SCM expr, const SCM env)
SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
-SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
+SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
-SCM
+static SCM
scm_m_begin (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -940,10 +981,10 @@ unmemoize_begin (const SCM expr, const SCM env)
SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case);
-SCM_GLOBAL_SYMBOL (scm_sym_case, s_case);
+SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
-SCM
+static SCM
scm_m_case (SCM expr, SCM env)
{
SCM clauses;
@@ -1036,10 +1077,10 @@ unmemoize_case (const SCM expr, const SCM env)
SCM_SYNTAX (s_cond, "cond", scm_i_makbimacro, scm_m_cond);
-SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond);
+SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
-SCM
+static SCM
scm_m_cond (SCM expr, SCM env)
{
/* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
@@ -1139,7 +1180,7 @@ unmemoize_cond (const SCM expr, const SCM env)
SCM_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define);
-SCM_GLOBAL_SYMBOL (scm_sym_define, s_define);
+SCM_GLOBAL_SYMBOL (scm_sym_define, "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
@@ -1201,7 +1242,7 @@ canonicalize_define (const SCM expr)
operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
bound. This means that EXPRESSION won't necessarily be able to assign
values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
-SCM
+static SCM
scm_m_define (SCM expr, SCM env)
{
ASSERT_SYNTAX (SCM_TOP_LEVEL (env), s_bad_define, expr);
@@ -1250,13 +1291,13 @@ memoize_as_thunk_prototype (const SCM expr, const SCM env SCM_UNUSED)
SCM_SYNTAX (s_delay, "delay", scm_i_makbimacro, scm_m_delay);
-SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
+SCM_GLOBAL_SYMBOL (scm_sym_delay, "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
+static SCM
scm_m_delay (SCM expr, SCM env)
{
const SCM new_expr = memoize_as_thunk_prototype (expr, env);
@@ -1279,7 +1320,7 @@ unmemoize_delay (const SCM expr, const SCM env)
SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do);
-SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
+SCM_GLOBAL_SYMBOL(scm_sym_do, "do");
/* DO gets the most radically altered syntax. The order of the vars is
* reversed here. During the evaluation this allows for simple consing of the
@@ -1299,7 +1340,7 @@ SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
(<body>)
<step1> <step2> ... <stepn>) ;; missing steps replaced by var
*/
-SCM
+static SCM
scm_m_do (SCM expr, SCM env SCM_UNUSED)
{
SCM variables = SCM_EOL;
@@ -1395,9 +1436,9 @@ unmemoize_do (const SCM expr, const SCM env)
SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if);
-SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
+SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
-SCM
+static SCM
scm_m_if (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -1429,7 +1470,7 @@ unmemoize_if (const SCM expr, const SCM env)
SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, scm_m_lambda);
-SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda);
+SCM_GLOBAL_SYMBOL (scm_sym_lambda, "lambda");
/* A helper function for memoize_lambda to support checking for duplicate
* formal arguments: Return true if OBJ is `eq?' to one of the elements of
@@ -1447,7 +1488,7 @@ c_improper_memq (SCM obj, SCM list)
return scm_is_eq (list, obj);
}
-SCM
+static SCM
scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
{
SCM formals;
@@ -1577,7 +1618,7 @@ transform_bindings (
SCM_SYNTAX(s_let, "let", scm_i_makbimacro, scm_m_let);
-SCM_GLOBAL_SYMBOL(scm_sym_let, s_let);
+SCM_GLOBAL_SYMBOL(scm_sym_let, "let");
/* This function is a helper function for memoize_let. It transforms
* (let name ((var init) ...) body ...) into
@@ -1617,7 +1658,7 @@ memoize_named_let (const SCM expr, const SCM env SCM_UNUSED)
/* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
* i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
-SCM
+static SCM
scm_m_let (SCM expr, SCM env)
{
SCM bindings;
@@ -1689,9 +1730,9 @@ unmemoize_let (const SCM expr, const SCM env)
SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec);
-SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
+SCM_GLOBAL_SYMBOL(scm_sym_letrec, "letrec");
-SCM
+static SCM
scm_m_letrec (SCM expr, SCM env)
{
SCM bindings;
@@ -1738,11 +1779,11 @@ unmemoize_letrec (const SCM expr, const SCM env)
SCM_SYNTAX (s_letstar, "let*", scm_i_makbimacro, scm_m_letstar);
-SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);
+SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*");
/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
* i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
-SCM
+static SCM
scm_m_letstar (SCM expr, SCM env SCM_UNUSED)
{
SCM binding_idx;
@@ -1813,9 +1854,9 @@ unmemoize_letstar (const SCM expr, const SCM env)
SCM_SYNTAX (s_or, "or", scm_i_makbimacro, scm_m_or);
-SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
+SCM_GLOBAL_SYMBOL (scm_sym_or, "or");
-SCM
+static SCM
scm_m_or (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -1843,7 +1884,7 @@ unmemoize_or (const SCM expr, const SCM env)
SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
-SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);
+SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
@@ -1899,7 +1940,7 @@ iqq (SCM form, SCM env, unsigned long int depth)
return form;
}
-SCM
+static SCM
scm_m_quasiquote (SCM expr, SCM env)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -1910,9 +1951,9 @@ scm_m_quasiquote (SCM expr, SCM env)
SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote);
-SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
+SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
-SCM
+static SCM
scm_m_quote (SCM expr, SCM env SCM_UNUSED)
{
SCM quotee;
@@ -1938,10 +1979,9 @@ unmemoize_quote (const SCM expr, const SCM env SCM_UNUSED)
/* 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_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
-SCM
+static SCM
scm_m_set_x (SCM expr, SCM env SCM_UNUSED)
{
SCM variable;
@@ -1971,14 +2011,57 @@ unmemoize_set_x (const SCM expr, const SCM env)
}
+
/* Start of the memoizers for non-R5RS builtin macros. */
+SCM_SYNTAX (s_at, "@", scm_makmmacro, scm_m_at);
+SCM_GLOBAL_SYMBOL (scm_sym_at, "@");
+
+static SCM
+scm_m_at (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM mod, var;
+ ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr)), s_bad_expression, expr);
+
+ mod = scm_resolve_module (scm_cadr (expr));
+ if (scm_is_false (mod))
+ error_unbound_variable (expr);
+ var = scm_module_variable (scm_module_public_interface (mod), scm_caddr (expr));
+ if (scm_is_false (var))
+ error_unbound_variable (expr);
+
+ return var;
+}
+
+SCM_SYNTAX (s_atat, "@@", scm_makmmacro, scm_m_atat);
+SCM_GLOBAL_SYMBOL (scm_sym_atat, "@@");
+
+static SCM
+scm_m_atat (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM mod, var;
+ ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr)), s_bad_expression, expr);
+
+ mod = scm_resolve_module (scm_cadr (expr));
+ if (scm_is_false (mod))
+ error_unbound_variable (expr);
+ var = scm_module_variable (mod, scm_caddr (expr));
+ if (scm_is_false (var))
+ error_unbound_variable (expr);
+
+ return var;
+}
+
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_GLOBAL_SYMBOL (scm_sym_atapply, "@apply");
+SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply");
-SCM
+static SCM
scm_m_apply (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -2015,7 +2098,7 @@ SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind);
*
* FIXME - also implement `@bind*'.
*/
-SCM
+static SCM
scm_m_atbind (SCM expr, SCM env)
{
SCM bindings;
@@ -2052,9 +2135,9 @@ scm_m_atbind (SCM expr, SCM env)
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_GLOBAL_SYMBOL(scm_sym_atcall_cc, "@call-with-current-continuation");
-SCM
+static SCM
scm_m_cont (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -2073,9 +2156,9 @@ unmemoize_atcall_cc (const SCM expr, const SCM env)
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_GLOBAL_SYMBOL(scm_sym_at_call_with_values, "@call-with-values");
-SCM
+static SCM
scm_m_at_call_with_values (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -2093,20 +2176,39 @@ unmemoize_at_call_with_values (const SCM expr, const SCM env)
unmemoize_exprs (SCM_CDR (expr), env));
}
+SCM_SYNTAX (s_eval_when, "eval-when", scm_makmmacro, scm_m_eval_when);
+SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
+SCM_SYMBOL (sym_eval, "eval");
+SCM_SYMBOL (sym_load, "load");
+
+
+static SCM
+scm_m_eval_when (SCM expr, SCM env SCM_UNUSED)
+{
+ ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr);
+
+ if (scm_is_true (scm_memq (sym_eval, scm_cadr (expr)))
+ || scm_is_true (scm_memq (sym_load, scm_cadr (expr))))
+ return scm_cons (SCM_IM_BEGIN, scm_cddr (expr));
+
+ return scm_list_1 (SCM_IM_BEGIN);
+}
+
#if 0
/* See futures.h for a comment why futures are not enabled.
*/
SCM_SYNTAX (s_future, "future", scm_i_makbimacro, scm_m_future);
-SCM_GLOBAL_SYMBOL (scm_sym_future, s_future);
+SCM_GLOBAL_SYMBOL (scm_sym_future, "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
+static SCM
scm_m_future (SCM expr, SCM env)
{
const SCM new_expr = memoize_as_thunk_prototype (expr, env);
@@ -2126,7 +2228,7 @@ unmemoize_future (const SCM expr, const SCM env)
SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x);
SCM_SYMBOL (scm_sym_setter, "setter");
-SCM
+static SCM
scm_m_generalized_set_x (SCM expr, SCM env)
{
SCM target, exp_target;
@@ -2183,9 +2285,11 @@ scm_m_generalized_set_x (SCM expr, SCM env)
* arbitrary modules during the startup phase, the code from goops.c should be
* moved here. */
+SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref);
+SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x);
SCM_SYMBOL (sym_atslot_ref, "@slot-ref");
-SCM
+static SCM
scm_m_atslot_ref (SCM expr, SCM env SCM_UNUSED)
{
SCM slot_nr;
@@ -2218,7 +2322,7 @@ unmemoize_atslot_ref (const SCM expr, const SCM env)
SCM_SYMBOL (sym_atslot_set_x, "@slot-set!");
-SCM
+static SCM
scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED)
{
SCM slot_nr;
@@ -2256,7 +2360,7 @@ SCM_SYNTAX (s_nil_cond, "nil-cond", scm_i_makbimacro, scm_m_nil_cond);
/* nil-cond expressions have the form
* (nil-cond COND VAL COND VAL ... ELSEVAL) */
-SCM
+static SCM
scm_m_nil_cond (SCM expr, SCM env SCM_UNUSED)
{
const long length = scm_ilength (SCM_CDR (expr));
@@ -2279,7 +2383,7 @@ SCM_SYNTAX (s_atfop, "@fop", scm_i_makbimacro, scm_m_atfop);
* if the value of var (across all aliasing) is not a macro, or
* (<un-aliased var> <expr> ...)
* if var is a macro. */
-SCM
+static SCM
scm_m_atfop (SCM expr, SCM env SCM_UNUSED)
{
SCM location;
@@ -2450,20 +2554,11 @@ scm_i_unmemocopy_body (SCM forms, SCM env)
#if (SCM_ENABLE_DEPRECATED == 1)
-/* Deprecated in guile 1.7.0 on 2003-11-09. */
-SCM
-scm_m_expand_body (SCM exprs, SCM env)
-{
- scm_c_issue_deprecation_warning
- ("`scm_m_expand_body' is deprecated.");
- m_expand_body (exprs, env);
- return exprs;
-}
-
+static SCM scm_m_undefine (SCM expr, SCM env);
SCM_SYNTAX (s_undefine, "undefine", scm_makacro, scm_m_undefine);
-SCM
+static SCM
scm_m_undefine (SCM expr, SCM env)
{
SCM variable;
@@ -2487,55 +2582,10 @@ scm_m_undefine (SCM expr, SCM env)
return SCM_UNSPECIFIED;
}
-SCM
-scm_macroexp (SCM x, SCM env)
-{
- scm_c_issue_deprecation_warning
- ("`scm_macroexp' is deprecated.");
- return macroexp (x, env);
-}
-
-#endif
-
-
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-SCM
-scm_unmemocar (SCM form, SCM env)
-{
- scm_c_issue_deprecation_warning
- ("`scm_unmemocar' is deprecated.");
-
- if (!scm_is_pair (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_is_false (sym))
- sym = sym_three_question_marks;
- SCM_SETCAR (form, sym);
- }
- else if (SCM_ILOCP (c))
- {
- unsigned long int ir;
-
- for (ir = SCM_IFRAME (c); ir != 0; --ir)
- env = SCM_CDR (env);
- env = SCM_CAAR (env);
- for (ir = SCM_IDIST (c); ir != 0; --ir)
- env = SCM_CDR (env);
-
- SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env));
- }
- return form;
- }
-}
+#endif /* SCM_ENABLE_DEPRECATED */
-#endif
+
/*****************************************************************************/
/*****************************************************************************/
/* The definitions for execution start here. */
@@ -2660,9 +2710,6 @@ scm_ilookup (SCM iloc, SCM env)
SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
-static void error_unbound_variable (SCM symbol) SCM_NORETURN;
-static void error_defined_variable (SCM symbol) SCM_NORETURN;
-
/* Call this for variables that are unfound.
*/
static void
@@ -2965,8 +3012,19 @@ scm_t_option scm_debug_opts[] = {
{ 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." },
+ /* This default stack limit will be overridden by debug.c:init_stack_limit(),
+ if we have getrlimit() and the stack limit is not INFINITY. But it is still
+ important, as some systems have both the soft and the hard limits set to
+ INFINITY; in that case we fall back to this value.
- { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
+ The situation is aggravated by certain compilers, which can consume
+ "beaucoup de stack", as they say in France.
+
+ See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
+ more discussion. This setting is 640 KB on 32-bit arches (should be enough
+ for anyone!) or a whoppin' 1280 KB on 64-bit arches.
+ */
+ { SCM_OPTION_INTEGER, "stack", 160000, "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' "
@@ -3050,32 +3108,56 @@ SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
SCM
scm_call_0 (SCM proc)
{
- return scm_apply (proc, SCM_EOL, SCM_EOL);
+ if (SCM_PROGRAM_P (proc))
+ return scm_c_vm_run (scm_the_vm (), proc, NULL, 0);
+ else
+ return scm_apply (proc, SCM_EOL, SCM_EOL);
}
SCM
scm_call_1 (SCM proc, SCM arg1)
{
- return scm_apply (proc, arg1, scm_listofnull);
+ if (SCM_PROGRAM_P (proc))
+ return scm_c_vm_run (scm_the_vm (), proc, &arg1, 1);
+ else
+ 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));
+ if (SCM_PROGRAM_P (proc))
+ {
+ SCM args[] = { arg1, arg2 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 2);
+ }
+ else
+ 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));
+ if (SCM_PROGRAM_P (proc))
+ {
+ SCM args[] = { arg1, arg2, arg3 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 3);
+ }
+ else
+ 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)));
+ if (SCM_PROGRAM_P (proc))
+ {
+ SCM args[] = { arg1, arg2, arg3, arg4 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 4);
+ }
+ else
+ return scm_apply (proc, arg1, scm_cons2 (arg2, arg3,
+ scm_cons (arg4, scm_listofnull)));
}
/* Simple procedure applies
@@ -3245,6 +3327,7 @@ scm_trampoline_0 (SCM proc)
case scm_tc7_rpsubr:
case scm_tc7_gsubr:
case scm_tc7_pws:
+ case scm_tc7_program:
trampoline = scm_call_0;
break;
default:
@@ -3297,8 +3380,7 @@ call_dsubr_1 (SCM proc, SCM arg1)
{
return (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
}
- SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
- SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc)));
+ SCM_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
}
static SCM
@@ -3371,6 +3453,7 @@ scm_trampoline_1 (SCM proc)
case scm_tc7_rpsubr:
case scm_tc7_gsubr:
case scm_tc7_pws:
+ case scm_tc7_program:
trampoline = scm_call_1;
break;
default:
@@ -3465,6 +3548,7 @@ scm_trampoline_2 (SCM proc)
break;
case scm_tc7_gsubr:
case scm_tc7_pws:
+ case scm_tc7_program:
trampoline = scm_call_2;
break;
default:
@@ -3663,13 +3747,23 @@ scm_closure (SCM code, SCM env)
scm_t_bits scm_tc16_promise;
-SCM
-scm_makprom (SCM code)
-{
+SCM_DEFINE (scm_make_promise, "make-promise", 1, 0, 0,
+ (SCM thunk),
+ "Create a new promise object.\n\n"
+ "@code{make-promise} is a procedural form of @code{delay}.\n"
+ "These two expressions are equivalent:\n"
+ "@lisp\n"
+ "(delay @var{exp})\n"
+ "(make-promise (lambda () @var{exp}))\n"
+ "@end lisp\n")
+#define FUNC_NAME s_scm_make_promise
+{
+ SCM_VALIDATE_THUNK (1, thunk);
SCM_RETURN_NEWSMOB2 (scm_tc16_promise,
- SCM_UNPACK (code),
+ SCM_UNPACK (thunk),
scm_make_recursive_mutex ());
}
+#undef FUNC_NAME
static int
@@ -4020,11 +4114,12 @@ SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
if (scm_is_dynamic_state (module_or_state))
scm_dynwind_current_dynamic_state (module_or_state);
- else
+ else if (scm_module_system_booted_p)
{
SCM_VALIDATE_MODULE (2, module_or_state);
scm_dynwind_current_module (module_or_state);
}
+ /* otherwise if the module system isn't booted, ignore the module arg */
res = scm_primitive_eval (exp);