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 /* Mark hook.  Only used when U64 and S64 are implemented as SCMs. */
 248
 249 #if SCM_HAVE_T_INT64 == 0
 250 static SCM
 251 uvec_mark (SCM uvec)
 252 {
 253   if (SCM_UVEC_TYPE (uvec) == SCM_UVEC_U64
 254       || SCM_UVEC_TYPE (uvec) == SCM_UVEC_S64)
 255     {
 256       SCM *ptr = (SCM *)SCM_UVEC_BASE (uvec);
 257       size_t len = SCM_UVEC_LENGTH (uvec), i;
 258       for (i = 0; i < len; i++)
 259         scm_gc_mark (*ptr++);
 260     }
 261   return SCM_BOOL_F;
 262 }
 263 #endif
 264
 265 /* Smob free hook for uniform numeric vectors. */
 266 static size_t
 267 uvec_free (SCM uvec)
 268 {
 269   int type = SCM_UVEC_TYPE (uvec);
 270   scm_gc_free (SCM_UVEC_BASE (uvec),
 271                SCM_UVEC_LENGTH (uvec) * uvec_sizes[type],
 272                uvec_names[type]);
 273   return 0;
 274 }
 275
 276 /* ================================================================ */
 277 /* Utility procedures.                                              */
 278 /* ================================================================ */
 279
 280 static SCM_C_INLINE_KEYWORD int
 281 is_uvec (int type, SCM obj)
 282 {
 283   if (SCM_IS_UVEC (obj))
 284     return SCM_UVEC_TYPE (obj) == type;
 285   if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
 286     {
 287       SCM v = SCM_I_ARRAY_V (obj);
 288       return SCM_IS_UVEC (v) && SCM_UVEC_TYPE (v) == type;
 289     }
 290   return 0;
 291 }
 292
 293 static SCM_C_INLINE_KEYWORD SCM
 294 uvec_p (int type, SCM obj)
 295 {
 296   return scm_from_bool (is_uvec (type, obj));
 297 }
 298
 299 static SCM_C_INLINE_KEYWORD void
 300 uvec_assert (int type, SCM obj)
 301 {
 302   if (!is_uvec (type, obj))
 303     scm_wrong_type_arg_msg (NULL, 0, obj, uvec_names[type]);
 304 }
 305
 306 static SCM
 307 take_uvec (int type, void *base, size_t len)
 308 {
 309   SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, (scm_t_bits) base);
 310 }
 311
 312 /* Create a new, uninitialized uniform numeric vector of type TYPE
 313    with space for LEN elements.  */
 314 static SCM
 315 alloc_uvec (int type, size_t len)
 316 {
 317   void *base;
 318   if (len > SCM_I_SIZE_MAX / uvec_sizes[type])
 319     scm_out_of_range (NULL, scm_from_size_t (len));
 320   base = scm_gc_malloc (len * uvec_sizes[type], uvec_names[type]);
 321 #if SCM_HAVE_T_INT64 == 0
 322   if (type == SCM_UVEC_U64 || type == SCM_UVEC_S64)
 323     {
 324       SCM *ptr = (SCM *)base;
 325       size_t i;
 326       for (i = 0; i < len; i++)
 327         *ptr++ = SCM_UNSPECIFIED;
 328     }
 329 #endif
 330   return take_uvec (type, base, len);
 331 }
 332
 333 /* GCC doesn't seem to want to optimize unused switch clauses away,
 334    so we use a big 'if' in the next two functions.
 335 */
 336
 337 static SCM_C_INLINE_KEYWORD SCM
 338 uvec_fast_ref (int type, const void *base, size_t c_idx)
 339 {
 340   if (type == SCM_UVEC_U8)
 341     return scm_from_uint8 (((scm_t_uint8*)base)[c_idx]);
 342   else if (type == SCM_UVEC_S8)
 343     return scm_from_int8 (((scm_t_int8*)base)[c_idx]);
 344   else if (type == SCM_UVEC_U16)
 345     return scm_from_uint16 (((scm_t_uint16*)base)[c_idx]);
 346   else if (type == SCM_UVEC_S16)
 347     return scm_from_int16 (((scm_t_int16*)base)[c_idx]);
 348   else if (type == SCM_UVEC_U32)
 349     return scm_from_uint32 (((scm_t_uint32*)base)[c_idx]);
 350   else if (type == SCM_UVEC_S32)
 351     return scm_from_int32 (((scm_t_int32*)base)[c_idx]);
 352 #if SCM_HAVE_T_INT64
 353   else if (type == SCM_UVEC_U64)
 354     return scm_from_uint64 (((scm_t_uint64*)base)[c_idx]);
 355   else if (type == SCM_UVEC_S64)
 356     return scm_from_int64 (((scm_t_int64*)base)[c_idx]);
 357 #else
 358   else if (type == SCM_UVEC_U64)
 359     return ((SCM *)base)[c_idx];
 360   else if (type == SCM_UVEC_S64)
 361     return ((SCM *)base)[c_idx];
 362 #endif
 363   else if (type == SCM_UVEC_F32)
 364     return scm_from_double (((float*)base)[c_idx]);
 365   else if (type == SCM_UVEC_F64)
 366     return scm_from_double (((double*)base)[c_idx]);
 367   else if (type == SCM_UVEC_C32)
 368     return scm_c_make_rectangular (((float*)base)[2*c_idx],
 369                                    ((float*)base)[2*c_idx+1]);
 370   else if (type == SCM_UVEC_C64)
 371     return scm_c_make_rectangular (((double*)base)[2*c_idx],
 372                                    ((double*)base)[2*c_idx+1]);
 373   else
 374     return SCM_BOOL_F;
 375 }
 376
 377 #if SCM_HAVE_T_INT64 == 0
 378 static SCM scm_uint64_min, scm_uint64_max;
 379 static SCM scm_int64_min, scm_int64_max;
 380
 381 static void
 382 assert_exact_integer_range (SCM val, SCM min, SCM max)
 383 {
 384   if (!scm_is_integer (val)
 385       || scm_is_false (scm_exact_p (val)))
 386     scm_wrong_type_arg_msg (NULL, 0, val, "exact integer");
 387   if (scm_is_true (scm_less_p (val, min))
 388       || scm_is_true (scm_gr_p (val, max)))
 389     scm_out_of_range (NULL, val);
 390 }
 391 #endif
 392
 393 static SCM_C_INLINE_KEYWORD void
 394 uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val)
 395 {
 396   if (type == SCM_UVEC_U8)
 397     (((scm_t_uint8*)base)[c_idx]) = scm_to_uint8 (val);
 398   else if (type == SCM_UVEC_S8)
 399     (((scm_t_int8*)base)[c_idx]) = scm_to_int8 (val);
 400   else if (type == SCM_UVEC_U16)
 401     (((scm_t_uint16*)base)[c_idx]) = scm_to_uint16 (val);
 402   else if (type == SCM_UVEC_S16)
 403     (((scm_t_int16*)base)[c_idx]) = scm_to_int16 (val);
 404   else if (type == SCM_UVEC_U32)
 405     (((scm_t_uint32*)base)[c_idx]) = scm_to_uint32 (val);
 406   else if (type == SCM_UVEC_S32)
 407     (((scm_t_int32*)base)[c_idx]) = scm_to_int32 (val);
 408 #if SCM_HAVE_T_INT64
 409   else if (type == SCM_UVEC_U64)
 410     (((scm_t_uint64*)base)[c_idx]) = scm_to_uint64 (val);
 411   else if (type == SCM_UVEC_S64)
 412     (((scm_t_int64*)base)[c_idx]) = scm_to_int64 (val);
 413 #else
 414   else if (type == SCM_UVEC_U64)
 415     {
 416       assert_exact_integer_range (val, scm_uint64_min, scm_uint64_max);
 417       ((SCM *)base)[c_idx] = val;
 418     }
 419   else if (type == SCM_UVEC_S64)
 420     {
 421       assert_exact_integer_range (val, scm_int64_min, scm_int64_max);
 422       ((SCM *)base)[c_idx] = val;
 423     }
 424 #endif
 425   else if (type == SCM_UVEC_F32)
 426     (((float*)base)[c_idx]) = scm_to_double (val);
 427   else if (type == SCM_UVEC_F64)
 428     (((double*)base)[c_idx]) = scm_to_double (val);
 429   else if (type == SCM_UVEC_C32)
 430     {
 431       (((float*)base)[2*c_idx])   = scm_c_real_part (val);
 432       (((float*)base)[2*c_idx+1]) = scm_c_imag_part (val);
 433     }
 434   else if (type == SCM_UVEC_C64)
 435     {
 436       (((double*)base)[2*c_idx])   = scm_c_real_part (val);
 437       (((double*)base)[2*c_idx+1]) = scm_c_imag_part (val);
 438     }
 439 }
 440
 441 static SCM_C_INLINE_KEYWORD SCM
 442 make_uvec (int type, SCM len, SCM fill)
 443 {
 444   size_t c_len = scm_to_size_t (len);
 445   SCM uvec = alloc_uvec (type, c_len);
 446   if (!SCM_UNBNDP (fill))
 447     {
 448       size_t idx;
 449       void *base = SCM_UVEC_BASE (uvec);
 450       for (idx = 0; idx < c_len; idx++)
 451         uvec_fast_set_x (type, base, idx, fill);
 452     }
 453   return uvec;
 454 }
 455
 456 static SCM_C_INLINE_KEYWORD void *
 457 uvec_writable_elements (int type, SCM uvec, scm_t_array_handle *handle,
 458                         size_t *lenp, ssize_t *incp)
 459 {
 460   if (type >= 0)
 461     {
 462       SCM v = uvec;
 463       if (SCM_I_ARRAYP (v))
 464         v = SCM_I_ARRAY_V (v);
 465       uvec_assert (type, v);
 466     }
 467
 468   return scm_uniform_vector_writable_elements (uvec, handle, lenp, incp);
 469 }
 470
 471 static SCM_C_INLINE_KEYWORD const void *
 472 uvec_elements (int type, SCM uvec, scm_t_array_handle *handle,
 473                size_t *lenp, ssize_t *incp)
 474 {
 475   return uvec_writable_elements (type, uvec, handle, lenp, incp);
 476 }
 477
 478 static int
 479 uvec_type (scm_t_array_handle *h)
 480 {
 481   SCM v = h->array;
 482   if (SCM_I_ARRAYP (v))
 483     v = SCM_I_ARRAY_V (v);
 484   return SCM_UVEC_TYPE (v);
 485 }
 486
 487 static SCM
 488 uvec_to_list (int type, SCM uvec)
 489 {
 490   scm_t_array_handle handle;
 491   size_t len;
 492   ssize_t i, inc;
 493   const void *elts;
 494   SCM res = SCM_EOL;
 495
 496   elts = uvec_elements (type, uvec, &handle, &len, &inc);
 497   for (i = len*inc; i > 0;)
 498     {
 499       i -= inc;
 500       res = scm_cons (scm_array_handle_ref (&handle, i), res);
 501     }
 502   scm_array_handle_release (&handle);
 503   return res;
 504 }
 505
 506 static SCM_C_INLINE_KEYWORD SCM
 507 uvec_length (int type, SCM uvec)
 508 {
 509   scm_t_array_handle handle;
 510   size_t len;
 511   ssize_t inc;
 512   uvec_elements (type, uvec, &handle, &len, &inc);
 513   scm_array_handle_release (&handle);
 514   return scm_from_size_t (len);
 515 }
 516
 517 static SCM_C_INLINE_KEYWORD SCM
 518 uvec_ref (int type, SCM uvec, SCM idx)
 519 {
 520   scm_t_array_handle handle;
 521   size_t i, len;
 522   ssize_t inc;
 523   const void *elts;
 524   SCM res;
 525
 526   elts = uvec_elements (type, uvec, &handle, &len, &inc);
 527   if (type < 0)
 528     type = uvec_type (&handle);
 529   i = scm_to_unsigned_integer (idx, 0, len-1);
 530   res = uvec_fast_ref (type, elts, i*inc);
 531   scm_array_handle_release (&handle);
 532   return res;
 533 }
 534
 535 static SCM_C_INLINE_KEYWORD SCM
 536 uvec_set_x (int type, SCM uvec, SCM idx, SCM val)
 537 {
 538   scm_t_array_handle handle;
 539   size_t i, len;
 540   ssize_t inc;
 541   void *elts;
 542
 543   elts = uvec_writable_elements (type, uvec, &handle, &len, &inc);
 544   if (type < 0)
 545     type = uvec_type (&handle);
 546   i = scm_to_unsigned_integer (idx, 0, len-1);
 547   uvec_fast_set_x (type, elts, i*inc, val);
 548   scm_array_handle_release (&handle);
 549   return SCM_UNSPECIFIED;
 550 }
 551
 552 static SCM_C_INLINE_KEYWORD SCM
 553 list_to_uvec (int type, SCM list)
 554 {
 555   SCM uvec;
 556   void *base;
 557   long idx;
 558   long len = scm_ilength (list);
 559   if (len < 0)
 560     scm_wrong_type_arg_msg (NULL, 0, list, "proper list");
 561
 562   uvec = alloc_uvec (type, len);
 563   base = SCM_UVEC_BASE (uvec);
 564   idx = 0;
 565   while (scm_is_pair (list) && idx < len)
 566     {
 567       uvec_fast_set_x (type, base, idx, SCM_CAR (list));
 568       list = SCM_CDR (list);
 569       idx++;
 570     }
 571   return uvec;
 572 }
 573
 574 static SCM
 575 coerce_to_uvec (int type, SCM obj)
 576 {
 577   if (is_uvec (type, obj))
 578     return obj;
 579   else if (scm_is_pair (obj))
 580     return list_to_uvec (type, obj);
 581   else if (scm_is_generalized_vector (obj))
 582     {
 583       scm_t_array_handle handle;
 584       size_t len = scm_c_generalized_vector_length (obj), i;
 585       SCM uvec = alloc_uvec (type, len);
 586       scm_array_get_handle (uvec, &handle);
 587       for (i = 0; i < len; i++)
 588         scm_array_handle_set (&handle, i,
 589                               scm_c_generalized_vector_ref (obj, i));
 590       scm_array_handle_release (&handle);
 591       return uvec;
 592     }
 593   else
 594     scm_wrong_type_arg_msg (NULL, 0, obj, "list or generalized vector");
 595 }
 596
 597 SCM_SYMBOL (scm_sym_a, "a");
 598 SCM_SYMBOL (scm_sym_b, "b");
 599
 600 SCM
 601 scm_i_generalized_vector_type (SCM v)
 602 {
 603   if (scm_is_vector (v))
 604     return SCM_BOOL_T;
 605   else if (scm_is_string (v))
 606     return scm_sym_a;
 607   else if (scm_is_bitvector (v))
 608     return scm_sym_b;
 609   else if (scm_is_uniform_vector (v))
 610     return scm_from_locale_symbol (uvec_tags[SCM_UVEC_TYPE(v)]);
 611   else
 612     return SCM_BOOL_F;
 613 }
 614
 615 int
 616 scm_is_uniform_vector (SCM obj)
 617 {
 618   if (SCM_IS_UVEC (obj))
 619     return 1;
 620   if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
 621     {
 622       SCM v = SCM_I_ARRAY_V (obj);
 623       return SCM_IS_UVEC (v);
 624     }
 625   return 0;
 626 }
 627
 628 size_t
 629 scm_c_uniform_vector_length (SCM uvec)
 630 {
 631   /* scm_generalized_vector_get_handle will ultimately call us to get
 632      the length of uniform vectors, so we can't use uvec_elements for
 633      naked vectors.
 634   */
 635
 636   if (SCM_IS_UVEC (uvec))
 637     return SCM_UVEC_LENGTH (uvec);
 638   else
 639     {
 640       scm_t_array_handle handle;
 641       size_t len;
 642       ssize_t inc;
 643       uvec_elements (-1, uvec, &handle, &len, &inc);
 644       scm_array_handle_release (&handle);
 645       return len;
 646     }
 647 }
 648
 649 SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
 650             (SCM obj),
 651             "Return @code{#t} if @var{obj} is a uniform vector.")
 652 #define FUNC_NAME s_scm_uniform_vector_p
 653 {
 654   return scm_from_bool (scm_is_uniform_vector (obj));
 655 }
 656 #undef FUNC_NAME
 657
 658 SCM
 659 scm_c_uniform_vector_ref (SCM v, size_t idx)
 660 {
 661   scm_t_array_handle handle;
 662   size_t len;
 663   ssize_t inc;
 664   SCM res;
 665
 666   uvec_elements (-1, v, &handle, &len, &inc);
 667   if (idx >= len)
 668     scm_out_of_range (NULL, scm_from_size_t (idx));
 669   res = scm_array_handle_ref (&handle, idx*inc);
 670   scm_array_handle_release (&handle);
 671   return res;
 672 }
 673
 674 SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
 675             (SCM v, SCM idx),
 676             "Return the element at index @var{idx} of the\n"
 677             "homogenous numeric vector @var{v}.")
 678 #define FUNC_NAME s_scm_uniform_vector_ref
 679 {
 680 #if SCM_ENABLE_DEPRECATED
 681   /* Support old argument convention.
 682    */
 683   if (scm_is_pair (idx))
 684     {
 685       scm_c_issue_deprecation_warning
 686         ("Using a list as the index to uniform-vector-ref is deprecated.");
 687       if (!scm_is_null (SCM_CDR (idx)))
 688         scm_wrong_num_args (NULL);
 689       idx = SCM_CAR (idx);
 690     }
 691 #endif
 692
 693   return scm_c_uniform_vector_ref (v, scm_to_size_t (idx));
 694 }
 695 #undef FUNC_NAME
 696
 697 void
 698 scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
 699 {
 700   scm_t_array_handle handle;
 701   size_t len;
 702   ssize_t inc;
 703
 704   uvec_writable_elements (-1, v, &handle, &len, &inc);
 705   if (idx >= len)
 706     scm_out_of_range (NULL, scm_from_size_t (idx));
 707   scm_array_handle_set (&handle, idx*inc, val);
 708   scm_array_handle_release (&handle);
 709 }
 710
 711 SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0,
 712             (SCM v, SCM idx, SCM val),
 713             "Set the element at index @var{idx} of the\n"
 714             "homogenous numeric vector @var{v} to @var{val}.")
 715 #define FUNC_NAME s_scm_uniform_vector_set_x
 716 {
 717 #if SCM_ENABLE_DEPRECATED
 718   /* Support old argument convention.
 719    */
 720   if (scm_is_pair (idx))
 721     {
 722       scm_c_issue_deprecation_warning
 723         ("Using a list as the index to uniform-vector-set! is deprecated.");
 724       if (!scm_is_null (SCM_CDR (idx)))
 725         scm_wrong_num_args (NULL);
 726       idx = SCM_CAR (idx);
 727     }
 728 #endif
 729
 730   scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val);
 731   return SCM_UNSPECIFIED;
 732 }
 733 #undef FUNC_NAME
 734
 735 SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
 736             (SCM uvec),
 737             "Convert the uniform numeric vector @var{uvec} to a list.")
 738 #define FUNC_NAME s_scm_uniform_vector_to_list
 739 {
 740   return uvec_to_list (-1, uvec);
 741 }
 742 #undef FUNC_NAME
 743
 744 size_t
 745 scm_array_handle_uniform_element_size (scm_t_array_handle *h)
 746 {
 747   SCM vec = h->array;
 748   if (SCM_I_ARRAYP (vec))
 749     vec = SCM_I_ARRAY_V (vec);
 750   if (scm_is_uniform_vector (vec))
 751     return uvec_sizes[SCM_UVEC_TYPE(vec)];
 752   scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
 753 }
 754
 755 #if SCM_ENABLE_DEPRECATED
 756
 757 /* return the size of an element in a uniform array or 0 if type not
 758    found.  */
 759 size_t
 760 scm_uniform_element_size (SCM obj)
 761 {
 762   scm_c_issue_deprecation_warning
 763     ("scm_uniform_element_size is deprecated.  "
 764      "Use scm_array_handle_uniform_element_size instead.");
 765
 766   if (SCM_IS_UVEC (obj))
 767     return uvec_sizes[SCM_UVEC_TYPE(obj)];
 768   else
 769     return 0;
 770 }
 771
 772 #endif
 773
 774 const void *
 775 scm_array_handle_uniform_elements (scm_t_array_handle *h)
 776 {
 777   return scm_array_handle_uniform_writable_elements (h);
 778 }
 779
 780 void *
 781 scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
 782 {
 783   SCM vec = h->array;
 784   if (SCM_I_ARRAYP (vec))
 785     vec = SCM_I_ARRAY_V (vec);
 786   if (SCM_IS_UVEC (vec))
 787     {
 788       size_t size = uvec_sizes[SCM_UVEC_TYPE(vec)];
 789       char *elts = SCM_UVEC_BASE (vec);
 790       return (void *) (elts + size*h->base);
 791     }
 792   scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
 793 }
 794
 795 const void *
 796 scm_uniform_vector_elements (SCM uvec,
 797                              scm_t_array_handle *h,
 798                              size_t *lenp, ssize_t *incp)
 799 {
 800   return scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
 801 }
 802
 803 void *
 804 scm_uniform_vector_writable_elements (SCM uvec,
 805                                       scm_t_array_handle *h,
 806                                       size_t *lenp, ssize_t *incp)
 807 {
 808   scm_generalized_vector_get_handle (uvec, h);
 809   if (lenp)
 810     {
 811       scm_t_array_dim *dim = scm_array_handle_dims (h);
 812       *lenp = dim->ubnd - dim->lbnd + 1;
 813       *incp = dim->inc;
 814     }
 815   return scm_array_handle_uniform_writable_elements (h);
 816 }
 817
 818 SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
 819             (SCM v),
 820             "Return the number of elements in the uniform vector @var{v}.")
 821 #define FUNC_NAME s_scm_uniform_vector_length
 822 {
 823   return uvec_length (-1, v);
 824 }
 825 #undef FUNC_NAME
 826
 827 SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
 828            (SCM uvec, SCM port_or_fd, SCM start, SCM end),
 829             "Fill the elements of @var{uvec} by reading\n"
 830             "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
 831             "The optional arguments @var{start} (inclusive) and @var{end}\n"
 832             "(exclusive) allow a specified region to be read,\n"
 833             "leaving the remainder of the vector unchanged.\n\n"
 834             "When @var{port-or-fdes} is a port, all specified elements\n"
 835             "of @var{uvec} are attempted to be read, potentially blocking\n"
 836             "while waiting formore input or end-of-file.\n"
 837             "When @var{port-or-fd} is an integer, a single call to\n"
 838             "read(2) is made.\n\n"
 839             "An error is signalled when the last element has only\n"
 840             "been partially filled before reaching end-of-file or in\n"
 841             "the single call to read(2).\n\n"
 842             "@code{uniform-vector-read!} returns the number of elements\n"
 843             "read.\n\n"
 844             "@var{port-or-fdes} may be omitted, in which case it defaults\n"
 845             "to the value returned by @code{(current-input-port)}.")
 846 #define FUNC_NAME s_scm_uniform_vector_read_x
 847 {
 848   scm_t_array_handle handle;
 849   size_t vlen, sz, ans;
 850   ssize_t inc;
 851   size_t cstart, cend;
 852   size_t remaining, off;
 853   char *base;
 854
 855   if (SCM_UNBNDP (port_or_fd))
 856     port_or_fd = scm_current_input_port ();
 857   else
 858     SCM_ASSERT (scm_is_integer (port_or_fd)
 859                 || (SCM_OPINPORTP (port_or_fd)),
 860                 port_or_fd, SCM_ARG2, FUNC_NAME);
 861
 862   if (!scm_is_uniform_vector (uvec))
 863     scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
 864
 865   base = scm_uniform_vector_writable_elements (uvec, &handle, &vlen, &inc);
 866   sz = scm_array_handle_uniform_element_size (&handle);
 867
 868   if (inc != 1)
 869     {
 870       /* XXX - we should of course support non contiguous vectors. */
 871       scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
 872                       scm_list_1 (uvec));
 873     }
 874
 875   cstart = 0;
 876   cend = vlen;
 877   if (!SCM_UNBNDP (start))
 878     {
 879       cstart = scm_to_unsigned_integer (start, 0, vlen);
 880       if (!SCM_UNBNDP (end))
 881         cend = scm_to_unsigned_integer (end, cstart, vlen);
 882     }
 883
 884   remaining = (cend - cstart) * sz;
 885   off = cstart * sz;
 886
 887   if (SCM_NIMP (port_or_fd))
 888     {
 889       scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd);
 890
 891       if (pt->rw_active == SCM_PORT_WRITE)
 892         scm_flush (port_or_fd);
 893
 894       ans = cend - cstart;
 895       while (remaining > 0)
 896         {
 897           if (pt->read_pos < pt->read_end)
 898             {
 899               size_t to_copy = min (pt->read_end - pt->read_pos,
 900                                     remaining);
 901
 902               memcpy (base + off, pt->read_pos, to_copy);
 903               pt->read_pos += to_copy;
 904               remaining -= to_copy;
 905               off += to_copy;
 906             }
 907           else
 908             {
 909               if (scm_fill_input (port_or_fd) == EOF)
 910                 {
 911                   if (remaining % sz != 0)
 912                     SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
 913                   ans -= remaining / sz;
 914                   break;
 915                 }
 916             }
 917         }
 918
 919       if (pt->rw_random)
 920         pt->rw_active = SCM_PORT_READ;
 921     }
 922   else /* file descriptor.  */
 923     {
 924       int fd = scm_to_int (port_or_fd);
 925       int n;
 926
 927       SCM_SYSCALL (n = read (fd, base + off, remaining));
 928       if (n == -1)
 929         SCM_SYSERROR;
 930       if (n % sz != 0)
 931         SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
 932       ans = n / sz;
 933     }
 934
 935   scm_array_handle_release (&handle);
 936
 937   return scm_from_size_t (ans);
 938 }
 939 #undef FUNC_NAME
 940
 941 SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
 942            (SCM uvec, SCM port_or_fd, SCM start, SCM end),
 943             "Write the elements of @var{uvec} as raw bytes to\n"
 944             "@var{port-or-fdes}, in the host byte order.\n\n"
 945             "The optional arguments @var{start} (inclusive)\n"
 946             "and @var{end} (exclusive) allow\n"
 947             "a specified region to be written.\n\n"
 948             "When @var{port-or-fdes} is a port, all specified elements\n"
 949             "of @var{uvec} are attempted to be written, potentially blocking\n"
 950             "while waiting for more room.\n"
 951             "When @var{port-or-fd} is an integer, a single call to\n"
 952             "write(2) is made.\n\n"
 953             "An error is signalled when the last element has only\n"
 954             "been partially written in the single call to write(2).\n\n"
 955             "The number of objects actually written is returned.\n"
 956             "@var{port-or-fdes} may be\n"
 957             "omitted, in which case it defaults to the value returned by\n"
 958             "@code{(current-output-port)}.")
 959 #define FUNC_NAME s_scm_uniform_vector_write
 960 {
 961   scm_t_array_handle handle;
 962   size_t vlen, sz, ans;
 963   ssize_t inc;
 964   size_t cstart, cend;
 965   size_t amount, off;
 966   const char *base;
 967
 968   port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
 969
 970   if (SCM_UNBNDP (port_or_fd))
 971     port_or_fd = scm_current_output_port ();
 972   else
 973     SCM_ASSERT (scm_is_integer (port_or_fd)
 974                 || (SCM_OPOUTPORTP (port_or_fd)),
 975                 port_or_fd, SCM_ARG2, FUNC_NAME);
 976
 977   base = scm_uniform_vector_elements (uvec, &handle, &vlen, &inc);
 978   sz = scm_array_handle_uniform_element_size (&handle);
 979
 980   if (inc != 1)
 981     {
 982       /* XXX - we should of course support non contiguous vectors. */
 983       scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
 984                       scm_list_1 (uvec));
 985     }
 986
 987   cstart = 0;
 988   cend = vlen;
 989   if (!SCM_UNBNDP (start))
 990     {
 991       cstart = scm_to_unsigned_integer (start, 0, vlen);
 992       if (!SCM_UNBNDP (end))
 993         cend = scm_to_unsigned_integer (end, cstart, vlen);
 994     }
 995
 996   amount = (cend - cstart) * sz;
 997   off = cstart * sz;
 998
 999   if (SCM_NIMP (port_or_fd))
