/* Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2, or (at your option) * any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this software; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, * Boston, MA 02111-1307 USA * * As a special exception, the Free Software Foundation gives permission * for additional uses of the text contained in its release of GUILE. * * The exception is that, if you link the GUILE library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of * linking the GUILE library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the * Free Software Foundation under the name GUILE. If you copy * code from other Free Software Foundation releases into a copy of * GUILE, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include #include "_scm.h" #include "eq.h" #include "scm_validate.h" #include "vectors.h" #include "unif.h" /* * This complicates things too much if allowed on any array. * C code can safely call it on arrays known to be used in a single * threaded manner. * * SCM_REGISTER_PROC(s_vector_set_length_x, "vector-set-length!", 2, 0, 0, scm_vector_set_length_x); */ static char s_vector_set_length_x[] = "vector-set-length!"; SCM scm_vector_set_length_x (SCM vect, SCM len) { long l; scm_sizet siz; scm_sizet sz; l = SCM_INUM (len); SCM_ASRTGO (SCM_NIMP (vect), badarg1); #ifdef HAVE_ARRAYS if (SCM_TYP7 (vect) == scm_tc7_bvect) { l = (l + SCM_LONG_BIT - 1) / SCM_LONG_BIT; } sz = scm_uniform_element_size (vect); if (sz == 0) #endif switch (SCM_TYP7 (vect)) { default: badarg1: scm_wta (vect, (char *) SCM_ARG1, s_vector_set_length_x); case scm_tc7_string: SCM_ASRTGO (vect != scm_nullstr, badarg1); sz = sizeof (char); l++; break; case scm_tc7_vector: case scm_tc7_wvect: SCM_ASRTGO (vect != scm_nullvect, badarg1); sz = sizeof (SCM); break; } SCM_ASSERT (SCM_INUMP (len), len, SCM_ARG2, s_vector_set_length_x); if (!l) l = 1L; siz = l * sz; if (siz != l * sz) scm_wta (SCM_MAKINUM (l * sz), (char *) SCM_NALLOC, s_vector_set_length_x); SCM_REDEFER_INTS; SCM_SETCHARS (vect, ((char *) scm_must_realloc (SCM_CHARS (vect), (long) SCM_LENGTH (vect) * sz, (long) siz, s_vector_set_length_x))); if (SCM_VECTORP (vect)) { sz = SCM_LENGTH (vect); while (l > sz) SCM_VELTS (vect)[--l] = SCM_UNSPECIFIED; } else if (SCM_STRINGP (vect)) SCM_CHARS (vect)[l - 1] = 0; SCM_SETLENGTH (vect, SCM_INUM (len), SCM_TYP7 (vect)); SCM_REALLOW_INTS; return vect; } GUILE_PROC (scm_vector_p, "vector?", 1, 0, 0, (SCM x), "") #define FUNC_NAME s_scm_vector_p { if (SCM_IMP (x)) return SCM_BOOL_F; return SCM_BOOL (SCM_VECTORP (x)); } #undef FUNC_NAME SCM_GPROC (s_vector_length, "vector-length", 1, 0, 0, scm_vector_length, g_vector_length); SCM scm_vector_length (SCM v) { SCM_GASSERT1 (SCM_VECTORP(v), g_vector_length, v, SCM_ARG1, s_vector_length); return SCM_MAKINUM (SCM_LENGTH (v)); } SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector); GUILE_PROC (scm_vector, "vector", 0, 0, 1, (SCM l), "") #define FUNC_NAME s_scm_vector { SCM res; register SCM *data; int i; SCM_VALIDATE_LIST_COPYLEN (1,l,i); res = scm_make_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED); data = SCM_VELTS (res); for(; i && SCM_NIMP(l); --i, l = SCM_CDR (l)) *data++ = SCM_CAR (l); return res; } #undef FUNC_NAME SCM_GPROC (s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref, g_vector_ref); SCM scm_vector_ref (SCM v, SCM k) { SCM_GASSERT2 (SCM_VECTORP (v), g_vector_ref, v, k, SCM_ARG1, s_vector_ref); SCM_GASSERT2 (SCM_INUMP (k), g_vector_ref, v, k, SCM_ARG2, s_vector_ref); SCM_ASSERT (SCM_INUM (k) < SCM_LENGTH (v) && SCM_INUM (k) >= 0, k, SCM_OUTOFRANGE, s_vector_ref); return SCM_VELTS (v)[(long) SCM_INUM (k)]; } SCM_GPROC (s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x, g_vector_set_x); SCM scm_vector_set_x (SCM v, SCM k, SCM obj) { SCM_GASSERTn (SCM_VECTORP (v), g_vector_set_x, SCM_LIST3 (v, k, obj), SCM_ARG1, s_vector_set_x); SCM_GASSERTn (SCM_INUMP (k), g_vector_set_x, SCM_LIST3 (v, k, obj), SCM_ARG2, s_vector_set_x); SCM_ASSERT ((SCM_INUM (k) < SCM_LENGTH (v)) && (SCM_INUM (k) >= 0), k, SCM_OUTOFRANGE, s_vector_set_x); SCM_VELTS(v)[(long) SCM_INUM(k)] = obj; return obj; } GUILE_PROC (scm_make_vector, "make-vector", 1, 1, 0, (SCM k, SCM fill), "") #define FUNC_NAME s_scm_make_vector { SCM v; register long i; register long j; register SCM *velts; SCM_VALIDATE_INT_MIN(1,k,0); if (SCM_UNBNDP(fill)) fill = SCM_UNSPECIFIED; i = SCM_INUM(k); SCM_NEWCELL(v); SCM_DEFER_INTS; SCM_SETCHARS(v, scm_must_malloc(i?(long)(i*sizeof(SCM)):1L, FUNC_NAME)); SCM_SETLENGTH(v, i, scm_tc7_vector); velts = SCM_VELTS(v); j = 0; while(--i >= j) (velts)[i] = fill; SCM_ALLOW_INTS; return v; } #undef FUNC_NAME GUILE_PROC(scm_vector_to_list, "vector->list", 1, 0, 0, (SCM v), "") #define FUNC_NAME s_scm_vector_to_list { SCM res = SCM_EOL; long i; SCM *data; SCM_VALIDATE_VECTOR(1,v); data = SCM_VELTS(v); for(i = SCM_LENGTH(v)-1;i >= 0;i--) res = scm_cons(data[i], res); return res; } #undef FUNC_NAME GUILE_PROC (scm_vector_fill_x, "vector-fill!", 2, 0, 0, (SCM v, SCM fill_x), "") #define FUNC_NAME s_scm_vector_fill_x { register long i; register SCM *data; SCM_VALIDATE_VECTOR(1,v); data = SCM_VELTS(v); for(i = SCM_LENGTH(v) - 1; i >= 0; i--) data[i] = fill_x; return SCM_UNSPECIFIED; } #undef FUNC_NAME SCM scm_vector_equal_p(SCM x, SCM y) { long i; for(i = SCM_LENGTH(x)-1;i >= 0;i--) if (SCM_FALSEP(scm_equal_p(SCM_VELTS(x)[i], SCM_VELTS(y)[i]))) return SCM_BOOL_F; return SCM_BOOL_T; } GUILE_PROC (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0, (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2), "Vector version of @code{substring-move-left!}.") #define FUNC_NAME s_scm_vector_move_left_x { long i; long j; long e; SCM_VALIDATE_VECTOR(1,vec1); SCM_VALIDATE_INT_COPY(2,start1,i); SCM_VALIDATE_INT_COPY(3,end1,e); SCM_VALIDATE_VECTOR(4,vec2); SCM_VALIDATE_INT_COPY(5,start2,j); SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, FUNC_NAME); SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, FUNC_NAME); SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, FUNC_NAME); SCM_ASSERT (e-i+j <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, FUNC_NAME); while (i= 0, start1, SCM_OUTOFRANGE, FUNC_NAME); SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, FUNC_NAME); SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, FUNC_NAME); j = e - i + j; SCM_ASSERT (j <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, FUNC_NAME); while (i < e) SCM_VELTS (vec2)[--j] = SCM_VELTS (vec1)[--e]; return SCM_UNSPECIFIED; } #undef FUNC_NAME void scm_init_vectors () { #include "vectors.x" /* scm_make_subr (s_resizuve, scm_tc7_subr_2, scm_vector_set_length_x); */ }