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