Commit | Line | Data |
---|---|---|
c53c0893 AW |
1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc. |
2 | * | |
3 | * This library is free software; you can redistribute it and/or | |
4 | * modify it under the terms of the GNU Lesser General Public License | |
5 | * as published by the Free Software Foundation; either version 3 of | |
6 | * the License, or (at your option) any later version. | |
7 | * | |
8 | * This library is distributed in the hope that it will be useful, but | |
9 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
11 | * Lesser General Public License for more details. | |
12 | * | |
13 | * You should have received a copy of the GNU Lesser General Public | |
14 | * License along with this library; if not, write to the Free Software | |
15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA | |
16 | * 02110-1301 USA | |
17 | */ | |
18 | ||
19 | ||
20 | \f | |
21 | ||
22 | #ifdef HAVE_CONFIG_H | |
23 | # include <config.h> | |
24 | #endif | |
25 | ||
26 | #include "libguile/_scm.h" | |
27 | #include "libguile/__scm.h" | |
28 | ||
29 | #include "libguile/array-handle.h" | |
30 | #include "libguile/unif.h" | |
31 | #include "libguile/strings.h" | |
32 | #include "libguile/vectors.h" | |
33 | #include "libguile/srfi-4.h" | |
34 | #include "libguile/bytevectors.h" | |
35 | ||
36 | ||
37 | static SCM | |
38 | enclosed_ref (scm_t_array_handle *h, ssize_t pos) | |
39 | { | |
40 | return scm_i_cvref (SCM_I_ARRAY_V (h->array), pos + h->base, 1); | |
41 | } | |
42 | ||
43 | static SCM | |
44 | vector_ref (scm_t_array_handle *h, ssize_t pos) | |
45 | { | |
46 | return ((const SCM *)h->elements)[pos]; | |
47 | } | |
48 | ||
49 | static SCM | |
50 | string_ref (scm_t_array_handle *h, ssize_t pos) | |
51 | { | |
52 | pos += h->base; | |
53 | if (SCM_I_ARRAYP (h->array)) | |
54 | return scm_c_string_ref (SCM_I_ARRAY_V (h->array), pos); | |
55 | else | |
56 | return scm_c_string_ref (h->array, pos); | |
57 | } | |
58 | ||
59 | static SCM | |
60 | bitvector_ref (scm_t_array_handle *h, ssize_t pos) | |
61 | { | |
62 | pos += scm_array_handle_bit_elements_offset (h); | |
63 | return | |
64 | scm_from_bool (((scm_t_uint32 *)h->elements)[pos/32] & (1l << (pos % 32))); | |
65 | } | |
66 | ||
67 | static SCM | |
68 | bytevector_ref (scm_t_array_handle *h, ssize_t pos) | |
69 | { | |
70 | return scm_from_uint8 (((scm_t_uint8 *) h->elements)[pos]); | |
71 | } | |
72 | ||
73 | static SCM | |
74 | memoize_ref (scm_t_array_handle *h, ssize_t pos) | |
75 | { | |
76 | SCM v = h->array; | |
77 | ||
78 | if (SCM_I_ENCLOSED_ARRAYP (v)) | |
79 | { | |
80 | h->ref = enclosed_ref; | |
81 | return enclosed_ref (h, pos); | |
82 | } | |
83 | ||
84 | if (SCM_I_ARRAYP (v)) | |
85 | v = SCM_I_ARRAY_V (v); | |
86 | ||
87 | if (scm_is_vector (v)) | |
88 | { | |
89 | h->elements = scm_array_handle_elements (h); | |
90 | h->ref = vector_ref; | |
91 | } | |
92 | else if (scm_is_uniform_vector (v)) | |
93 | { | |
94 | h->elements = scm_array_handle_uniform_elements (h); | |
95 | h->ref = scm_i_uniform_vector_ref_proc (v); | |
96 | } | |
97 | else if (scm_is_string (v)) | |
98 | { | |
99 | h->ref = string_ref; | |
100 | } | |
101 | else if (scm_is_bitvector (v)) | |
102 | { | |
103 | h->elements = scm_array_handle_bit_elements (h); | |
104 | h->ref = bitvector_ref; | |
105 | } | |
106 | else if (scm_is_bytevector (v)) | |
107 | { | |
108 | h->elements = scm_array_handle_uniform_elements (h); | |
109 | h->ref = bytevector_ref; | |
110 | } | |
111 | else | |
112 | scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array)); | |
113 | ||
114 | return h->ref (h, pos); | |
115 | } | |
116 | ||
117 | static void | |
118 | enclosed_set (scm_t_array_handle *h, ssize_t pos, SCM val) | |
119 | { | |
120 | scm_wrong_type_arg_msg (NULL, 0, h->array, "non-enclosed array"); | |
121 | } | |
122 | ||
123 | static void | |
124 | vector_set (scm_t_array_handle *h, ssize_t pos, SCM val) | |
125 | { | |
126 | ((SCM *)h->writable_elements)[pos] = val; | |
127 | } | |
128 | ||
129 | static void | |
130 | string_set (scm_t_array_handle *h, ssize_t pos, SCM val) | |
131 | { | |
132 | pos += h->base; | |
133 | if (SCM_I_ARRAYP (h->array)) | |
134 | scm_c_string_set_x (SCM_I_ARRAY_V (h->array), pos, val); | |
135 | else | |
136 | scm_c_string_set_x (h->array, pos, val); | |
137 | } | |
138 | ||
139 | static void | |
140 | bitvector_set (scm_t_array_handle *h, ssize_t pos, SCM val) | |
141 | { | |
142 | scm_t_uint32 mask; | |
143 | pos += scm_array_handle_bit_elements_offset (h); | |
144 | mask = 1l << (pos % 32); | |
145 | if (scm_to_bool (val)) | |
146 | ((scm_t_uint32 *)h->writable_elements)[pos/32] |= mask; | |
147 | else | |
148 | ((scm_t_uint32 *)h->writable_elements)[pos/32] &= ~mask; | |
149 | } | |
150 | ||
151 | static void | |
152 | bytevector_set (scm_t_array_handle *h, ssize_t pos, SCM val) | |
153 | { | |
154 | scm_t_uint8 c_value; | |
155 | scm_t_uint8 *elements; | |
156 | ||
157 | c_value = scm_to_uint8 (val); | |
158 | elements = (scm_t_uint8 *) h->elements; | |
159 | elements[pos] = (scm_t_uint8) c_value; | |
160 | } | |
161 | ||
162 | static void | |
163 | memoize_set (scm_t_array_handle *h, ssize_t pos, SCM val) | |
164 | { | |
165 | SCM v = h->array; | |
166 | ||
167 | if (SCM_I_ENCLOSED_ARRAYP (v)) | |
168 | { | |
169 | h->set = enclosed_set; | |
170 | enclosed_set (h, pos, val); | |
171 | return; | |
172 | } | |
173 | ||
174 | if (SCM_I_ARRAYP (v)) | |
175 | v = SCM_I_ARRAY_V (v); | |
176 | ||
177 | if (scm_is_vector (v)) | |
178 | { | |
179 | h->writable_elements = scm_array_handle_writable_elements (h); | |
180 | h->set = vector_set; | |
181 | } | |
182 | else if (scm_is_uniform_vector (v)) | |
183 | { | |
184 | h->writable_elements = scm_array_handle_uniform_writable_elements (h); | |
185 | h->set = scm_i_uniform_vector_set_proc (v); | |
186 | } | |
187 | else if (scm_is_string (v)) | |
188 | { | |
189 | h->set = string_set; | |
190 | } | |
191 | else if (scm_is_bitvector (v)) | |
192 | { | |
193 | h->writable_elements = scm_array_handle_bit_writable_elements (h); | |
194 | h->set = bitvector_set; | |
195 | } | |
196 | else if (scm_is_bytevector (v)) | |
197 | { | |
198 | h->elements = scm_array_handle_uniform_writable_elements (h); | |
199 | h->set = bytevector_set; | |
200 | } | |
201 | else | |
202 | scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array)); | |
203 | ||
204 | h->set (h, pos, val); | |
205 | } | |
206 | ||
207 | void | |
208 | scm_array_get_handle (SCM array, scm_t_array_handle *h) | |
209 | { | |
210 | h->array = array; | |
211 | h->ref = memoize_ref; | |
212 | h->set = memoize_set; | |
213 | ||
214 | if (SCM_I_ARRAYP (array) || SCM_I_ENCLOSED_ARRAYP (array)) | |
215 | { | |
216 | h->dims = SCM_I_ARRAY_DIMS (array); | |
217 | h->base = SCM_I_ARRAY_BASE (array); | |
218 | } | |
219 | else if (scm_is_generalized_vector (array)) | |
220 | { | |
221 | h->dim0.lbnd = 0; | |
222 | h->dim0.ubnd = scm_c_generalized_vector_length (array) - 1; | |
223 | h->dim0.inc = 1; | |
224 | h->dims = &h->dim0; | |
225 | h->base = 0; | |
226 | } | |
227 | else | |
228 | scm_wrong_type_arg_msg (NULL, 0, array, "array"); | |
229 | } | |
230 | ||
231 | void | |
232 | scm_array_handle_release (scm_t_array_handle *h) | |
233 | { | |
234 | /* Nothing to do here until arrays need to be reserved for real. | |
235 | */ | |
236 | } | |
237 | ||
238 | size_t | |
239 | scm_array_handle_rank (scm_t_array_handle *h) | |
240 | { | |
241 | if (SCM_I_ARRAYP (h->array) || SCM_I_ENCLOSED_ARRAYP (h->array)) | |
242 | return SCM_I_ARRAY_NDIM (h->array); | |
243 | else | |
244 | return 1; | |
245 | } | |
246 | ||
247 | scm_t_array_dim * | |
248 | scm_array_handle_dims (scm_t_array_handle *h) | |
249 | { | |
250 | return h->dims; | |
251 | } | |
252 | ||
253 | const SCM * | |
254 | scm_array_handle_elements (scm_t_array_handle *h) | |
255 | { | |
256 | SCM vec = h->array; | |
257 | if (SCM_I_ARRAYP (vec)) | |
258 | vec = SCM_I_ARRAY_V (vec); | |
259 | if (SCM_I_IS_VECTOR (vec)) | |
260 | return SCM_I_VECTOR_ELTS (vec) + h->base; | |
261 | scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); | |
262 | } | |
263 | ||
264 | SCM * | |
265 | scm_array_handle_writable_elements (scm_t_array_handle *h) | |
266 | { | |
267 | SCM vec = h->array; | |
268 | if (SCM_I_ARRAYP (vec)) | |
269 | vec = SCM_I_ARRAY_V (vec); | |
270 | if (SCM_I_IS_VECTOR (vec)) | |
271 | return SCM_I_VECTOR_WELTS (vec) + h->base; | |
272 | scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); | |
273 | } | |
274 | ||
275 | ||
276 | void | |
277 | scm_init_array_handle (void) | |
278 | { | |
279 | #include "libguile/array-handle.x" | |
280 | } | |
281 | ||
282 | /* | |
283 | Local Variables: | |
284 | c-file-style: "gnu" | |
285 | End: | |
286 | */ |