-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
\f
-#define _GNU_SOURCE
-
/* SECTION: This code is compiled once.
*/
-#if HAVE_CONFIG_H
+#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
-#include "libguile/__scm.h"
+#include <alloca.h>
-/* This blob per the Autoconf manual (under "Particular Functions"). */
-#if HAVE_ALLOCA_H
-# include <alloca.h>
-#elif defined __GNUC__
-# define alloca __builtin_alloca
-#elif defined _AIX
-# define alloca __alloca
-#elif defined _MSC_VER
-# include <malloc.h>
-# define alloca _alloca
-#else
-# include <stddef.h>
-# ifdef __cplusplus
-extern "C"
-# endif
-void *alloca (size_t);
-#endif
+#include "libguile/__scm.h"
#include <assert.h>
#include "libguile/_scm.h"
/* 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); }
+#define ASSERT_SYNTAX(cond, message, form) \
+ { if (SCM_UNLIKELY (!(cond))) \
+ syntax_error (message, form, SCM_UNDEFINED); }
+#define ASSERT_SYNTAX_2(cond, message, form, expr) \
+ { if (SCM_UNLIKELY (!(cond))) \
+ syntax_error (message, form, expr); }
\f
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);
-
- /* 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;
+ 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. */
unmemoize_delay (const SCM expr, const SCM env)
{
const SCM thunk_expr = SCM_CADDR (expr);
- return scm_list_2 (scm_sym_delay, unmemoize_expression (thunk_expr, env));
+ /* A promise is implemented as a closure, and when applying a
+ closure the evaluator adds a new frame to the environment - even
+ though, in the case of a promise, the added frame is always
+ empty. We need to extend the environment here in the same way,
+ so that any ILOCs in thunk_expr can be unmemoized correctly. */
+ const SCM new_env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env);
+ return scm_list_2 (scm_sym_delay, unmemoize_expression (thunk_expr, new_env));
}
return scm_list_2 (scm_sym_future, unmemoize_expression (thunk_expr, env));
}
-#endif
+#endif /* futures disabled. */
SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x);
SCM_SYMBOL (scm_sym_setter, "setter");
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 SCM
promise_mark (SCM promise)
if (scm_is_dynamic_state (module_or_state))
scm_dynwind_current_dynamic_state (module_or_state);
else
- scm_dynwind_current_module (module_or_state);
+ {
+ SCM_VALIDATE_MODULE (2, module_or_state);
+ scm_dynwind_current_module (module_or_state);
+ }
res = scm_primitive_eval (exp);
HCoop / bpt / guile.git / blobdiff