1 /*===========================================================================
2 * Filename : vector.c
3 * About : R5RS vectors
4 *
5 * Copyright (C) 2005 Kazuki Ohta <mover AT hct.zaq.ne.jp>
6 * Copyright (C) 2005-2006 Jun Inoue <jun.lambda AT gmail.com>
7 * Copyright (C) 2005-2006 YAMAMOTO Kengo <yamaken AT bp.iij4u.or.jp>
8 * Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
9 *
10 * All rights reserved.
11 *
12 * Redistribution and use in source and binary forms, with or without
13 * modification, are permitted provided that the following conditions
14 * are met:
15 *
16 * 1. Redistributions of source code must retain the above copyright
17 * notice, this list of conditions and the following disclaimer.
18 * 2. Redistributions in binary form must reproduce the above copyright
19 * notice, this list of conditions and the following disclaimer in the
20 * documentation and/or other materials provided with the distribution.
21 * 3. Neither the name of authors nor the names of its contributors
22 * may be used to endorse or promote products derived from this software
23 * without specific prior written permission.
24 *
25 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
26 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
27 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
28 * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
29 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
30 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
31 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
32 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
33 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
34 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
35 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36 ===========================================================================*/
37
38 #include <config.h>
39
40 #include "sigscheme.h"
41 #include "sigschemeinternal.h"
42
43 /*=======================================
44 File Local Macro Definitions
45 =======================================*/
46
47 /*=======================================
48 File Local Type Definitions
49 =======================================*/
50
51 /*=======================================
52 Variable Definitions
53 =======================================*/
54
55 /*=======================================
56 File Local Function Declarations
57 =======================================*/
58
59 /*=======================================
60 Function Definitions
61 =======================================*/
62 /*===========================================================================
63 R5RS : 6.3 Other data types : 6.3.6 Vectors
64 ===========================================================================*/
65 SCM_EXPORT ScmObj
scm_p_vectorp(ScmObj obj)66 scm_p_vectorp(ScmObj obj)
67 {
68 DECLARE_FUNCTION("vector?", procedure_fixed_1);
69
70 return MAKE_BOOL(VECTORP(obj));
71 }
72
73 SCM_EXPORT ScmObj
scm_p_make_vector(ScmObj scm_len,ScmObj args)74 scm_p_make_vector(ScmObj scm_len, ScmObj args)
75 {
76 ScmObj *vec, filler;
77 scm_int_t len, i;
78 DECLARE_FUNCTION("make-vector", procedure_variadic_1);
79
80 ENSURE_INT(scm_len);
81
82 len = SCM_INT_VALUE(scm_len);
83 if (len < 0)
84 ERR_OBJ("length must be a non-negative integer", scm_len);
85
86 vec = scm_malloc(sizeof(ScmObj) * len);
87 if (NULLP(args)) {
88 filler = SCM_UNDEF;
89 } else {
90 filler = POP(args);
91 ASSERT_NO_MORE_ARG(args);
92 }
93 for (i = 0; i < len; i++)
94 vec[i] = filler;
95
96 return MAKE_VECTOR(vec, len);
97 }
98
99 SCM_EXPORT ScmObj
scm_p_vector(ScmObj args)100 scm_p_vector(ScmObj args)
101 {
102 DECLARE_FUNCTION("vector", procedure_variadic_0);
103
104 return scm_p_list2vector(args);
105 }
106
107 SCM_EXPORT ScmObj
scm_p_vector_length(ScmObj vec)108 scm_p_vector_length(ScmObj vec)
109 {
110 DECLARE_FUNCTION("vector-length", procedure_fixed_1);
111
112 ENSURE_VECTOR(vec);
113
114 return MAKE_INT(SCM_VECTOR_LEN(vec));
115 }
116
117 SCM_EXPORT ScmObj
scm_p_vector_ref(ScmObj vec,ScmObj _k)118 scm_p_vector_ref(ScmObj vec, ScmObj _k)
119 {
120 scm_int_t k;
121 DECLARE_FUNCTION("vector-ref", procedure_fixed_2);
122
123 ENSURE_VECTOR(vec);
124 ENSURE_INT(_k);
125
126 k = SCM_INT_VALUE(_k);
127
128 if (!SCM_VECTOR_VALID_INDEXP(vec, k))
129 ERR_OBJ("index out of range", _k);
130
131 return SCM_VECTOR_VEC(vec)[k];
132 }
133
134 SCM_EXPORT ScmObj
scm_p_vector_setx(ScmObj vec,ScmObj _k,ScmObj obj)135 scm_p_vector_setx(ScmObj vec, ScmObj _k, ScmObj obj)
136 {
137 scm_int_t k;
138 DECLARE_FUNCTION("vector-set!", procedure_fixed_3);
139
140 ENSURE_VECTOR(vec);
141 #if SCM_CONST_VECTOR_LITERAL
142 ENSURE_MUTABLE_VECTOR(vec);
143 #endif
144 ENSURE_INT(_k);
145
146 k = SCM_INT_VALUE(_k);
147
148 if (!SCM_VECTOR_VALID_INDEXP(vec, k))
149 ERR_OBJ("index out of range", _k);
150
151 SCM_VECTOR_VEC(vec)[k] = obj;
152
153 return SCM_UNDEF;
154 }
155
156 SCM_EXPORT ScmObj
scm_p_vector2list(ScmObj vec)157 scm_p_vector2list(ScmObj vec)
158 {
159 ScmQueue q;
160 ScmObj ret, *v;
161 scm_int_t len, i;
162 DECLARE_FUNCTION("vector->list", procedure_fixed_1);
163
164 ENSURE_VECTOR(vec);
165
166 v = SCM_VECTOR_VEC(vec);
167 len = SCM_VECTOR_LEN(vec);
168
169 ret = SCM_NULL;
170 SCM_QUEUE_POINT_TO(q, ret);
171 for (i = 0; i < len; i++)
172 SCM_QUEUE_ADD(q, v[i]);
173
174 return ret;
175 }
176
177 SCM_EXPORT ScmObj
scm_p_list2vector(ScmObj lst)178 scm_p_list2vector(ScmObj lst)
179 {
180 ScmObj *vec;
181 scm_int_t len, i;
182 DECLARE_FUNCTION("list->vector", procedure_fixed_1);
183
184 len = scm_length(lst);
185 if (!SCM_LISTLEN_PROPERP(len))
186 ERR_OBJ("proper list required but got", lst);
187
188 vec = scm_malloc(sizeof(ScmObj) * len);
189 for (i = 0; i < len; i++)
190 vec[i] = POP(lst);
191
192 return MAKE_VECTOR(vec, len);
193 }
194
195 SCM_EXPORT ScmObj
scm_p_vector_fillx(ScmObj vec,ScmObj fill)196 scm_p_vector_fillx(ScmObj vec, ScmObj fill)
197 {
198 ScmObj *v;
199 scm_int_t len, i;
200 DECLARE_FUNCTION("vector-fill!", procedure_fixed_2);
201
202 ENSURE_VECTOR(vec);
203 #if SCM_CONST_VECTOR_LITERAL
204 ENSURE_MUTABLE_VECTOR(vec);
205 #endif
206
207 v = SCM_VECTOR_VEC(vec);
208 len = SCM_VECTOR_LEN(vec);
209 for (i = 0; i < len; i++)
210 v[i] = fill;
211
212 return SCM_UNDEF;
213 }
214
215 /* This procedure should rightfully be written in module-sscm-ext.c, but since
216 * SigScheme's function table generator isn't supporting #if -surrounded
217 * procedure, it packed into this file. */
218 SCM_EXPORT ScmObj
scm_p_vector_mutablep(ScmObj vec)219 scm_p_vector_mutablep(ScmObj vec)
220 {
221 DECLARE_FUNCTION("%%vector-mutable?", procedure_fixed_1);
222
223 ENSURE_VECTOR(vec);
224
225 return MAKE_BOOL(SCM_VECTOR_MUTABLEP(vec));
226 }
227