Commit | Line | Data |
---|---|---|
25d50a05 | 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2011 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 | ||
100 | SCM | |
101 | scm_array_handle_element_type (scm_t_array_handle *h) | |
102 | { | |
103 | if (h->element_type < 0 || h->element_type > SCM_ARRAY_ELEMENT_TYPE_LAST) | |
104 | abort (); /* guile programming error */ | |
105 | return scm_i_array_element_types[h->element_type]; | |
c53c0893 AW |
106 | } |
107 | ||
108 | void | |
109 | scm_array_handle_release (scm_t_array_handle *h) | |
110 | { | |
111 | /* Nothing to do here until arrays need to be reserved for real. | |
112 | */ | |
113 | } | |
114 | ||
c53c0893 AW |
115 | const SCM * |
116 | scm_array_handle_elements (scm_t_array_handle *h) | |
117 | { | |
2a610be5 AW |
118 | if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) |
119 | scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); | |
120 | return ((const SCM*)h->elements) + h->base; | |
c53c0893 AW |
121 | } |
122 | ||
123 | SCM * | |
124 | scm_array_handle_writable_elements (scm_t_array_handle *h) | |
125 | { | |
2a610be5 AW |
126 | if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) |
127 | scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); | |
128 | return ((SCM*)h->elements) + h->base; | |
c53c0893 AW |
129 | } |
130 | ||
c53c0893 AW |
131 | void |
132 | scm_init_array_handle (void) | |
133 | { | |
2a610be5 | 134 | #define DEFINE_ARRAY_TYPE(tag, TAG) \ |
25d50a05 | 135 | scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] = scm_from_utf8_symbol (#tag) |
2a610be5 AW |
136 | |
137 | scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_SCM] = SCM_BOOL_T; | |
138 | DEFINE_ARRAY_TYPE (a, CHAR); | |
139 | DEFINE_ARRAY_TYPE (b, BIT); | |
140 | DEFINE_ARRAY_TYPE (vu8, VU8); | |
141 | DEFINE_ARRAY_TYPE (u8, U8); | |
142 | DEFINE_ARRAY_TYPE (s8, S8); | |
143 | DEFINE_ARRAY_TYPE (u16, U16); | |
144 | DEFINE_ARRAY_TYPE (s16, S16); | |
145 | DEFINE_ARRAY_TYPE (u32, U32); | |
146 | DEFINE_ARRAY_TYPE (s32, S32); | |
147 | DEFINE_ARRAY_TYPE (u64, U64); | |
148 | DEFINE_ARRAY_TYPE (s64, S64); | |
149 | DEFINE_ARRAY_TYPE (f32, F32); | |
150 | DEFINE_ARRAY_TYPE (f64, F64); | |
151 | DEFINE_ARRAY_TYPE (c32, C32); | |
152 | DEFINE_ARRAY_TYPE (c64, C64); | |
153 | ||
c53c0893 AW |
154 | #include "libguile/array-handle.x" |
155 | } | |
156 | ||
157 | /* | |
158 | Local Variables: | |
159 | c-file-style: "gnu" | |
160 | End: | |
161 | */ |