guile18/libguile/srfi-4.c

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