1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc.
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.
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.
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
26 #include "libguile/_scm.h"
27 #include "libguile/__scm.h"
29 #include "libguile/array-handle.h"
30 #include "libguile/unif.h"
31 #include "libguile/strings.h"
32 #include "libguile/vectors.h"
33 #include "libguile/srfi-4.h"
34 #include "libguile/bitvectors.h"
35 #include "libguile/bytevectors.h"
39 enclosed_ref (scm_t_array_handle
*h
, ssize_t pos
)
41 return scm_i_cvref (SCM_I_ARRAY_V (h
->array
), pos
+ h
->base
, 1);
45 vector_ref (scm_t_array_handle
*h
, ssize_t pos
)
47 return ((const SCM
*)h
->elements
)[pos
];
51 string_ref (scm_t_array_handle
*h
, ssize_t pos
)
54 if (SCM_I_ARRAYP (h
->array
))
55 return scm_c_string_ref (SCM_I_ARRAY_V (h
->array
), pos
);
57 return scm_c_string_ref (h
->array
, pos
);
61 bitvector_ref (scm_t_array_handle
*h
, ssize_t pos
)
63 pos
+= scm_array_handle_bit_elements_offset (h
);
65 scm_from_bool (((scm_t_uint32
*)h
->elements
)[pos
/32] & (1l << (pos
% 32)));
69 bytevector_ref (scm_t_array_handle
*h
, ssize_t pos
)
71 return scm_from_uint8 (((scm_t_uint8
*) h
->elements
)[pos
]);
75 memoize_ref (scm_t_array_handle
*h
, ssize_t pos
)
79 if (SCM_I_ENCLOSED_ARRAYP (v
))
81 h
->ref
= enclosed_ref
;
82 return enclosed_ref (h
, pos
);
86 v
= SCM_I_ARRAY_V (v
);
88 if (scm_is_vector (v
))
90 h
->elements
= scm_array_handle_elements (h
);
93 else if (scm_is_uniform_vector (v
))
95 h
->elements
= scm_array_handle_uniform_elements (h
);
96 h
->ref
= scm_i_uniform_vector_ref_proc (v
);
98 else if (scm_is_string (v
))
102 else if (scm_is_bitvector (v
))
104 h
->elements
= scm_array_handle_bit_elements (h
);
105 h
->ref
= bitvector_ref
;
107 else if (scm_is_bytevector (v
))
109 h
->elements
= scm_array_handle_uniform_elements (h
);
110 h
->ref
= bytevector_ref
;
113 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (h
->array
));
115 return h
->ref (h
, pos
);
119 enclosed_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
121 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-enclosed array");
125 vector_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
127 ((SCM
*)h
->writable_elements
)[pos
] = val
;
131 string_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
134 if (SCM_I_ARRAYP (h
->array
))
135 scm_c_string_set_x (SCM_I_ARRAY_V (h
->array
), pos
, val
);
137 scm_c_string_set_x (h
->array
, pos
, val
);
141 bitvector_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
144 pos
+= scm_array_handle_bit_elements_offset (h
);
145 mask
= 1l << (pos
% 32);
146 if (scm_to_bool (val
))
147 ((scm_t_uint32
*)h
->writable_elements
)[pos
/32] |= mask
;
149 ((scm_t_uint32
*)h
->writable_elements
)[pos
/32] &= ~mask
;
153 bytevector_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
156 scm_t_uint8
*elements
;
158 c_value
= scm_to_uint8 (val
);
159 elements
= (scm_t_uint8
*) h
->elements
;
160 elements
[pos
] = (scm_t_uint8
) c_value
;
164 memoize_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
168 if (SCM_I_ENCLOSED_ARRAYP (v
))
170 h
->set
= enclosed_set
;
171 enclosed_set (h
, pos
, val
);
175 if (SCM_I_ARRAYP (v
))
176 v
= SCM_I_ARRAY_V (v
);
178 if (scm_is_vector (v
))
180 h
->writable_elements
= scm_array_handle_writable_elements (h
);
183 else if (scm_is_uniform_vector (v
))
185 h
->writable_elements
= scm_array_handle_uniform_writable_elements (h
);
186 h
->set
= scm_i_uniform_vector_set_proc (v
);
188 else if (scm_is_string (v
))
192 else if (scm_is_bitvector (v
))
194 h
->writable_elements
= scm_array_handle_bit_writable_elements (h
);
195 h
->set
= bitvector_set
;
197 else if (scm_is_bytevector (v
))
199 h
->elements
= scm_array_handle_uniform_writable_elements (h
);
200 h
->set
= bytevector_set
;
203 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (h
->array
));
205 h
->set (h
, pos
, val
);
209 scm_array_get_handle (SCM array
, scm_t_array_handle
*h
)
212 h
->ref
= memoize_ref
;
213 h
->set
= memoize_set
;
215 if (SCM_I_ARRAYP (array
) || SCM_I_ENCLOSED_ARRAYP (array
))
217 h
->dims
= SCM_I_ARRAY_DIMS (array
);
218 h
->base
= SCM_I_ARRAY_BASE (array
);
220 else if (scm_is_generalized_vector (array
))
223 h
->dim0
.ubnd
= scm_c_generalized_vector_length (array
) - 1;
229 scm_wrong_type_arg_msg (NULL
, 0, array
, "array");
233 scm_array_handle_release (scm_t_array_handle
*h
)
235 /* Nothing to do here until arrays need to be reserved for real.
240 scm_array_handle_rank (scm_t_array_handle
*h
)
242 if (SCM_I_ARRAYP (h
->array
) || SCM_I_ENCLOSED_ARRAYP (h
->array
))
243 return SCM_I_ARRAY_NDIM (h
->array
);
249 scm_array_handle_dims (scm_t_array_handle
*h
)
255 scm_array_handle_elements (scm_t_array_handle
*h
)
258 if (SCM_I_ARRAYP (vec
))
259 vec
= SCM_I_ARRAY_V (vec
);
260 if (SCM_I_IS_VECTOR (vec
))
261 return SCM_I_VECTOR_ELTS (vec
) + h
->base
;
262 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-uniform array");
266 scm_array_handle_writable_elements (scm_t_array_handle
*h
)
269 if (SCM_I_ARRAYP (vec
))
270 vec
= SCM_I_ARRAY_V (vec
);
271 if (SCM_I_IS_VECTOR (vec
))
272 return SCM_I_VECTOR_WELTS (vec
) + h
->base
;
273 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-uniform array");
278 scm_init_array_handle (void)
280 #include "libguile/array-handle.x"