libguile/vectors.c

   1 /*      Copyright (C) 1995, 1996, 1998 Free Software Foundation, Inc.
   2  *
   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)
   6  * any later version.
   7  *
   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.
  12  *
  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
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  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.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  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.
  37  *
  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.  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45 #include "eq.h"
  46
  47 #include "vectors.h"
  48 \f
  49
  50
  51 SCM_PROC(s_vector_p, "vector?", 1, 0, 0, scm_vector_p);
  52
  53 SCM
  54 scm_vector_p(x)
  55      SCM x;
  56 {
  57   if (SCM_IMP(x)) return SCM_BOOL_F;
  58   return SCM_VECTORP(x) ? SCM_BOOL_T : SCM_BOOL_F;
  59 }
  60
  61 SCM_PROC(s_vector_length, "vector-length", 1, 0, 0, scm_vector_length);
  62
  63 SCM
  64 scm_vector_length(v)
  65      SCM v;
  66 {
  67   SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_length);
  68   return SCM_MAKINUM(SCM_LENGTH(v));
  69 }
  70
  71 SCM_PROC(s_list_to_vector, "list->vector", 1, 0, 0, scm_vector);
  72 SCM_PROC(s_vector, "vector", 0, 0, 1, scm_vector);
  73
  74 SCM
  75 scm_vector(l)
  76      SCM l;
  77 {
  78   SCM res;
  79   register SCM *data;
  80   long i = scm_ilength(l);
  81   SCM_ASSERT(i >= 0, l, SCM_ARG1, s_vector);
  82   res = scm_make_vector (SCM_MAKINUM(i), SCM_UNSPECIFIED);
  83   data = SCM_VELTS(res);
  84   for(;i && SCM_NIMP(l);--i, l = SCM_CDR(l))
  85     *data++ = SCM_CAR(l);
  86   return res;
  87 }
  88
  89 SCM_PROC(s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref);
  90
  91 SCM
  92 scm_vector_ref (SCM v, SCM k)
  93 {
  94   SCM_ASSERT (SCM_NIMP (v) && SCM_VECTORP (v), v, SCM_ARG1, s_vector_ref);
  95   SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG2, s_vector_ref);
  96   SCM_ASSERT (SCM_INUM (k) < SCM_LENGTH (v) && SCM_INUM (k) >= 0,
  97               k, SCM_OUTOFRANGE, s_vector_ref);
  98   return SCM_VELTS (v)[(long) SCM_INUM (k)];
  99 }
 100
 101 SCM_PROC(s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x);
 102
 103 SCM
 104 scm_vector_set_x(v, k, obj)
 105      SCM v;
 106      SCM k;
 107      SCM obj;
 108 {
 109   SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_set_x);
 110   SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_vector_set_x);
 111   SCM_ASSERT((SCM_INUM(k) < SCM_LENGTH(v)) && (SCM_INUM(k) >= 0), k, SCM_OUTOFRANGE, s_vector_set_x);
 112   SCM_VELTS(v)[((long) SCM_INUM(k))] = obj;
 113   return obj;
 114 }
 115
 116
 117 SCM_PROC (s_make_vector, "make-vector", 1, 1, 0, scm_make_vector);
 118
 119 SCM
 120 scm_make_vector (k, fill)
 121      SCM k;
 122      SCM fill;
 123 {
 124   SCM v;
 125   register long i;
 126   register long j;
 127   register SCM *velts;
 128
 129   SCM_ASSERT(SCM_INUMP(k) && (0 <= SCM_INUM (k)), k, SCM_ARG1, s_make_vector);
 130   if (SCM_UNBNDP(fill))
 131     fill = SCM_UNSPECIFIED;
 132   i = SCM_INUM(k);
 133   SCM_NEWCELL(v);
 134   SCM_DEFER_INTS;
 135   SCM_SETCHARS(v, scm_must_malloc(i?(long)(i*sizeof(SCM)):1L, s_vector));
 136   SCM_SETLENGTH(v, i, scm_tc7_vector);
 137   velts = SCM_VELTS(v);
 138   j = 0;
 139   while(--i >= j) (velts)[i] = fill;
 140   SCM_ALLOW_INTS;
 141   return v;
 142 }
 143
 144
 145 SCM_PROC(s_vector_to_list, "vector->list", 1, 0, 0, scm_vector_to_list);
 146
 147 SCM
 148 scm_vector_to_list(v)
 149      SCM v;
 150 {
 151   SCM res = SCM_EOL;
 152   long i;
 153   SCM *data;
 154   SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_to_list);
 155   data = SCM_VELTS(v);
 156   for(i = SCM_LENGTH(v)-1;i >= 0;i--) res = scm_cons(data[i], res);
 157   return res;
 158 }
 159
 160
 161 SCM_PROC (s_vector_fill_x, "vector-fill!", 2, 0, 0, scm_vector_fill_x);
 162
 163 SCM
 164 scm_vector_fill_x (v, fill_x)
 165      SCM v;
 166      SCM fill_x;
 167 {
 168   register long i;
 169   register SCM *data;
 170   SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_fill_x);
 171   data = SCM_VELTS(v);
 172   for(i = SCM_LENGTH(v) - 1; i >= 0; i--)
 173     data[i] = fill_x;
 174   return SCM_UNSPECIFIED;
 175 }
 176
 177
 178
 179 SCM
 180 scm_vector_equal_p(x, y)
 181      SCM x;
 182      SCM y;
 183 {
 184   long i;
 185   for(i = SCM_LENGTH(x)-1;i >= 0;i--)
 186     if (SCM_FALSEP(scm_equal_p(SCM_VELTS(x)[i], SCM_VELTS(y)[i])))
 187       return SCM_BOOL_F;
 188   return SCM_BOOL_T;
 189 }
 190
 191
 192 SCM_PROC (s_vector_move_left_x, "vector-move-left!", 5, 0, 0, scm_vector_move_left_x);
 193
 194 SCM
 195 scm_vector_move_left_x (vec1, start1, end1, vec2, start2)
 196      SCM vec1;
 197      SCM start1;
 198      SCM end1;
 199      SCM vec2;
 200      SCM start2;
 201 {
 202   long i;
 203   long j;
 204   long e;
 205
 206   SCM_ASSERT (SCM_NIMP (vec1) && SCM_VECTORP (vec1), vec1, SCM_ARG1, s_vector_move_left_x);
 207   SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_vector_move_left_x);
 208   SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_vector_move_left_x);
 209   SCM_ASSERT (SCM_NIMP (vec2) && SCM_VECTORP (vec2), vec2, SCM_ARG4, s_vector_move_left_x);
 210   SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_vector_move_left_x);
 211   i = SCM_INUM (start1);
 212   j = SCM_INUM (start2);
 213   e = SCM_INUM (end1);
 214   SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, s_vector_move_left_x);
 215   SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, s_vector_move_left_x);
 216   SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, s_vector_move_left_x);
 217   SCM_ASSERT (e-i+j <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, s_vector_move_left_x);
 218   while (i<e) SCM_VELTS (vec2)[j++] = SCM_VELTS (vec1)[i++];
 219   return SCM_UNSPECIFIED;
 220 }
 221
 222 SCM_PROC (s_vector_move_right_x, "vector-move-right!", 5, 0, 0, scm_vector_move_right_x);
 223
 224 SCM
 225 scm_vector_move_right_x (vec1, start1, end1, vec2, start2)
 226      SCM vec1;
 227      SCM start1;
 228      SCM end1;
 229      SCM vec2;
 230      SCM start2;
 231 {
 232   long i;
 233   long j;
 234   long e;
 235
 236   SCM_ASSERT (SCM_NIMP (vec1) && SCM_VECTORP (vec1), vec1, SCM_ARG1, s_vector_move_right_x);
 237   SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_vector_move_right_x);
 238   SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_vector_move_right_x);
 239   SCM_ASSERT (SCM_NIMP (vec2) && SCM_VECTORP (vec2), vec2, SCM_ARG4, s_vector_move_right_x);
 240   SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_vector_move_right_x);
 241   i = SCM_INUM (start1);
 242   j = SCM_INUM (start2);
 243   e = SCM_INUM (end1);
 244   SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, s_vector_move_right_x);
 245   SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, s_vector_move_right_x);
 246   SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, s_vector_move_right_x);
 247   SCM_ASSERT ((j = e-i+j) <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, s_vector_move_right_x);
 248   while (i<e) SCM_VELTS (vec2)[--j] = SCM_VELTS (vec1)[--e];
 249   return SCM_UNSPECIFIED;
 250 }
 251
 252
 253
 254 void
 255 scm_init_vectors ()
 256 {
 257 #include "vectors.x"
 258 }
 259