Commit | Line | Data |
---|---|---|
b2b33168 | 1 | /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011 |
7b893819 AW |
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" | |
7b893819 AW |
44 | #include "libguile/list.h" |
45 | #include "libguile/macros.h" | |
46 | #include "libguile/memoize.h" | |
47 | #include "libguile/modules.h" | |
48 | #include "libguile/ports.h" | |
49 | #include "libguile/print.h" | |
50 | #include "libguile/procprop.h" | |
51 | #include "libguile/programs.h" | |
52 | #include "libguile/root.h" | |
53 | #include "libguile/smob.h" | |
54 | #include "libguile/srcprop.h" | |
55 | #include "libguile/stackchk.h" | |
56 | #include "libguile/strings.h" | |
57 | #include "libguile/threads.h" | |
58 | #include "libguile/throw.h" | |
59 | #include "libguile/validate.h" | |
60 | #include "libguile/values.h" | |
61 | #include "libguile/promises.h" | |
62 | ||
63 | ||
64 | \f | |
65 | ||
66 | ||
67 | scm_t_bits scm_tc16_promise; | |
68 | ||
69 | SCM_DEFINE (scm_make_promise, "make-promise", 1, 0, 0, | |
70 | (SCM thunk), | |
71 | "Create a new promise object.\n\n" | |
72 | "@code{make-promise} is a procedural form of @code{delay}.\n" | |
73 | "These two expressions are equivalent:\n" | |
74 | "@lisp\n" | |
75 | "(delay @var{exp})\n" | |
76 | "(make-promise (lambda () @var{exp}))\n" | |
77 | "@end lisp\n") | |
78 | #define FUNC_NAME s_scm_make_promise | |
79 | { | |
80 | SCM_VALIDATE_THUNK (1, thunk); | |
81 | SCM_RETURN_NEWSMOB2 (scm_tc16_promise, | |
82 | SCM_UNPACK (thunk), | |
b2b33168 | 83 | SCM_UNPACK (scm_make_recursive_mutex ())); |
7b893819 AW |
84 | } |
85 | #undef FUNC_NAME | |
86 | ||
87 | static int | |
88 | promise_print (SCM exp, SCM port, scm_print_state *pstate) | |
89 | { | |
90 | int writingp = SCM_WRITINGP (pstate); | |
0607ebbf | 91 | scm_puts_unlocked ("#<promise ", port); |
7b893819 AW |
92 | SCM_SET_WRITINGP (pstate, 1); |
93 | scm_iprin1 (SCM_PROMISE_DATA (exp), port, pstate); | |
94 | SCM_SET_WRITINGP (pstate, writingp); | |
0607ebbf | 95 | scm_putc_unlocked ('>', port); |
7b893819 AW |
96 | return !0; |
97 | } | |
98 | ||
99 | SCM_DEFINE (scm_force, "force", 1, 0, 0, | |
100 | (SCM promise), | |
b7e64f8b BT |
101 | "If @var{promise} has not been computed yet, compute and\n" |
102 | "return @var{promise}, otherwise just return the previously computed\n" | |
7b893819 AW |
103 | "value.") |
104 | #define FUNC_NAME s_scm_force | |
105 | { | |
106 | SCM_VALIDATE_SMOB (1, promise, promise); | |
107 | scm_lock_mutex (SCM_PROMISE_MUTEX (promise)); | |
108 | if (!SCM_PROMISE_COMPUTED_P (promise)) | |
109 | { | |
110 | SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise)); | |
111 | if (!SCM_PROMISE_COMPUTED_P (promise)) | |
112 | { | |
113 | SCM_SET_PROMISE_DATA (promise, ans); | |
114 | SCM_SET_PROMISE_COMPUTED (promise); | |
115 | } | |
116 | } | |
117 | scm_unlock_mutex (SCM_PROMISE_MUTEX (promise)); | |
118 | return SCM_PROMISE_DATA (promise); | |
119 | } | |
120 | #undef FUNC_NAME | |
121 | ||
122 | ||
123 | SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0, | |
124 | (SCM obj), | |
125 | "Return true if @var{obj} is a promise, i.e. a delayed computation\n" | |
126 | "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).") | |
127 | #define FUNC_NAME s_scm_promise_p | |
128 | { | |
129 | return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise, obj)); | |
130 | } | |
131 | #undef FUNC_NAME | |
132 | ||
133 | void | |
134 | scm_init_promises () | |
135 | { | |
136 | scm_tc16_promise = scm_make_smob_type ("promise", 0); | |
137 | scm_set_smob_print (scm_tc16_promise, promise_print); | |
138 | ||
139 | #include "libguile/promises.x" | |
140 | ||
141 | scm_add_feature ("delay"); | |
142 | } | |
143 | ||
144 | /* | |
145 | Local Variables: | |
146 | c-file-style: "gnu" | |
147 | End: | |
148 | */ | |
149 |