libguile/vectors.c

   1 /*      Copyright (C) 1995,1996 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(v, k)
  93      SCM v;
  94      SCM k;
  95 {
  96   SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_ref);
  97   SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_vector_ref);
  98   SCM_ASSERT((SCM_INUM(k) < SCM_LENGTH(v)) && (SCM_INUM(k) >= 0), k, SCM_OUTOFRANGE, s_vector_ref);
  99   return SCM_VELTS(v)[((long) SCM_INUM(k))];
 100 }
 101
 102
 103 SCM_PROC(s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x);
 104
 105 SCM
 106 scm_vector_set_x(v, k, obj)
 107      SCM v;
 108      SCM k;
 109      SCM obj;
 110 {
 111   SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_set_x);
 112   SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_vector_set_x);
 113   SCM_ASSERT((SCM_INUM(k) < SCM_LENGTH(v)) && (SCM_INUM(k) >= 0), k, SCM_OUTOFRANGE, s_vector_set_x);
 114   SCM_VELTS(v)[((long) SCM_INUM(k))] = obj;
 115   return obj;
 116 }
 117
 118
 119 SCM_PROC (s_make_vector, "make-vector", 1, 1, 0, scm_make_vector);
 120
 121 SCM
 122 scm_make_vector (k, fill)
 123      SCM k;
 124      SCM fill;
 125 {
 126   SCM v;
 127   register long i;
 128   register long j;
 129   register SCM *velts;
 130
 131   SCM_ASSERT(SCM_INUMP(k) && (0 <= SCM_INUM (k)), k, SCM_ARG1, s_make_vector);
 132   if (SCM_UNBNDP(fill))
 133     fill = SCM_UNSPECIFIED;
 134   i = SCM_INUM(k);
 135   SCM_NEWCELL(v);
 136   SCM_DEFER_INTS;
 137   SCM_SETCHARS(v, scm_must_malloc(i?(long)(i*sizeof(SCM)):1L, s_vector));
 138   SCM_SETLENGTH(v, i, scm_tc7_vector);
 139   velts = SCM_VELTS(v);
 140   j = 0;
 141   while(--i >= j) (velts)[i] = fill;
 142   SCM_ALLOW_INTS;
 143   return v;
 144 }
 145
 146
 147 SCM_PROC(s_vector_to_list, "vector->list", 1, 0, 0, scm_vector_to_list);
 148
 149 SCM
 150 scm_vector_to_list(v)
 151      SCM v;
 152 {
 153   SCM res = SCM_EOL;
 154   long i;
 155   SCM *data;
 156   SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_to_list);
 157   data = SCM_VELTS(v);
 158   for(i = SCM_LENGTH(v)-1;i >= 0;i--) res = scm_cons(data[i], res);
 159   return res;
 160 }
 161
 162
 163 SCM_PROC (s_vector_fill_x, "vector-fill!", 2, 0, 0, scm_vector_fill_x);
 164
 165 SCM
 166 scm_vector_fill_x (v, fill_x)
 167      SCM v;
 168      SCM fill_x;
 169 {
 170   register long i;
 171   register SCM *data;
 172   SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_fill_x);
 173   data = SCM_VELTS(v);
 174   for(i = SCM_LENGTH(v) - 1; i >= 0; i--)
 175     data[i] = fill_x;
 176   return SCM_UNSPECIFIED;
 177 }
 178
 179
 180
 181 SCM
 182 scm_vector_equal_p(x, y)
 183      SCM x;
 184      SCM y;
 185 {
 186   long i;
 187   for(i = SCM_LENGTH(x)-1;i >= 0;i--)
 188     if (SCM_FALSEP(scm_equal_p(SCM_VELTS(x)[i], SCM_VELTS(y)[i])))
 189       return SCM_BOOL_F;
 190   return SCM_BOOL_T;
 191 }
 192
 193
 194 SCM_PROC (s_vector_move_left_x, "vector-move-left!", 5, 0, 0, scm_vector_move_left_x);
 195
 196 SCM
 197 scm_vector_move_left_x (vec1, start1, end1, vec2, start2)
 198      SCM vec1;
 199      SCM start1;
 200      SCM end1;
 201      SCM vec2;
 202      SCM start2;
 203 {
 204   long i;
 205   long j;
 206   long e;
 207
 208   SCM_ASSERT (SCM_NIMP (vec1) && SCM_VECTORP (vec1), vec1, SCM_ARG1, s_vector_move_left_x);
 209   SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_vector_move_left_x);
 210   SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_vector_move_left_x);
 211   SCM_ASSERT (SCM_NIMP (vec2) && SCM_VECTORP (vec2), vec2, SCM_ARG4, s_vector_move_left_x);
 212   SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_vector_move_left_x);
 213   i = SCM_INUM (start1);
 214   j = SCM_INUM (start2);
 215   e = SCM_INUM (end1);
 216   SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, s_vector_move_left_x);
 217   SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, s_vector_move_left_x);
 218   SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, s_vector_move_left_x);
 219   SCM_ASSERT (e-i+j <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, s_vector_move_left_x);
 220   while (i<e) SCM_VELTS (vec2)[j++] = SCM_VELTS (vec1)[i++];
 221   return SCM_UNSPECIFIED;
 222 }
 223
 224 SCM_PROC (s_vector_move_right_x, "vector-move-right!", 5, 0, 0, scm_vector_move_right_x);
 225
 226 SCM
 227 scm_vector_move_right_x (vec1, start1, end1, vec2, start2)
 228      SCM vec1;
 229      SCM start1;
 230      SCM end1;
 231      SCM vec2;
 232      SCM start2;
 233 {
 234   long i;
 235   long j;
 236   long e;
 237
 238   SCM_ASSERT (SCM_NIMP (vec1) && SCM_VECTORP (vec1), vec1, SCM_ARG1, s_vector_move_right_x);
 239   SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_vector_move_right_x);
 240   SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_vector_move_right_x);
 241   SCM_ASSERT (SCM_NIMP (vec2) && SCM_VECTORP (vec2), vec2, SCM_ARG4, s_vector_move_right_x);
 242   SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_vector_move_right_x);
 243   i = SCM_INUM (start1);
 244   j = SCM_INUM (start2);
 245   e = SCM_INUM (end1);
 246   SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, s_vector_move_right_x);
 247   SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, s_vector_move_right_x);
 248   SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, s_vector_move_right_x);
 249   SCM_ASSERT ((j = e-i+j) <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, s_vector_move_right_x);
 250   while (i<e) SCM_VELTS (vec2)[--j] = SCM_VELTS (vec1)[--e];
 251   return SCM_UNSPECIFIED;
 252 }
 253
 254
 255
 256 void
 257 scm_init_vectors ()
 258 {
 259 #include "vectors.x"
 260 }
 261