1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005,
2 * 2006, 2009, 2011, 2013 Free Software Foundation, Inc.
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.
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.
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
27 #include "libguile/_scm.h"
28 #include "libguile/__scm.h"
30 #include "libguile/array-handle.h"
33 SCM scm_i_array_element_types
[SCM_ARRAY_ELEMENT_TYPE_LAST
+ 1];
36 #define ARRAY_IMPLS_N_STATIC_ALLOC 7
37 static scm_t_array_implementation array_impls
[ARRAY_IMPLS_N_STATIC_ALLOC
];
38 static int num_array_impls_registered
= 0;
42 scm_i_register_array_implementation (scm_t_array_implementation
*impl
)
44 if (num_array_impls_registered
>= ARRAY_IMPLS_N_STATIC_ALLOC
)
45 /* need to increase ARRAY_IMPLS_N_STATIC_ALLOC, buster */
48 array_impls
[num_array_impls_registered
++] = *impl
;
51 scm_t_array_implementation
*
52 scm_i_array_implementation_for_obj (SCM obj
)
55 for (i
= 0; i
< num_array_impls_registered
; i
++)
57 && (SCM_CELL_TYPE (obj
) & array_impls
[i
].mask
) == array_impls
[i
].tag
)
58 return &array_impls
[i
];
63 scm_array_get_handle (SCM array
, scm_t_array_handle
*h
)
65 scm_t_array_implementation
*impl
= scm_i_array_implementation_for_obj (array
);
67 scm_wrong_type_arg_msg (NULL
, 0, array
, "array");
73 h
->element_type
= SCM_ARRAY_ELEMENT_TYPE_SCM
; /* have to default to
76 h
->writable_elements
= NULL
;
77 h
->impl
->get_handle (array
, h
);
81 scm_array_handle_pos (scm_t_array_handle
*h
, SCM indices
)
83 scm_t_array_dim
*s
= scm_array_handle_dims (h
);
85 size_t k
= scm_array_handle_rank (h
);
87 while (k
> 0 && scm_is_pair (indices
))
89 i
= scm_to_signed_integer (SCM_CAR (indices
), s
->lbnd
, s
->ubnd
);
90 pos
+= (i
- s
->lbnd
) * s
->inc
;
93 indices
= SCM_CDR (indices
);
95 if (k
> 0 || !scm_is_null (indices
))
96 scm_misc_error (NULL
, "wrong number of indices, expecting ~a",
97 scm_list_1 (scm_from_size_t (scm_array_handle_rank (h
))));
102 check_array_index_bounds (scm_t_array_dim
*dim
, ssize_t idx
)
104 if (idx
< dim
->lbnd
|| idx
> dim
->ubnd
)
105 scm_error (scm_out_of_range_key
, NULL
, "Value out of range ~S to ~S: ~S",
106 scm_list_3 (scm_from_ssize_t (dim
->lbnd
),
107 scm_from_ssize_t (dim
->ubnd
),
108 scm_from_ssize_t (idx
)),
109 scm_list_1 (scm_from_ssize_t (idx
)));
113 scm_array_handle_pos_1 (scm_t_array_handle
*h
, ssize_t idx0
)
115 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
117 if (scm_array_handle_rank (h
) != 1)
118 scm_misc_error (NULL
, "wrong number of indices, expecting ~A",
119 scm_list_1 (scm_from_size_t (scm_array_handle_rank (h
))));
121 check_array_index_bounds (&dim
[0], idx0
);
123 return (idx0
- dim
[0].lbnd
) * dim
[0].inc
;
127 scm_array_handle_pos_2 (scm_t_array_handle
*h
, ssize_t idx0
, ssize_t idx1
)
129 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
131 if (scm_array_handle_rank (h
) != 2)
132 scm_misc_error (NULL
, "wrong number of indices, expecting ~A",
133 scm_list_1 (scm_from_size_t (scm_array_handle_rank (h
))));
135 check_array_index_bounds (&dim
[0], idx0
);
136 check_array_index_bounds (&dim
[1], idx1
);
138 return ((idx0
- dim
[0].lbnd
) * dim
[0].inc
139 + (idx1
- dim
[1].lbnd
) * dim
[1].inc
);
143 scm_array_handle_element_type (scm_t_array_handle
*h
)
145 if (h
->element_type
< 0 || h
->element_type
> SCM_ARRAY_ELEMENT_TYPE_LAST
)
146 abort (); /* guile programming error */
147 return scm_i_array_element_types
[h
->element_type
];
151 scm_array_handle_release (scm_t_array_handle
*h
)
153 /* Nothing to do here until arrays need to be reserved for real.
158 scm_array_handle_elements (scm_t_array_handle
*h
)
160 if (h
->element_type
!= SCM_ARRAY_ELEMENT_TYPE_SCM
)
161 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-uniform array");
162 return ((const SCM
*)h
->elements
) + h
->base
;
166 scm_array_handle_writable_elements (scm_t_array_handle
*h
)
168 if (h
->element_type
!= SCM_ARRAY_ELEMENT_TYPE_SCM
)
169 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-uniform array");
170 return ((SCM
*)h
->elements
) + h
->base
;
174 scm_init_array_handle (void)
176 #define DEFINE_ARRAY_TYPE(tag, TAG) \
177 scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] = scm_from_utf8_symbol (#tag)
179 scm_i_array_element_types
[SCM_ARRAY_ELEMENT_TYPE_SCM
] = SCM_BOOL_T
;
180 DEFINE_ARRAY_TYPE (a
, CHAR
);
181 DEFINE_ARRAY_TYPE (b
, BIT
);
182 DEFINE_ARRAY_TYPE (vu8
, VU8
);
183 DEFINE_ARRAY_TYPE (u8
, U8
);
184 DEFINE_ARRAY_TYPE (s8
, S8
);
185 DEFINE_ARRAY_TYPE (u16
, U16
);
186 DEFINE_ARRAY_TYPE (s16
, S16
);
187 DEFINE_ARRAY_TYPE (u32
, U32
);
188 DEFINE_ARRAY_TYPE (s32
, S32
);
189 DEFINE_ARRAY_TYPE (u64
, U64
);
190 DEFINE_ARRAY_TYPE (s64
, S64
);
191 DEFINE_ARRAY_TYPE (f32
, F32
);
192 DEFINE_ARRAY_TYPE (f64
, F64
);
193 DEFINE_ARRAY_TYPE (c32
, C32
);
194 DEFINE_ARRAY_TYPE (c64
, C64
);
196 #include "libguile/array-handle.x"