libguile/srfi-4.c

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