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