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