Commit | Line | Data |
---|---|---|
7b893819 AW |
1 | /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009 |
2 | * Free Software Foundation, Inc. | |
3 | * | |
4 | * This library is free software; you can redistribute it and/or | |
5 | * modify it under the terms of the GNU Lesser General Public License | |
6 | * as published by the Free Software Foundation; either version 3 of | |
7 | * the License, or (at your option) any later version. | |
8 | * | |
9 | * This library is distributed in the hope that it will be useful, but | |
10 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
12 | * Lesser General Public License for more details. | |
13 | * | |
14 | * You should have received a copy of the GNU Lesser General Public | |
15 | * License along with this library; if not, write to the Free Software | |
16 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA | |
17 | * 02110-1301 USA | |
18 | */ | |
19 | ||
20 | \f | |
21 | ||
22 | #ifdef HAVE_CONFIG_H | |
23 | # include <config.h> | |
24 | #endif | |
25 | ||
26 | #include <alloca.h> | |
27 | ||
28 | #include "libguile/__scm.h" | |
29 | ||
30 | #include "libguile/_scm.h" | |
31 | #include "libguile/alist.h" | |
32 | #include "libguile/async.h" | |
33 | #include "libguile/continuations.h" | |
34 | #include "libguile/debug.h" | |
35 | #include "libguile/deprecation.h" | |
36 | #include "libguile/dynwind.h" | |
37 | #include "libguile/eq.h" | |
38 | #include "libguile/eval.h" | |
39 | #include "libguile/feature.h" | |
40 | #include "libguile/fluids.h" | |
41 | #include "libguile/goops.h" | |
42 | #include "libguile/hash.h" | |
43 | #include "libguile/hashtab.h" | |
44 | #include "libguile/lang.h" | |
45 | #include "libguile/list.h" | |
46 | #include "libguile/macros.h" | |
47 | #include "libguile/memoize.h" | |
48 | #include "libguile/modules.h" | |
49 | #include "libguile/ports.h" | |
50 | #include "libguile/print.h" | |
51 | #include "libguile/procprop.h" | |
52 | #include "libguile/programs.h" | |
53 | #include "libguile/root.h" | |
54 | #include "libguile/smob.h" | |
55 | #include "libguile/srcprop.h" | |
56 | #include "libguile/stackchk.h" | |
57 | #include "libguile/strings.h" | |
58 | #include "libguile/threads.h" | |
59 | #include "libguile/throw.h" | |
60 | #include "libguile/validate.h" | |
61 | #include "libguile/values.h" | |
62 | #include "libguile/promises.h" | |
63 | ||
64 | ||
65 | \f | |
66 | ||
67 | ||
68 | scm_t_bits scm_tc16_promise; | |
69 | ||
70 | SCM_DEFINE (scm_make_promise, "make-promise", 1, 0, 0, | |
71 | (SCM thunk), | |
72 | "Create a new promise object.\n\n" | |
73 | "@code{make-promise} is a procedural form of @code{delay}.\n" | |
74 | "These two expressions are equivalent:\n" | |
75 | "@lisp\n" | |
76 | "(delay @var{exp})\n" | |
77 | "(make-promise (lambda () @var{exp}))\n" | |
78 | "@end lisp\n") | |
79 | #define FUNC_NAME s_scm_make_promise | |
80 | { | |
81 | SCM_VALIDATE_THUNK (1, thunk); | |
82 | SCM_RETURN_NEWSMOB2 (scm_tc16_promise, | |
83 | SCM_UNPACK (thunk), | |
84 | scm_make_recursive_mutex ()); | |
85 | } | |
86 | #undef FUNC_NAME | |
87 | ||
88 | static int | |
89 | promise_print (SCM exp, SCM port, scm_print_state *pstate) | |
90 | { | |
91 | int writingp = SCM_WRITINGP (pstate); | |
92 | scm_puts ("#<promise ", port); | |
93 | SCM_SET_WRITINGP (pstate, 1); | |
94 | scm_iprin1 (SCM_PROMISE_DATA (exp), port, pstate); | |
95 | SCM_SET_WRITINGP (pstate, writingp); | |
96 | scm_putc ('>', port); | |
97 | return !0; | |
98 | } | |
99 | ||
100 | SCM_DEFINE (scm_force, "force", 1, 0, 0, | |
101 | (SCM promise), | |
102 | "If the promise @var{x} has not been computed yet, compute and\n" | |
103 | "return @var{x}, otherwise just return the previously computed\n" | |
104 | "value.") | |
105 | #define FUNC_NAME s_scm_force | |
106 | { | |
107 | SCM_VALIDATE_SMOB (1, promise, promise); | |
108 | scm_lock_mutex (SCM_PROMISE_MUTEX (promise)); | |
109 | if (!SCM_PROMISE_COMPUTED_P (promise)) | |
110 | { | |
111 | SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise)); | |
112 | if (!SCM_PROMISE_COMPUTED_P (promise)) | |
113 | { | |
114 | SCM_SET_PROMISE_DATA (promise, ans); | |
115 | SCM_SET_PROMISE_COMPUTED (promise); | |
116 | } | |
117 | } | |
118 | scm_unlock_mutex (SCM_PROMISE_MUTEX (promise)); | |
119 | return SCM_PROMISE_DATA (promise); | |
120 | } | |
121 | #undef FUNC_NAME | |
122 | ||
123 | ||
124 | SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0, | |
125 | (SCM obj), | |
126 | "Return true if @var{obj} is a promise, i.e. a delayed computation\n" | |
127 | "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).") | |
128 | #define FUNC_NAME s_scm_promise_p | |
129 | { | |
130 | return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise, obj)); | |
131 | } | |
132 | #undef FUNC_NAME | |
133 | ||
134 | void | |
135 | scm_init_promises () | |
136 | { | |
137 | scm_tc16_promise = scm_make_smob_type ("promise", 0); | |
138 | scm_set_smob_print (scm_tc16_promise, promise_print); | |
139 | ||
140 | #include "libguile/promises.x" | |
141 | ||
142 | scm_add_feature ("delay"); | |
143 | } | |
144 | ||
145 | /* | |
146 | Local Variables: | |
147 | c-file-style: "gnu" | |
148 | End: | |
149 | */ | |
150 |