1000     {
1001       scm_lfwrite (base + off, amount, port_or_fd);
1002       ans = cend - cstart;
1003     }
1004   else /* file descriptor.  */
1005     {
1006       int fd = scm_to_int (port_or_fd), n;
1007       SCM_SYSCALL (n = write (fd, base + off, amount));
1008       if (n == -1)
1009         SCM_SYSERROR;
1010       if (n % sz != 0)
1011         SCM_MISC_ERROR ("last element only written partially", SCM_EOL);
1012       ans = n / sz;
1013     }
1014
1015   scm_array_handle_release (&handle);
1016
1017   return scm_from_size_t (ans);
1018 }
1019 #undef FUNC_NAME
1020
1021 /* ================================================================ */
1022 /* Exported procedures.                                             */
1023 /* ================================================================ */
1024
1025 #define TYPE  SCM_UVEC_U8
1026 #define TAG   u8
1027 #define CTYPE scm_t_uint8
1028 #include "libguile/srfi-4.i.c"
1029
1030 #define TYPE  SCM_UVEC_S8
1031 #define TAG   s8
1032 #define CTYPE scm_t_int8
1033 #include "libguile/srfi-4.i.c"
1034
1035 #define TYPE  SCM_UVEC_U16
1036 #define TAG   u16
1037 #define CTYPE scm_t_uint16
1038 #include "libguile/srfi-4.i.c"
1039
1040 #define TYPE  SCM_UVEC_S16
1041 #define TAG   s16
1042 #define CTYPE scm_t_int16
1043 #include "libguile/srfi-4.i.c"
1044
1045 #define TYPE  SCM_UVEC_U32
1046 #define TAG   u32
1047 #define CTYPE scm_t_uint32
1048 #include "libguile/srfi-4.i.c"
1049
1050 #define TYPE  SCM_UVEC_S32
1051 #define TAG   s32
1052 #define CTYPE scm_t_int32
1053 #include "libguile/srfi-4.i.c"
1054
1055 #define TYPE  SCM_UVEC_U64
1056 #define TAG   u64
1057 #if SCM_HAVE_T_UINT64
1058 #define CTYPE scm_t_uint64
1059 #endif
1060 #include "libguile/srfi-4.i.c"
1061
1062 #define TYPE  SCM_UVEC_S64
1063 #define TAG   s64
1064 #if SCM_HAVE_T_INT64
1065 #define CTYPE scm_t_int64
1066 #endif
1067 #include "libguile/srfi-4.i.c"
1068
1069 #define TYPE  SCM_UVEC_F32
1070 #define TAG   f32
1071 #define CTYPE float
1072 #include "libguile/srfi-4.i.c"
1073
1074 #define TYPE  SCM_UVEC_F64
1075 #define TAG   f64
1076 #define CTYPE double
1077 #include "libguile/srfi-4.i.c"
1078
1079 #define TYPE  SCM_UVEC_C32
1080 #define TAG   c32
1081 #define CTYPE float
1082 #include "libguile/srfi-4.i.c"
1083
1084 #define TYPE  SCM_UVEC_C64
1085 #define TAG   c64
1086 #define CTYPE double
1087 #include "libguile/srfi-4.i.c"
1088
1089 static scm_i_t_array_ref uvec_reffers[12] = {
1090   u8ref, s8ref,
1091   u16ref, s16ref,
1092   u32ref, s32ref,
1093   u64ref, s64ref,
1094   f32ref, f64ref,
1095   c32ref, c64ref
1096 };
1097
1098 static scm_i_t_array_set uvec_setters[12] = {
1099   u8set, s8set,
1100   u16set, s16set,
1101   u32set, s32set,
1102   u64set, s64set,
1103   f32set, f64set,
1104   c32set, c64set
1105 };
1106
1107 scm_i_t_array_ref
1108 scm_i_uniform_vector_ref_proc (SCM uvec)
1109 {
1110   return uvec_reffers[SCM_UVEC_TYPE(uvec)];
1111 }
1112
1113 scm_i_t_array_set
1114 scm_i_uniform_vector_set_proc (SCM uvec)
1115 {
1116   return uvec_setters[SCM_UVEC_TYPE(uvec)];
1117 }
1118
1119 void
1120 scm_init_srfi_4 (void)
1121 {
1122   scm_tc16_uvec = scm_make_smob_type ("uvec", 0);
1123   scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp);
1124 #if SCM_HAVE_T_INT64 == 0
1125   scm_set_smob_mark (scm_tc16_uvec, uvec_mark);
1126 #endif
1127   scm_set_smob_free (scm_tc16_uvec, uvec_free);
1128   scm_set_smob_print (scm_tc16_uvec, uvec_print);
1129
1130 #if SCM_HAVE_T_INT64 == 0
1131   scm_uint64_min =
1132     scm_permanent_object (scm_from_int (0));
1133   scm_uint64_max =
1134     scm_permanent_object (scm_c_read_string ("18446744073709551615"));
1135   scm_int64_min =
1136     scm_permanent_object (scm_c_read_string ("-9223372036854775808"));
1137   scm_int64_max =
1138     scm_permanent_object (scm_c_read_string ("9223372036854775807"));
1139 #endif
1140
1141 #include "libguile/srfi-4.x"
1142
1143 }
1144
1145 /* End of srfi-4.c.  */