libguile/srfi-4.c

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