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