srfi/srfi-4.c

   1 /* srfi-4.c --- Homogeneous numeric vector datatypes.
   2  *
   3  *      Copyright (C) 2001 Free Software Foundation, Inc.
   4  *
   5  * This program is free software; you can redistribute it and/or
   6  * modify it under the terms of the GNU General Public License as
   7  * published by the Free Software Foundation; either version 2, or (at
   8  * your option) any later version.
   9  *
  10  * This program 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  * General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License
  16  * along with this software; see the file COPYING.  If not, write to
  17  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18  * Boston, MA 02111-1307 USA
  19  *
  20  * As a special exception, the Free Software Foundation gives
  21  * permission for additional uses of the text contained in its release
  22  * of GUILE.
  23  *
  24  * The exception is that, if you link the GUILE library with other
  25  * files to produce an executable, this does not by itself cause the
  26  * resulting executable to be covered by the GNU General Public
  27  * License.  Your use of that executable is in no way restricted on
  28  * account of linking the GUILE library code into it.
  29  *
  30  * This exception does not however invalidate any other reasons why
  31  * the executable file might be covered by the GNU General Public
  32  * License.
  33  *
  34  * This exception applies only to the code released by the Free
  35  * Software Foundation under the name GUILE.  If you copy code from
  36  * other Free Software Foundation releases into a copy of GUILE, as
  37  * the General Public License permits, the exception does not apply to
  38  * the code that you add in this way.  To avoid misleading anyone as
  39  * to the status of such modified files, you must delete this
  40  * exception notice from them.
  41  *
  42  * If you write modifications of your own for GUILE, it is your choice
  43  * whether to permit this exception to apply to your modifications.
  44  * If you do not wish that, delete this exception notice.  */
  45
  46 #include <libguile.h>
  47
  48 #include "srfi-4.h"
  49
  50
  51 /* For brevity and maintainability, we define our own types for the
  52    various integer and floating point types.  */
  53 typedef unsigned char int_u8;
  54 typedef signed char int_s8;
  55 typedef unsigned short int_u16;
  56 typedef signed short int_s16;
  57 typedef unsigned int int_u32;
  58 typedef signed int int_s32;
  59 #ifdef HAVE_LONG_LONG
  60 #if SIZEOF_LONG == 8
  61 typedef unsigned long int_u64;
  62 typedef signed long int_s64;
  63 #else
  64 typedef unsigned long long int_u64;
  65 typedef signed long long int_s64;
  66 #endif /* SIZEOF_LONG */
  67 #endif /* HAVE_LONG_LONG */
  68 typedef float float_f32;
  69 typedef double float_f64;
  70
  71
  72 /* Smob type code for homogeneous numeric vectors.  */
  73 int scm_tc16_uvec = 0;
  74
  75
  76 /* Accessor macros for the three components of a homogeneous numeric
  77    vector:
  78    - The type tag (one of the symbolic constants below).
  79    - The vector's length (counted in elements).
  80    - The address of the data area (holding the elements of the
  81      vector). */
  82 #define SCM_UVEC_TYPE(u)   (SCM_CELL_WORD_1(u))
  83 #define SCM_UVEC_LENGTH(u) (SCM_CELL_WORD_2(u))
  84 #define SCM_UVEC_BASE(u)   (SCM_CELL_OBJECT_3(u))
  85
  86
  87 /* Symbolic constants encoding the various types of homogeneous
  88    numeric vectors.  */
  89 #define SCM_UVEC_U8     0
  90 #define SCM_UVEC_S8     1
  91 #define SCM_UVEC_U16    2
  92 #define SCM_UVEC_S16    3
  93 #define SCM_UVEC_U32    4
  94 #define SCM_UVEC_S32    5
  95 #define SCM_UVEC_U64    6
  96 #define SCM_UVEC_S64    7
  97 #define SCM_UVEC_F32    8
  98 #define SCM_UVEC_F64    9
  99
 100
 101 /* This array maps type tags to the size of the elements.  */
 102 static int uvec_sizes[10] = {1, 1, 2, 2, 4, 4, 8, 8, 4, 8};
 103
 104
 105 /* ================================================================ */
 106 /* SMOB procedures.                                                 */
 107 /* ================================================================ */
 108
 109
 110 /* Smob print hook for homogeneous vectors.  */
 111 static int
 112 uvec_print (SCM uvec, SCM port, scm_print_state *pstate SCM_UNUSED)
 113 {
 114   switch (SCM_UVEC_TYPE (uvec))
 115     {
 116     case SCM_UVEC_U8:
 117       {
 118         int_u8 * p = (int_u8 *) SCM_UVEC_BASE (uvec);
 119         int i = 0;
 120
 121         scm_puts ("#u8(", port);
 122         if (SCM_UVEC_LENGTH (uvec) > 0)
 123           {
 124             scm_intprint (*p, 10, port);
 125             p++;
 126             i++;
 127             for (; i < SCM_UVEC_LENGTH (uvec); i++)
 128               {
 129                 scm_puts (" ", port);
 130                 scm_intprint (*p, 10, port);
 131                 p++;
 132               }
 133           }
 134         scm_puts (")", port);
 135         break;
 136       }
 137
 138     case SCM_UVEC_S8:
 139       {
 140         int_s8 * p = (int_s8 *) SCM_UVEC_BASE (uvec);
 141         int i = 0;
 142
 143         scm_puts ("#s8(", port);
 144         if (SCM_UVEC_LENGTH (uvec) > 0)
 145           {
 146             scm_intprint (*p, 10, port);
 147             p++;
 148             i++;
 149             for (; i < SCM_UVEC_LENGTH (uvec); i++)
 150               {
 151                 scm_puts (" ", port);
 152                 scm_intprint (*p, 10, port);
 153                 p++;
 154               }
 155           }
 156         scm_puts (")", port);
 157         break;
 158       }
 159
 160     case SCM_UVEC_U16:
 161       {
 162         int_u16 * p = (int_u16 *) SCM_UVEC_BASE (uvec);
 163         int i = 0;
 164
 165         scm_puts ("#u16(", port);
 166         if (SCM_UVEC_LENGTH (uvec) > 0)
 167           {
 168             scm_intprint (*p, 10, port);
 169             p++;
 170             i++;
 171             for (; i < SCM_UVEC_LENGTH (uvec); i++)
 172               {
 173                 scm_puts (" ", port);
 174                 scm_intprint (*p, 10, port);
 175                 p++;
 176               }
 177           }
 178         scm_puts (")", port);
 179         break;
 180       }
 181
 182     case SCM_UVEC_S16:
 183       {
 184         int_s16 * p = (int_s16 *) SCM_UVEC_BASE (uvec);
 185         int i = 0;
 186
 187         scm_puts ("#s16(", port);
 188         if (SCM_UVEC_LENGTH (uvec) > 0)
 189           {
 190             scm_intprint (*p, 10, port);
 191             p++;
 192             i++;
 193             for (; i < SCM_UVEC_LENGTH (uvec); i++)
 194               {
 195                 scm_puts (" ", port);
 196                 scm_intprint (*p, 10, port);
 197                 p++;
 198               }
 199           }
 200         scm_puts (")", port);
 201         break;
 202       }
 203
 204     case SCM_UVEC_U32:
 205       {
 206         int_u32 * p = (int_u32 *) SCM_UVEC_BASE (uvec);
 207         int i = 0;
 208
 209         scm_puts ("#u32(", port);
 210         if (SCM_UVEC_LENGTH (uvec) > 0)
 211           {
 212             scm_intprint (*p, 10, port);
 213             p++;
 214             i++;
 215             for (; i < SCM_UVEC_LENGTH (uvec); i++)
 216               {
 217                 scm_puts (" ", port);
 218                 scm_intprint (*p, 10, port);
 219                 p++;
 220               }
 221           }
 222         scm_puts (")", port);
 223         break;
 224       }
 225
 226     case SCM_UVEC_S32:
 227       {
 228         int_s32 * p = (int_s32 *) SCM_UVEC_BASE (uvec);
 229         int i = 0;
 230
 231         scm_puts ("#s32(", port);
 232         if (SCM_UVEC_LENGTH (uvec) > 0)
 233           {
 234             scm_intprint (*p, 10, port);
 235             p++;
 236             i++;
 237             for (; i < SCM_UVEC_LENGTH (uvec); i++)
 238               {
 239                 scm_puts (" ", port);
 240                 scm_intprint (*p, 10, port);
 241                 p++;
 242               }
 243           }
 244         scm_puts (")", port);
 245         break;
 246       }
 247
 248 #ifdef HAVE_LONG_LONG
 249     case SCM_UVEC_U64:
 250       {
 251         int_u64 * p = (int_u64 *) SCM_UVEC_BASE (uvec);
 252         int i = 0;
 253
 254         scm_puts ("#u64(", port);
 255         if (SCM_UVEC_LENGTH (uvec) > 0)
 256           {
 257             scm_intprint (*p, 10, port);
 258             p++;
 259             i++;
 260             for (; i < SCM_UVEC_LENGTH (uvec); i++)
 261               {
 262                 scm_puts (" ", port);
 263                 scm_intprint (*p, 10, port);
 264                 p++;
 265               }
 266           }
 267         scm_puts (")", port);
 268         break;
 269       }
 270
 271     case SCM_UVEC_S64:
 272       {
 273         int_s64 * p = (int_s64 *) SCM_UVEC_BASE (uvec);
 274         int i = 0;
 275
 276         scm_puts ("#s64(", port);
 277         if (SCM_UVEC_LENGTH (uvec) > 0)
 278           {
 279             scm_intprint (*p, 10, port);
 280             p++;
 281             i++;
 282             for (; i < SCM_UVEC_LENGTH (uvec); i++)
 283               {
 284                 scm_puts (" ", port);
 285                 scm_intprint (*p, 10, port);
 286                 p++;
 287               }
 288           }
 289         scm_puts (")", port);
 290         break;
 291       }
 292 #endif
 293
 294     case SCM_UVEC_F32:
 295       {
 296         float_f32 * p = (float_f32 *) SCM_UVEC_BASE (uvec);
 297         int i = 0;
 298
 299         scm_puts ("#f32(", port);
 300         if (SCM_UVEC_LENGTH (uvec) > 0)
 301           {
 302             scm_iprin1 (scm_make_real (*p), port, pstate);
 303             p++;
 304             i++;
 305             for (; i < SCM_UVEC_LENGTH (uvec); i++)
 306               {
 307                 scm_puts (" ", port);
 308                 scm_iprin1 (scm_make_real (*p), port, pstate);
 309                 p++;
 310               }
 311           }
 312         scm_puts (")", port);
 313         break;
 314       }
 315
 316     case SCM_UVEC_F64:
 317       {
 318         float_f64 * p = (float_f64 *) SCM_UVEC_BASE (uvec);
 319         int i = 0;
 320
 321         scm_puts ("#f64(", port);
 322         if (SCM_UVEC_LENGTH (uvec) > 0)
 323           {
 324             scm_iprin1 (scm_make_real (*p), port, pstate);
 325             p++;
 326             i++;
 327             for (; i < SCM_UVEC_LENGTH (uvec); i++)
 328               {
 329                 scm_puts (" ", port);
 330                 scm_iprin1 (scm_make_real (*p), port, pstate);
 331                 p++;
 332               }
 333           }
 334         scm_puts (")", port);
 335         break;
 336       }
 337
 338     default:
 339       abort ();                 /* Sanity check.  */
 340     }
 341   return 1;
 342 }
 343
 344
 345 /* Smob free hook for homogeneous numeric vectors. */
 346 static size_t
 347 uvec_free (SCM uvec)
 348 {
 349   scm_gc_free (SCM_UVEC_BASE (uvec),
 350                SCM_UVEC_LENGTH (uvec) * uvec_sizes[SCM_UVEC_TYPE (uvec)],
 351                "uvec");
 352   return 0;
 353 }
 354
 355
 356 /* ================================================================ */
 357 /* Utility procedures.                                              */
 358 /* ================================================================ */
 359
 360
 361 /* Create a new, uninitialized homogeneous numeric vector of type TYPE
 362    with space for LEN elements.  */
 363 static SCM
 364 make_uvec (const char * func_name, int type, int len)
 365 {
 366   void * p;
 367
 368   p = scm_gc_malloc (len * uvec_sizes[type], "uvec");
 369   SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, p);
 370 }
 371
 372
 373 /* ================================================================ */
 374 /* U8 procedures.                                                   */
 375 /* ================================================================ */
 376
 377
 378 SCM_DEFINE (scm_u8vector_p, "u8vector?", 1, 0, 0,
 379             (SCM obj),
 380             "Return @code{#t} if @var{obj} is a vector of type u8,\n"
 381             "@code{#f} otherwise.")
 382 #define FUNC_NAME s_scm_u8vector_p
 383 {
 384   return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
 385                    SCM_UVEC_TYPE (obj) == SCM_UVEC_U8);
 386 }
 387 #undef FUNC_NAME
 388
 389
 390 SCM_DEFINE (scm_make_u8vector, "make-u8vector", 1, 1, 0,
 391             (SCM n, SCM fill),
 392             "Create a newly allocated homogeneous numeric vector which can\n"
 393             "hold @var{len} elements.  If @var{fill} is given, it is used to\n"
 394             "initialize the elements, otherwise the contents of the vector\n"
 395             "is unspecified.")
 396 #define FUNC_NAME s_scm_make_u8vector
 397 {
 398   SCM uvec;
 399   int_u8 * p;
 400   int_u8 f;
 401   int count;
 402
 403   SCM_VALIDATE_INUM (1, n);
 404   count = SCM_INUM (n);
 405   uvec = make_uvec (FUNC_NAME, SCM_UVEC_U8, count);
 406   if (SCM_UNBNDP (fill))
 407     f = 0;
 408   else
 409     {
 410       unsigned int s = scm_num2uint (fill, 2, FUNC_NAME);
 411       f = s;
 412       if ((unsigned int) f != s)
 413         scm_out_of_range_pos (FUNC_NAME, fill, SCM_MAKINUM (2));
 414     }
 415   p = (int_u8 *) SCM_UVEC_BASE (uvec);
 416   while (count-- > 0)
 417     *p++ = f;
 418   return uvec;
 419 }
 420 #undef FUNC_NAME
 421
 422
 423 SCM_DEFINE (scm_u8vector, "u8vector", 0, 0, 1,
 424             (SCM l),
 425             "Create a newly allocated homogeneous numeric vector containing\n"
 426             "all argument values.")
 427 #define FUNC_NAME s_scm_u8vector
 428 {
 429   SCM_VALIDATE_REST_ARGUMENT (l);
 430   return scm_list_to_u8vector (l);
 431 }
 432 #undef FUNC_NAME
 433
 434
 435 SCM_DEFINE (scm_u8vector_length, "u8vector-length", 1, 0, 0,
 436             (SCM uvec),
 437             "Return the number of elements in the homogeneous numeric vector\n"
 438             "@var{uvec}.")
 439 #define FUNC_NAME s_scm_u8vector_length
 440 {
 441   SCM_VALIDATE_SMOB (1, uvec, uvec);
 442   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8)
 443     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
 444   return scm_int2num (SCM_UVEC_LENGTH (uvec));
 445 }
 446 #undef FUNC_NAME
 447
 448
 449 SCM_DEFINE (scm_u8vector_ref, "u8vector-ref", 2, 0, 0,
 450             (SCM uvec, SCM index),
 451             "Return the element at @var{index} in the homogeneous numeric\n"
 452             "vector @var{uvec}.")
 453 #define FUNC_NAME s_scm_u8vector_ref
 454 {
 455   int idx;
 456
 457   SCM_VALIDATE_SMOB (1, uvec, uvec);
 458   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8)
 459     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
 460
 461   idx = scm_num2int (index, 2, FUNC_NAME);
 462   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
 463     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
 464
 465   return scm_short2num (((int_u8 *) SCM_UVEC_BASE (uvec))[idx]);
 466 }
 467 #undef FUNC_NAME
 468
 469
 470 SCM_DEFINE (scm_u8vector_set_x, "u8vector-set!", 3, 0, 0,
 471             (SCM uvec, SCM index, SCM value),
 472             "Set the element at @var{index} in the homogeneous numeric\n"
 473             "vector @var{uvec} to @var{value}.  The return value is not\n"
 474             "specified.")
 475 #define FUNC_NAME s_scm_u8vector_ref
 476 {
 477   int idx;
 478   int_u8 f;
 479   unsigned int s;
 480
 481   SCM_VALIDATE_SMOB (1, uvec, uvec);
 482   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8)
 483     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
 484
 485   idx = scm_num2int (index, 2, FUNC_NAME);
 486   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
 487     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
 488
 489   s = scm_num2uint (value, 3, FUNC_NAME);
 490   f = s;
 491   if ((unsigned int) f != s)
 492     scm_out_of_range_pos (FUNC_NAME, value, SCM_MAKINUM (3));
 493
 494   ((int_u8 *) SCM_UVEC_BASE (uvec))[idx] = f;
 495   return SCM_UNSPECIFIED;
 496 }
 497 #undef FUNC_NAME
 498
 499
 500 SCM_DEFINE (scm_u8vector_to_list, "u8vector->list", 1, 0, 0,
 501             (SCM uvec),
 502             "Convert the homogeneous numeric vector @var{uvec} to a list.")
 503 #define FUNC_NAME s_scm_u8vector_to_list
 504 {
 505   int idx;
 506   int_u8 * p;
 507   SCM res = SCM_EOL;
 508
 509   SCM_VALIDATE_SMOB (1, uvec, uvec);
 510   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8)
 511     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
 512
 513   idx = SCM_UVEC_LENGTH (uvec);
 514   p = (int_u8 *) SCM_UVEC_BASE (uvec) + idx;
 515   while (idx-- > 0)
 516     {
 517       p--;
 518       res = scm_cons (SCM_MAKINUM (*p), res);
 519     }
 520   return res;
 521 }
 522 #undef FUNC_NAME
 523
 524
 525 SCM_DEFINE (scm_list_to_u8vector, "list->u8vector", 1, 0, 0,
 526             (SCM l),
 527             "Convert the list @var{l}, which must only contain unsigned\n"
 528             "8-bit values, to a numeric homogeneous vector.")
 529 #define FUNC_NAME s_scm_list_to_u8vector
 530 {
 531   SCM uvec;
 532   SCM tmp;
 533   int_u8 * p;
 534   int n;
 535   int arg_pos = 1;
 536
 537   SCM_VALIDATE_LIST_COPYLEN (1, l, n);
 538
 539   uvec = make_uvec (FUNC_NAME, SCM_UVEC_U8, n);
 540   p = (int_u8 *) SCM_UVEC_BASE (uvec);
 541   tmp = l;
 542   while (SCM_CONSP (tmp))
 543     {
 544       int_u8 f;
 545       unsigned int s = scm_num2uint (SCM_CAR (tmp), 2, FUNC_NAME);
 546       f = s;
 547       if ((unsigned int) f != s)
 548         scm_out_of_range (FUNC_NAME, SCM_CAR (tmp));
 549       *p++ = f;
 550       tmp = SCM_CDR (tmp);
 551       arg_pos++;
 552     }
 553   scm_remember_upto_here_1 (l);
 554   return uvec;
 555 }
 556 #undef FUNC_NAME
 557
 558
 559 /* ================================================================ */
 560 /* S8 procedures.                                                   */
 561 /* ================================================================ */
 562
 563
 564 SCM_DEFINE (scm_s8vector_p, "s8vector?", 1, 0, 0,
 565             (SCM obj),
 566             "Return @code{#t} if @var{obj} is a vector of type s8,\n"
 567             "@code{#f} otherwise.")
 568 #define FUNC_NAME s_scm_s8vector_p
 569 {
 570   return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
 571                    SCM_UVEC_TYPE (obj) == SCM_UVEC_S8);
 572 }
 573 #undef FUNC_NAME
 574
 575
 576 SCM_DEFINE (scm_make_s8vector, "make-s8vector", 1, 1, 0,
 577             (SCM n, SCM fill),
 578             "Create a newly allocated homogeneous numeric vector which can\n"
 579             "hold @var{len} elements.  If @var{fill} is given, it is used to\n"
 580             "initialize the elements, otherwise the contents of the vector\n"
 581             "is unspecified.")
 582 #define FUNC_NAME s_scm_make_s8vector
 583 {
 584   SCM uvec;
 585   int_s8 * p;
 586   int_s8 f;
 587   int count;
 588
 589   SCM_VALIDATE_INUM (1, n);
 590   count = SCM_INUM (n);
 591   uvec = make_uvec (FUNC_NAME, SCM_UVEC_S8, count);
 592   if (SCM_UNBNDP (fill))
 593     f = 0;
 594   else
 595     {
 596       signed int s = scm_num2int (fill, 2, FUNC_NAME);
 597       f = s;
 598       if ((signed int) f != s)
 599         scm_out_of_range_pos (FUNC_NAME, fill, SCM_MAKINUM (2));
 600     }
 601   p = (int_s8 *) SCM_UVEC_BASE (uvec);
 602   while (count-- > 0)
 603     *p++ = f;
 604   return uvec;
 605 }
 606 #undef FUNC_NAME
 607
 608
 609 SCM_DEFINE (scm_s8vector, "s8vector", 0, 0, 1,
 610             (SCM l),
 611             "Create a newly allocated homogeneous numeric vector containing\n"
 612             "all argument values.")
 613 #define FUNC_NAME s_scm_s8vector
 614 {
 615   SCM_VALIDATE_REST_ARGUMENT (l);
 616   return scm_list_to_s8vector (l);
 617 }
 618 #undef FUNC_NAME
 619
 620
 621 SCM_DEFINE (scm_s8vector_length, "s8vector-length", 1, 0, 0,
 622             (SCM uvec),
 623             "Return the number of elements in the homogeneous numeric vector\n"
 624             "@var{uvec}.")
 625 #define FUNC_NAME s_scm_s8vector_length
 626 {
 627   SCM_VALIDATE_SMOB (1, uvec, uvec);
 628   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8)
 629     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
 630   return scm_int2num (SCM_UVEC_LENGTH (uvec));
 631 }
 632 #undef FUNC_NAME
 633
 634
 635 SCM_DEFINE (scm_s8vector_ref, "s8vector-ref", 2, 0, 0,
 636             (SCM uvec, SCM index),
 637             "Return the element at @var{index} in the homogeneous numeric\n"
 638             "vector @var{uvec}.")
 639 #define FUNC_NAME s_scm_s8vector_ref
 640 {
 641   int idx;
 642
 643   SCM_VALIDATE_SMOB (1, uvec, uvec);
 644   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8)
 645     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
 646
 647   idx = scm_num2int (index, 2, FUNC_NAME);
 648   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
 649     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
 650
 651   return scm_short2num (((int_s8 *) SCM_UVEC_BASE (uvec))[idx]);
 652 }
 653 #undef FUNC_NAME
 654
 655
 656 SCM_DEFINE (scm_s8vector_set_x, "s8vector-set!", 3, 0, 0,
 657             (SCM uvec, SCM index, SCM value),
 658             "Set the element at @var{index} in the homogeneous numeric\n"
 659             "vector @var{uvec} to @var{value}.  The return value is not\n"
 660             "specified.")
 661 #define FUNC_NAME s_scm_s8vector_ref
 662 {
 663   int idx;
 664   int_s8 f;
 665   signed int s;
 666
 667   SCM_VALIDATE_SMOB (1, uvec, uvec);
 668   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8)
 669     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
 670
 671   idx = scm_num2int (index, 2, FUNC_NAME);
 672   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
 673     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
 674
 675   s = scm_num2int (value, 3, FUNC_NAME);
 676   f = s;
 677   if ((signed int) f != s)
 678     scm_out_of_range_pos (FUNC_NAME, value, SCM_MAKINUM (3));
 679
 680   ((int_s8 *) SCM_UVEC_BASE (uvec))[idx] = f;
 681   return SCM_UNSPECIFIED;
 682 }
 683 #undef FUNC_NAME
 684
 685
 686 SCM_DEFINE (scm_s8vector_to_list, "s8vector->list", 1, 0, 0,
 687             (SCM uvec),
 688             "Convert the homogeneous numeric vector @var{uvec} to a list.")
 689 #define FUNC_NAME s_scm_s8vector_to_list
 690 {
 691   int idx;
 692   int_s8 * p;
 693   SCM res = SCM_EOL;
 694
 695   SCM_VALIDATE_SMOB (1, uvec, uvec);
 696   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8)
 697     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
 698
 699   idx = SCM_UVEC_LENGTH (uvec);
 700   p = (int_s8 *) SCM_UVEC_BASE (uvec) + idx;
 701   while (idx-- > 0)
 702     {
 703       p--;
 704       res = scm_cons (SCM_MAKINUM (*p), res);
 705     }
 706   return res;
 707 }
 708 #undef FUNC_NAME
 709
 710
 711 SCM_DEFINE (scm_list_to_s8vector, "list->s8vector", 1, 0, 0,
 712             (SCM l),
 713             "Convert the list @var{l}, which must only contain signed\n"
 714             "8-bit values, to a numeric homogeneous vector.")
 715 #define FUNC_NAME s_scm_list_to_s8vector
 716 {
 717   SCM uvec;
 718   SCM tmp;
 719   int_s8 * p;
 720   int n;
 721   int arg_pos = 1;
 722
 723   SCM_VALIDATE_LIST_COPYLEN (1, l, n);
 724
 725   uvec = make_uvec (FUNC_NAME, SCM_UVEC_S8, n);
 726   p = (int_s8 *) SCM_UVEC_BASE (uvec);
 727   tmp = l;
 728   while (SCM_CONSP (tmp))
 729     {
 730       int_s8 f;
 731       signed int s;
 732
 733       s = scm_num2int (SCM_CAR (tmp), 2, FUNC_NAME);
 734       f = s;
 735       if ((signed int) f != s)
 736         scm_out_of_range (FUNC_NAME, SCM_CAR (tmp));
 737       *p++ = f;
 738       tmp = SCM_CDR (tmp);
 739       arg_pos++;
 740     }
 741   scm_remember_upto_here_1 (l);
 742   return uvec;
 743 }
 744 #undef FUNC_NAME
 745
 746
 747 /* ================================================================ */
 748 /* U16 procedures.                                                   */
 749 /* ================================================================ */
 750
 751
 752 SCM_DEFINE (scm_u16vector_p, "u16vector?", 1, 0, 0,
 753             (SCM obj),
 754             "Return @code{#t} if @var{obj} is a vector of type u16,\n"
 755             "@code{#f} otherwise.")
 756 #define FUNC_NAME s_scm_u16vector_p
 757 {
 758   return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
 759                    SCM_UVEC_TYPE (obj) == SCM_UVEC_U16);
 760 }
 761 #undef FUNC_NAME
 762
 763
 764 SCM_DEFINE (scm_make_u16vector, "make-u16vector", 1, 1, 0,
 765             (SCM n, SCM fill),
 766             "Create a newly allocated homogeneous numeric vector which can\n"
 767             "hold @var{len} elements.  If @var{fill} is given, it is used to\n"
 768             "initialize the elements, otherwise the contents of the vector\n"
 769             "is unspecified.")
 770 #define FUNC_NAME s_scm_make_u16vector
 771 {
 772   SCM uvec;
 773   int_u16 * p;
 774   int_u16 f;
 775   int count;
 776
 777   SCM_VALIDATE_INUM (1, n);
 778   count = SCM_INUM (n);
 779   uvec = make_uvec (FUNC_NAME, SCM_UVEC_U16, count);
 780   if (SCM_UNBNDP (fill))
 781     f = 0;
 782   else
 783     f = scm_num2ushort (fill, 2, FUNC_NAME);
 784   p = (int_u16 *) SCM_UVEC_BASE (uvec);
 785   while (count-- > 0)
 786     *p++ = f;
 787   return uvec;
 788 }
 789 #undef FUNC_NAME
 790
 791
 792 SCM_DEFINE (scm_u16vector, "u16vector", 0, 0, 1,
 793             (SCM l),
 794             "Create a newly allocated homogeneous numeric vector containing\n"
 795             "all argument values.")
 796 #define FUNC_NAME s_scm_u16vector
 797 {
 798   SCM_VALIDATE_REST_ARGUMENT (l);
 799   return scm_list_to_u16vector (l);
 800 }
 801 #undef FUNC_NAME
 802
 803
 804 SCM_DEFINE (scm_u16vector_length, "u16vector-length", 1, 0, 0,
 805             (SCM uvec),
 806             "Return the number of elements in the homogeneous numeric vector\n"
 807             "@var{uvec}.")
 808 #define FUNC_NAME s_scm_u16vector_length
 809 {
 810   SCM_VALIDATE_SMOB (1, uvec, uvec);
 811   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16)
 812     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
 813   return scm_int2num (SCM_UVEC_LENGTH (uvec));
 814 }
 815 #undef FUNC_NAME
 816
 817
 818 SCM_DEFINE (scm_u16vector_ref, "u16vector-ref", 2, 0, 0,
 819             (SCM uvec, SCM index),
 820             "Return the element at @var{index} in the homogeneous numeric\n"
 821             "vector @var{uvec}.")
 822 #define FUNC_NAME s_scm_u16vector_ref
 823 {
 824   int idx;
 825
 826   SCM_VALIDATE_SMOB (1, uvec, uvec);
 827   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16)
 828     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
 829
 830   idx = scm_num2int (index, 2, FUNC_NAME);
 831   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
 832     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
 833
 834   return scm_ushort2num (((int_u16 *) SCM_UVEC_BASE (uvec))[idx]);
 835 }
 836 #undef FUNC_NAME
 837
 838
 839 SCM_DEFINE (scm_u16vector_set_x, "u16vector-set!", 3, 0, 0,
 840             (SCM uvec, SCM index, SCM value),
 841             "Set the element at @var{index} in the homogeneous numeric\n"
 842             "vector @var{uvec} to @var{value}.  The return value is not\n"
 843             "specified.")
 844 #define FUNC_NAME s_scm_u16vector_ref
 845 {
 846   int idx;
 847   int_u16 f;
 848
 849   SCM_VALIDATE_SMOB (1, uvec, uvec);
 850   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16)
 851     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
 852
 853   idx = scm_num2int (index, 2, FUNC_NAME);
 854   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
 855     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
 856
 857   f = scm_num2ushort (value, 3, FUNC_NAME);
 858
 859   ((int_u16 *) SCM_UVEC_BASE (uvec))[idx] = f;
 860   return SCM_UNSPECIFIED;
 861 }
 862 #undef FUNC_NAME
 863
 864
 865 SCM_DEFINE (scm_u16vector_to_list, "u16vector->list", 1, 0, 0,
 866             (SCM uvec),
 867             "Convert the homogeneous numeric vector @var{uvec} to a list.")
 868 #define FUNC_NAME s_scm_u16vector_to_list
 869 {
 870   int idx;
 871   int_u16 * p;
 872   SCM res = SCM_EOL;
 873
 874   SCM_VALIDATE_SMOB (1, uvec, uvec);
 875   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16)
 876     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
 877
 878   idx = SCM_UVEC_LENGTH (uvec);
 879   p = (int_u16 *) SCM_UVEC_BASE (uvec) + idx;
 880   while (idx-- > 0)
 881     {
 882       p--;
 883       res = scm_cons (SCM_MAKINUM (*p), res);
 884     }
 885   return res;
 886 }
 887 #undef FUNC_NAME
 888
 889
 890 SCM_DEFINE (scm_list_to_u16vector, "list->u16vector", 1, 0, 0,
 891             (SCM l),
 892             "Convert the list @var{l}, which must only contain unsigned\n"
 893             "16-bit values, to a numeric homogeneous vector.")
 894 #define FUNC_NAME s_scm_list_to_u16vector
 895 {
 896   SCM uvec;
 897   int_u16 * p;
 898   int n;
 899   int arg_pos = 1;
 900
 901   SCM_VALIDATE_LIST_COPYLEN (1, l, n);
 902
 903   uvec = make_uvec (FUNC_NAME, SCM_UVEC_U16, n);
 904   p = (int_u16 *) SCM_UVEC_BASE (uvec);
 905   while (SCM_CONSP (l))
 906     {
 907       int_u16 f = scm_num2ushort (SCM_CAR (l), 2, FUNC_NAME);
 908       *p++ = f;
 909       l = SCM_CDR (l);
 910       arg_pos++;
 911     }
 912   return uvec;
 913 }
 914 #undef FUNC_NAME
 915
 916
 917 /* ================================================================ */
 918 /* S16 procedures.                                                   */
 919 /* ================================================================ */
 920
 921
 922 SCM_DEFINE (scm_s16vector_p, "s16vector?", 1, 0, 0,
 923             (SCM obj),
 924             "Return @code{#t} if @var{obj} is a vector of type s16,\n"
 925             "@code{#f} otherwise.")
 926 #define FUNC_NAME s_scm_s16vector_p
 927 {
 928   return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
 929                    SCM_UVEC_TYPE (obj) == SCM_UVEC_S16);
 930 }
 931 #undef FUNC_NAME
 932
 933
 934 SCM_DEFINE (scm_make_s16vector, "make-s16vector", 1, 1, 0,
 935             (SCM n, SCM fill),
 936             "Create a newly allocated homogeneous numeric vector which can\n"
 937             "hold @var{len} elements.  If @var{fill} is given, it is used to\n"
 938             "initialize the elements, otherwise the contents of the vector\n"
 939             "is unspecified.")
 940 #define FUNC_NAME s_scm_make_s16vector
 941 {
 942   SCM uvec;
 943   int_s16 * p;
 944   int_s16 f;
 945   int count;
 946
 947   SCM_VALIDATE_INUM (1, n);
 948   count = SCM_INUM (n);
 949   uvec = make_uvec (FUNC_NAME, SCM_UVEC_S16, count);
 950   if (SCM_UNBNDP (fill))
 951     f = 0;
 952   else
 953     f = scm_num2short (fill, 2, FUNC_NAME);
 954   p = (int_s16 *) SCM_UVEC_BASE (uvec);
 955   while (count-- > 0)
 956     *p++ = f;
 957   return uvec;
 958 }
 959 #undef FUNC_NAME
 960
 961
 962 SCM_DEFINE (scm_s16vector, "s16vector", 0, 0, 1,
 963             (SCM l),
 964             "Create a newly allocated homogeneous numeric vector containing\n"
 965             "all argument values.")
 966 #define FUNC_NAME s_scm_s16vector
 967 {
 968   SCM_VALIDATE_REST_ARGUMENT (l);
 969   return scm_list_to_s16vector (l);
 970 }
 971 #undef FUNC_NAME
 972
 973
 974 SCM_DEFINE (scm_s16vector_length, "s16vector-length", 1, 0, 0,
 975             (SCM uvec),
 976             "Return the number of elements in the homogeneous numeric vector\n"
 977             "@var{uvec}.")
 978 #define FUNC_NAME s_scm_s16vector_length
 979 {
 980   SCM_VALIDATE_SMOB (1, uvec, uvec);
 981   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16)
 982     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
 983   return scm_int2num (SCM_UVEC_LENGTH (uvec));
 984 }
 985 #undef FUNC_NAME
 986
 987
 988 SCM_DEFINE (scm_s16vector_ref, "s16vector-ref", 2, 0, 0,
 989             (SCM uvec, SCM index),
 990             "Return the element at @var{index} in the homogeneous numeric\n"
 991             "vector @var{uvec}.")
 992 #define FUNC_NAME s_scm_s16vector_ref
 993 {
 994   int idx;
 995
 996   SCM_VALIDATE_SMOB (1, uvec, uvec);
 997   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16)
 998     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
 999
