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 SCM_SYMBOL (scm_sym_a, "a");
 453 SCM_SYMBOL (scm_sym_b, "b");
 454
 455 SCM
 456 scm_i_generalized_vector_type (SCM v)
 457 {
 458   if (scm_is_vector (v))
 459     return SCM_BOOL_T;
 460   else if (scm_is_string (v))
 461     return scm_sym_a;
 462   else if (scm_is_bitvector (v))
 463     return scm_sym_b;
 464   else if (scm_is_uniform_vector (v))
 465     return scm_from_locale_symbol (uvec_tags[SCM_UVEC_TYPE(v)]);
 466   else
 467     return SCM_BOOL_F;
 468 }
 469
 470 int
 471 scm_is_uniform_vector (SCM obj)
 472 {
 473   return SCM_SMOB_PREDICATE (scm_tc16_uvec, obj);
 474 }
 475
 476 size_t
 477 scm_c_uniform_vector_length (SCM v)
 478 {
 479   if (scm_is_uniform_vector (v))
 480     return SCM_UVEC_LENGTH (v);
 481   else
 482     scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
 483 }
 484
 485 size_t
 486 scm_c_uniform_vector_size (SCM v)
 487 {
 488   if (scm_is_uniform_vector (v))
 489     return SCM_UVEC_LENGTH (v) * uvec_sizes[SCM_UVEC_TYPE (v)];
 490   else
 491     scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
 492 }
 493
 494 SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
 495             (SCM obj),
 496             "Return @code{#t} if @var{obj} is a uniform vector.")
 497 #define FUNC_NAME s_scm_uniform_vector_p
 498 {
 499   return scm_from_bool (scm_is_uniform_vector (obj));
 500 }
 501 #undef FUNC_NAME
 502
 503 SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
 504             (SCM v, SCM idx),
 505             "Return the element at index @var{idx} of the\n"
 506             "homogenous numeric vector @var{v}.")
 507 #define FUNC_NAME s_scm_uniform_vector_ref
 508 {
 509   /* Support old argument convention.
 510    */
 511   if (scm_is_pair (idx))
 512     {
 513       if (!scm_is_null (SCM_CDR (idx)))
 514         scm_wrong_num_args (NULL);
 515       idx = SCM_CAR (idx);
 516     }
 517
 518   if (scm_is_uniform_vector (v))
 519     return uvec_ref (SCM_UVEC_TYPE (v), v, idx);
 520   else
 521     scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
 522 }
 523 #undef FUNC_NAME
 524
 525 SCM
 526 scm_c_uniform_vector_ref (SCM v, size_t idx)
 527 {
 528   if (scm_is_uniform_vector (v))
 529     {
 530       if (idx < SCM_UVEC_LENGTH (v))
 531         return uvec_fast_ref (SCM_UVEC_TYPE (v), SCM_UVEC_BASE (v), idx);
 532       else
 533         scm_out_of_range (NULL, scm_from_size_t (idx));
 534     }
 535   else
 536     scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
 537 }
 538
 539 SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0,
 540             (SCM v, SCM idx, SCM val),
 541             "Set the element at index @var{idx} of the\n"
 542             "homogenous numeric vector @var{v} to @var{val}.")
 543 #define FUNC_NAME s_scm_uniform_vector_set_x
 544 {
 545   /* Support old argument convention.
 546    */
 547   if (scm_is_pair (idx))
 548     {
 549       if (!scm_is_null (SCM_CDR (idx)))
 550         scm_wrong_num_args (NULL);
 551       idx = SCM_CAR (idx);
 552     }
 553
 554   if (scm_is_uniform_vector (v))
 555     return uvec_set_x (SCM_UVEC_TYPE (v), v, idx, val);
 556   else
 557     scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
 558 }
 559 #undef FUNC_NAME
 560
 561 void
 562 scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
 563 {
 564   if (scm_is_uniform_vector (v))
 565     {
 566       if (idx < SCM_UVEC_LENGTH (v))
 567         uvec_fast_set_x (SCM_UVEC_TYPE (v), SCM_UVEC_BASE (v), idx, val);
 568       else
 569         scm_out_of_range (NULL, scm_from_size_t (idx));
 570     }
 571   else
 572     scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
 573 }
 574
 575 SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
 576             (SCM uvec),
 577             "Convert the homogeneous numeric vector @var{uvec} to a list.")
 578 #define FUNC_NAME s_scm_uniform_vector_to_list
 579 {
 580   if (scm_is_uniform_vector (uvec))
 581     return uvec_to_list (SCM_UVEC_TYPE (uvec), uvec);
 582   else
 583     scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
 584 }
 585 #undef FUNC_NAME
 586
 587 const void *
 588 scm_uniform_vector_elements (SCM uvec)
 589 {
 590   if (scm_is_uniform_vector (uvec))
 591     return SCM_UVEC_BASE (uvec);
 592   else
 593     scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
 594 }
 595
 596 void
 597 scm_uniform_vector_release_elements (SCM uvec)
 598 {
 599   /* Nothing to do right now, but this function might come in handy
 600      when uniform vectors need to be locked when giving away a pointer
 601      to their elements.
 602
 603      Also, a call to scm_uniform_vector_release acts like
 604      scm_remember_upto_here, which is needed in any case.
 605   */
 606
 607   scm_remember_upto_here_1 (uvec);
 608 }
 609
 610 void
 611 scm_frame_uniform_vector_release_elements (SCM uvec)
 612 {
 613   scm_frame_unwind_handler_with_scm (scm_uniform_vector_release_elements, uvec,
 614                                      SCM_F_WIND_EXPLICITLY);
 615 }
 616
 617 void *
 618 scm_uniform_vector_writable_elements (SCM uvec)
 619 {
 620   if (scm_is_uniform_vector (uvec))
 621     return SCM_UVEC_BASE (uvec);
 622   else
 623     scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
 624 }
 625
 626 void
 627 scm_uniform_vector_release_writable_elements (SCM uvec)
 628 {
 629   /* Nothing to do right now, but this function might come in handy
 630      when uniform vectors need to be locked when giving away a pointer
 631      to their elements.
 632
 633      Also, a call to scm_uniform_vector_release acts like
 634      scm_remember_upto_here, which is needed in any case.
 635   */
 636
 637   scm_remember_upto_here_1 (uvec);
 638 }
 639
 640 void
 641 scm_frame_uniform_vector_release_writable_elements (SCM uvec)
 642 {
 643   scm_frame_unwind_handler_with_scm
 644     (scm_uniform_vector_release_writable_elements, uvec,
 645      SCM_F_WIND_EXPLICITLY);
 646 }
 647
 648 size_t
 649 scm_uniform_vector_element_size (SCM uvec)
 650 {
 651   if (scm_is_uniform_vector (uvec))
 652     return uvec_sizes[SCM_UVEC_TYPE (uvec)];
 653   else
 654     scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
 655 }
 656
 657 /* return the size of an element in a uniform array or 0 if type not
 658    found.  */
 659 size_t
 660 scm_uniform_element_size (SCM obj)
 661 {
 662   if (scm_is_uniform_vector (obj))
 663     return scm_uniform_vector_element_size (obj);
 664   else
 665     return 0;
 666 }
 667
 668 SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
 669             (SCM v),
 670             "Return the number of elements in the uniform vector @var{v}.")
 671 #define FUNC_NAME s_scm_uniform_vector_length
 672 {
 673   return scm_from_size_t (scm_c_uniform_vector_length (v));
 674 }
 675 #undef FUNC_NAME
 676
 677 SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
 678            (SCM uvec, SCM port_or_fd, SCM start, SCM end),
 679             "Fill the elements of @var{uvec} by reading\n"
 680             "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
 681             "The optional arguments @var{start} (inclusive) and @var{end}\n"
 682             "(exclusive) allow a specified region to be read,\n"
 683             "leaving the remainder of the vector unchanged.\n\n"
 684             "When @var{port-or-fdes} is a port, all specified elements\n"
 685             "of @var{uvec} are attempted to be read, potentially blocking\n"
 686             "while waiting formore input or end-of-file.\n"
 687             "When @var{port-or-fd} is an integer, a single call to\n"
 688             "read(2) is made.\n\n"
 689             "An error is signalled when the last element has only\n"
 690             "been partially filled before reaching end-of-file or in\n"
 691             "the single call to read(2).\n\n"
 692             "@code{uniform-array-read!} returns the number of elements read.\n"
 693             "@var{port-or-fdes} may be omitted, in which case it defaults\n"
 694             "to the value returned by @code{(current-input-port)}.")
 695 #define FUNC_NAME s_scm_uniform_vector_read_x
 696 {
 697   size_t vlen, sz, ans;
 698   size_t cstart, cend;
 699   size_t remaining, off;
 700   void *base;
 701
 702   if (SCM_UNBNDP (port_or_fd))
 703     port_or_fd = scm_cur_inp;
 704   else
 705     SCM_ASSERT (scm_is_integer (port_or_fd)
 706                 || (SCM_OPINPORTP (port_or_fd)),
 707                 port_or_fd, SCM_ARG2, FUNC_NAME);
 708
 709
 710   scm_frame_begin (0);
 711
 712   vlen = scm_c_uniform_vector_length (uvec);
 713   sz = scm_uniform_vector_element_size (uvec);
 714   base = scm_uniform_vector_writable_elements (uvec);
 715   scm_frame_uniform_vector_release_writable_elements (uvec);
 716
 717   cstart = 0;
 718   cend = vlen;
 719   if (!SCM_UNBNDP (start))
 720     {
 721       cstart = scm_to_unsigned_integer (start, 0, vlen);
 722       if (!SCM_UNBNDP (end))
 723         cend = scm_to_unsigned_integer (end, cstart, vlen);
 724     }
 725
 726   remaining = (cend - cstart) * sz;
 727   off = cstart * sz;
 728
 729   if (SCM_NIMP (port_or_fd))
 730     {
 731       scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd);
 732
 733       if (pt->rw_active == SCM_PORT_WRITE)
 734         scm_flush (port_or_fd);
 735
 736       ans = cend - cstart;
 737       while (remaining > 0)
 738         {
 739           if (pt->read_pos < pt->read_end)
 740             {
 741               size_t to_copy = min (pt->read_end - pt->read_pos,
 742                                     remaining);
 743
 744               memcpy (base + off, pt->read_pos, to_copy);
 745               pt->read_pos += to_copy;
 746               remaining -= to_copy;
 747               off += to_copy;
 748             }
 749           else
 750             {
 751               if (scm_fill_input (port_or_fd) == EOF)
 752                 {
 753                   if (remaining % sz != 0)
 754                     SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
 755                   ans -= remaining / sz;
 756                   break;
 757                 }
 758             }
 759         }
 760
 761       if (pt->rw_random)
 762         pt->rw_active = SCM_PORT_READ;
 763     }
 764   else /* file descriptor.  */
 765     {
 766       int fd = scm_to_int (port_or_fd);
 767       int n;
 768
 769       SCM_SYSCALL (n = read (fd, base + off, remaining));
 770       if (n == -1)
 771         SCM_SYSERROR;
 772       if (n % sz != 0)
 773         SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
 774       ans = n / sz;
 775     }
 776
 777   scm_frame_end ();
 778
 779   return scm_from_size_t (ans);
 780 }
 781 #undef FUNC_NAME
 782
 783 SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
 784            (SCM uvec, SCM port_or_fd, SCM start, SCM end),
 785             "Write the elements of @var{uvec} as raw bytes to\n"
 786             "@var{port-or-fdes}, in the host byte order.\n\n"
 787             "The optional arguments @var{start} (inclusive)\n"
 788             "and @var{end} (exclusive) allow\n"
 789             "a specified region to be written.\n\n"
 790             "When @var{port-or-fdes} is a port, all specified elements\n"
 791             "of @var{uvec} are attempted to be written, potentially blocking\n"
 792             "while waiting for more room.\n"
 793             "When @var{port-or-fd} is an integer, a single call to\n"
 794             "write(2) is made.\n\n"
 795             "An error is signalled when the last element has only\n"
 796             "been partially written in the single call to write(2).\n\n"
 797             "The number of objects actually written is returned.\n"
 798             "@var{port-or-fdes} may be\n"
 799             "omitted, in which case it defaults to the value returned by\n"
 800             "@code{(current-output-port)}.")
 801 #define FUNC_NAME s_scm_uniform_vector_write
 802 {
 803   size_t vlen, sz, ans;
 804   size_t cstart, cend;
 805   size_t amount, off;
 806   const void *base;
 807
 808   port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
 809
 810   if (SCM_UNBNDP (port_or_fd))
 811     port_or_fd = scm_cur_outp;
 812   else
 813     SCM_ASSERT (scm_is_integer (port_or_fd)
 814                 || (SCM_OPOUTPORTP (port_or_fd)),
 815                 port_or_fd, SCM_ARG2, FUNC_NAME);
 816
 817   scm_frame_begin (0);
 818
 819   vlen = scm_c_generalized_vector_length (uvec);
 820   sz = scm_uniform_vector_element_size (uvec);
 821   base = scm_uniform_vector_elements (uvec);
 822   scm_frame_uniform_vector_release_elements (uvec);
 823
 824   cstart = 0;
 825   cend = vlen;
 826   if (!SCM_UNBNDP (start))
 827     {
 828       cstart = scm_to_unsigned_integer (start, 0, vlen);
 829       if (!SCM_UNBNDP (end))
 830         cend = scm_to_unsigned_integer (end, cstart, vlen);
 831     }
 832
 833   amount = (cend - cstart) * sz;
 834   off = cstart * sz;
 835
 836   if (SCM_NIMP (port_or_fd))
 837     {
 838       scm_lfwrite (base + off, amount, port_or_fd);
 839       ans = cend - cstart;
 840     }
 841   else /* file descriptor.  */
 842     {
 843       int fd = scm_to_int (port_or_fd), n;
 844       SCM_SYSCALL (n = write (fd, base + off, amount));
 845       if (n == -1)
 846         SCM_SYSERROR;
 847       if (n % sz != 0)
 848         SCM_MISC_ERROR ("last element only written partially", SCM_EOL);
 849       ans = n / sz;
 850     }
 851
 852   scm_frame_end ();
 853
 854   return scm_from_size_t (ans);
 855 }
 856 #undef FUNC_NAME
 857
 858 /* ================================================================ */
 859 /* Exported procedures.                                             */
 860 /* ================================================================ */
 861
 862 #define TYPE  SCM_UVEC_U8
 863 #define TAG   u8
 864 #define CTYPE scm_t_uint8
 865 #include "libguile/srfi-4.i.c"
 866
 867 #define TYPE  SCM_UVEC_S8
 868 #define TAG   s8
 869 #define CTYPE scm_t_int8
 870 #include "libguile/srfi-4.i.c"
 871
 872 #define TYPE  SCM_UVEC_U16
 873 #define TAG   u16
 874 #define CTYPE scm_t_uint16
 875 #include "libguile/srfi-4.i.c"
 876
 877 #define TYPE  SCM_UVEC_S16
 878 #define TAG   s16
 879 #define CTYPE scm_t_int16
 880 #include "libguile/srfi-4.i.c"
 881
 882 #define TYPE  SCM_UVEC_U32
 883 #define TAG   u32
 884 #define CTYPE scm_t_uint32
 885 #include "libguile/srfi-4.i.c"
 886
 887 #define TYPE  SCM_UVEC_S32
 888 #define TAG   s32
 889 #define CTYPE scm_t_int32
 890 #include "libguile/srfi-4.i.c"
 891
 892 #define TYPE  SCM_UVEC_U64
 893 #define TAG   u64
 894 #define CTYPE scm_t_uint64
 895 #include "libguile/srfi-4.i.c"
 896
 897 #define TYPE  SCM_UVEC_S64
 898 #define TAG   s64
 899 #define CTYPE scm_t_int64
 900 #include "libguile/srfi-4.i.c"
 901
 902 #define TYPE  SCM_UVEC_F32
 903 #define TAG   f32
 904 #define CTYPE float
 905 #include "libguile/srfi-4.i.c"
 906
 907 #define TYPE  SCM_UVEC_F64
 908 #define TAG   f64
 909 #define CTYPE double
 910 #include "libguile/srfi-4.i.c"
 911
 912 #define TYPE  SCM_UVEC_C32
 913 #define TAG   c32
 914 #define CTYPE float
 915 #include "libguile/srfi-4.i.c"
 916
 917 #define TYPE  SCM_UVEC_C64
 918 #define TAG   c64
 919 #define CTYPE double
 920 #include "libguile/srfi-4.i.c"
 921
 922 void
 923 scm_init_srfi_4 (void)
 924 {
 925   scm_tc16_uvec = scm_make_smob_type ("uvec", 0);
 926   scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp);
 927   scm_set_smob_free (scm_tc16_uvec, uvec_free);
 928   scm_set_smob_print (scm_tc16_uvec, uvec_print);
 929
 930 #include "libguile/srfi-4.x"
 931
 932 }
 933
 934 /* End of srfi-4.c.  */