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