1000   idx = scm_num2int (index, 2, FUNC_NAME);
1001   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
1002     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
1003
1004   return scm_short2num (((int_s16 *) SCM_UVEC_BASE (uvec))[idx]);
1005 }
1006 #undef FUNC_NAME
1007
1008
1009 SCM_DEFINE (scm_s16vector_set_x, "s16vector-set!", 3, 0, 0,
1010             (SCM uvec, SCM index, SCM value),
1011             "Set the element at @var{index} in the homogeneous numeric\n"
1012             "vector @var{uvec} to @var{value}.  The return value is not\n"
1013             "specified.")
1014 #define FUNC_NAME s_scm_s16vector_ref
1015 {
1016   int idx;
1017   int_s16 f;
1018
1019   SCM_VALIDATE_SMOB (1, uvec, uvec);
1020   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16)
1021     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1022
1023   idx = scm_num2int (index, 2, FUNC_NAME);
1024   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
1025     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
1026
1027   f = scm_num2short (value, 3, FUNC_NAME);
1028
1029   ((int_s16 *) SCM_UVEC_BASE (uvec))[idx] = f;
1030   return SCM_UNSPECIFIED;
1031 }
1032 #undef FUNC_NAME
1033
1034
1035 SCM_DEFINE (scm_s16vector_to_list, "s16vector->list", 1, 0, 0,
1036             (SCM uvec),
1037             "Convert the homogeneous numeric vector @var{uvec} to a list.")
1038 #define FUNC_NAME s_scm_s16vector_to_list
1039 {
1040   int idx;
1041   int_s16 * p;
1042   SCM res = SCM_EOL;
1043
1044   SCM_VALIDATE_SMOB (1, uvec, uvec);
1045   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16)
1046     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1047
1048   idx = SCM_UVEC_LENGTH (uvec);
1049   p = (int_s16 *) SCM_UVEC_BASE (uvec) + idx;
1050   while (idx-- > 0)
1051     {
1052       p--;
1053       res = scm_cons (SCM_MAKINUM (*p), res);
1054     }
1055   return res;
1056 }
1057 #undef FUNC_NAME
1058
1059
1060 SCM_DEFINE (scm_list_to_s16vector, "list->s16vector", 1, 0, 0,
1061             (SCM l),
1062             "Convert the list @var{l}, which must only contain signed\n"
1063             "16-bit values, to a numeric homogeneous vector.")
1064 #define FUNC_NAME s_scm_list_to_s16vector
1065 {
1066   SCM uvec;
1067   SCM tmp;
1068   int_s16 * p;
1069   int n;
1070   int arg_pos = 1;
1071
1072   SCM_VALIDATE_LIST_COPYLEN (1, l, n);
1073
1074   uvec = make_uvec (FUNC_NAME, SCM_UVEC_S16, n);
1075   p = (int_s16 *) SCM_UVEC_BASE (uvec);
1076   tmp = l;
1077   while (SCM_CONSP (tmp))
1078     {
1079       int_s16 f = scm_num2short (SCM_CAR (tmp), 2, FUNC_NAME);
1080       *p++ = f;
1081       tmp = SCM_CDR (tmp);
1082       arg_pos++;
1083     }
1084   scm_remember_upto_here_1 (l);
1085   return uvec;
1086 }
1087 #undef FUNC_NAME
1088
1089
1090 /* ================================================================ */
1091 /* U32 procedures.                                                   */
1092 /* ================================================================ */
1093
1094
1095 SCM_DEFINE (scm_u32vector_p, "u32vector?", 1, 0, 0,
1096             (SCM obj),
1097             "Return @code{#t} if @var{obj} is a vector of type u32,\n"
1098             "@code{#f} otherwise.")
1099 #define FUNC_NAME s_scm_u32vector_p
1100 {
1101   return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
1102                    SCM_UVEC_TYPE (obj) == SCM_UVEC_U32);
1103 }
1104 #undef FUNC_NAME
1105
1106
1107 SCM_DEFINE (scm_make_u32vector, "make-u32vector", 1, 1, 0,
1108             (SCM n, SCM fill),
1109             "Create a newly allocated homogeneous numeric vector which can\n"
1110             "hold @var{len} elements.  If @var{fill} is given, it is used to\n"
1111             "initialize the elements, otherwise the contents of the vector\n"
1112             "is unspecified.")
1113 #define FUNC_NAME s_scm_make_u32vector
1114 {
1115   SCM uvec;
1116   int_u32 * p;
1117   int_u32 f;
1118   int count;
1119
1120   SCM_VALIDATE_INUM (1, n);
1121   count = SCM_INUM (n);
1122   uvec = make_uvec (FUNC_NAME, SCM_UVEC_U32, count);
1123   if (SCM_UNBNDP (fill))
1124     f = 0;
1125   else
1126     f = scm_num2uint (fill, 2, FUNC_NAME);
1127   p = (int_u32 *) SCM_UVEC_BASE (uvec);
1128   while (count-- > 0)
1129     *p++ = f;
1130   return uvec;
1131 }
1132 #undef FUNC_NAME
1133
1134
1135 SCM_DEFINE (scm_u32vector, "u32vector", 0, 0, 1,
1136             (SCM l),
1137             "Create a newly allocated homogeneous numeric vector containing\n"
1138             "all argument values.")
1139 #define FUNC_NAME s_scm_u32vector
1140 {
1141   SCM_VALIDATE_REST_ARGUMENT (l);
1142   return scm_list_to_u32vector (l);
1143 }
1144 #undef FUNC_NAME
1145
1146
1147 SCM_DEFINE (scm_u32vector_length, "u32vector-length", 1, 0, 0,
1148             (SCM uvec),
1149             "Return the number of elements in the homogeneous numeric vector\n"
1150             "@var{uvec}.")
1151 #define FUNC_NAME s_scm_u32vector_length
1152 {
1153   SCM_VALIDATE_SMOB (1, uvec, uvec);
1154   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32)
1155     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1156   return scm_int2num (SCM_UVEC_LENGTH (uvec));
1157 }
1158 #undef FUNC_NAME
1159
1160
1161 SCM_DEFINE (scm_u32vector_ref, "u32vector-ref", 2, 0, 0,
1162             (SCM uvec, SCM index),
1163             "Return the element at @var{index} in the homogeneous numeric\n"
1164             "vector @var{uvec}.")
1165 #define FUNC_NAME s_scm_u32vector_ref
1166 {
1167   int idx;
1168
1169   SCM_VALIDATE_SMOB (1, uvec, uvec);
1170   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32)
1171     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1172
1173   idx = scm_num2int (index, 2, FUNC_NAME);
1174   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
1175     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
1176
1177   return scm_uint2num (((int_u32 *) SCM_UVEC_BASE (uvec))[idx]);
1178 }
1179 #undef FUNC_NAME
1180
1181
1182 SCM_DEFINE (scm_u32vector_set_x, "u32vector-set!", 3, 0, 0,
1183             (SCM uvec, SCM index, SCM value),
1184             "Set the element at @var{index} in the homogeneous numeric\n"
1185             "vector @var{uvec} to @var{value}.  The return value is not\n"
1186             "specified.")
1187 #define FUNC_NAME s_scm_u32vector_ref
1188 {
1189   int idx;
1190   int_u32 f;
1191
1192   SCM_VALIDATE_SMOB (1, uvec, uvec);
1193   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32)
1194     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1195
1196   idx = scm_num2int (index, 2, FUNC_NAME);
1197   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
1198     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
1199
1200   f = scm_num2uint (value, 3, FUNC_NAME);
1201
1202   ((int_u32 *) SCM_UVEC_BASE (uvec))[idx] = f;
1203   return SCM_UNSPECIFIED;
1204 }
1205 #undef FUNC_NAME
1206
1207
1208 SCM_DEFINE (scm_u32vector_to_list, "u32vector->list", 1, 0, 0,
1209             (SCM uvec),
1210             "Convert the homogeneous numeric vector @var{uvec} to a list.")
1211 #define FUNC_NAME s_scm_u32vector_to_list
1212 {
1213   int idx;
1214   int_u32 * p;
1215   SCM res = SCM_EOL;
1216
1217   SCM_VALIDATE_SMOB (1, uvec, uvec);
1218   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32)
1219     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1220
1221   idx = SCM_UVEC_LENGTH (uvec);
1222   p = (int_u32 *) SCM_UVEC_BASE (uvec) + idx;
1223   while (idx-- > 0)
1224     {
1225       p--;
1226       res = scm_cons (scm_uint2num (*p), res);
1227     }
1228   return res;
1229 }
1230 #undef FUNC_NAME
1231
1232
1233 SCM_DEFINE (scm_list_to_u32vector, "list->u32vector", 1, 0, 0,
1234             (SCM l),
1235             "Convert the list @var{l}, which must only contain unsigned\n"
1236             "32-bit values, to a numeric homogeneous vector.")
1237 #define FUNC_NAME s_scm_list_to_u32vector
1238 {
1239   SCM uvec;
1240   int_u32 * p;
1241   int n;
1242   int arg_pos = 1;
1243
1244   SCM_VALIDATE_LIST_COPYLEN (1, l, n);
1245
1246   uvec = make_uvec (FUNC_NAME, SCM_UVEC_U32, n);
1247   p = (int_u32 *) SCM_UVEC_BASE (uvec);
1248   while (SCM_CONSP (l))
1249     {
1250       int_u32 f;
1251       f = scm_num2uint (SCM_CAR (l), 2, FUNC_NAME);
1252       *p++ = f;
1253       l = SCM_CDR (l);
1254       arg_pos++;
1255     }
1256   return uvec;
1257 }
1258 #undef FUNC_NAME
1259
1260
1261 /* ================================================================ */
1262 /* S32 procedures.                                                   */
1263 /* ================================================================ */
1264
1265
1266 SCM_DEFINE (scm_s32vector_p, "s32vector?", 1, 0, 0,
1267             (SCM obj),
1268             "Return @code{#t} if @var{obj} is a vector of type s32,\n"
1269             "@code{#f} otherwise.")
1270 #define FUNC_NAME s_scm_s32vector_p
1271 {
1272   return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
1273                    SCM_UVEC_TYPE (obj) == SCM_UVEC_S32);
1274 }
1275 #undef FUNC_NAME
1276
1277
1278 SCM_DEFINE (scm_make_s32vector, "make-s32vector", 1, 1, 0,
1279             (SCM n, SCM fill),
1280             "Create a newly allocated homogeneous numeric vector which can\n"
1281             "hold @var{len} elements.  If @var{fill} is given, it is used to\n"
1282             "initialize the elements, otherwise the contents of the vector\n"
1283             "is unspecified.")
1284 #define FUNC_NAME s_scm_make_s32vector
1285 {
1286   SCM uvec;
1287   int_s32 * p;
1288   int_s32 f;
1289   int count;
1290
1291   SCM_VALIDATE_INUM (1, n);
1292   count = SCM_INUM (n);
1293   uvec = make_uvec (FUNC_NAME, SCM_UVEC_S32, count);
1294   if (SCM_UNBNDP (fill))
1295     f = 0;
1296   else
1297     f = scm_num2int (fill, 2, FUNC_NAME);
1298   p = (int_s32 *) SCM_UVEC_BASE (uvec);
1299   while (count-- > 0)
1300     *p++ = f;
1301   return uvec;
1302 }
1303 #undef FUNC_NAME
1304
1305
1306 SCM_DEFINE (scm_s32vector, "s32vector", 0, 0, 1,
1307             (SCM l),
1308             "Create a newly allocated homogeneous numeric vector containing\n"
1309             "all argument values.")
1310 #define FUNC_NAME s_scm_s32vector
1311 {
1312   SCM_VALIDATE_REST_ARGUMENT (l);
1313   return scm_list_to_s32vector (l);
1314 }
1315 #undef FUNC_NAME
1316
1317
1318 SCM_DEFINE (scm_s32vector_length, "s32vector-length", 1, 0, 0,
1319             (SCM uvec),
1320             "Return the number of elements in the homogeneous numeric vector\n"
1321             "@var{uvec}.")
1322 #define FUNC_NAME s_scm_s32vector_length
1323 {
1324   SCM_VALIDATE_SMOB (1, uvec, uvec);
1325   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32)
1326     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1327   return scm_int2num (SCM_UVEC_LENGTH (uvec));
1328 }
1329 #undef FUNC_NAME
1330
1331
1332 SCM_DEFINE (scm_s32vector_ref, "s32vector-ref", 2, 0, 0,
1333             (SCM uvec, SCM index),
1334             "Return the element at @var{index} in the homogeneous numeric\n"
1335             "vector @var{uvec}.")
1336 #define FUNC_NAME s_scm_s32vector_ref
1337 {
1338   int idx;
1339
1340   SCM_VALIDATE_SMOB (1, uvec, uvec);
1341   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32)
1342     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1343
1344   idx = scm_num2int (index, 2, FUNC_NAME);
1345   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
1346     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
1347
1348   return scm_int2num (((int_s32 *) SCM_UVEC_BASE (uvec))[idx]);
1349 }
1350 #undef FUNC_NAME
1351
1352
1353 SCM_DEFINE (scm_s32vector_set_x, "s32vector-set!", 3, 0, 0,
1354             (SCM uvec, SCM index, SCM value),
1355             "Set the element at @var{index} in the homogeneous numeric\n"
1356             "vector @var{uvec} to @var{value}.  The return value is not\n"
1357             "specified.")
1358 #define FUNC_NAME s_scm_s32vector_ref
1359 {
1360   int idx;
1361   int_s32 f;
1362
1363   SCM_VALIDATE_SMOB (1, uvec, uvec);
1364   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32)
1365     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1366
1367   idx = scm_num2int (index, 2, FUNC_NAME);
1368   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
1369     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
1370
1371   f = scm_num2int (value, 3, FUNC_NAME);
1372
1373   ((int_s32 *) SCM_UVEC_BASE (uvec))[idx] = f;
1374   return SCM_UNSPECIFIED;
1375 }
1376 #undef FUNC_NAME
1377
1378
1379 SCM_DEFINE (scm_s32vector_to_list, "s32vector->list", 1, 0, 0,
1380             (SCM uvec),
1381             "Convert the homogeneous numeric vector @var{uvec} to a list.")
1382 #define FUNC_NAME s_scm_s32vector_to_list
1383 {
1384   int idx;
1385   int_s32 * p;
1386   SCM res = SCM_EOL;
1387
1388   SCM_VALIDATE_SMOB (1, uvec, uvec);
1389   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32)
1390     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1391
1392   idx = SCM_UVEC_LENGTH (uvec);
1393   p = (int_s32 *) SCM_UVEC_BASE (uvec) + idx;
1394   while (idx-- > 0)
1395     {
1396       p--;
1397       res = scm_cons (scm_int2num (*p), res);
1398     }
1399   return res;
1400 }
1401 #undef FUNC_NAME
1402
1403
1404 SCM_DEFINE (scm_list_to_s32vector, "list->s32vector", 1, 0, 0,
1405             (SCM l),
1406             "Convert the list @var{l}, which must only contain signed\n"
1407             "32-bit values, to a numeric homogeneous vector.")
1408 #define FUNC_NAME s_scm_list_to_s32vector
1409 {
1410   SCM uvec;
1411   int_s32 * p;
1412   int n;
1413   int arg_pos = 1;
1414
1415   SCM_VALIDATE_LIST_COPYLEN (1, l, n);
1416
1417   uvec = make_uvec (FUNC_NAME, SCM_UVEC_S32, n);
1418   p = (int_s32 *) SCM_UVEC_BASE (uvec);
1419   while (SCM_CONSP (l))
1420     {
1421       int_s32 f;
1422       f = scm_num2int (SCM_CAR (l), 2, FUNC_NAME);
1423       *p++ = f;
1424       l = SCM_CDR (l);
1425       arg_pos++;
1426     }
1427   return uvec;
1428 }
1429 #undef FUNC_NAME
1430
1431
1432 #ifdef HAVE_LONG_LONG
1433
1434 /* ================================================================ */
1435 /* U64 procedures.                                                   */
1436 /* ================================================================ */
1437
1438
1439 SCM_DEFINE (scm_u64vector_p, "u64vector?", 1, 0, 0,
1440             (SCM obj),
1441             "Return @code{#t} if @var{obj} is a vector of type u64,\n"
1442             "@code{#f} otherwise.")
1443 #define FUNC_NAME s_scm_u64vector_p
1444 {
1445   return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
1446                    SCM_UVEC_TYPE (obj) == SCM_UVEC_U64);
1447 }
1448 #undef FUNC_NAME
1449
1450
1451 SCM_DEFINE (scm_make_u64vector, "make-u64vector", 1, 1, 0,
1452             (SCM n, SCM fill),
1453             "Create a newly allocated homogeneous numeric vector which can\n"
1454             "hold @var{len} elements.  If @var{fill} is given, it is used to\n"
1455             "initialize the elements, otherwise the contents of the vector\n"
1456             "is unspecified.")
1457 #define FUNC_NAME s_scm_make_u64vector
1458 {
1459   SCM uvec;
1460   int_u64 * p;
1461   int_u64 f;
1462   int count;
1463
1464   SCM_VALIDATE_INUM (1, n);
1465   count = SCM_INUM (n);
1466   uvec = make_uvec (FUNC_NAME, SCM_UVEC_U64, count);
1467   if (SCM_UNBNDP (fill))
1468     f = 0;
1469   else
1470     f = scm_num2ulong_long (fill, 2, FUNC_NAME);
1471   p = (int_u64 *) SCM_UVEC_BASE (uvec);
1472   while (count-- > 0)
1473     *p++ = f;
1474   return uvec;
1475 }
1476 #undef FUNC_NAME
1477
1478
1479 SCM_DEFINE (scm_u64vector, "u64vector", 0, 0, 1,
1480             (SCM l),
1481             "Create a newly allocated homogeneous numeric vector containing\n"
1482             "all argument values.")
1483 #define FUNC_NAME s_scm_u64vector
1484 {
1485   SCM_VALIDATE_REST_ARGUMENT (l);
1486   return scm_list_to_u64vector (l);
1487 }
1488 #undef FUNC_NAME
1489
1490
1491 SCM_DEFINE (scm_u64vector_length, "u64vector-length", 1, 0, 0,
1492             (SCM uvec),
1493             "Return the number of elements in the homogeneous numeric vector\n"
1494             "@var{uvec}.")
1495 #define FUNC_NAME s_scm_u64vector_length
1496 {
1497   SCM_VALIDATE_SMOB (1, uvec, uvec);
1498   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64)
1499     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1500   return scm_int2num (SCM_UVEC_LENGTH (uvec));
1501 }
1502 #undef FUNC_NAME
1503
1504
1505 SCM_DEFINE (scm_u64vector_ref, "u64vector-ref", 2, 0, 0,
1506             (SCM uvec, SCM index),
1507             "Return the element at @var{index} in the homogeneous numeric\n"
1508             "vector @var{uvec}.")
1509 #define FUNC_NAME s_scm_u64vector_ref
1510 {
1511   int idx;
1512
1513   SCM_VALIDATE_SMOB (1, uvec, uvec);
1514   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64)
1515     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1516
1517   idx = scm_num2int (index, 2, FUNC_NAME);
1518   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
1519     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
1520
1521   return scm_ulong_long2num (((int_u64 *) SCM_UVEC_BASE (uvec))[idx]);
1522 }
1523 #undef FUNC_NAME
1524
1525
1526 SCM_DEFINE (scm_u64vector_set_x, "u64vector-set!", 3, 0, 0,
1527             (SCM uvec, SCM index, SCM value),
1528             "Set the element at @var{index} in the homogeneous numeric\n"
1529             "vector @var{uvec} to @var{value}.  The return value is not\n"
1530             "specified.")
1531 #define FUNC_NAME s_scm_u64vector_ref
1532 {
1533   int idx;
1534   int_u64 f;
1535
1536   SCM_VALIDATE_SMOB (1, uvec, uvec);
1537   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64)
1538     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1539
1540   idx = scm_num2int (index, 2, FUNC_NAME);
1541   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
1542     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
1543
1544   f = scm_num2ulong_long (value, 3, FUNC_NAME);
1545
1546   ((int_u64 *) SCM_UVEC_BASE (uvec))[idx] = f;
1547   return SCM_UNSPECIFIED;
1548 }
1549 #undef FUNC_NAME
1550
1551
1552 SCM_DEFINE (scm_u64vector_to_list, "u64vector->list", 1, 0, 0,
1553             (SCM uvec),
1554             "Convert the homogeneous numeric vector @var{uvec} to a list.")
1555 #define FUNC_NAME s_scm_u64vector_to_list
1556 {
1557   int idx;
1558   int_u64 * p;
1559   SCM res = SCM_EOL;
1560
1561   SCM_VALIDATE_SMOB (1, uvec, uvec);
1562   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64)
1563     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1564
1565   idx = SCM_UVEC_LENGTH (uvec);
1566   p = (int_u64 *) SCM_UVEC_BASE (uvec) + idx;
1567   while (idx-- > 0)
1568     {
1569       p--;
1570       res = scm_cons (scm_long_long2num (*p), res);
1571     }
1572   return res;
1573 }
1574 #undef FUNC_NAME
1575
1576
1577 SCM_DEFINE (scm_list_to_u64vector, "list->u64vector", 1, 0, 0,
1578             (SCM l),
1579             "Convert the list @var{l}, which must only contain unsigned\n"
1580             "64-bit values, to a numeric homogeneous vector.")
1581 #define FUNC_NAME s_scm_list_to_u64vector
1582 {
1583   SCM uvec;
1584   int_u64 * p;
1585   int n;
1586   int arg_pos = 1;
1587
1588   SCM_VALIDATE_LIST_COPYLEN (1, l, n);
1589
1590   uvec = make_uvec (FUNC_NAME, SCM_UVEC_U64, n);
1591   p = (int_u64 *) SCM_UVEC_BASE (uvec);
1592   while (SCM_CONSP (l))
1593     {
1594       int_u64 f;
1595       f = scm_num2ulong_long (SCM_CAR (l), 2, FUNC_NAME);
1596       *p++ = f;
1597       l = SCM_CDR (l);
1598       arg_pos++;
1599     }
1600   return uvec;
1601 }
1602 #undef FUNC_NAME
1603
1604
1605 /* ================================================================ */
1606 /* S64 procedures.                                                   */
1607 /* ================================================================ */
1608
1609
1610 SCM_DEFINE (scm_s64vector_p, "s64vector?", 1, 0, 0,
1611             (SCM obj),
1612             "Return @code{#t} if @var{obj} is a vector of type s64,\n"
1613             "@code{#f} otherwise.")
1614 #define FUNC_NAME s_scm_s64vector_p
1615 {
1616   return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
1617                    SCM_UVEC_TYPE (obj) == SCM_UVEC_S64);
1618 }
1619 #undef FUNC_NAME
1620
1621
1622 SCM_DEFINE (scm_make_s64vector, "make-s64vector", 1, 1, 0,
1623             (SCM n, SCM fill),
1624             "Create a newly allocated homogeneous numeric vector which can\n"
1625             "hold @var{len} elements.  If @var{fill} is given, it is used to\n"
1626             "initialize the elements, otherwise the contents of the vector\n"
1627             "is unspecified.")
1628 #define FUNC_NAME s_scm_make_s64vector
1629 {
1630   SCM uvec;
1631   int_s64 * p;
1632   int_s64 f;
1633   int count;
1634
1635   SCM_VALIDATE_INUM (1, n);
1636   count = SCM_INUM (n);
1637   uvec = make_uvec (FUNC_NAME, SCM_UVEC_S64, count);
1638   if (SCM_UNBNDP (fill))
1639     f = 0;
1640   else
1641     f = scm_num2long_long (fill, 2, FUNC_NAME);
1642   p = (int_s64 *) SCM_UVEC_BASE (uvec);
1643   while (count-- > 0)
1644     *p++ = f;
1645   return uvec;
1646 }
1647 #undef FUNC_NAME
1648
1649
1650 SCM_DEFINE (scm_s64vector, "s64vector", 0, 0, 1,
1651             (SCM l),
1652             "Create a newly allocated homogeneous numeric vector containing\n"
1653             "all argument values.")
1654 #define FUNC_NAME s_scm_s64vector
1655 {
1656   SCM_VALIDATE_REST_ARGUMENT (l);
1657   return scm_list_to_s64vector (l);
1658 }
1659 #undef FUNC_NAME
1660
1661
1662 SCM_DEFINE (scm_s64vector_length, "s64vector-length", 1, 0, 0,
1663             (SCM uvec),
1664             "Return the number of elements in the homogeneous numeric vector\n"
1665             "@var{uvec}.")
1666 #define FUNC_NAME s_scm_s64vector_length
1667 {
1668   SCM_VALIDATE_SMOB (1, uvec, uvec);
1669   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64)
1670     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1671   return scm_int2num (SCM_UVEC_LENGTH (uvec));
1672 }
1673 #undef FUNC_NAME
1674
1675
1676 SCM_DEFINE (scm_s64vector_ref, "s64vector-ref", 2, 0, 0,
1677             (SCM uvec, SCM index),
1678             "Return the element at @var{index} in the homogeneous numeric\n"
1679             "vector @var{uvec}.")
1680 #define FUNC_NAME s_scm_s64vector_ref
1681 {
1682   int idx;
1683
1684   SCM_VALIDATE_SMOB (1, uvec, uvec);
1685   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64)
1686     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1687
1688   idx = scm_num2int (index, 2, FUNC_NAME);
1689   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
1690     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
1691
1692   return scm_long_long2num (((int_s64 *) SCM_UVEC_BASE (uvec))[idx]);
1693 }
1694 #undef FUNC_NAME
1695
1696
1697 SCM_DEFINE (scm_s64vector_set_x, "s64vector-set!", 3, 0, 0,
1698             (SCM uvec, SCM index, SCM value),
1699             "Set the element at @var{index} in the homogeneous numeric\n"
1700             "vector @var{uvec} to @var{value}.  The return value is not\n"
1701             "specified.")
1702 #define FUNC_NAME s_scm_s64vector_ref
1703 {
1704   int idx;
1705   int_s64 f;
1706
1707   SCM_VALIDATE_SMOB (1, uvec, uvec);
1708   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64)
1709     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1710
1711   idx = scm_num2int (index, 2, FUNC_NAME);
1712   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
1713     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
1714
1715   f = scm_num2long_long (value, 3, FUNC_NAME);
1716
1717   ((int_s64 *) SCM_UVEC_BASE (uvec))[idx] = f;
1718   return SCM_UNSPECIFIED;
1719 }
1720 #undef FUNC_NAME
1721
1722
1723 SCM_DEFINE (scm_s64vector_to_list, "s64vector->list", 1, 0, 0,
1724             (SCM uvec),
1725             "Convert the homogeneous numeric vector @var{uvec} to a list.")
1726 #define FUNC_NAME s_scm_s64vector_to_list
1727 {
1728   int idx;
1729   int_s64 * p;
1730   SCM res = SCM_EOL;
1731
1732   SCM_VALIDATE_SMOB (1, uvec, uvec);
1733   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64)
1734     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1735
1736   idx = SCM_UVEC_LENGTH (uvec);
1737   p = (int_s64 *) SCM_UVEC_BASE (uvec) + idx;
1738   while (idx-- > 0)
1739     {
1740       p--;
1741       res = scm_cons (scm_long_long2num (*p), res);
1742     }
1743   return res;
1744 }
1745 #undef FUNC_NAME
1746
1747
1748 SCM_DEFINE (scm_list_to_s64vector, "list->s64vector", 1, 0, 0,
1749             (SCM l),
1750             "Convert the list @var{l}, which must only contain signed\n"
1751             "64-bit values, to a numeric homogeneous vector.")
1752 #define FUNC_NAME s_scm_list_to_s64vector
1753 {
1754   SCM uvec;
1755   int_s64 * p;
1756   int n;
1757   int arg_pos = 1;
1758
1759   SCM_VALIDATE_LIST_COPYLEN (1, l, n);
1760
1761   uvec = make_uvec (FUNC_NAME, SCM_UVEC_S64, n);
1762   p = (int_s64 *) SCM_UVEC_BASE (uvec);
1763   while (SCM_CONSP (l))
1764     {
1765       int_s64 f;
1766       f = scm_num2long_long (SCM_CAR (l), 2, FUNC_NAME);
1767       *p++ = f;
1768       l = SCM_CDR (l);
1769       arg_pos++;
1770     }
1771   return uvec;
1772 }
1773 #undef FUNC_NAME
1774
1775 #endif /* HAVE_LONG_LONG */
1776
1777
1778 /* ================================================================ */
1779 /* F32 procedures.                                                   */
1780 /* ================================================================ */
1781
1782
1783 SCM_DEFINE (scm_f32vector_p, "f32vector?", 1, 0, 0,
1784             (SCM obj),
1785             "Return @code{#t} if @var{obj} is a vector of type f32,\n"
1786             "@code{#f} otherwise.")
1787 #define FUNC_NAME s_scm_f32vector_p
1788 {
1789   return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
1790                    SCM_UVEC_TYPE (obj) == SCM_UVEC_F32);
1791 }
1792 #undef FUNC_NAME
1793
1794
1795 SCM_DEFINE (scm_make_f32vector, "make-f32vector", 1, 1, 0,
1796             (SCM n, SCM fill),
1797             "Create a newly allocated homogeneous numeric vector which can\n"
1798             "hold @var{len} elements.  If @var{fill} is given, it is used to\n"
1799             "initialize the elements, otherwise the contents of the vector\n"
1800             "is unspecified.")
1801 #define FUNC_NAME s_scm_make_f32vector
1802 {
1803   SCM uvec;
1804   float_f32 * p;
1805   float_f32 f;
1806   int count;
1807
1808   SCM_VALIDATE_INUM (1, n);
1809   count = SCM_INUM (n);
1810   uvec = make_uvec (FUNC_NAME, SCM_UVEC_F32, count);
1811   if (SCM_UNBNDP (fill))
1812     f = 0;
1813   else
1814     {
1815       double d = scm_num2dbl (fill, FUNC_NAME);
1816       f = d;
1817 #if 0
1818       /* This test somehow fails for even the simplest inexact
1819          numbers, like 3.1.  Must find out how to check properly.  */
1820       if (f != d)
1821         scm_out_of_range_pos (FUNC_NAME, fill, SCM_MAKINUM (2));
1822 #endif /* 0 */
1823     }
1824   p = (float_f32 *) SCM_UVEC_BASE (uvec);
1825   while (count-- > 0)
1826     *p++ = f;
1827   return uvec;
1828 }
1829 #undef FUNC_NAME
1830
1831
1832 SCM_DEFINE (scm_f32vector, "f32vector", 0, 0, 1,
1833             (SCM l),
1834             "Create a newly allocated homogeneous numeric vector containing\n"
1835             "all argument values.")
1836 #define FUNC_NAME s_scm_f32vector
1837 {
1838   SCM_VALIDATE_REST_ARGUMENT (l);
1839   return scm_list_to_f32vector (l);
1840 }
1841 #undef FUNC_NAME
1842
1843
1844 SCM_DEFINE (scm_f32vector_length, "f32vector-length", 1, 0, 0,
1845             (SCM uvec),
1846             "Return the number of elements in the homogeneous numeric vector\n"
1847             "@var{uvec}.")
1848 #define FUNC_NAME s_scm_f32vector_length
1849 {
1850   SCM_VALIDATE_SMOB (1, uvec, uvec);
1851   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32)
1852     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1853   return scm_int2num (SCM_UVEC_LENGTH (uvec));
1854 }
1855 #undef FUNC_NAME
1856
1857
1858 SCM_DEFINE (scm_f32vector_ref, "f32vector-ref", 2, 0, 0,
1859             (SCM uvec, SCM index),
1860             "Return the element at @var{index} in the homogeneous numeric\n"
1861             "vector @var{uvec}.")
1862 #define FUNC_NAME s_scm_f32vector_ref
1863 {
1864   int idx;
1865
1866   SCM_VALIDATE_SMOB (1, uvec, uvec);
1867   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32)
1868     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1869
1870   idx = scm_num2int (index, 2, FUNC_NAME);
1871   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
1872     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
1873
1874   return scm_make_real (((float_f32 *) SCM_UVEC_BASE (uvec))[idx]);
1875 }
1876 #undef FUNC_NAME
1877
1878
1879 SCM_DEFINE (scm_f32vector_set_x, "f32vector-set!", 3, 0, 0,
1880             (SCM uvec, SCM index, SCM value),
1881             "Set the element at @var{index} in the homogeneous numeric\n"
1882             "vector @var{uvec} to @var{value}.  The return value is not\n"
1883             "specified.")
1884 #define FUNC_NAME s_scm_f32vector_ref
1885 {
1886   int idx;
1887   float_f32 f;
1888   double d;
1889
1890   SCM_VALIDATE_SMOB (1, uvec, uvec);
1891   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32)
1892     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1893
1894   idx = scm_num2int (index, 2, FUNC_NAME);
1895   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
1896     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
1897
1898   d = scm_num2dbl (value, FUNC_NAME);
1899   f = d;
1900 #if 0
1901       /* This test somehow fails for even the simplest inexact
1902          numbers, like 3.1.  Must find out how to check properly.  */
1903   if (f != d)
1904     scm_out_of_range_pos (FUNC_NAME, value, SCM_MAKINUM (3));
1905 #endif /* 0 */
1906
1907   ((float_f32 *) SCM_UVEC_BASE (uvec))[idx] = f;
1908   return SCM_UNSPECIFIED;
1909 }
1910 #undef FUNC_NAME
1911
1912
1913 SCM_DEFINE (scm_f32vector_to_list, "f32vector->list", 1, 0, 0,
1914             (SCM uvec),
1915             "Convert the homogeneous numeric vector @var{uvec} to a list.")
1916 #define FUNC_NAME s_scm_f32vector_to_list
1917 {
1918   int idx;
1919   float_f32 * p;
1920   SCM res = SCM_EOL;
1921
1922   SCM_VALIDATE_SMOB (1, uvec, uvec);
1923   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32)
1924     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1925
1926   idx = SCM_UVEC_LENGTH (uvec);
1927   p = (float_f32 *) SCM_UVEC_BASE (uvec) + idx;
1928   while (idx-- > 0)
1929     {
1930       p--;
1931       res = scm_cons (scm_make_real (*p), res);
1932     }
1933   return res;
1934 }
1935 #undef FUNC_NAME
1936
1937
1938 SCM_DEFINE (scm_list_to_f32vector, "list->f32vector", 1, 0, 0,
1939             (SCM l),
1940             "Convert the list @var{l}, which must only contain unsigned\n"
1941             "8-bit values, to a numeric homogeneous vector.")
1942 #define FUNC_NAME s_scm_list_to_f32vector
1943 {
1944   SCM uvec;
1945   float_f32 * p;
1946   int n;
1947   int arg_pos = 1;
1948
1949   SCM_VALIDATE_LIST_COPYLEN (1, l, n);
1950
1951   uvec = make_uvec (FUNC_NAME, SCM_UVEC_F32, n);
1952   p = (float_f32 *) SCM_UVEC_BASE (uvec);
1953   while (SCM_CONSP (l))
1954     {
1955       float_f32 f;
1956       double d;
1957       d = scm_num2dbl (SCM_CAR (l), FUNC_NAME);
1958       f = d;
1959 #if 0
1960       /* This test somehow fails for even the simplest inexact
1961          numbers, like 3.1.  Must find out how to check properly.  */
1962       if (d != f)
1963         scm_out_of_range_pos (FUNC_NAME, l, SCM_MAKINUM (1));
1964 #endif /* 0 */
1965       *p++ = f;
1966       l = SCM_CDR (l);
1967       arg_pos++;
1968     }
1969   return uvec;
1970 }
1971 #undef FUNC_NAME
1972
1973
1974 /* ================================================================ */
1975 /* F64 procedures.                                                   */
1976 /* ================================================================ */
1977
1978
1979 SCM_DEFINE (scm_f64vector_p, "f64vector?", 1, 0, 0,
1980             (SCM obj),
1981             "Return @code{#t} if @var{obj} is a vector of type f64,\n"
1982             "@code{#f} otherwise.")
1983 #define FUNC_NAME s_scm_f64vector_p
1984 {
1985   return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
1986                    SCM_UVEC_TYPE (obj) == SCM_UVEC_F64);
1987 }
1988 #undef FUNC_NAME
1989
1990
1991 SCM_DEFINE (scm_make_f64vector, "make-f64vector", 1, 1, 0,
1992             (SCM n, SCM fill),
1993             "Create a newly allocated homogeneous numeric vector which can\n"
1994             "hold @var{len} elements.  If @var{fill} is given, it is used to\n"
1995             "initialize the elements, otherwise the contents of the vector\n"
1996             "is unspecified.")
1997 #define FUNC_NAME s_scm_make_f64vector
1998 {
1999   SCM uvec;
2000   float_f64 * p;
2001   float_f64 f;
2002   int count;
2003
2004   SCM_VALIDATE_INUM (1, n);
2005   count = SCM_INUM (n);
2006   uvec = make_uvec (FUNC_NAME, SCM_UVEC_F64, count);
2007   if (SCM_UNBNDP (fill))
2008     f = 0;
2009   else
2010     f = scm_num2dbl (fill, FUNC_NAME);
2011   p = (float_f64 *) SCM_UVEC_BASE (uvec);
2012   while (count-- > 0)
2013     *p++ = f;
2014   return uvec;
2015 }
2016 #undef FUNC_NAME
2017
2018
2019 SCM_DEFINE (scm_f64vector, "f64vector", 0, 0, 1,
2020             (SCM l),
2021             "Create a newly allocated homogeneous numeric vector containing\n"
2022             "all argument values.")
2023 #define FUNC_NAME s_scm_f64vector
2024 {
2025   SCM_VALIDATE_REST_ARGUMENT (l);
2026   return scm_list_to_f64vector (l);
2027 }
2028 #undef FUNC_NAME
2029
2030
2031 SCM_DEFINE (scm_f64vector_length, "f64vector-length", 1, 0, 0,
2032             (SCM uvec),
2033             "Return the number of elements in the homogeneous numeric vector\n"
2034             "@var{uvec}.")
2035 #define FUNC_NAME s_scm_f64vector_length
2036 {
2037   SCM_VALIDATE_SMOB (1, uvec, uvec);
2038   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64)
2039     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
2040   return scm_int2num (SCM_UVEC_LENGTH (uvec));
2041 }
2042 #undef FUNC_NAME
2043
2044
2045 SCM_DEFINE (scm_f64vector_ref, "f64vector-ref", 2, 0, 0,
2046             (SCM uvec, SCM index),
2047             "Return the element at @var{index} in the homogeneous numeric\n"
2048             "vector @var{uvec}.")
2049 #define FUNC_NAME s_scm_f64vector_ref
2050 {
2051   int idx;
2052
2053   SCM_VALIDATE_SMOB (1, uvec, uvec);
2054   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64)
2055     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
2056
2057   idx = scm_num2int (index, 2, FUNC_NAME);
2058   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
2059     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
2060
2061   return scm_make_real (((float_f64 *) SCM_UVEC_BASE (uvec))[idx]);
2062 }
2063 #undef FUNC_NAME
2064
2065
2066 SCM_DEFINE (scm_f64vector_set_x, "f64vector-set!", 3, 0, 0,
2067             (SCM uvec, SCM index, SCM value),
2068             "Set the element at @var{index} in the homogeneous numeric\n"
2069             "vector @var{uvec} to @var{value}.  The return value is not\n"
2070             "specified.")
2071 #define FUNC_NAME s_scm_f64vector_ref
2072 {
2073   int idx;
2074   float_f64 f;
2075
2076   SCM_VALIDATE_SMOB (1, uvec, uvec);
2077   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64)
2078     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
2079
2080   idx = scm_num2int (index, 2, FUNC_NAME);
2081   if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
2082     scm_out_of_range_pos (FUNC_NAME, index, SCM_MAKINUM (2));
2083
2084   f = scm_num2dbl (value, FUNC_NAME);
2085
2086   ((float_f64 *) SCM_UVEC_BASE (uvec))[idx] = f;
2087   return SCM_UNSPECIFIED;
2088 }
2089 #undef FUNC_NAME
2090
2091
2092 SCM_DEFINE (scm_f64vector_to_list, "f64vector->list", 1, 0, 0,
2093             (SCM uvec),
2094             "Convert the homogeneous numeric vector @var{uvec} to a list.")
2095 #define FUNC_NAME s_scm_f64vector_to_list
2096 {
2097   int idx;
2098   float_f64 * p;
2099   SCM res = SCM_EOL;
2100
2101   SCM_VALIDATE_SMOB (1, uvec, uvec);
2102   if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64)
2103     scm_wrong_type_arg (FUNC_NAME, 1, uvec);
2104
2105   idx = SCM_UVEC_LENGTH (uvec);
2106   p = (float_f64 *) SCM_UVEC_BASE (uvec) + idx;
2107   while (idx-- > 0)
2108     {
2109       p--;
2110       res = scm_cons (scm_make_real (*p), res);
2111     }
2112   return res;
2113 }
2114 #undef FUNC_NAME
2115
2116
2117 SCM_DEFINE (scm_list_to_f64vector, "list->f64vector", 1, 0, 0,
2118             (SCM l),
2119             "Convert the list @var{l}, which must only contain signed\n"
2120             "8-bit values, to a numeric homogeneous vector.")
2121 #define FUNC_NAME s_scm_list_to_f64vector
2122 {
2123   SCM uvec;
2124   float_f64 * p;
2125   int n;
2126   int arg_pos = 1;
2127
2128   SCM_VALIDATE_LIST_COPYLEN (1, l, n);
2129
2130   uvec = make_uvec (FUNC_NAME, SCM_UVEC_F64, n);
2131   p = (float_f64 *) SCM_UVEC_BASE (uvec);
2132   while (SCM_CONSP (l))
2133     {
2134       float_f64 f = scm_num2dbl (SCM_CAR (l), FUNC_NAME);
2135       *p++ = f;
2136       l = SCM_CDR (l);
2137       arg_pos++;
2138     }
2139   return uvec;
2140 }
2141 #undef FUNC_NAME
2142
2143
2144 /* Create the smob type for homogeneous numeric vectors and install
2145    the primitives.  */
2146 void
2147 scm_init_srfi_4 (void)
2148 {
2149   scm_tc16_uvec = scm_make_smob_type ("uvec", 0);
2150   scm_set_smob_free (scm_tc16_uvec, uvec_free);
2151   scm_set_smob_print (scm_tc16_uvec, uvec_print);
2152 #include "srfi/srfi-4.x"
2153 }
2154
2155 /* End of srfi-4.c.  */