96dad819bc8025949af5a0ef28a4f5563bee60ba
1 /* Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
51 #include "scm_validate.h"
57 * This complicates things too much if allowed on any array.
58 * C code can safely call it on arrays known to be used in a single
61 * SCM_REGISTER_PROC(s_vector_set_length_x, "vector-set-length!", 2, 0, 0, scm_vector_set_length_x);
63 static char s_vector_set_length_x
[] = "vector-set-length!";
67 scm_vector_set_length_x (SCM vect
, SCM len
)
74 SCM_ASRTGO (SCM_NIMP (vect
), badarg1
);
77 if (SCM_TYP7 (vect
) == scm_tc7_bvect
)
79 l
= (l
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
81 sz
= scm_uniform_element_size (vect
);
84 switch (SCM_TYP7 (vect
))
87 badarg1
: scm_wta (vect
, (char *) SCM_ARG1
, s_vector_set_length_x
);
89 SCM_ASRTGO (vect
!= scm_nullstr
, badarg1
);
95 SCM_ASRTGO (vect
!= scm_nullvect
, badarg1
);
99 SCM_ASSERT (SCM_INUMP (len
), len
, SCM_ARG2
, s_vector_set_length_x
);
104 scm_wta (SCM_MAKINUM (l
* sz
), (char *) SCM_NALLOC
, s_vector_set_length_x
);
108 scm_must_realloc (SCM_CHARS (vect
),
109 (long) SCM_LENGTH (vect
) * sz
,
111 s_vector_set_length_x
)));
112 if (SCM_VECTORP (vect
))
114 sz
= SCM_LENGTH (vect
);
116 SCM_VELTS (vect
)[--l
] = SCM_UNSPECIFIED
;
118 else if (SCM_STRINGP (vect
))
119 SCM_CHARS (vect
)[l
- 1] = 0;
120 SCM_SETLENGTH (vect
, SCM_INUM (len
), SCM_TYP7 (vect
));
125 GUILE_PROC(scm_vector_p
, "vector?", 1, 0, 0,
128 #define FUNC_NAME s_scm_vector_p
130 if (SCM_IMP(x
)) return SCM_BOOL_F
;
131 return SCM_BOOL(SCM_VECTORP(x
));
135 SCM_GPROC(s_vector_length
, "vector-length", 1, 0, 0, scm_vector_length
, g_vector_length
);
138 scm_vector_length(SCM v
)
140 SCM_GASSERT1(SCM_NIMP(v
) && SCM_VECTORP(v
),
141 g_vector_length
, v
, SCM_ARG1
, s_vector_length
);
142 return SCM_MAKINUM(SCM_LENGTH(v
));
145 SCM_REGISTER_PROC(s_list_to_vector
, "list->vector", 1, 0, 0, scm_vector
);
147 GUILE_PROC(scm_vector
, "vector", 0, 0, 1,
150 #define FUNC_NAME s_scm_vector
155 SCM_VALIDATE_LIST_COPYLEN(1,l
,i
);
156 res
= scm_make_vector (SCM_MAKINUM(i
), SCM_UNSPECIFIED
);
157 data
= SCM_VELTS(res
);
158 for(;i
&& SCM_NIMP(l
);--i
, l
= SCM_CDR(l
))
159 *data
++ = SCM_CAR(l
);
164 SCM_GPROC(s_vector_ref
, "vector-ref", 2, 0, 0, scm_vector_ref
, g_vector_ref
);
167 scm_vector_ref (SCM v
, SCM k
)
169 SCM_GASSERT2 (SCM_NIMP (v
) && SCM_VECTORP (v
),
170 g_vector_ref
, v
, k
, SCM_ARG1
, s_vector_ref
);
171 SCM_GASSERT2 (SCM_INUMP (k
),
172 g_vector_ref
, v
, k
, SCM_ARG2
, s_vector_ref
);
173 SCM_ASSERT (SCM_INUM (k
) < SCM_LENGTH (v
) && SCM_INUM (k
) >= 0,
174 k
, SCM_OUTOFRANGE
, s_vector_ref
);
175 return SCM_VELTS (v
)[(long) SCM_INUM (k
)];
178 SCM_GPROC(s_vector_set_x
, "vector-set!", 3, 0, 0, scm_vector_set_x
, g_vector_set_x
);
181 scm_vector_set_x(SCM v
, SCM k
, SCM obj
)
183 SCM_GASSERTn (SCM_NIMP(v
) && SCM_VECTORP(v
),
184 g_vector_set_x
, SCM_LIST3 (v
, k
, obj
),
185 SCM_ARG1
, s_vector_set_x
);
186 SCM_GASSERTn (SCM_INUMP(k
),
187 g_vector_set_x
, SCM_LIST3 (v
, k
, obj
),
188 SCM_ARG2
, s_vector_set_x
);
189 SCM_ASSERT ((SCM_INUM(k
) < SCM_LENGTH(v
)) && (SCM_INUM(k
) >= 0),
190 k
, SCM_OUTOFRANGE
, s_vector_set_x
);
191 SCM_VELTS(v
)[((long) SCM_INUM(k
))] = obj
;
196 GUILE_PROC (scm_make_vector
, "make-vector", 1, 1, 0,
199 #define FUNC_NAME s_scm_make_vector
206 SCM_VALIDATE_INT_MIN(1,k
,0);
207 if (SCM_UNBNDP(fill
))
208 fill
= SCM_UNSPECIFIED
;
212 SCM_SETCHARS(v
, scm_must_malloc(i
?(long)(i
*sizeof(SCM
)):1L, FUNC_NAME
));
213 SCM_SETLENGTH(v
, i
, scm_tc7_vector
);
214 velts
= SCM_VELTS(v
);
216 while(--i
>= j
) (velts
)[i
] = fill
;
223 GUILE_PROC(scm_vector_to_list
, "vector->list", 1, 0, 0,
226 #define FUNC_NAME s_scm_vector_to_list
231 SCM_VALIDATE_VECTOR(1,v
);
233 for(i
= SCM_LENGTH(v
)-1;i
>= 0;i
--) res
= scm_cons(data
[i
], res
);
239 GUILE_PROC (scm_vector_fill_x
, "vector-fill!", 2, 0, 0,
242 #define FUNC_NAME s_scm_vector_fill_x
246 SCM_VALIDATE_VECTOR(1,v
);
248 for(i
= SCM_LENGTH(v
) - 1; i
>= 0; i
--)
250 return SCM_UNSPECIFIED
;
257 scm_vector_equal_p(SCM x
, SCM y
)
260 for(i
= SCM_LENGTH(x
)-1;i
>= 0;i
--)
261 if (SCM_FALSEP(scm_equal_p(SCM_VELTS(x
)[i
], SCM_VELTS(y
)[i
])))
267 GUILE_PROC (scm_vector_move_left_x
, "vector-move-left!", 5, 0, 0,
268 (SCM vec1
, SCM start1
, SCM end1
, SCM vec2
, SCM start2
),
269 "Vector version of @code{substring-move-left!}.")
270 #define FUNC_NAME s_scm_vector_move_left_x
276 SCM_VALIDATE_VECTOR(1,vec1
);
277 SCM_VALIDATE_INT_COPY(2,start1
,i
);
278 SCM_VALIDATE_INT_COPY(3,end1
,e
);
279 SCM_VALIDATE_VECTOR(4,vec2
);
280 SCM_VALIDATE_INT_COPY(5,start2
,j
);
281 SCM_ASSERT (i
<= SCM_LENGTH (vec1
) && i
>= 0, start1
, SCM_OUTOFRANGE
, FUNC_NAME
);
282 SCM_ASSERT (j
<= SCM_LENGTH (vec2
) && j
>= 0, start2
, SCM_OUTOFRANGE
, FUNC_NAME
);
283 SCM_ASSERT (e
<= SCM_LENGTH (vec1
) && e
>= 0, end1
, SCM_OUTOFRANGE
, FUNC_NAME
);
284 SCM_ASSERT (e
-i
+j
<= SCM_LENGTH (vec2
), start2
, SCM_OUTOFRANGE
, FUNC_NAME
);
285 while (i
<e
) SCM_VELTS (vec2
)[j
++] = SCM_VELTS (vec1
)[i
++];
286 return SCM_UNSPECIFIED
;
290 GUILE_PROC (scm_vector_move_right_x
, "vector-move-right!", 5, 0, 0,
291 (SCM vec1
, SCM start1
, SCM end1
, SCM vec2
, SCM start2
),
292 "Vector version of @code{substring-move-right!}.")
293 #define FUNC_NAME s_scm_vector_move_right_x
299 SCM_VALIDATE_VECTOR(1,vec1
);
300 SCM_VALIDATE_INT_COPY(2,start1
,i
);
301 SCM_VALIDATE_INT_COPY(3,end1
,e
);
302 SCM_VALIDATE_VECTOR(4,vec2
);
303 SCM_VALIDATE_INT_COPY(5,start2
,j
);
304 SCM_ASSERT (i
<= SCM_LENGTH (vec1
) && i
>= 0, start1
, SCM_OUTOFRANGE
, FUNC_NAME
);
305 SCM_ASSERT (j
<= SCM_LENGTH (vec2
) && j
>= 0, start2
, SCM_OUTOFRANGE
, FUNC_NAME
);
306 SCM_ASSERT (e
<= SCM_LENGTH (vec1
) && e
>= 0, end1
, SCM_OUTOFRANGE
, FUNC_NAME
);
308 SCM_ASSERT (j
<= SCM_LENGTH (vec2
), start2
, SCM_OUTOFRANGE
, FUNC_NAME
);
310 SCM_VELTS (vec2
)[--j
] = SCM_VELTS (vec1
)[--e
];
311 return SCM_UNSPECIFIED
;
322 scm_make_subr (s_resizuve, scm_tc7_subr_2, scm_vector_set_length_x); */