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 size_t
 588 scm_uniform_vector_element_size (SCM uvec)
 589 {
 590   if (scm_is_uniform_vector (uvec))
 591     return uvec_sizes[SCM_UVEC_TYPE (uvec)];
 592   else
 593     scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
 594 }
 595
 596 /* return the size of an element in a uniform array or 0 if type not
 597    found.  */
 598 size_t
 599 scm_uniform_element_size (SCM obj)
 600 {
 601   if (scm_is_uniform_vector (obj))
 602     return scm_uniform_vector_element_size (obj);
 603   else
 604     return 0;
 605 }
 606
 607 const void *
 608 scm_array_handle_uniform_elements (scm_t_array_handle *h)
 609 {
 610   return scm_array_handle_uniform_writable_elements (h);
 611 }
 612
 613 void *
 614 scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
 615 {
 616   SCM vec = h->array;
 617   if (SCM_ARRAYP (vec))
 618     vec = SCM_ARRAY_V (vec);
 619   if (scm_is_uniform_vector (vec))
 620     {
 621       size_t size = uvec_sizes[SCM_UVEC_TYPE(vec)];
 622       char *elts = SCM_UVEC_BASE (vec);
 623       return (void *) (elts + size*h->base);
 624     }
 625   scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
 626 }
 627
 628 const void *
 629 scm_uniform_vector_elements (SCM uvec,
 630                              scm_t_array_handle *h,
 631                              size_t *lenp, ssize_t *incp)
 632 {
 633   return scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
 634 }
 635
 636 void *
 637 scm_uniform_vector_writable_elements (SCM uvec,
 638                                       scm_t_array_handle *h,
 639                                       size_t *lenp, ssize_t *incp)
 640 {
 641   scm_vector_get_handle (uvec, h);
 642   if (lenp)
 643     {
 644       scm_t_array_dim *dim = scm_array_handle_dims (h);
 645       *lenp = dim->ubnd - dim->lbnd + 1;
 646       *incp = dim->inc;
 647     }
 648   return scm_array_handle_uniform_writable_elements (h);
 649 }
 650
 651 SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
 652             (SCM v),
 653             "Return the number of elements in the uniform vector @var{v}.")
 654 #define FUNC_NAME s_scm_uniform_vector_length
 655 {
 656   return scm_from_size_t (scm_c_uniform_vector_length (v));
 657 }
 658 #undef FUNC_NAME
 659
 660 SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
 661            (SCM uvec, SCM port_or_fd, SCM start, SCM end),
 662             "Fill the elements of @var{uvec} by reading\n"
 663             "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
 664             "The optional arguments @var{start} (inclusive) and @var{end}\n"
 665             "(exclusive) allow a specified region to be read,\n"
 666             "leaving the remainder of the vector unchanged.\n\n"
 667             "When @var{port-or-fdes} is a port, all specified elements\n"
 668             "of @var{uvec} are attempted to be read, potentially blocking\n"
 669             "while waiting formore input or end-of-file.\n"
 670             "When @var{port-or-fd} is an integer, a single call to\n"
 671             "read(2) is made.\n\n"
 672             "An error is signalled when the last element has only\n"
 673             "been partially filled before reaching end-of-file or in\n"
 674             "the single call to read(2).\n\n"
 675             "@code{uniform-vector-read!} returns the number of elements\n"
 676             "read.\n\n"
 677             "@var{port-or-fdes} may be omitted, in which case it defaults\n"
 678             "to the value returned by @code{(current-input-port)}.")
 679 #define FUNC_NAME s_scm_uniform_vector_read_x
 680 {
 681   scm_t_array_handle handle;
 682   size_t vlen, sz, ans;
 683   ssize_t inc;
 684   size_t cstart, cend;
 685   size_t remaining, off;
 686   void *base;
 687
 688   if (SCM_UNBNDP (port_or_fd))
 689     port_or_fd = scm_cur_inp;
 690   else
 691     SCM_ASSERT (scm_is_integer (port_or_fd)
 692                 || (SCM_OPINPORTP (port_or_fd)),
 693                 port_or_fd, SCM_ARG2, FUNC_NAME);
 694
 695   if (!scm_is_uniform_vector (uvec))
 696     scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
 697
 698   base = scm_uniform_vector_writable_elements (uvec, &handle, &vlen, &inc);
 699   sz = scm_uniform_vector_element_size (uvec);
 700
 701   if (inc != 1)
 702     {
 703       /* XXX - we should of course support non contiguous vectors. */
 704       scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
 705                       scm_list_1 (uvec));
 706     }
 707
 708   cstart = 0;
 709   cend = vlen;
 710   if (!SCM_UNBNDP (start))
 711     {
 712       cstart = scm_to_unsigned_integer (start, 0, vlen);
 713       if (!SCM_UNBNDP (end))
 714         cend = scm_to_unsigned_integer (end, cstart, vlen);
 715     }
 716
 717   remaining = (cend - cstart) * sz;
 718   off = cstart * sz;
 719
 720   if (SCM_NIMP (port_or_fd))
 721     {
 722       scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd);
 723
 724       if (pt->rw_active == SCM_PORT_WRITE)
 725         scm_flush (port_or_fd);
 726
 727       ans = cend - cstart;
 728       while (remaining > 0)
 729         {
 730           if (pt->read_pos < pt->read_end)
 731             {
 732               size_t to_copy = min (pt->read_end - pt->read_pos,
 733                                     remaining);
 734
 735               memcpy (base + off, pt->read_pos, to_copy);
 736               pt->read_pos += to_copy;
 737               remaining -= to_copy;
 738               off += to_copy;
 739             }
 740           else
 741             {
 742               if (scm_fill_input (port_or_fd) == EOF)
 743                 {
 744                   if (remaining % sz != 0)
 745                     SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
 746                   ans -= remaining / sz;
 747                   break;
 748                 }
 749             }
 750         }
 751
 752       if (pt->rw_random)
 753         pt->rw_active = SCM_PORT_READ;
 754     }
 755   else /* file descriptor.  */
 756     {
 757       int fd = scm_to_int (port_or_fd);
 758       int n;
 759
 760       SCM_SYSCALL (n = read (fd, base + off, remaining));
 761       if (n == -1)
 762         SCM_SYSERROR;
 763       if (n % sz != 0)
 764         SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
 765       ans = n / sz;
 766     }
 767
 768   return scm_from_size_t (ans);
 769 }
 770 #undef FUNC_NAME
 771
 772 SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
 773            (SCM uvec, SCM port_or_fd, SCM start, SCM end),
 774             "Write the elements of @var{uvec} as raw bytes to\n"
 775             "@var{port-or-fdes}, in the host byte order.\n\n"
 776             "The optional arguments @var{start} (inclusive)\n"
 777             "and @var{end} (exclusive) allow\n"
 778             "a specified region to be written.\n\n"
 779             "When @var{port-or-fdes} is a port, all specified elements\n"
 780             "of @var{uvec} are attempted to be written, potentially blocking\n"
 781             "while waiting for more room.\n"
 782             "When @var{port-or-fd} is an integer, a single call to\n"
 783             "write(2) is made.\n\n"
 784             "An error is signalled when the last element has only\n"
 785             "been partially written in the single call to write(2).\n\n"
 786             "The number of objects actually written is returned.\n"
 787             "@var{port-or-fdes} may be\n"
 788             "omitted, in which case it defaults to the value returned by\n"
 789             "@code{(current-output-port)}.")
 790 #define FUNC_NAME s_scm_uniform_vector_write
 791 {
 792   scm_t_array_handle handle;
 793   size_t vlen, sz, ans;
 794   ssize_t inc;
 795   size_t cstart, cend;
 796   size_t amount, off;
 797   const void *base;
 798
 799   port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
 800
 801   if (SCM_UNBNDP (port_or_fd))
 802     port_or_fd = scm_cur_outp;
 803   else
 804     SCM_ASSERT (scm_is_integer (port_or_fd)
 805                 || (SCM_OPOUTPORTP (port_or_fd)),
 806                 port_or_fd, SCM_ARG2, FUNC_NAME);
 807
 808   base = scm_uniform_vector_elements (uvec, &handle, &vlen, &inc);
 809   sz = scm_uniform_vector_element_size (uvec);
 810
 811   if (inc != 1)
 812     {
 813       /* XXX - we should of course support non contiguous vectors. */
 814       scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
 815                       scm_list_1 (uvec));
 816     }
 817
 818   cstart = 0;
 819   cend = vlen;
 820   if (!SCM_UNBNDP (start))
 821     {
 822       cstart = scm_to_unsigned_integer (start, 0, vlen);
 823       if (!SCM_UNBNDP (end))
 824         cend = scm_to_unsigned_integer (end, cstart, vlen);
 825     }
 826
 827   amount = (cend - cstart) * sz;
 828   off = cstart * sz;
 829
 830   if (SCM_NIMP (port_or_fd))
 831     {
 832       scm_lfwrite (base + off, amount, port_or_fd);
 833       ans = cend - cstart;
 834     }
 835   else /* file descriptor.  */
 836     {
 837       int fd = scm_to_int (port_or_fd), n;
 838       SCM_SYSCALL (n = write (fd, base + off, amount));
 839       if (n == -1)
 840         SCM_SYSERROR;
 841       if (n % sz != 0)
 842         SCM_MISC_ERROR ("last element only written partially", SCM_EOL);
 843       ans = n / sz;
 844     }
 845
 846   return scm_from_size_t (ans);
 847 }
 848 #undef FUNC_NAME
 849
 850 /* ================================================================ */
 851 /* Exported procedures.                                             */
 852 /* ================================================================ */
 853
 854 #define TYPE  SCM_UVEC_U8
 855 #define TAG   u8
 856 #define CTYPE scm_t_uint8
 857 #include "libguile/srfi-4.i.c"
 858
 859 #define TYPE  SCM_UVEC_S8
 860 #define TAG   s8
 861 #define CTYPE scm_t_int8
 862 #include "libguile/srfi-4.i.c"
 863
 864 #define TYPE  SCM_UVEC_U16
 865 #define TAG   u16
 866 #define CTYPE scm_t_uint16
 867 #include "libguile/srfi-4.i.c"
 868
 869 #define TYPE  SCM_UVEC_S16
 870 #define TAG   s16
 871 #define CTYPE scm_t_int16
 872 #include "libguile/srfi-4.i.c"
 873
 874 #define TYPE  SCM_UVEC_U32
 875 #define TAG   u32
 876 #define CTYPE scm_t_uint32
 877 #include "libguile/srfi-4.i.c"
 878
 879 #define TYPE  SCM_UVEC_S32
 880 #define TAG   s32
 881 #define CTYPE scm_t_int32
 882 #include "libguile/srfi-4.i.c"
 883
 884 #define TYPE  SCM_UVEC_U64
 885 #define TAG   u64
 886 #define CTYPE scm_t_uint64
 887 #include "libguile/srfi-4.i.c"
 888
 889 #define TYPE  SCM_UVEC_S64
 890 #define TAG   s64
 891 #define CTYPE scm_t_int64
 892 #include "libguile/srfi-4.i.c"
 893
 894 #define TYPE  SCM_UVEC_F32
 895 #define TAG   f32
 896 #define CTYPE float
 897 #include "libguile/srfi-4.i.c"
 898
 899 #define TYPE  SCM_UVEC_F64
 900 #define TAG   f64
 901 #define CTYPE double
 902 #include "libguile/srfi-4.i.c"
 903
 904 #define TYPE  SCM_UVEC_C32
 905 #define TAG   c32
 906 #define CTYPE float
 907 #include "libguile/srfi-4.i.c"
 908
 909 #define TYPE  SCM_UVEC_C64
 910 #define TAG   c64
 911 #define CTYPE double
 912 #include "libguile/srfi-4.i.c"
 913
 914 void
 915 scm_init_srfi_4 (void)
 916 {
 917   scm_tc16_uvec = scm_make_smob_type ("uvec", 0);
 918   scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp);
 919   scm_set_smob_free (scm_tc16_uvec, uvec_free);
 920   scm_set_smob_print (scm_tc16_uvec, uvec_print);
 921
 922 #include "libguile/srfi-4.x"
 923
 924 }
 925
 926 /* End of srfi-4.c.  */