mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
promises are in their own file now
* libguile.h: * libguile/Makefile.am: * libguile/eval.c: * libguile/eval.h: * libguile/init.c: * libguile/promises.c: * libguile/promises.h: Split promises out into their own file.
This commit is contained in:
Andy Wingo
parent
b7742c6b71
commit
7b89381965
7 changed files with 218 additions and 91 deletions
|
|
@ -80,6 +80,7 @@ extern "C" {
|
|||
#include "libguile/posix.h"
|
||||
#include "libguile/print.h"
|
||||
#include "libguile/procprop.h"
|
||||
#include "libguile/promises.h"
|
||||
#include "libguile/properties.h"
|
||||
#include "libguile/procs.h"
|
||||
#include "libguile/r6rs-ports.h"
|
||||
|
|
|
|||
|
|
@ -167,6 +167,7 @@ libguile_la_SOURCES = \
|
|||
procprop.c \
|
||||
procs.c \
|
||||
programs.c \
|
||||
promises.c \
|
||||
properties.c \
|
||||
r6rs-ports.c \
|
||||
random.c \
|
||||
|
|
@ -260,6 +261,7 @@ DOT_X_FILES = \
|
|||
print.x \
|
||||
procprop.x \
|
||||
procs.x \
|
||||
promises.x \
|
||||
properties.x \
|
||||
r6rs-ports.x \
|
||||
random.x \
|
||||
|
|
@ -357,6 +359,7 @@ DOT_DOC_FILES = \
|
|||
print.doc \
|
||||
procprop.doc \
|
||||
procs.doc \
|
||||
promises.doc \
|
||||
properties.doc \
|
||||
r6rs-ports.doc \
|
||||
random.doc \
|
||||
|
|
@ -525,6 +528,7 @@ modinclude_HEADERS = \
|
|||
procprop.h \
|
||||
procs.h \
|
||||
programs.h \
|
||||
promises.h \
|
||||
properties.h \
|
||||
pthread-threads.h \
|
||||
r6rs-ports.h \
|
||||
|
|
|
|||
|
|
@ -987,72 +987,6 @@ scm_closure (SCM code, SCM env)
|
|||
}
|
||||
|
||||
|
||||
scm_t_bits scm_tc16_promise;
|
||||
|
||||
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 (thunk),
|
||||
scm_make_recursive_mutex ());
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
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_lock_mutex (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_unlock_mutex (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_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise, obj));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0,
|
||||
(SCM exp),
|
||||
"Evaluate @var{exp} in the top-level environment specified by\n"
|
||||
|
|
@ -1138,17 +1072,12 @@ scm_init_eval ()
|
|||
scm_init_opts (scm_eval_options_interface,
|
||||
scm_eval_opts);
|
||||
|
||||
scm_tc16_promise = scm_make_smob_type ("promise", 0);
|
||||
scm_set_smob_print (scm_tc16_promise, promise_print);
|
||||
|
||||
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");
|
||||
}
|
||||
|
||||
/*
|
||||
|
|
|
|||
|
|
@ -46,23 +46,6 @@
|
|||
|
||||
|
||||
|
||||
/* {Promises}
|
||||
*/
|
||||
|
||||
#define SCM_F_PROMISE_COMPUTED (1L << 0)
|
||||
#define SCM_PROMISE_COMPUTED_P(promise) \
|
||||
(SCM_F_PROMISE_COMPUTED & SCM_SMOB_FLAGS (promise))
|
||||
#define SCM_SET_PROMISE_COMPUTED(promise) \
|
||||
SCM_SET_SMOB_FLAGS ((promise), SCM_F_PROMISE_COMPUTED)
|
||||
#define SCM_PROMISE_MUTEX SCM_SMOB_OBJECT_2
|
||||
#define SCM_PROMISE_DATA SCM_SMOB_OBJECT
|
||||
#define SCM_SET_PROMISE_DATA SCM_SET_SMOB_OBJECT
|
||||
|
||||
|
||||
SCM_API scm_t_bits scm_tc16_promise;
|
||||
|
||||
|
||||
|
||||
/* {Evaluator}
|
||||
*/
|
||||
|
||||
|
|
@ -97,9 +80,6 @@ SCM_API SCM scm_apply (SCM proc, SCM arg1, SCM args);
|
|||
SCM_API SCM scm_map (SCM proc, SCM arg1, SCM args);
|
||||
SCM_API SCM scm_for_each (SCM proc, SCM arg1, SCM args);
|
||||
SCM_API SCM scm_closure (SCM code, SCM env);
|
||||
SCM_API SCM scm_make_promise (SCM thunk);
|
||||
SCM_API SCM scm_force (SCM x);
|
||||
SCM_API SCM scm_promise_p (SCM x);
|
||||
SCM_API SCM scm_primitive_eval (SCM exp);
|
||||
#define scm_primitive_eval_x(exp) scm_primitive_eval (exp)
|
||||
SCM_API SCM scm_eval (SCM exp, SCM module);
|
||||
|
|
|
|||
|
|
@ -94,6 +94,7 @@
|
|||
#include "libguile/print.h"
|
||||
#include "libguile/procprop.h"
|
||||
#include "libguile/procs.h"
|
||||
#include "libguile/promises.h"
|
||||
#include "libguile/properties.h"
|
||||
#include "libguile/array-map.h"
|
||||
#include "libguile/random.h"
|
||||
|
|
@ -490,6 +491,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
|
|||
scm_init_hashtab ();
|
||||
scm_init_deprecation (); /* Requires hashtabs */
|
||||
scm_init_objprop ();
|
||||
scm_init_promises ();
|
||||
scm_init_properties ();
|
||||
scm_init_hooks (); /* Requires smob_prehistory */
|
||||
scm_init_gc (); /* Requires hooks, async */
|
||||
|
|
|
|||
150
libguile/promises.c
Normal file
150
libguile/promises.c
Normal file
|
|
@ -0,0 +1,150 @@
|
|||
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
|
||||
* 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 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
|
||||
* 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
|
||||
*/
|
||||
|
||||
|
||||
|
||||
#ifdef HAVE_CONFIG_H
|
||||
# include <config.h>
|
||||
#endif
|
||||
|
||||
#include <alloca.h>
|
||||
|
||||
#include "libguile/__scm.h"
|
||||
|
||||
#include "libguile/_scm.h"
|
||||
#include "libguile/alist.h"
|
||||
#include "libguile/async.h"
|
||||
#include "libguile/continuations.h"
|
||||
#include "libguile/debug.h"
|
||||
#include "libguile/deprecation.h"
|
||||
#include "libguile/dynwind.h"
|
||||
#include "libguile/eq.h"
|
||||
#include "libguile/eval.h"
|
||||
#include "libguile/feature.h"
|
||||
#include "libguile/fluids.h"
|
||||
#include "libguile/goops.h"
|
||||
#include "libguile/hash.h"
|
||||
#include "libguile/hashtab.h"
|
||||
#include "libguile/lang.h"
|
||||
#include "libguile/list.h"
|
||||
#include "libguile/macros.h"
|
||||
#include "libguile/memoize.h"
|
||||
#include "libguile/modules.h"
|
||||
#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"
|
||||
#include "libguile/stackchk.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/threads.h"
|
||||
#include "libguile/throw.h"
|
||||
#include "libguile/validate.h"
|
||||
#include "libguile/values.h"
|
||||
#include "libguile/promises.h"
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
scm_t_bits scm_tc16_promise;
|
||||
|
||||
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 (thunk),
|
||||
scm_make_recursive_mutex ());
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
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_lock_mutex (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_unlock_mutex (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_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise, obj));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
void
|
||||
scm_init_promises ()
|
||||
{
|
||||
scm_tc16_promise = scm_make_smob_type ("promise", 0);
|
||||
scm_set_smob_print (scm_tc16_promise, promise_print);
|
||||
|
||||
#include "libguile/promises.x"
|
||||
|
||||
scm_add_feature ("delay");
|
||||
}
|
||||
|
||||
/*
|
||||
Local Variables:
|
||||
c-file-style: "gnu"
|
||||
End:
|
||||
*/
|
||||
|
||||
61
libguile/promises.h
Normal file
61
libguile/promises.h
Normal file
|
|
@ -0,0 +1,61 @@
|
|||
/* classes: h_files */
|
||||
|
||||
#ifndef SCM_PROMISES_H
|
||||
#define SCM_PROMISES_H
|
||||
|
||||
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004,2008,2009
|
||||
* 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 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
|
||||
* 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
|
||||
*/
|
||||
|
||||
|
||||
|
||||
#include "libguile/__scm.h"
|
||||
|
||||
|
||||
|
||||
/* {Promises}
|
||||
*/
|
||||
|
||||
#define SCM_F_PROMISE_COMPUTED (1L << 0)
|
||||
#define SCM_PROMISE_COMPUTED_P(promise) \
|
||||
(SCM_F_PROMISE_COMPUTED & SCM_SMOB_FLAGS (promise))
|
||||
#define SCM_SET_PROMISE_COMPUTED(promise) \
|
||||
SCM_SET_SMOB_FLAGS ((promise), SCM_F_PROMISE_COMPUTED)
|
||||
#define SCM_PROMISE_MUTEX SCM_SMOB_OBJECT_2
|
||||
#define SCM_PROMISE_DATA SCM_SMOB_OBJECT
|
||||
#define SCM_SET_PROMISE_DATA SCM_SET_SMOB_OBJECT
|
||||
|
||||
|
||||
SCM_API scm_t_bits scm_tc16_promise;
|
||||
|
||||
|
||||
|
||||
SCM_API SCM scm_make_promise (SCM thunk);
|
||||
SCM_API SCM scm_force (SCM x);
|
||||
SCM_API SCM scm_promise_p (SCM x);
|
||||
|
||||
SCM_INTERNAL void scm_init_promises (void);
|
||||
|
||||
|
||||
#endif /* SCM_PROMISES_H */
|
||||
|
||||
/*
|
||||
Local Variables:
|
||||
c-file-style: "gnu"
|
||||
End:
|
||||
*/
|
||||
Loading…
Add table
Add a link
Reference in a new issue