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 const 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_elements (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   scm_remember_upto_here_1 (uvec);
 620 }
 621
 622 void
 623 scm_frame_uniform_vector_release_elements (SCM uvec)
 624 {
 625   scm_frame_unwind_handler_with_scm (scm_uniform_vector_release_elements, uvec,
 626                                      SCM_F_WIND_EXPLICITLY);
 627 }
 628
 629 void *
 630 scm_uniform_vector_writable_elements (SCM uvec)
 631 {
 632   if (scm_is_uniform_vector (uvec))
 633     return SCM_UVEC_BASE (uvec);
 634   else
 635     scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
 636 }
 637
 638 void
 639 scm_uniform_vector_release_writable_elements (SCM uvec)
 640 {
 641   /* Nothing to do right now, but this function might come in handy
 642      when uniform vectors need to be locked when giving away a pointer
 643      to their elements.
 644
 645      Also, a call to scm_uniform_vector_release acts like
 646      scm_remember_upto_here, which is needed in any case.
 647   */
 648
 649   scm_remember_upto_here_1 (uvec);
 650 }
 651
 652 void
 653 scm_frame_uniform_vector_release_writable_elements (SCM uvec)
 654 {
 655   scm_frame_unwind_handler_with_scm
 656     (scm_uniform_vector_release_writable_elements, uvec,
 657      SCM_F_WIND_EXPLICITLY);
 658 }
 659
 660 size_t
 661 scm_uniform_vector_element_size (SCM uvec)
 662 {
 663   if (scm_is_uniform_vector (uvec))
 664     return uvec_sizes[SCM_UVEC_TYPE (uvec)];
 665   else
 666     scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
 667 }
 668
 669 /* return the size of an element in a uniform array or 0 if type not
 670    found.  */
 671 size_t
 672 scm_uniform_element_size (SCM obj)
 673 {
 674   if (scm_is_uniform_vector (obj))
 675     return scm_uniform_vector_element_size (obj);
 676   else
 677     return 0;
 678 }
 679
 680 SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
 681             (SCM v),
 682             "Return the number of elements in the uniform vector @var{v}.")
 683 #define FUNC_NAME s_scm_uniform_vector_length
 684 {
 685   return scm_from_size_t (scm_c_uniform_vector_length (v));
 686 }
 687 #undef FUNC_NAME
 688
 689 SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
 690            (SCM uvec, SCM port_or_fd, SCM start, SCM end),
 691             "Fill the elements of @var{uvec} by reading\n"
 692             "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
 693             "The optional arguments @var{start} (inclusive) and @var{end}\n"
 694             "(exclusive) allow a specified region to be read,\n"
 695             "leaving the remainder of the vector unchanged.\n\n"
 696             "When @var{port-or-fdes} is a port, all specified elements\n"
 697             "of @var{uvec} are attempted to be read, potentially blocking\n"
 698             "while waiting formore input or end-of-file.\n"
 699             "When @var{port-or-fd} is an integer, a single call to\n"
 700             "read(2) is made.\n\n"
 701             "An error is signalled when the last element has only\n"
 702             "been partially filled before reaching end-of-file or in\n"
 703             "the single call to read(2).\n\n"
 704             "@code{uniform-array-read!} returns the number of elements read.\n"
 705             "@var{port-or-fdes} may be omitted, in which case it defaults\n"
 706             "to the value returned by @code{(current-input-port)}.")
 707 #define FUNC_NAME s_scm_uniform_vector_read_x
 708 {
 709   size_t vlen, sz, ans;
 710   size_t cstart, cend;
 711   size_t remaining, off;
 712   void *base;
 713
 714   if (SCM_UNBNDP (port_or_fd))
 715     port_or_fd = scm_cur_inp;
 716   else
 717     SCM_ASSERT (scm_is_integer (port_or_fd)
 718                 || (SCM_OPINPORTP (port_or_fd)),
 719                 port_or_fd, SCM_ARG2, FUNC_NAME);
 720
 721
 722   scm_frame_begin (0);
 723
 724   vlen = scm_c_uniform_vector_length (uvec);
 725   sz = scm_uniform_vector_element_size (uvec);
 726   base = scm_uniform_vector_writable_elements (uvec);
 727   scm_frame_uniform_vector_release_writable_elements (uvec);
 728
 729   cstart = 0;
 730   cend = vlen;
 731   if (!SCM_UNBNDP (start))
 732     {
 733       cstart = scm_to_unsigned_integer (start, 0, vlen);
 734       if (!SCM_UNBNDP (end))
 735         cend = scm_to_unsigned_integer (end, cstart, vlen);
 736     }
 737
 738   remaining = (cend - cstart) * sz;
 739   off = cstart * sz;
 740
 741   if (SCM_NIMP (port_or_fd))
 742     {
 743       scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd);
 744
 745       if (pt->rw_active == SCM_PORT_WRITE)
 746         scm_flush (port_or_fd);
 747
 748       ans = cend - cstart;
 749       while (remaining > 0)
 750         {
 751           if (pt->read_pos < pt->read_end)
 752             {
 753               size_t to_copy = min (pt->read_end - pt->read_pos,
 754                                     remaining);
 755
 756               memcpy (base + off, pt->read_pos, to_copy);
 757               pt->read_pos += to_copy;
 758               remaining -= to_copy;
 759               off += to_copy;
 760             }
 761           else
 762             {
 763               if (scm_fill_input (port_or_fd) == EOF)
 764                 {
 765                   if (remaining % sz != 0)
 766                     SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
 767                   ans -= remaining / sz;
 768                   break;
 769                 }
 770             }
 771         }
 772
 773       if (pt->rw_random)
 774         pt->rw_active = SCM_PORT_READ;
 775     }
 776   else /* file descriptor.  */
 777     {
 778       int fd = scm_to_int (port_or_fd);
 779       int n;
 780
 781       SCM_SYSCALL (n = read (fd, base + off, remaining));
 782       if (n == -1)
 783         SCM_SYSERROR;
 784       if (n % sz != 0)
 785         SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
 786       ans = n / sz;
 787     }
 788
 789   scm_frame_end ();
 790
 791   return scm_from_size_t (ans);
 792 }
 793 #undef FUNC_NAME
 794
 795 SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
 796            (SCM uvec, SCM port_or_fd, SCM start, SCM end),
 797             "Write the elements of @var{uvec} as raw bytes to\n"
 798             "@var{port-or-fdes}, in the host byte order.\n\n"
 799             "The optional arguments @var{start} (inclusive)\n"
 800             "and @var{end} (exclusive) allow\n"
 801             "a specified region to be written.\n\n"
 802             "When @var{port-or-fdes} is a port, all specified elements\n"
 803             "of @var{uvec} are attempted to be written, potentially blocking\n"
 804             "while waiting for more room.\n"
 805             "When @var{port-or-fd} is an integer, a single call to\n"
 806             "write(2) is made.\n\n"
 807             "An error is signalled when the last element has only\n"
 808             "been partially written in the single call to write(2).\n\n"
 809             "The number of objects actually written is returned.\n"
 810             "@var{port-or-fdes} may be\n"
 811             "omitted, in which case it defaults to the value returned by\n"
 812             "@code{(current-output-port)}.")
 813 #define FUNC_NAME s_scm_uniform_vector_write
 814 {
 815   size_t vlen, sz, ans;
 816   size_t cstart, cend;
 817   size_t amount, off;
 818   const void *base;
 819
 820   port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
 821
 822   if (SCM_UNBNDP (port_or_fd))
 823     port_or_fd = scm_cur_outp;
 824   else
 825     SCM_ASSERT (scm_is_integer (port_or_fd)
 826                 || (SCM_OPOUTPORTP (port_or_fd)),
 827                 port_or_fd, SCM_ARG2, FUNC_NAME);
 828
 829   scm_frame_begin (0);
 830
 831   vlen = scm_c_generalized_vector_length (uvec);
 832   sz = scm_uniform_vector_element_size (uvec);
 833   base = scm_uniform_vector_elements (uvec);
 834   scm_frame_uniform_vector_release_elements (uvec);
 835
 836   cstart = 0;
 837   cend = vlen;
 838   if (!SCM_UNBNDP (start))
 839     {
 840       cstart = scm_to_unsigned_integer (start, 0, vlen);
 841       if (!SCM_UNBNDP (end))
 842         cend = scm_to_unsigned_integer (end, cstart, vlen);
 843     }
 844
 845   amount = (cend - cstart) * sz;
 846   off = cstart * sz;
 847
 848   if (SCM_NIMP (port_or_fd))
 849     {
 850       scm_lfwrite (base + off, amount, port_or_fd);
 851       ans = cend - cstart;
 852     }
 853   else /* file descriptor.  */
 854     {
 855       int fd = scm_to_int (port_or_fd), n;
 856       SCM_SYSCALL (n = write (fd, base + off, amount));
 857       if (n == -1)
 858         SCM_SYSERROR;
 859       if (n % sz != 0)
 860         SCM_MISC_ERROR ("last element only written partially", SCM_EOL);
 861       ans = n / sz;
 862     }
 863
 864   scm_frame_end ();
 865
 866   return scm_from_size_t (ans);
 867 }
 868 #undef FUNC_NAME
 869
 870 /* ================================================================ */
 871 /* Exported procedures.                                             */
 872 /* ================================================================ */
 873
 874 #define TYPE  SCM_UVEC_U8
 875 #define TAG   u8
 876 #define CTYPE scm_t_uint8
 877 #include "libguile/srfi-4.i.c"
 878
 879 #define TYPE  SCM_UVEC_S8
 880 #define TAG   s8
 881 #define CTYPE scm_t_int8
 882 #include "libguile/srfi-4.i.c"
 883
 884 #define TYPE  SCM_UVEC_U16
 885 #define TAG   u16
 886 #define CTYPE scm_t_uint16
 887 #include "libguile/srfi-4.i.c"
 888
 889 #define TYPE  SCM_UVEC_S16
 890 #define TAG   s16
 891 #define CTYPE scm_t_int16
 892 #include "libguile/srfi-4.i.c"
 893
 894 #define TYPE  SCM_UVEC_U32
 895 #define TAG   u32
 896 #define CTYPE scm_t_uint32
 897 #include "libguile/srfi-4.i.c"
 898
 899 #define TYPE  SCM_UVEC_S32
 900 #define TAG   s32
 901 #define CTYPE scm_t_int32
 902 #include "libguile/srfi-4.i.c"
 903
 904 #define TYPE  SCM_UVEC_U64
 905 #define TAG   u64
 906 #define CTYPE scm_t_uint64
 907 #include "libguile/srfi-4.i.c"
 908
 909 #define TYPE  SCM_UVEC_S64
 910 #define TAG   s64
 911 #define CTYPE scm_t_int64
 912 #include "libguile/srfi-4.i.c"
 913
 914 #define TYPE  SCM_UVEC_F32
 915 #define TAG   f32
 916 #define CTYPE float
 917 #include "libguile/srfi-4.i.c"
 918
 919 #define TYPE  SCM_UVEC_F64
 920 #define TAG   f64
 921 #define CTYPE double
 922 #include "libguile/srfi-4.i.c"
 923
 924 #define TYPE  SCM_UVEC_C32
 925 #define TAG   c32
 926 #define CTYPE float
 927 #include "libguile/srfi-4.i.c"
 928
 929 #define TYPE  SCM_UVEC_C64
 930 #define TAG   c64
 931 #define CTYPE double
 932 #include "libguile/srfi-4.i.c"
 933
 934 SCM scm_i_proc_make_u8vector;
 935 SCM scm_i_proc_make_s8vector;
 936 SCM scm_i_proc_make_u16vector;
 937 SCM scm_i_proc_make_s16vector;
 938 SCM scm_i_proc_make_u32vector;
 939 SCM scm_i_proc_make_s32vector;
 940 SCM scm_i_proc_make_u64vector;
 941 SCM scm_i_proc_make_s64vector;
 942 SCM scm_i_proc_make_f32vector;
 943 SCM scm_i_proc_make_f64vector;
 944 SCM scm_i_proc_make_c32vector;
 945 SCM scm_i_proc_make_c64vector;
 946
 947 /* Create the smob type for homogeneous numeric vectors and install
 948    the primitives.  */
 949 void
 950 scm_init_srfi_4 (void)
 951 {
 952   scm_tc16_uvec = scm_make_smob_type ("uvec", 0);
 953   scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp);
 954   scm_set_smob_free (scm_tc16_uvec, uvec_free);
 955   scm_set_smob_print (scm_tc16_uvec, uvec_print);
 956 #include "libguile/srfi-4.x"
 957
 958 #define GETPROC(tag) \
 959   scm_i_proc_make_##tag##vector = \
 960     scm_variable_ref (scm_c_lookup ("make-"#tag"vector"))
 961
 962   GETPROC (u8);
 963   GETPROC (s8);
 964   GETPROC (u16);
 965   GETPROC (s16);
 966   GETPROC (u32);
 967   GETPROC (s32);
 968   GETPROC (u64);
 969   GETPROC (s64);
 970   GETPROC (f32);
 971   GETPROC (f64);
 972   GETPROC (c32);
 973   GETPROC (c64);
 974 }
 975
 976 /* End of srfi-4.c.  */