Commit | Line | Data |
---|---|---|
1d4e6ee3 LC |
1 | /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, |
2 | * 2005, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. | |
3 | * | |
f332e957 AW |
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" | |
31 | #include "libguile/generalized-arrays.h" | |
32 | #include "libguile/generalized-vectors.h" | |
33 | ||
34 | ||
f45eccff AW |
35 | struct scm_t_vector_ctor |
36 | { | |
37 | SCM tag; | |
38 | SCM (*ctor)(SCM, SCM); | |
39 | }; | |
40 | ||
41 | #define VECTOR_CTORS_N_STATIC_ALLOC 20 | |
42 | static struct scm_t_vector_ctor vector_ctors[VECTOR_CTORS_N_STATIC_ALLOC]; | |
43 | static int num_vector_ctors_registered = 0; | |
44 | ||
45 | void | |
46 | scm_i_register_vector_constructor (SCM type, SCM (*ctor)(SCM, SCM)) | |
47 | { | |
48 | if (num_vector_ctors_registered >= VECTOR_CTORS_N_STATIC_ALLOC) | |
49 | /* need to increase VECTOR_CTORS_N_STATIC_ALLOC, buster */ | |
50 | abort (); | |
51 | else | |
52 | { | |
53 | vector_ctors[num_vector_ctors_registered].tag = type; | |
54 | vector_ctors[num_vector_ctors_registered].ctor = ctor; | |
55 | num_vector_ctors_registered++; | |
56 | } | |
57 | } | |
58 | ||
59 | SCM_DEFINE (scm_make_generalized_vector, "make-generalized-vector", 2, 1, 0, | |
60 | (SCM type, SCM len, SCM fill), | |
61 | "Make a generalized vector") | |
62 | #define FUNC_NAME s_scm_make_generalized_vector | |
63 | { | |
64 | int i; | |
65 | for (i = 0; i < num_vector_ctors_registered; i++) | |
d223c3fc | 66 | if (scm_is_eq (vector_ctors[i].tag, type)) |
f45eccff AW |
67 | return vector_ctors[i].ctor(len, fill); |
68 | scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "array type"); | |
69 | } | |
70 | #undef FUNC_NAME | |
71 | ||
f332e957 AW |
72 | int |
73 | scm_is_generalized_vector (SCM obj) | |
74 | { | |
75 | int ret = 0; | |
76 | if (scm_is_array (obj)) | |
77 | { | |
78 | scm_t_array_handle h; | |
79 | scm_array_get_handle (obj, &h); | |
80 | ret = scm_array_handle_rank (&h) == 1; | |
81 | scm_array_handle_release (&h); | |
82 | } | |
83 | return ret; | |
84 | } | |
85 | ||
86 | SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0, | |
87 | (SCM obj), | |
88 | "Return @code{#t} if @var{obj} is a vector, string,\n" | |
89 | "bitvector, or uniform numeric vector.") | |
90 | #define FUNC_NAME s_scm_generalized_vector_p | |
91 | { | |
92 | return scm_from_bool (scm_is_generalized_vector (obj)); | |
93 | } | |
94 | #undef FUNC_NAME | |
95 | ||
96 | #define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle) \ | |
97 | scm_generalized_vector_get_handle (val, handle) | |
98 | ||
99 | ||
100 | void | |
101 | scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h) | |
102 | { | |
103 | scm_array_get_handle (vec, h); | |
104 | if (scm_array_handle_rank (h) != 1) | |
105 | { | |
106 | scm_array_handle_release (h); | |
107 | scm_wrong_type_arg_msg (NULL, 0, vec, "vector"); | |
108 | } | |
109 | } | |
110 | ||
111 | size_t | |
112 | scm_c_generalized_vector_length (SCM v) | |
113 | { | |
114 | scm_t_array_handle h; | |
115 | size_t ret; | |
116 | scm_generalized_vector_get_handle (v, &h); | |
117 | ret = h.dims[0].ubnd - h.dims[0].lbnd + 1; | |
118 | scm_array_handle_release (&h); | |
119 | return ret; | |
120 | } | |
121 | ||
122 | SCM_DEFINE (scm_generalized_vector_length, "generalized-vector-length", 1, 0, 0, | |
123 | (SCM v), | |
124 | "Return the length of the generalized vector @var{v}.") | |
125 | #define FUNC_NAME s_scm_generalized_vector_length | |
126 | { | |
127 | return scm_from_size_t (scm_c_generalized_vector_length (v)); | |
128 | } | |
129 | #undef FUNC_NAME | |
130 | ||
131 | SCM | |
132 | scm_c_generalized_vector_ref (SCM v, size_t idx) | |
133 | { | |
134 | scm_t_array_handle h; | |
2b414e24 | 135 | size_t pos; |
f332e957 AW |
136 | SCM ret; |
137 | scm_generalized_vector_get_handle (v, &h); | |
2b414e24 AW |
138 | pos = h.base + h.dims[0].lbnd + idx * h.dims[0].inc; |
139 | ret = h.impl->vref (&h, pos); | |
f332e957 AW |
140 | scm_array_handle_release (&h); |
141 | return ret; | |
142 | } | |
143 | ||
144 | SCM_DEFINE (scm_generalized_vector_ref, "generalized-vector-ref", 2, 0, 0, | |
145 | (SCM v, SCM idx), | |
146 | "Return the element at index @var{idx} of the\n" | |
147 | "generalized vector @var{v}.") | |
148 | #define FUNC_NAME s_scm_generalized_vector_ref | |
149 | { | |
150 | return scm_c_generalized_vector_ref (v, scm_to_size_t (idx)); | |
151 | } | |
152 | #undef FUNC_NAME | |
153 | ||
154 | void | |
155 | scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val) | |
156 | { | |
157 | scm_t_array_handle h; | |
2b414e24 | 158 | size_t pos; |
f332e957 | 159 | scm_generalized_vector_get_handle (v, &h); |
2b414e24 AW |
160 | pos = h.base + h.dims[0].lbnd + idx * h.dims[0].inc; |
161 | h.impl->vset (&h, pos, val); | |
f332e957 AW |
162 | scm_array_handle_release (&h); |
163 | } | |
164 | ||
165 | SCM_DEFINE (scm_generalized_vector_set_x, "generalized-vector-set!", 3, 0, 0, | |
166 | (SCM v, SCM idx, SCM val), | |
167 | "Set the element at index @var{idx} of the\n" | |
168 | "generalized vector @var{v} to @var{val}.") | |
169 | #define FUNC_NAME s_scm_generalized_vector_set_x | |
170 | { | |
171 | scm_c_generalized_vector_set_x (v, scm_to_size_t (idx), val); | |
172 | return SCM_UNSPECIFIED; | |
173 | } | |
174 | #undef FUNC_NAME | |
175 | ||
176 | SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0, | |
177 | (SCM v), | |
178 | "Return a new list whose elements are the elements of the\n" | |
179 | "generalized vector @var{v}.") | |
180 | #define FUNC_NAME s_scm_generalized_vector_to_list | |
181 | { | |
1d4e6ee3 | 182 | /* FIXME: This duplicates `array_to_list'. */ |
f332e957 | 183 | SCM ret = SCM_EOL; |
1d4e6ee3 LC |
184 | long inc; |
185 | ssize_t pos, i; | |
f332e957 | 186 | scm_t_array_handle h; |
1d4e6ee3 | 187 | |
f332e957 | 188 | scm_generalized_vector_get_handle (v, &h); |
1d4e6ee3 LC |
189 | |
190 | i = h.dims[0].ubnd - h.dims[0].lbnd + 1; | |
191 | inc = h.dims[0].inc; | |
192 | pos = (i - 1) * inc; | |
193 | ||
194 | for (; i > 0; i--, pos -= inc) | |
195 | ret = scm_cons (h.impl->vref (&h, h.base + pos), ret); | |
196 | ||
f332e957 AW |
197 | scm_array_handle_release (&h); |
198 | return ret; | |
199 | } | |
200 | #undef FUNC_NAME | |
201 | ||
202 | void | |
203 | scm_init_generalized_vectors () | |
204 | { | |
205 | #include "libguile/generalized-vectors.x" | |
206 | } | |
207 | ||
208 | /* | |
209 | Local Variables: | |
210 | c-file-style: "gnu" | |
211 | End: | |
212 | */ |