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