1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
/* Copyright (C) 2016, 2018 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 "libguile/_scm.h"
#include "libguile/ports.h"
#include "libguile/validate.h"
#include "libguile/atomics-internal.h"
#include "libguile/atomic.h"
SCM_DEFINE (scm_make_atomic_box, "make-atomic-box", 1, 0, 0,
(SCM init),
"Return an atomic box initialized to value @var{init}.")
#define FUNC_NAME s_scm_make_atomic_box
{
SCM ret = scm_cell (scm_tc7_atomic_box, SCM_UNPACK (SCM_UNDEFINED));
scm_atomic_box_set_x (ret, init);
return ret;
}
#undef FUNC_NAME
SCM_DEFINE (scm_atomic_box_p, "atomic-box?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is an atomic-box object, else\n"
"return @code{#f}.")
#define FUNC_NAME s_scm_atomic_box_p
{
return scm_from_bool (scm_is_atomic_box (obj));
}
#undef FUNC_NAME
SCM_DEFINE (scm_atomic_box_ref, "atomic-box-ref", 1, 0, 0,
(SCM box),
"Fetch the value stored in the atomic box @var{box} and\n"
"return it.")
#define FUNC_NAME s_scm_atomic_box_ref
{
SCM_VALIDATE_ATOMIC_BOX (1, box);
return scm_atomic_ref_scm (scm_atomic_box_loc (box));
}
#undef FUNC_NAME
SCM_DEFINE (scm_atomic_box_set_x, "atomic-box-set!", 2, 0, 0,
(SCM box, SCM val),
"Store @var{val} into the atomic box @var{box}.")
#define FUNC_NAME s_scm_atomic_box_set_x
{
SCM_VALIDATE_ATOMIC_BOX (1, box);
scm_atomic_set_scm (scm_atomic_box_loc (box), val);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_atomic_box_swap_x, "atomic-box-swap!", 2, 0, 0,
(SCM box, SCM val),
"Store @var{val} into the atomic box @var{box},\n"
"and return the value that was previously stored in\n"
"the box.")
#define FUNC_NAME s_scm_atomic_box_swap_x
{
SCM_VALIDATE_ATOMIC_BOX (1, box);
return scm_atomic_swap_scm (scm_atomic_box_loc (box), val);
}
#undef FUNC_NAME
SCM_DEFINE (scm_atomic_box_compare_and_swap_x,
"atomic-box-compare-and-swap!", 3, 0, 0,
(SCM box, SCM expected, SCM desired),
"If the value of the atomic box @var{box} is the same as,\n"
"@var{expected} (in the sense of @code{eq?}), replace the\n"
"contents of the box with @var{desired}. Otherwise does not\n"
"update the box. Returns the previous value of the box in\n"
"either case, so you can know if the swap worked by checking\n"
"if the return value is @code{eq?} to @var{expected}.")
#define FUNC_NAME s_scm_atomic_box_compare_and_swap_x
{
SCM result = expected;
SCM_VALIDATE_ATOMIC_BOX (1, box);
while (!scm_atomic_compare_and_swap_scm (scm_atomic_box_loc (box),
&result, desired)
&& scm_is_eq (result, expected))
{
/* 'scm_atomic_compare_and_swap_scm' has spuriously failed,
i.e. it has returned 0 to indicate failure, although the
observed value is 'eq?' to EXPECTED. In this case, we *must*
try again, because the API of 'atomic-box-compare-and-swap!'
provides no way to indicate to the caller that the exchange
failed when the observed value is 'eq?' to EXPECTED. */
}
return result;
}
#undef FUNC_NAME
void
scm_i_atomic_box_print (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts ("#<atomic-box ", port);
scm_uintprint (SCM_UNPACK (exp), 16, port);
scm_puts (" value: ", port);
scm_iprin1 (scm_atomic_box_ref (exp), port, pstate);
scm_putc ('>', port);
}
static void
scm_init_atomic (void)
{
#include "libguile/atomic.x"
}
void
scm_register_atomic (void)
{
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_atomic",
(scm_t_extension_init_func) scm_init_atomic,
NULL);
}
|
