libguile/srfi-4.c

   1 /* srfi-4.c --- Homogeneous numeric vector datatypes.
   2  *
   3  *      Copyright (C) 2001, 2004 Free Software Foundation, Inc.
   4  *
   5  * This library is free software; you can redistribute it and/or
   6  * modify it under the terms of the GNU Lesser General Public
   7  * License as published by the Free Software Foundation; either
   8  * version 2.1 of the License, or (at your option) any later version.
   9  *
  10  * This library is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13  * Lesser General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU Lesser General Public
  16  * License along with this library; if not, write to the Free Software
  17  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  18  */
  19
  20 #if HAVE_CONFIG_H
  21 #  include <config.h>
  22 #endif
  23
  24 #include <string.h>
  25 #include <errno.h>
  26 #include <stdio.h>
  27
  28 #include "libguile/_scm.h"
  29 #include "libguile/__scm.h"
  30 #include "libguile/srfi-4.h"
  31 #include "libguile/error.h"
  32 #include "libguile/read.h"
  33 #include "libguile/ports.h"
  34 #include "libguile/chars.h"
  35 #include "libguile/vectors.h"
  36 #include "libguile/unif.h"
  37 #include "libguile/strings.h"
  38 #include "libguile/dynwind.h"
  39
  40 #ifdef HAVE_UNISTD_H
  41 #include <unistd.h>
  42 #endif
  43
  44 #ifdef HAVE_IO_H
  45 #include <io.h>
  46 #endif
  47
  48 /* Smob type code for homogeneous numeric vectors.  */
  49 int scm_tc16_uvec = 0;
  50
  51 #define SCM_IS_UVEC(obj) SCM_SMOB_PREDICATE (scm_tc16_uvec, (obj))
  52
  53 /* Accessor macros for the three components of a homogeneous numeric
  54    vector:
  55    - The type tag (one of the symbolic constants below).
  56    - The vector's length (counted in elements).
  57    - The address of the data area (holding the elements of the
  58      vector). */
  59 #define SCM_UVEC_TYPE(u)   (SCM_CELL_WORD_1(u))
  60 #define SCM_UVEC_LENGTH(u) ((size_t)SCM_CELL_WORD_2(u))
  61 #define SCM_UVEC_BASE(u)   ((void *)SCM_CELL_WORD_3(u))
  62
  63
  64 /* Symbolic constants encoding the various types of homogeneous
  65    numeric vectors.  */
  66 #define SCM_UVEC_U8     0
  67 #define SCM_UVEC_S8     1
  68 #define SCM_UVEC_U16    2
  69 #define SCM_UVEC_S16    3
  70 #define SCM_UVEC_U32    4
  71 #define SCM_UVEC_S32    5
  72 #define SCM_UVEC_U64    6
  73 #define SCM_UVEC_S64    7
  74 #define SCM_UVEC_F32    8
  75 #define SCM_UVEC_F64    9
  76 #define SCM_UVEC_C32   10
  77 #define SCM_UVEC_C64   11
  78
  79
  80 /* This array maps type tags to the size of the elements.  */
  81 static const int uvec_sizes[12] = {
  82   1, 1,
  83   2, 2,
  84   4, 4,
  85   8, 8,
  86   sizeof(float), sizeof(double),
  87   2*sizeof(float), 2*sizeof(double)
  88 };
  89
  90 static const char *uvec_tags[12] = {
  91   "u8", "s8",
  92   "u16", "s16",
  93   "u32", "s32",
  94   "u64", "s64",
  95   "f32", "f64",
  96   "c32", "c64",
  97 };
  98
  99 static const char *uvec_names[12] = {
 100   "u8vector", "s8vector",
 101   "u16vector", "s16vector",
 102   "u32vector", "s32vector",
 103   "u64vector", "s64vector",
 104   "f32vector", "f64vector",
 105   "c32vector", "c64vector"
 106 };
 107
 108 /* ================================================================ */
 109 /* SMOB procedures.                                                 */
 110 /* ================================================================ */
 111
 112
 113 /* Smob print hook for homogeneous vectors.  */
 114 static int
 115 uvec_print (SCM uvec, SCM port, scm_print_state *pstate)
 116 {
 117   union {
 118     scm_t_uint8 *u8;
 119     scm_t_int8 *s8;
 120     scm_t_uint16 *u16;
 121     scm_t_int16 *s16;
 122     scm_t_uint32 *u32;
 123     scm_t_int32 *s32;
 124 #if SCM_HAVE_T_INT64
 125     scm_t_uint64 *u64;
 126     scm_t_int64 *s64;
 127 #endif
 128     float *f32;
 129     double *f64;
 130   } np;
 131
 132   size_t i = 0;
 133   const size_t uvlen = SCM_UVEC_LENGTH (uvec);
 134   void *uptr = SCM_UVEC_BASE (uvec);
 135
 136   switch (SCM_UVEC_TYPE (uvec))
 137   {
 138     case SCM_UVEC_U8: np.u8 = (scm_t_uint8 *) uptr; break;
 139     case SCM_UVEC_S8: np.s8 = (scm_t_int8 *) uptr; break;
 140     case SCM_UVEC_U16: np.u16 = (scm_t_uint16 *) uptr; break;
 141     case SCM_UVEC_S16: np.s16 = (scm_t_int16 *) uptr; break;
 142     case SCM_UVEC_U32: np.u32 = (scm_t_uint32 *) uptr; break;
 143     case SCM_UVEC_S32: np.s32 = (scm_t_int32 *) uptr; break;
 144 #if SCM_HAVE_T_INT64
 145     case SCM_UVEC_U64: np.u64 = (scm_t_uint64 *) uptr; break;
 146     case SCM_UVEC_S64: np.s64 = (scm_t_int64 *) uptr; break;
 147 #endif
 148     case SCM_UVEC_F32: np.f32 = (float *) uptr; break;
 149     case SCM_UVEC_F64: np.f64 = (double *) uptr; break;
 150     case SCM_UVEC_C32: np.f32 = (float *) uptr; break;
 151     case SCM_UVEC_C64: np.f64 = (double *) uptr; break;
 152     default:
 153       abort ();                 /* Sanity check.  */
 154       break;
 155   }
 156
 157   scm_putc ('#', port);
 158   scm_puts (uvec_tags [SCM_UVEC_TYPE (uvec)], port);
 159   scm_putc ('(', port);
 160
 161   while (i < uvlen)
 162     {
 163       if (i != 0) scm_puts (" ", port);
 164       switch (SCM_UVEC_TYPE (uvec))
 165         {
 166         case SCM_UVEC_U8: scm_uintprint (*np.u8, 10, port); np.u8++; break;
 167         case SCM_UVEC_S8: scm_intprint (*np.s8, 10, port); np.s8++; break;
 168         case SCM_UVEC_U16: scm_uintprint (*np.u16, 10, port); np.u16++; break;
 169         case SCM_UVEC_S16: scm_intprint (*np.s16, 10, port); np.s16++; break;
 170         case SCM_UVEC_U32: scm_uintprint (*np.u32, 10, port); np.u32++; break;
 171         case SCM_UVEC_S32: scm_intprint (*np.s32, 10, port); np.s32++; break;
 172 #if SCM_HAVE_T_INT64
 173         case SCM_UVEC_U64: scm_uintprint (*np.u64, 10, port); np.u64++; break;
 174         case SCM_UVEC_S64: scm_intprint (*np.s64, 10, port); np.s64++; break;
 175 #endif
 176         case SCM_UVEC_F32: scm_i_print_double (*np.f32, port); np.f32++; break;
 177         case SCM_UVEC_F64: scm_i_print_double (*np.f64, port); np.f64++; break;
 178         case SCM_UVEC_C32:
 179           scm_i_print_complex (np.f32[0], np.f32[1], port);
 180           np.f32 += 2;
 181           break;
 182         case SCM_UVEC_C64:
 183           scm_i_print_complex (np.f64[0], np.f64[1], port);
 184           np.f64 += 2;
 185           break;
 186         default:
 187           abort ();                     /* Sanity check.  */
 188           break;
 189         }
 190       i++;
 191     }
 192   scm_remember_upto_here_1 (uvec);
 193   scm_puts (")", port);
 194   return 1;
 195 }
 196
 197 const char *
 198 scm_i_uniform_vector_tag (SCM uvec)
 199 {
 200   return uvec_tags[SCM_UVEC_TYPE (uvec)];
 201 }
 202
 203 static SCM
 204 uvec_equalp (SCM a, SCM b)
 205 {
 206   SCM result = SCM_BOOL_T;
 207   if (SCM_UVEC_TYPE (a) != SCM_UVEC_TYPE (b))
 208     result = SCM_BOOL_F;
 209   else if (SCM_UVEC_LENGTH (a) != SCM_UVEC_LENGTH (b))
 210     result = SCM_BOOL_F;
 211   else if (memcmp (SCM_UVEC_BASE (a), SCM_UVEC_BASE (b),
 212                    SCM_UVEC_LENGTH (a) * uvec_sizes[SCM_UVEC_TYPE(a)]) != 0)
 213     result = SCM_BOOL_F;
 214
 215   scm_remember_upto_here_2 (a, b);
 216   return result;
 217 }
 218
 219 /* Smob free hook for homogeneous numeric vectors. */
 220 static size_t
 221 uvec_free (SCM uvec)
 222 {
 223   int type = SCM_UVEC_TYPE (uvec);
 224   scm_gc_free (SCM_UVEC_BASE (uvec),
 225                SCM_UVEC_LENGTH (uvec) * uvec_sizes[type],
 226                uvec_names[type]);
 227   return 0;
 228 }
 229
 230 /* ================================================================ */
 231 /* Utility procedures.                                              */
 232 /* ================================================================ */
 233
 234 static SCM_C_INLINE int
 235 is_uvec (int type, SCM obj)
 236 {
 237   if (SCM_IS_UVEC (obj))
 238     return SCM_UVEC_TYPE (obj) == type;
 239   if (SCM_ARRAYP (obj) && SCM_ARRAY_NDIM (obj) == 1)
 240     {
 241       SCM v = SCM_ARRAY_V (obj);
 242       return SCM_IS_UVEC (v) && SCM_UVEC_TYPE (v) == type;
 243     }
 244   return 0;
 245 }
 246
 247 static SCM_C_INLINE SCM
 248 uvec_p (int type, SCM obj)
 249 {
 250   return scm_from_bool (is_uvec (type, obj));
 251 }
 252
 253 static SCM_C_INLINE void
 254 uvec_assert (int type, SCM obj)
 255 {
 256   if (!is_uvec (type, obj))
 257     scm_wrong_type_arg_msg (NULL, 0, obj, uvec_names[type]);
 258 }
 259
 260 static SCM
 261 take_uvec (int type, const void *base, size_t len)
 262 {
 263   SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, (scm_t_bits) base);
 264 }
 265
 266 /* Create a new, uninitialized homogeneous numeric vector of type TYPE
 267    with space for LEN elements.  */
 268 static SCM
 269 alloc_uvec (int type, size_t len)
 270 {
 271   void *base;
 272   if (len > SCM_I_SIZE_MAX / uvec_sizes[type])
 273     scm_out_of_range (NULL, scm_from_size_t (len));
 274   base = scm_gc_malloc (len * uvec_sizes[type], uvec_names[type]);
 275   return take_uvec (type, base, len);
 276 }
 277
 278 /* GCC doesn't seem to want to optimize unused switch clauses away,
 279    so we use a big 'if' in the next two functions.
 280 */
 281
 282 static SCM_C_INLINE SCM
 283 uvec_fast_ref (int type, const void *base, size_t c_idx)
 284 {
 285   if (type == SCM_UVEC_U8)
 286     return scm_from_uint8 (((scm_t_uint8*)base)[c_idx]);
 287   else if (type == SCM_UVEC_S8)
 288     return scm_from_int8 (((scm_t_int8*)base)[c_idx]);
 289   else if (type == SCM_UVEC_U16)
 290     return scm_from_uint16 (((scm_t_uint16*)base)[c_idx]);
 291   else if (type == SCM_UVEC_S16)
 292     return scm_from_int16 (((scm_t_int16*)base)[c_idx]);
 293   else if (type == SCM_UVEC_U32)
 294     return scm_from_uint32 (((scm_t_uint32*)base)[c_idx]);
 295   else if (type == SCM_UVEC_S32)
 296     return scm_from_int32 (((scm_t_int32*)base)[c_idx]);
 297 #if SCM_HAVE_T_INT64
 298   else if (type == SCM_UVEC_U64)
 299     return scm_from_uint64 (((scm_t_uint64*)base)[c_idx]);
 300   else if (type == SCM_UVEC_S64)
 301     return scm_from_int64 (((scm_t_int64*)base)[c_idx]);
 302 #endif
 303   else if (type == SCM_UVEC_F32)
 304     return scm_from_double (((float*)base)[c_idx]);
 305   else if (type == SCM_UVEC_F64)
 306     return scm_from_double (((double*)base)[c_idx]);
 307   else if (type == SCM_UVEC_C32)
 308     return scm_c_make_rectangular (((float*)base)[2*c_idx],
 309                                    ((float*)base)[2*c_idx+1]);
 310   else if (type == SCM_UVEC_C64)
 311     return scm_c_make_rectangular (((double*)base)[2*c_idx],
 312                                    ((double*)base)[2*c_idx+1]);
 313   else
 314     return SCM_BOOL_F;
 315 }
 316
 317 static SCM_C_INLINE void
 318 uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val)
 319 {
 320   if (type == SCM_UVEC_U8)
 321     (((scm_t_uint8*)base)[c_idx]) = scm_to_uint8 (val);
 322   else if (type == SCM_UVEC_S8)
 323     (((scm_t_int8*)base)[c_idx]) = scm_to_int8 (val);
 324   else if (type == SCM_UVEC_U16)
 325     (((scm_t_uint16*)base)[c_idx]) = scm_to_uint16 (val);
 326   else if (type == SCM_UVEC_S16)
 327     (((scm_t_int16*)base)[c_idx]) = scm_to_int16 (val);
 328   else if (type == SCM_UVEC_U32)
 329     (((scm_t_uint32*)base)[c_idx]) = scm_to_uint32 (val);
 330   else if (type == SCM_UVEC_S32)
 331     (((scm_t_int32*)base)[c_idx]) = scm_to_int32 (val);
 332 #if SCM_HAVE_T_INT64
 333   else if (type == SCM_UVEC_U64)
 334     (((scm_t_uint64*)base)[c_idx]) = scm_to_uint64 (val);
 335   else if (type == SCM_UVEC_S64)
 336     (((scm_t_int64*)base)[c_idx]) = scm_to_int64 (val);
 337 #endif
 338   else if (type == SCM_UVEC_F32)
 339     (((float*)base)[c_idx]) = scm_to_double (val);
 340   else if (type == SCM_UVEC_F64)
 341     (((double*)base)[c_idx]) = scm_to_double (val);
 342   else if (type == SCM_UVEC_C32)
 343     {
 344       (((float*)base)[2*c_idx])   = scm_c_real_part (val);
 345       (((float*)base)[2*c_idx+1]) = scm_c_imag_part (val);
 346     }
 347   else if (type == SCM_UVEC_C64)
 348     {
 349       (((double*)base)[2*c_idx])   = scm_c_real_part (val);
 350       (((double*)base)[2*c_idx+1]) = scm_c_imag_part (val);
 351     }
 352 }
 353
 354 static SCM_C_INLINE SCM
 355 make_uvec (int type, SCM len, SCM fill)
 356 {
 357   size_t c_len = scm_to_size_t (len);
 358   SCM uvec = alloc_uvec (type, c_len);
 359   if (!SCM_UNBNDP (fill))
 360     {
 361       size_t idx;
 362       void *base = SCM_UVEC_BASE (uvec);
 363       for (idx = 0; idx < c_len; idx++)
 364         uvec_fast_set_x (type, base, idx, fill);
 365     }
 366   return uvec;
 367 }
 368
 369 static SCM_C_INLINE void *
 370 uvec_writable_elements (int type, SCM uvec, scm_t_array_handle *handle,
 371                         size_t *lenp, ssize_t *incp)
 372 {
 373   if (type >= 0)
 374     {
 375       SCM v = uvec;
 376       if (SCM_ARRAYP (v))
 377         v = SCM_ARRAY_V (v);
 378       uvec_assert (type, v);
 379     }
 380
 381   return scm_uniform_vector_writable_elements (uvec, handle, lenp, incp);
 382 }
 383
 384 static SCM_C_INLINE const void *
 385 uvec_elements (int type, SCM uvec, scm_t_array_handle *handle,
 386                size_t *lenp, ssize_t *incp)
 387 {
 388   return uvec_writable_elements (type, uvec, handle, lenp, incp);
 389 }
 390
 391 static SCM
 392 uvec_to_list (int type, SCM uvec)
 393 {
 394   scm_t_array_handle handle;
 395   size_t len;
 396   ssize_t i, inc;
 397   const void *elts;
 398   SCM res = SCM_EOL;
 399
 400   elts = uvec_elements (type, uvec, &handle, &len, &inc);
 401   for (i = len*inc; i > 0;)
 402     {
 403       i -= inc;
 404       res = scm_cons (uvec_fast_ref (type, elts, i), res);
 405     }
 406   scm_array_handle_release (&handle);
 407   return res;
 408 }
 409
 410 static SCM_C_INLINE SCM
 411 uvec_length (int type, SCM uvec)
 412 {
 413   scm_t_array_handle handle;
 414   size_t len;
 415   ssize_t inc;
 416   uvec_elements (type, uvec, &handle, &len, &inc);
 417   scm_array_handle_release (&handle);
 418   return scm_from_size_t (len);
 419 }
 420
 421 static SCM_C_INLINE SCM
 422 uvec_ref (int type, SCM uvec, SCM idx)
 423 {
 424   scm_t_array_handle handle;
 425   size_t i, len;
 426   ssize_t inc;
 427   const void *elts;
 428   SCM res;
 429
 430   elts = uvec_elements (type, uvec, &handle, &len, &inc);
 431   i = scm_to_unsigned_integer (idx, 0, len-1);
 432   res = uvec_fast_ref (type, elts, i*inc);
 433   scm_array_handle_release (&handle);
 434   return res;
 435 }
 436
 437 static SCM_C_INLINE SCM
 438 uvec_set_x (int type, SCM uvec, SCM idx, SCM val)
 439 {
 440   scm_t_array_handle handle;
 441   size_t i, len;
 442   ssize_t inc;
 443   void *elts;
 444
 445   elts = uvec_writable_elements (type, uvec, &handle, &len, &inc);
 446   i = scm_to_unsigned_integer (idx, 0, len-1);
 447   uvec_fast_set_x (type, elts, i*inc, val);
 448   scm_array_handle_release (&handle);
 449   return SCM_UNSPECIFIED;
 450 }
 451
 452 static SCM_C_INLINE SCM
 453 list_to_uvec (int type, SCM list)
 454 {
 455   SCM uvec;
 456   void *base;
 457   long idx;
 458   long len = scm_ilength (list);
 459   if (len < 0)
 460     scm_wrong_type_arg_msg (NULL, 0, list, "proper list");
 461
 462   uvec = alloc_uvec (type, len);
 463   base = SCM_UVEC_BASE (uvec);
 464   idx = 0;
 465   while (scm_is_pair (list) && idx < len)
 466     {
 467       uvec_fast_set_x (type, base, idx, SCM_CAR (list));
 468       list = SCM_CDR (list);
 469       idx++;
 470     }
 471   return uvec;
 472 }
 473
 474 static SCM
 475 coerce_to_uvec (int type, SCM obj)
 476 {
 477   if (is_uvec (type, obj))
 478     return obj;
 479   else if (scm_is_pair (obj))
 480     return list_to_uvec (type, obj);
 481   else if (scm_is_generalized_vector (obj))
 482     {
 483       size_t len = scm_c_generalized_vector_length (obj), i;
 484       SCM uvec = alloc_uvec (type, len);
 485       void *base = SCM_UVEC_BASE (uvec);
 486       for (i = 0; i < len; i++)
 487         uvec_fast_set_x (type, base, i, scm_c_generalized_vector_ref (obj, i));
 488       return uvec;
 489     }
 490   else
 491     scm_wrong_type_arg_msg (NULL, 0, obj, "list or generalized vector");
 492 }
 493
 494 SCM_SYMBOL (scm_sym_a, "a");
 495 SCM_SYMBOL (scm_sym_b, "b");
 496
 497 SCM
 498 scm_i_generalized_vector_type (SCM v)
 499 {
 500   if (scm_is_vector (v))
 501     return SCM_BOOL_T;
 502   else if (scm_is_string (v))
 503     return scm_sym_a;
 504   else if (scm_is_bitvector (v))
 505     return scm_sym_b;
 506   else if (scm_is_uniform_vector (v))
 507     return scm_from_locale_symbol (uvec_tags[SCM_UVEC_TYPE(v)]);
 508   else
 509     return SCM_BOOL_F;
 510 }
 511
 512 int
 513 scm_is_uniform_vector (SCM obj)
 514 {
 515   if (SCM_IS_UVEC (obj))
 516     return 1;
 517   if (SCM_ARRAYP (obj) && SCM_ARRAY_NDIM (obj) == 1)
 518     {
 519       SCM v = SCM_ARRAY_V (obj);
 520       return SCM_IS_UVEC (v);
 521     }
 522   return 0;
 523 }
 524
 525 size_t
 526 scm_c_uniform_vector_length (SCM uvec)
 527 {
 528   /* scm_generalized_vector_get_handle will ultimately call us to get
 529      the length of uniform vectors, so we can't use uvec_elements for
 530      naked vectors.
 531   */
 532
 533   if (SCM_IS_UVEC (uvec))
 534     return SCM_UVEC_LENGTH (uvec);
 535   else
 536     {
 537       scm_t_array_handle handle;
 538       size_t len;
 539       ssize_t inc;
 540       uvec_elements (-1, uvec, &handle, &len, &inc);
 541       scm_array_handle_release (&handle);
 542       return len;
 543     }
 544 }
 545
 546 SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
 547             (SCM obj),
 548             "Return @code{#t} if @var{obj} is a uniform vector.")
 549 #define FUNC_NAME s_scm_uniform_vector_p
 550 {
 551   return scm_from_bool (scm_is_uniform_vector (obj));
 552 }
 553 #undef FUNC_NAME
 554
 555 SCM
 556 scm_c_uniform_vector_ref (SCM v, size_t idx)
 557 {
 558   scm_t_array_handle handle;
 559   const void *elts;
 560   size_t len;
 561   ssize_t inc;
 562   SCM res;
 563
 564   elts = uvec_elements (-1, v, &handle, &len, &inc);
 565   if (idx >= len)
 566     scm_out_of_range (NULL, scm_from_size_t (idx));
 567   res = uvec_fast_ref (SCM_UVEC_TYPE (v), elts, idx*inc);
 568   scm_array_handle_release (&handle);
 569   return res;
 570 }
 571
 572 SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
 573             (SCM v, SCM idx),
 574             "Return the element at index @var{idx} of the\n"
 575             "homogenous numeric vector @var{v}.")
 576 #define FUNC_NAME s_scm_uniform_vector_ref
 577 {
 578 #if SCM_ENABLE_DEPRECATED
 579   /* Support old argument convention.
 580    */
 581   if (scm_is_pair (idx))
 582     {
 583       scm_c_issue_deprecation_warning
 584         ("Using a list as the index to uniform-vector-ref is deprecated.");
 585       if (!scm_is_null (SCM_CDR (idx)))
 586         scm_wrong_num_args (NULL);
 587       idx = SCM_CAR (idx);
 588     }
 589 #endif
 590
 591   return scm_c_uniform_vector_ref (v, scm_to_size_t (idx));
 592 }
 593 #undef FUNC_NAME
 594
 595 void
 596 scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
 597 {
 598   scm_t_array_handle handle;
 599   void *elts;
 600   size_t len;
 601   ssize_t inc;
 602
 603   elts = uvec_writable_elements (-1, v, &handle, &len, &inc);
 604   if (idx >= len)
 605     scm_out_of_range (NULL, scm_from_size_t (idx));
 606   uvec_fast_set_x (SCM_UVEC_TYPE (v), elts, idx*inc, val);
 607   scm_array_handle_release (&handle);
 608 }
 609
 610 SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0,
 611             (SCM v, SCM idx, SCM val),
 612             "Set the element at index @var{idx} of the\n"
 613             "homogenous numeric vector @var{v} to @var{val}.")
 614 #define FUNC_NAME s_scm_uniform_vector_set_x
 615 {
 616 #if SCM_ENABLE_DEPRECATED
 617   /* Support old argument convention.
 618    */
 619   if (scm_is_pair (idx))
 620     {
 621       scm_c_issue_deprecation_warning
 622         ("Using a list as the index to uniform-vector-set! is deprecated.");
 623       if (!scm_is_null (SCM_CDR (idx)))
 624         scm_wrong_num_args (NULL);
 625       idx = SCM_CAR (idx);
 626     }
 627 #endif
 628
 629   scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val);
 630   return SCM_UNSPECIFIED;
 631 }
 632 #undef FUNC_NAME
 633
 634 SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
 635             (SCM uvec),
 636             "Convert the homogeneous numeric vector @var{uvec} to a list.")
 637 #define FUNC_NAME s_scm_uniform_vector_to_list
 638 {
 639   return uvec_to_list (-1, uvec);
 640 }
 641 #undef FUNC_NAME
 642
 643 size_t
 644 scm_array_handle_uniform_element_size (scm_t_array_handle *h)
 645 {
 646   SCM vec = h->array;
 647   if (SCM_ARRAYP (vec))
 648     vec = SCM_ARRAY_V (vec);
 649   if (scm_is_uniform_vector (vec))
 650     return uvec_sizes[SCM_UVEC_TYPE(vec)];
 651   scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
 652 }
 653
 654 /* return the size of an element in a uniform array or 0 if type not
 655    found.  */
 656 size_t
 657 scm_uniform_element_size (SCM obj)
 658 {
 659   if (SCM_IS_UVEC (obj))
 660     return uvec_sizes[SCM_UVEC_TYPE(obj)];
 661   else
 662     return 0;
 663 }
 664
 665 const void *
 666 scm_array_handle_uniform_elements (scm_t_array_handle *h)
 667 {
 668   return scm_array_handle_uniform_writable_elements (h);
 669 }
 670
 671 void *
 672 scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
 673 {
 674   SCM vec = h->array;
 675   if (SCM_ARRAYP (vec))
 676     vec = SCM_ARRAY_V (vec);
 677   if (SCM_IS_UVEC (vec))
 678     {
 679       size_t size = uvec_sizes[SCM_UVEC_TYPE(vec)];
 680       char *elts = SCM_UVEC_BASE (vec);
 681       return (void *) (elts + size*h->base);
 682     }
 683   scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
 684 }
 685
 686 const void *
 687 scm_uniform_vector_elements (SCM uvec,
 688                              scm_t_array_handle *h,
 689                              size_t *lenp, ssize_t *incp)
 690 {
 691   return scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
 692 }
 693
 694 void *
 695 scm_uniform_vector_writable_elements (SCM uvec,
 696                                       scm_t_array_handle *h,
 697                                       size_t *lenp, ssize_t *incp)
 698 {
 699   scm_generalized_vector_get_handle (uvec, h);
 700   if (lenp)
 701     {
 702       scm_t_array_dim *dim = scm_array_handle_dims (h);
 703       *lenp = dim->ubnd - dim->lbnd + 1;
 704       *incp = dim->inc;
 705     }
 706   return scm_array_handle_uniform_writable_elements (h);
 707 }
 708
 709 SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
 710             (SCM v),
 711             "Return the number of elements in the uniform vector @var{v}.")
 712 #define FUNC_NAME s_scm_uniform_vector_length
 713 {
 714   return uvec_length (-1, v);
 715 }
 716 #undef FUNC_NAME
 717
 718 SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
 719            (SCM uvec, SCM port_or_fd, SCM start, SCM end),
 720             "Fill the elements of @var{uvec} by reading\n"
 721             "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
 722             "The optional arguments @var{start} (inclusive) and @var{end}\n"
 723             "(exclusive) allow a specified region to be read,\n"
 724             "leaving the remainder of the vector unchanged.\n\n"
 725             "When @var{port-or-fdes} is a port, all specified elements\n"
 726             "of @var{uvec} are attempted to be read, potentially blocking\n"
 727             "while waiting formore input or end-of-file.\n"
 728             "When @var{port-or-fd} is an integer, a single call to\n"
 729             "read(2) is made.\n\n"
 730             "An error is signalled when the last element has only\n"
 731             "been partially filled before reaching end-of-file or in\n"
 732             "the single call to read(2).\n\n"
 733             "@code{uniform-vector-read!} returns the number of elements\n"
 734             "read.\n\n"
 735             "@var{port-or-fdes} may be omitted, in which case it defaults\n"
 736             "to the value returned by @code{(current-input-port)}.")
 737 #define FUNC_NAME s_scm_uniform_vector_read_x
 738 {
 739   scm_t_array_handle handle;
 740   size_t vlen, sz, ans;
 741   ssize_t inc;
 742   size_t cstart, cend;
 743   size_t remaining, off;
 744   void *base;
 745
 746   if (SCM_UNBNDP (port_or_fd))
 747     port_or_fd = scm_cur_inp;
 748   else
 749     SCM_ASSERT (scm_is_integer (port_or_fd)
 750                 || (SCM_OPINPORTP (port_or_fd)),
 751                 port_or_fd, SCM_ARG2, FUNC_NAME);
 752
 753   if (!scm_is_uniform_vector (uvec))
 754     scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
 755
 756   base = scm_uniform_vector_writable_elements (uvec, &handle, &vlen, &inc);
 757   sz = scm_array_handle_uniform_element_size (&handle);
 758
 759   if (inc != 1)
 760     {
 761       /* XXX - we should of course support non contiguous vectors. */
 762       scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
 763                       scm_list_1 (uvec));
 764     }
 765
 766   cstart = 0;
 767   cend = vlen;
 768   if (!SCM_UNBNDP (start))
 769     {
 770       cstart = scm_to_unsigned_integer (start, 0, vlen);
 771       if (!SCM_UNBNDP (end))
 772         cend = scm_to_unsigned_integer (end, cstart, vlen);
 773     }
 774
 775   remaining = (cend - cstart) * sz;
 776   off = cstart * sz;
 777
 778   if (SCM_NIMP (port_or_fd))
 779     {
 780       scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd);
 781
 782       if (pt->rw_active == SCM_PORT_WRITE)
 783         scm_flush (port_or_fd);
 784
 785       ans = cend - cstart;
 786       while (remaining > 0)
 787         {
 788           if (pt->read_pos < pt->read_end)
 789             {
 790               size_t to_copy = min (pt->read_end - pt->read_pos,
 791                                     remaining);
 792
 793               memcpy (base + off, pt->read_pos, to_copy);
 794               pt->read_pos += to_copy;
 795               remaining -= to_copy;
 796               off += to_copy;
 797             }
 798           else
 799             {
 800               if (scm_fill_input (port_or_fd) == EOF)
 801                 {
 802                   if (remaining % sz != 0)
 803                     SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
 804                   ans -= remaining / sz;
 805                   break;
 806                 }
 807             }
 808         }
 809
 810       if (pt->rw_random)
 811         pt->rw_active = SCM_PORT_READ;
 812     }
 813   else /* file descriptor.  */
 814     {
 815       int fd = scm_to_int (port_or_fd);
 816       int n;
 817
 818       SCM_SYSCALL (n = read (fd, base + off, remaining));
 819       if (n == -1)
 820         SCM_SYSERROR;
 821       if (n % sz != 0)
 822         SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
 823       ans = n / sz;
 824     }
 825
 826   scm_array_handle_release (&handle);
 827
 828   return scm_from_size_t (ans);
 829 }
 830 #undef FUNC_NAME
 831
 832 SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
 833            (SCM uvec, SCM port_or_fd, SCM start, SCM end),
 834             "Write the elements of @var{uvec} as raw bytes to\n"
 835             "@var{port-or-fdes}, in the host byte order.\n\n"
 836             "The optional arguments @var{start} (inclusive)\n"
 837             "and @var{end} (exclusive) allow\n"
 838             "a specified region to be written.\n\n"
 839             "When @var{port-or-fdes} is a port, all specified elements\n"
 840             "of @var{uvec} are attempted to be written, potentially blocking\n"
 841             "while waiting for more room.\n"
 842             "When @var{port-or-fd} is an integer, a single call to\n"
 843             "write(2) is made.\n\n"
 844             "An error is signalled when the last element has only\n"
 845             "been partially written in the single call to write(2).\n\n"
 846             "The number of objects actually written is returned.\n"
 847             "@var{port-or-fdes} may be\n"
 848             "omitted, in which case it defaults to the value returned by\n"
 849             "@code{(current-output-port)}.")
 850 #define FUNC_NAME s_scm_uniform_vector_write
 851 {
 852   scm_t_array_handle handle;
 853   size_t vlen, sz, ans;
 854   ssize_t inc;
 855   size_t cstart, cend;
 856   size_t amount, off;
 857   const void *base;
 858
 859   port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
 860
 861   if (SCM_UNBNDP (port_or_fd))
 862     port_or_fd = scm_cur_outp;
 863   else
 864     SCM_ASSERT (scm_is_integer (port_or_fd)
 865                 || (SCM_OPOUTPORTP (port_or_fd)),
 866                 port_or_fd, SCM_ARG2, FUNC_NAME);
 867
 868   base = scm_uniform_vector_elements (uvec, &handle, &vlen, &inc);
 869   sz = scm_array_handle_uniform_element_size (&handle);
 870
 871   if (inc != 1)
 872     {
 873       /* XXX - we should of course support non contiguous vectors. */
 874       scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
 875                       scm_list_1 (uvec));
 876     }
 877
 878   cstart = 0;
 879   cend = vlen;
 880   if (!SCM_UNBNDP (start))
 881     {
 882       cstart = scm_to_unsigned_integer (start, 0, vlen);
 883       if (!SCM_UNBNDP (end))
 884         cend = scm_to_unsigned_integer (end, cstart, vlen);
 885     }
 886
 887   amount = (cend - cstart) * sz;
 888   off = cstart * sz;
 889
 890   if (SCM_NIMP (port_or_fd))
 891     {
 892       scm_lfwrite (base + off, amount, port_or_fd);
 893       ans = cend - cstart;
 894     }
 895   else /* file descriptor.  */
 896     {
 897       int fd = scm_to_int (port_or_fd), n;
 898       SCM_SYSCALL (n = write (fd, base + off, amount));
 899       if (n == -1)
 900         SCM_SYSERROR;
 901       if (n % sz != 0)
 902         SCM_MISC_ERROR ("last element only written partially", SCM_EOL);
 903       ans = n / sz;
 904     }
 905
 906   scm_array_handle_release (&handle);
 907
 908   return scm_from_size_t (ans);
 909 }
 910 #undef FUNC_NAME
 911
 912 /* ================================================================ */
 913 /* Exported procedures.                                             */
 914 /* ================================================================ */
 915
 916 #define TYPE  SCM_UVEC_U8
 917 #define TAG   u8
 918 #define CTYPE scm_t_uint8
 919 #include "libguile/srfi-4.i.c"
 920
 921 #define TYPE  SCM_UVEC_S8
 922 #define TAG   s8
 923 #define CTYPE scm_t_int8
 924 #include "libguile/srfi-4.i.c"
 925
 926 #define TYPE  SCM_UVEC_U16
 927 #define TAG   u16
 928 #define CTYPE scm_t_uint16
 929 #include "libguile/srfi-4.i.c"
 930
 931 #define TYPE  SCM_UVEC_S16
 932 #define TAG   s16
 933 #define CTYPE scm_t_int16
 934 #include "libguile/srfi-4.i.c"
 935
 936 #define TYPE  SCM_UVEC_U32
 937 #define TAG   u32
 938 #define CTYPE scm_t_uint32
 939 #include "libguile/srfi-4.i.c"
 940
 941 #define TYPE  SCM_UVEC_S32
 942 #define TAG   s32
 943 #define CTYPE scm_t_int32
 944 #include "libguile/srfi-4.i.c"
 945
 946 #define TYPE  SCM_UVEC_U64
 947 #define TAG   u64
 948 #define CTYPE scm_t_uint64
 949 #include "libguile/srfi-4.i.c"
 950
 951 #define TYPE  SCM_UVEC_S64
 952 #define TAG   s64
 953 #define CTYPE scm_t_int64
 954 #include "libguile/srfi-4.i.c"
 955
 956 #define TYPE  SCM_UVEC_F32
 957 #define TAG   f32
 958 #define CTYPE float
 959 #include "libguile/srfi-4.i.c"
 960
 961 #define TYPE  SCM_UVEC_F64
 962 #define TAG   f64
 963 #define CTYPE double
 964 #include "libguile/srfi-4.i.c"
 965
 966 #define TYPE  SCM_UVEC_C32
 967 #define TAG   c32
 968 #define CTYPE float
 969 #include "libguile/srfi-4.i.c"
 970
 971 #define TYPE  SCM_UVEC_C64
 972 #define TAG   c64
 973 #define CTYPE double
 974 #include "libguile/srfi-4.i.c"
 975
 976 void
 977 scm_init_srfi_4 (void)
 978 {
 979   scm_tc16_uvec = scm_make_smob_type ("uvec", 0);
 980   scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp);
 981   scm_set_smob_free (scm_tc16_uvec, uvec_free);
 982   scm_set_smob_print (scm_tc16_uvec, uvec_print);
 983
 984 #include "libguile/srfi-4.x"
 985
 986 }
 987
 988 /* End of srfi-4.c.  */