Commit | Line | Data |
---|---|---|
9b977c83 AW |
1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, |
2 | * 2006, 2009, 2011, 2013 Free Software Foundation, Inc. | |
c53c0893 AW |
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 | ||
21 | \f | |
22 | ||
23 | #ifdef HAVE_CONFIG_H | |
24 | # include <config.h> | |
25 | #endif | |
26 | ||
27 | #include "libguile/_scm.h" | |
28 | #include "libguile/__scm.h" | |
29 | ||
30 | #include "libguile/array-handle.h" | |
c53c0893 AW |
31 | |
32 | ||
2a610be5 | 33 | SCM scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_LAST + 1]; |
c53c0893 | 34 | |
c53c0893 | 35 | |
2a610be5 AW |
36 | #define ARRAY_IMPLS_N_STATIC_ALLOC 7 |
37 | static scm_t_array_implementation array_impls[ARRAY_IMPLS_N_STATIC_ALLOC]; | |
38 | static int num_array_impls_registered = 0; | |
c53c0893 | 39 | |
c53c0893 | 40 | |
2a610be5 AW |
41 | void |
42 | scm_i_register_array_implementation (scm_t_array_implementation *impl) | |
c53c0893 | 43 | { |
2a610be5 AW |
44 | if (num_array_impls_registered >= ARRAY_IMPLS_N_STATIC_ALLOC) |
45 | /* need to increase ARRAY_IMPLS_N_STATIC_ALLOC, buster */ | |
46 | abort (); | |
c53c0893 | 47 | else |
2a610be5 | 48 | array_impls[num_array_impls_registered++] = *impl; |
c53c0893 AW |
49 | } |
50 | ||
2a610be5 AW |
51 | scm_t_array_implementation* |
52 | scm_i_array_implementation_for_obj (SCM obj) | |
c53c0893 | 53 | { |
2a610be5 AW |
54 | int i; |
55 | for (i = 0; i < num_array_impls_registered; i++) | |
56 | if (SCM_NIMP (obj) | |
57 | && (SCM_CELL_TYPE (obj) & array_impls[i].mask) == array_impls[i].tag) | |
58 | return &array_impls[i]; | |
59 | return NULL; | |
c53c0893 AW |
60 | } |
61 | ||
62 | void | |
63 | scm_array_get_handle (SCM array, scm_t_array_handle *h) | |
64 | { | |
2a610be5 AW |
65 | scm_t_array_implementation *impl = scm_i_array_implementation_for_obj (array); |
66 | if (!impl) | |
67 | scm_wrong_type_arg_msg (NULL, 0, array, "array"); | |
c53c0893 | 68 | h->array = array; |
2a610be5 AW |
69 | h->impl = impl; |
70 | h->base = 0; | |
71 | h->ndims = 0; | |
72 | h->dims = NULL; | |
73 | h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM; /* have to default to | |
74 | something... */ | |
75 | h->elements = NULL; | |
76 | h->writable_elements = NULL; | |
77 | h->impl->get_handle (array, h); | |
78 | } | |
79 | ||
80 | ssize_t | |
81 | scm_array_handle_pos (scm_t_array_handle *h, SCM indices) | |
82 | { | |
83 | scm_t_array_dim *s = scm_array_handle_dims (h); | |
84 | ssize_t pos = 0, i; | |
85 | size_t k = scm_array_handle_rank (h); | |
86 | ||
87 | while (k > 0 && scm_is_pair (indices)) | |
c53c0893 | 88 | { |
2a610be5 AW |
89 | i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd); |
90 | pos += (i - s->lbnd) * s->inc; | |
91 | k--; | |
92 | s++; | |
93 | indices = SCM_CDR (indices); | |
c53c0893 | 94 | } |
2a610be5 AW |
95 | if (k > 0 || !scm_is_null (indices)) |
96 | scm_misc_error (NULL, "wrong number of indices, expecting ~a", | |
97 | scm_list_1 (scm_from_size_t (scm_array_handle_rank (h)))); | |
98 | return pos; | |
99 | } | |
100 | ||
336c9211 AW |
101 | static void |
102 | check_array_index_bounds (scm_t_array_dim *dim, ssize_t idx) | |
103 | { | |
104 | if (idx < dim->lbnd || idx > dim->ubnd) | |
105 | scm_error (scm_out_of_range_key, NULL, "Value out of range ~S to ~S: ~S", | |
106 | scm_list_3 (scm_from_ssize_t (dim->lbnd), | |
107 | scm_from_ssize_t (dim->ubnd), | |
108 | scm_from_ssize_t (idx)), | |
109 | scm_list_1 (scm_from_ssize_t (idx))); | |
110 | } | |
111 | ||
112 | ssize_t | |
113 | scm_array_handle_pos_1 (scm_t_array_handle *h, ssize_t idx0) | |
114 | { | |
115 | scm_t_array_dim *dim = scm_array_handle_dims (h); | |
116 | ||
117 | if (scm_array_handle_rank (h) != 1) | |
118 | scm_misc_error (NULL, "wrong number of indices, expecting ~A", | |
119 | scm_list_1 (scm_from_size_t (scm_array_handle_rank (h)))); | |
120 | ||
121 | check_array_index_bounds (&dim[0], idx0); | |
122 | ||
123 | return (idx0 - dim[0].lbnd) * dim[0].inc; | |
124 | } | |
125 | ||
126 | ssize_t | |
127 | scm_array_handle_pos_2 (scm_t_array_handle *h, ssize_t idx0, ssize_t idx1) | |
128 | { | |
129 | scm_t_array_dim *dim = scm_array_handle_dims (h); | |
130 | ||
131 | if (scm_array_handle_rank (h) != 2) | |
132 | scm_misc_error (NULL, "wrong number of indices, expecting ~A", | |
133 | scm_list_1 (scm_from_size_t (scm_array_handle_rank (h)))); | |
134 | ||
135 | check_array_index_bounds (&dim[0], idx0); | |
136 | check_array_index_bounds (&dim[1], idx1); | |
137 | ||
138 | return ((idx0 - dim[0].lbnd) * dim[0].inc | |
139 | + (idx1 - dim[1].lbnd) * dim[1].inc); | |
140 | } | |
141 | ||
2a610be5 AW |
142 | SCM |
143 | scm_array_handle_element_type (scm_t_array_handle *h) | |
144 | { | |
145 | if (h->element_type < 0 || h->element_type > SCM_ARRAY_ELEMENT_TYPE_LAST) | |
146 | abort (); /* guile programming error */ | |
147 | return scm_i_array_element_types[h->element_type]; | |
c53c0893 AW |
148 | } |
149 | ||
150 | void | |
151 | scm_array_handle_release (scm_t_array_handle *h) | |
152 | { | |
153 | /* Nothing to do here until arrays need to be reserved for real. | |
154 | */ | |
155 | } | |
156 | ||
c53c0893 AW |
157 | const SCM * |
158 | scm_array_handle_elements (scm_t_array_handle *h) | |
159 | { | |
2a610be5 AW |
160 | if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) |
161 | scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); | |
162 | return ((const SCM*)h->elements) + h->base; | |
c53c0893 AW |
163 | } |
164 | ||
165 | SCM * | |
166 | scm_array_handle_writable_elements (scm_t_array_handle *h) | |
167 | { | |
2a610be5 AW |
168 | if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) |
169 | scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); | |
170 | return ((SCM*)h->elements) + h->base; | |
c53c0893 AW |
171 | } |
172 | ||
c53c0893 AW |
173 | void |
174 | scm_init_array_handle (void) | |
175 | { | |
2a610be5 | 176 | #define DEFINE_ARRAY_TYPE(tag, TAG) \ |
25d50a05 | 177 | scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] = scm_from_utf8_symbol (#tag) |
2a610be5 AW |
178 | |
179 | scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_SCM] = SCM_BOOL_T; | |
180 | DEFINE_ARRAY_TYPE (a, CHAR); | |
181 | DEFINE_ARRAY_TYPE (b, BIT); | |
182 | DEFINE_ARRAY_TYPE (vu8, VU8); | |
183 | DEFINE_ARRAY_TYPE (u8, U8); | |
184 | DEFINE_ARRAY_TYPE (s8, S8); | |
185 | DEFINE_ARRAY_TYPE (u16, U16); | |
186 | DEFINE_ARRAY_TYPE (s16, S16); | |
187 | DEFINE_ARRAY_TYPE (u32, U32); | |
188 | DEFINE_ARRAY_TYPE (s32, S32); | |
189 | DEFINE_ARRAY_TYPE (u64, U64); | |
190 | DEFINE_ARRAY_TYPE (s64, S64); | |
191 | DEFINE_ARRAY_TYPE (f32, F32); | |
192 | DEFINE_ARRAY_TYPE (f64, F64); | |
193 | DEFINE_ARRAY_TYPE (c32, C32); | |
194 | DEFINE_ARRAY_TYPE (c64, C64); | |
195 | ||
c53c0893 AW |
196 | #include "libguile/array-handle.x" |
197 | } | |
198 | ||
199 | /* | |
200 | Local Variables: | |
201 | c-file-style: "gnu" | |
202 | End: | |
203 | */ |