src/bytevector.c

   1 /* Guile-R6RS-Libs --- Implementation of R6RS standard libraries.
   2    Copyright (C) 2007  Ludovic Courtès <ludovic.courtes@laas.fr>
   3
   4    Guile-R6RS-Libs is free software; you can redistribute it and/or
   5    modify it under the terms of the GNU Lesser General Public
   6    License as published by the Free Software Foundation; either
   7    version 2.1 of the License, or (at your option) any later version.
   8
   9    Guile-R6RS-Libs is distributed in the hope that it will be useful,
  10    but WITHOUT ANY WARRANTY; without even the implied warranty of
  11    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12    Lesser General Public License for more details.
  13
  14    You should have received a copy of the GNU Lesser General Public
  15    License along with Guile-R6RS-Libs; if not, write to the Free Software
  16    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA  */
  17
  18 #include "config.h"
  19
  20 #include <libguile.h>
  21 #include <gmp.h>
  22
  23 #ifdef HAVE_BYTESWAP_H
  24 # include <byteswap.h>
  25 #endif
  26 #ifdef HAVE_LIMITS_H
  27 # include <limits.h>
  28 #else
  29 /* Assuming 32-bit longs.  */
  30 # define ULONG_MAX 4294967295UL
  31 #endif
  32
  33 #include <string.h>
  34
  35 \f
  36 /* Utilities.  */
  37
  38 #ifdef __GNUC__
  39 # define EXPECT  __builtin_expect
  40 #else
  41 # define EXPECT(_expr, _value) (_expr)
  42 #endif
  43
  44 #define EXPECT_TRUE(_expr)  EXPECT ((_expr), 1)
  45 #define EXPECT_FALSE(_expr) EXPECT ((_expr), 0)
  46
  47
  48 \f
  49 /* Bytevector type.  */
  50
  51 SCM_SMOB (scm_tc16_r6rs_bytevector, "r6rs-bytevector", 0);
  52
  53 #define SCM_VALIDATE_R6RS_BYTEVECTOR(_pos, _obj)                \
  54   SCM_VALIDATE_SMOB ((_pos), (_obj), r6rs_bytevector);
  55
  56
  57 static inline SCM
  58 make_bytevector (unsigned len, signed char *contents)
  59 {
  60   SCM_RETURN_NEWSMOB2 (scm_tc16_r6rs_bytevector, len, contents);
  61 }
  62
  63 #define SCM_R6RS_BYTEVECTOR_LENGTH(_bv)         \
  64   ((unsigned) SCM_SMOB_DATA (_bv))
  65 #define SCM_R6RS_BYTEVECTOR_CONTENTS(_bv)       \
  66   ((signed char *) SCM_SMOB_DATA_2 (_bv))
  67
  68 #define SCM_GC_BYTEVECTOR "r6rs-bytevector"
  69
  70 SCM_SMOB_FREE (scm_tc16_r6rs_bytevector, free_bytevector, bv)
  71 {
  72   unsigned c_len;
  73   signed char *c_bv;
  74
  75   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
  76   c_bv = SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
  77
  78   scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
  79
  80   return 0;
  81 }
  82
  83
  84 \f
  85 /* General operations.  */
  86
  87 SCM_SYMBOL (scm_sym_big, "big");
  88 SCM_SYMBOL (scm_sym_little, "little");
  89
  90 /* Host endianness (a symbol).  */
  91 static SCM native_endianness = SCM_UNSPECIFIED;
  92
  93 /* Byte-swapping.  */
  94 #ifdef HAVE_BYTESWAP_H
  95 # define non_native_byteswap_16 bswap_16
  96 # define non_native_byteswap_32 bswap_32
  97 #else
  98 # error "No byteswap function available."
  99 #endif
 100
 101
 102 SCM_DEFINE (scm_r6rs_native_endianness, "native-endianness", 0, 0, 0,
 103             (void),
 104             "Return a symbol denoting the machine's native endianness.")
 105 #define FUNC_NAME s_scm_r6rs_native_endianness
 106 {
 107   return native_endianness;
 108 }
 109 #undef FUNC_NAME
 110
 111 SCM_DEFINE (scm_r6rs_bytevector_p, "bytevector?", 1, 0, 0,
 112             (SCM obj),
 113             "Return true if @var{obj} is a bytevector.")
 114 #define FUNC_NAME s_scm_r6rs_bytevector_p
 115 {
 116   return (scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_r6rs_bytevector,
 117                                              obj)));
 118 }
 119 #undef FUNC_NAME
 120
 121 SCM_DEFINE (scm_r6rs_make_bytevector, "make-bytevector", 1, 1, 0,
 122             (SCM len, SCM fill),
 123             "Return a newly allocated bytevector of @var{len} bytes, "
 124             "optionally filled with @var{fill}.")
 125 #define FUNC_NAME s_scm_r6rs_make_bytevector
 126 {
 127   unsigned c_len;
 128   signed char c_fill;
 129   signed char *contents;
 130
 131   SCM_VALIDATE_UINT_COPY (1, len, c_len);
 132   if (fill != SCM_UNDEFINED)
 133     {
 134       int value;
 135
 136       value = scm_to_int (fill);
 137       if (EXPECT_FALSE ((value < -128) || (value > 255)))
 138         scm_out_of_range (FUNC_NAME, fill);
 139       c_fill = (signed char) value;
 140     }
 141
 142   contents = (signed char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
 143   if (fill != SCM_UNDEFINED)
 144     {
 145       unsigned i;
 146
 147       for (i = 0; i < c_len; i++)
 148         contents[i] = c_fill;
 149     }
 150
 151   return (make_bytevector (c_len, contents));
 152 }
 153 #undef FUNC_NAME
 154
 155 SCM_DEFINE (scm_r6rs_bytevector_length, "bytevector-length", 1, 0, 0,
 156             (SCM bv),
 157             "Return the length (in bytes) of @var{bv}.")
 158 #define FUNC_NAME s_scm_r6rs_bytevector_length
 159 {
 160   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);
 161
 162   return (scm_from_uint (SCM_R6RS_BYTEVECTOR_LENGTH (bv)));
 163 }
 164 #undef FUNC_NAME
 165
 166 SCM_DEFINE (scm_r6rs_bytevector_eq_p, "bytevector=?", 2, 0, 0,
 167             (SCM bv1, SCM bv2),
 168             "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
 169             "have the same length and contents.")
 170 #define FUNC_NAME s_scm_r6rs_bytevector_eq_p
 171 {
 172   SCM result = SCM_BOOL_F;
 173   unsigned c_len1, c_len2;
 174
 175   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv1);
 176   SCM_VALIDATE_R6RS_BYTEVECTOR (2, bv2);
 177
 178   c_len1 = SCM_R6RS_BYTEVECTOR_LENGTH (bv1);
 179   c_len2 = SCM_R6RS_BYTEVECTOR_LENGTH (bv2);
 180
 181   if (c_len1 == c_len2)
 182     {
 183       signed char *c_bv1, *c_bv2;
 184
 185       c_bv1 = SCM_R6RS_BYTEVECTOR_CONTENTS (bv1);
 186       c_bv2 = SCM_R6RS_BYTEVECTOR_CONTENTS (bv2);
 187
 188       result = scm_from_bool (!memcmp (c_bv1, c_bv2, c_len1));
 189     }
 190
 191   return result;
 192 }
 193 #undef FUNC_NAME
 194
 195 SCM_DEFINE (scm_r6rs_bytevector_fill_x, "bytevector-fill!", 2, 0, 0,
 196             (SCM bv, SCM fill),
 197             "Fill bytevector @var{bv} with @var{fill}, a byte.")
 198 #define FUNC_NAME s_scm_r6rs_bytevector_fill_x
 199 {
 200   unsigned c_len, i;
 201   signed char *c_bv, c_fill;
 202
 203   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);
 204   c_fill = scm_to_int8 (fill);
 205
 206   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
 207   c_bv = SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
 208
 209   for (i = 0; i < c_len; i++)
 210     c_bv[i] = c_fill;
 211
 212   return SCM_UNSPECIFIED;
 213 }
 214 #undef FUNC_NAME
 215
 216 SCM_DEFINE (scm_r6rs_bytevector_copy_x, "bytevector-copy!", 5, 0, 0,
 217             (SCM source, SCM source_start, SCM target, SCM target_start,
 218              SCM len),
 219             "Copy @var{len} bytes from @var{source} into @var{target}, "
 220             "starting reading from @var{source_start} (a positive index "
 221             "within @var{source}) and start writing at "
 222             "@var{target_start}.")
 223 #define FUNC_NAME s_scm_r6rs_bytevector_copy_x
 224 {
 225   unsigned c_len, c_source_len, c_target_len;
 226   unsigned c_source_start, c_target_start;
 227   signed char *c_source, *c_target;
 228
 229   SCM_VALIDATE_R6RS_BYTEVECTOR (1, source);
 230   SCM_VALIDATE_R6RS_BYTEVECTOR (3, target);
 231
 232   c_len = scm_to_uint (len);
 233   c_source_start = scm_to_uint (source_start);
 234   c_target_start = scm_to_uint (target_start);
 235
 236   c_source = SCM_R6RS_BYTEVECTOR_CONTENTS (source);
 237   c_target = SCM_R6RS_BYTEVECTOR_CONTENTS (target);
 238   c_source_len = SCM_R6RS_BYTEVECTOR_LENGTH (source);
 239   c_target_len = SCM_R6RS_BYTEVECTOR_LENGTH (target);
 240
 241   if (EXPECT_FALSE (c_source_start + c_len > c_source_len))
 242     scm_out_of_range (FUNC_NAME, source_start);
 243   if (EXPECT_FALSE (c_target_start + c_len > c_target_len))
 244     scm_out_of_range (FUNC_NAME, target_start);
 245
 246   memcpy (c_target + c_target_start,
 247           c_source + c_source_start,
 248           c_len);
 249
 250   return SCM_UNSPECIFIED;
 251 }
 252 #undef FUNC_NAME
 253
 254 SCM_DEFINE (scm_r6rs_bytevector_copy, "bytevector-copy", 1, 0, 0,
 255             (SCM bv),
 256             "Return a newly allocated copy of @var{bv}.")
 257 #define FUNC_NAME s_scm_r6rs_bytevector_copy
 258 {
 259   unsigned c_len;
 260   signed char *c_bv, *c_copy;
 261
 262   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);
 263
 264   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
 265   c_bv = SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
 266
 267   c_copy = scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
 268   memcpy (c_copy, c_bv, c_len);
 269
 270   return (make_bytevector (c_len, c_copy));
 271 }
 272 #undef FUNC_NAME
 273
 274 \f
 275 /* Operations on bytes and octets.  */
 276
 277 #define OCTET_ACCESSOR_PROLOGUE(_sign)                          \
 278   unsigned c_len, c_index;                                      \
 279   _sign char *c_bv;                                             \
 280                                                                 \
 281   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);                         \
 282   c_index = scm_to_uint (index);                                \
 283                                                                 \
 284   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);                      \
 285   c_bv = (_sign char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);      \
 286                                                                 \
 287   if (EXPECT_FALSE (c_index >= c_len))                          \
 288     scm_out_of_range (FUNC_NAME, index);
 289
 290
 291 SCM_DEFINE (scm_r6rs_bytevector_u8_ref, "bytevector-u8-ref", 2, 0, 0,
 292             (SCM bv, SCM index),
 293             "Return the octet located at @var{index} in @var{bv}.")
 294 #define FUNC_NAME s_scm_r6rs_bytevector_u8_ref
 295 {
 296   OCTET_ACCESSOR_PROLOGUE (unsigned);
 297
 298   return (SCM_I_MAKINUM (c_bv[c_index]));
 299 }
 300 #undef FUNC_NAME
 301
 302 SCM_DEFINE (scm_r6rs_bytevector_s8_ref, "bytevector-s8-ref", 2, 0, 0,
 303             (SCM bv, SCM index),
 304             "Return the byte located at @var{index} in @var{bv}.")
 305 #define FUNC_NAME s_scm_r6rs_bytevector_u8_ref
 306 {
 307   OCTET_ACCESSOR_PROLOGUE (signed);
 308
 309   return (SCM_I_MAKINUM (c_bv[c_index]));
 310 }
 311 #undef FUNC_NAME
 312
 313 SCM_DEFINE (scm_r6rs_bytevector_u8_set_x, "bytevector-u8-set!", 3, 0, 0,
 314             (SCM bv, SCM index, SCM value),
 315             "Return the octet located at @var{index} in @var{bv}.")
 316 #define FUNC_NAME s_scm_r6rs_bytevector_u8_set_x
 317 {
 318   unsigned char c_value;
 319
 320   OCTET_ACCESSOR_PROLOGUE (unsigned);
 321   c_value = scm_to_uint8 (value);
 322
 323   c_bv[c_index] = c_value;
 324
 325   return SCM_UNSPECIFIED;
 326 }
 327 #undef FUNC_NAME
 328
 329 SCM_DEFINE (scm_r6rs_bytevector_s8_set_x, "bytevector-s8-set!", 3, 0, 0,
 330             (SCM bv, SCM index, SCM value),
 331             "Return the octet located at @var{index} in @var{bv}.")
 332 #define FUNC_NAME s_scm_r6rs_bytevector_u8_set_x
 333 {
 334   unsigned char c_value;
 335
 336   OCTET_ACCESSOR_PROLOGUE (signed);
 337   c_value = scm_to_int8 (value);
 338
 339   c_bv[c_index] = c_value;
 340
 341   return SCM_UNSPECIFIED;
 342 }
 343 #undef FUNC_NAME
 344
 345 #undef OCTET_ACCESSOR_PROLOGUE
 346
 347
 348 SCM_DEFINE (scm_r6rs_bytevector_to_u8_list, "bytevector->u8-list", 1, 0, 0,
 349             (SCM bv),
 350             "Return a newly allocated list of octets containing the "
 351             "contents of @var{bv}.")
 352 #define FUNC_NAME s_scm_r6rs_bytevector_to_u8_list
 353 {
 354   SCM lst, pair;
 355   unsigned c_len, i;
 356   unsigned char *c_bv;
 357
 358   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);
 359
 360   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
 361   c_bv = (unsigned char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
 362
 363   lst = scm_make_list (scm_from_uint (c_len), SCM_UNSPECIFIED);
 364   for (i = 0, pair = lst;
 365        i < c_len;
 366        i++, pair = SCM_CDR (pair))
 367     {
 368       SCM_SETCAR (pair, SCM_I_MAKINUM (c_bv[i]));
 369     }
 370
 371   return lst;
 372 }
 373 #undef FUNC_NAME
 374
 375 SCM_DEFINE (scm_r6rs_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0,
 376             (SCM lst),
 377             "Turn @var{lst}, a list of octets, into a bytevector.")
 378 #define FUNC_NAME s_scm_r6rs_u8_list_to_bytevector
 379 {
 380   SCM item;
 381   unsigned c_len, i;
 382   unsigned char *c_bv;
 383
 384   SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len);
 385
 386   c_bv = scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
 387   for (i = 0; i < c_len; lst = SCM_CDR (lst), i++)
 388     {
 389       item = SCM_CAR (lst);
 390
 391       if (EXPECT_TRUE (SCM_I_INUMP (item)))
 392         {
 393           long c_item;
 394
 395           c_item = SCM_I_INUM (item);
 396           if (EXPECT_TRUE ((c_item >= 0) && (c_item < 256)))
 397             c_bv[i] = (unsigned char) c_item;
 398           else
 399             goto type_error;
 400         }
 401       else
 402         goto type_error;
 403     }
 404
 405   return (make_bytevector (c_len, (signed char *) c_bv));
 406
 407  type_error:
 408   scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
 409   scm_wrong_type_arg (FUNC_NAME, 1, item);
 410
 411   return SCM_BOOL_F;
 412 }
 413 #undef FUNC_NAME
 414
 415 /* Compute the two's complement of VALUE (a positive integer) on SIZE octets
 416    using (2^(SIZE * 8) - VALUE).  */
 417 static inline void
 418 twos_complement (mpz_t value, size_t size)
 419 {
 420   unsigned long bit_count;
 421
 422   /* We expect BIT_COUNT to fit in a unsigned long thanks to the range
 423      checking on SIZE performed earlier.  */
 424   bit_count = (unsigned long) size << 3UL;
 425
 426   if (EXPECT_TRUE (bit_count < sizeof (unsigned long)))
 427     mpz_ui_sub (value, 1UL << bit_count, value);
 428   else
 429     {
 430       mpz_t max;
 431
 432       mpz_init (max);
 433       mpz_ui_pow_ui (max, 2, bit_count);
 434       mpz_sub (value, max, value);
 435       mpz_clear (max);
 436     }
 437 }
 438
 439 static inline SCM
 440 bytevector_large_ref (const char *c_bv, size_t c_size, int signed_p,
 441                       SCM endianness)
 442 {
 443   SCM result;
 444   mpz_t c_mpz;
 445   int c_endianness, negative_p = 0;
 446
 447   if (signed_p)
 448     {
 449       if (scm_is_eq (endianness, scm_sym_big))
 450         negative_p = c_bv[0] & 0x80;
 451       else
 452         negative_p = c_bv[c_size - 1] & 0x80;
 453     }
 454
 455   c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1;
 456
 457   mpz_init (c_mpz);
 458   mpz_import (c_mpz, 1 /* 1 word */, 1 /* word order doesn't matter */,
 459               c_size /* word is C_SIZE-byte long */,
 460               c_endianness,
 461               0 /* nails */, c_bv);
 462
 463   if (signed_p && negative_p)
 464     {
 465       twos_complement (c_mpz, c_size);
 466       mpz_neg (c_mpz, c_mpz);
 467     }
 468
 469   result = scm_from_mpz (c_mpz);
 470   mpz_clear (c_mpz);  /* FIXME: Needed? */
 471
 472   return result;
 473 }
 474
 475 static inline int
 476 bytevector_large_set (char *c_bv, size_t c_size, int signed_p,
 477                       SCM value, SCM endianness)
 478 {
 479   size_t word_count, value_size;
 480   mpz_t c_mpz;
 481   int c_endianness, err = 0;
 482
 483   c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1;
 484
 485   mpz_init (c_mpz);
 486   scm_to_mpz (value, c_mpz);
 487   if (mpz_sgn (c_mpz) < 0)
 488     {
 489       if (EXPECT_TRUE (signed_p))
 490         {
 491           mpz_neg (c_mpz, c_mpz);
 492           twos_complement (c_mpz, c_size);
 493         }
 494       else
 495         {
 496           err = -1;
 497           goto finish;
 498         }
 499     }
 500
 501   value_size = (mpz_sizeinbase (c_mpz, 2) + (8 * c_size)) / (8 * c_size);
 502   if (EXPECT_FALSE (value_size > c_size))
 503     {
 504       err = -2;
 505       goto finish;
 506     }
 507
 508   mpz_export (c_bv, &word_count, 1 /* word order doesn't matter */,
 509               c_size, c_endianness,
 510               0 /* nails */, c_mpz);
 511   if (EXPECT_FALSE (word_count != 1))
 512     abort ();
 513
 514  finish:
 515   mpz_clear (c_mpz);
 516
 517   return err;
 518 }
 519
 520 #define INTEGER_ACCESSOR_PROLOGUE(_sign)                                \
 521   unsigned c_len, c_index, c_size;                                      \
 522   _sign char *c_bv;                                                     \
 523                                                                         \
 524   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);                                 \
 525   c_index = scm_to_uint (index);                                        \
 526   c_size = scm_to_uint (size);                                          \
 527                                                                         \
 528   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);                              \
 529   c_bv = (_sign char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);              \
 530                                                                         \
 531   /* C_SIZE must have its 3 higher bits set to zero so that             \
 532      multiplying it by 8 yields a number that fits in an                \
 533      unsigned long.  */                                                 \
 534   if (EXPECT_FALSE ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L))))    \
 535     scm_out_of_range (FUNC_NAME, size);                                 \
 536   if (EXPECT_FALSE (c_index + c_size > c_len))                          \
 537     scm_out_of_range (FUNC_NAME, index);
 538
 539
 540 #define BV_SIGNED_signed 1
 541 #define BV_SIGNED_unsigned 0
 542 #define INT16_T_signed   scm_t_int16
 543 #define INT16_T_unsigned scm_t_uint16
 544
 545 #define is_signed_int8(_x)    (((_x) >= -128L) && ((_x) <= 127L))
 546 #define is_unsigned_int8(_x)  ((_x) <= 255UL)
 547 #define is_signed_int16(_x)   (((_x) >= -32768L) && ((_x) <= 32767L))
 548 #define is_unsigned_int16(_x) ((_x) <= 65535UL)
 549
 550 /* Template of an integer reference function.  */
 551 #define INTEGER_REF(_sign)                                              \
 552   SCM result;                                                           \
 553                                                                         \
 554   if (c_size < 3)                                                       \
 555     {                                                                   \
 556       int swap;                                                         \
 557       _sign int value;                                                  \
 558                                                                         \
 559       swap = !scm_is_eq (endianness, native_endianness);                \
 560       switch (c_size)                                                   \
 561         {                                                               \
 562         case 1:                                                         \
 563           value = *(_sign char *) c_bv;                                 \
 564           break;                                                        \
 565         case 2:                                                         \
 566           value = *(INT16_T_ ## _sign *) c_bv;                          \
 567           if (swap)                                                     \
 568             value = (INT16_T_ ## _sign) non_native_byteswap_16 (value); \
 569           break;                                                        \
 570         default:                                                        \
 571           abort ();                                                     \
 572         }                                                               \
 573                                                                         \
 574       result = SCM_I_MAKINUM ((_sign int) value);                       \
 575     }                                                                   \
 576   else                                                                  \
 577     result = bytevector_large_ref ((char *) c_bv,                       \
 578                                    c_size,                              \
 579                                    BV_SIGNED_ ## _sign, endianness);    \
 580                                                                         \
 581   return result;
 582
 583 static inline SCM
 584 bytevector_signed_ref (const char *c_bv, size_t c_size, SCM endianness)
 585 {
 586   INTEGER_REF (signed);
 587 }
 588
 589 static inline SCM
 590 bytevector_unsigned_ref (const char *c_bv, size_t c_size, SCM endianness)
 591 {
 592   INTEGER_REF (unsigned);
 593 }
 594
 595
 596 /* Template of an integer assignment function.  */
 597 #define INTEGER_SET(_sign)                                              \
 598   if (c_size < 3)                                                       \
 599     {                                                                   \
 600       _sign int c_value;                                                \
 601                                                                         \
 602       if (EXPECT_FALSE (!SCM_I_INUMP (value)))                          \
 603         goto range_error;                                               \
 604                                                                         \
 605       c_value = SCM_I_INUM (value);                                     \
 606       switch (c_size)                                                   \
 607         {                                                               \
 608         case 1:                                                         \
 609           if (EXPECT_TRUE (is_ ## _sign ## _int8 (c_value)))            \
 610             * (_sign char *) c_bv = (_sign char) c_value;               \
 611           else                                                          \
 612             goto range_error;                                           \
 613           break;                                                        \
 614                                                                         \
 615         case 2:                                                         \
 616           if (EXPECT_TRUE (is_ ## _sign ## _int16 (c_value)))           \
 617             {                                                           \
 618               int swap;                                                 \
 619               INT16_T_ ## _sign  c_value16;                             \
 620                                                                         \
 621               swap = !scm_is_eq (endianness, native_endianness);        \
 622                                                                         \
 623               c_value16 =                                               \
 624                 swap ? non_native_byteswap_16 (c_value) : c_value;      \
 625               *(INT16_T_ ## _sign *) c_bv = c_value16;                  \
 626             }                                                           \
 627           else                                                          \
 628             goto range_error;                                           \
 629           break;                                                        \
 630                                                                         \
 631         default:                                                        \
 632           abort ();                                                     \
 633         }                                                               \
 634     }                                                                   \
 635   else                                                                  \
 636     {                                                                   \
 637       int err;                                                          \
 638                                                                         \
 639       err = bytevector_large_set (c_bv, c_size,                         \
 640                                   BV_SIGNED_ ## _sign,                  \
 641                                   value, endianness);                   \
 642       if (err)                                                          \
 643         goto range_error;                                               \
 644     }                                                                   \
 645                                                                         \
 646   return;                                                               \
 647                                                                         \
 648  range_error:                                                           \
 649   scm_out_of_range (FUNC_NAME, value);                                  \
 650   return;
 651
 652 static inline void
 653 bytevector_signed_set (char *c_bv, size_t c_size,
 654                        SCM value, SCM endianness,
 655                        const char *func_name)
 656 #define FUNC_NAME func_name
 657 {
 658   INTEGER_SET (signed);
 659 }
 660 #undef FUNC_NAME
 661
 662 static inline void
 663 bytevector_unsigned_set (char *c_bv, size_t c_size,
 664                          SCM value, SCM endianness,
 665                          const char *func_name)
 666 #define FUNC_NAME func_name
 667 {
 668   INTEGER_SET (unsigned);
 669 }
 670 #undef FUNC_NAME
 671
 672 #undef INTEGER_SET
 673 #undef INTEGER_REF
 674 #undef is_signed_int16
 675 #undef is_unsigned_int16
 676 #undef is_signed_int8
 677 #undef is_unsigned_int8
 678 #undef INT16_T_signed
 679 #undef INT16_T_unsigned
 680 #undef BV_SIGNED_unsigned
 681 #undef BV_SIGNED_signed
 682
 683
 684 SCM_DEFINE (scm_r6rs_bytevector_uint_ref, "bytevector-uint-ref", 4, 0, 0,
 685             (SCM bv, SCM index, SCM endianness, SCM size),
 686             "Return the @var{size}-octet long unsigned integer at index "
 687             "@var{index} in @var{bv}.")
 688 #define FUNC_NAME s_scm_r6rs_bytevector_uint_ref
 689 {
 690   INTEGER_ACCESSOR_PROLOGUE ();
 691
 692   return (bytevector_unsigned_ref (&c_bv[c_index], c_size, endianness));
 693 }
 694 #undef FUNC_NAME
 695
 696 SCM_DEFINE (scm_r6rs_bytevector_sint_ref, "bytevector-sint-ref", 4, 0, 0,
 697             (SCM bv, SCM index, SCM endianness, SCM size),
 698             "Return the @var{size}-octet long unsigned integer at index "
 699             "@var{index} in @var{bv}.")
 700 #define FUNC_NAME s_scm_r6rs_bytevector_sint_ref
 701 {
 702   INTEGER_ACCESSOR_PROLOGUE ();
 703
 704   return (bytevector_signed_ref (&c_bv[c_index], c_size, endianness));
 705 }
 706 #undef FUNC_NAME
 707
 708 SCM_DEFINE (scm_r6rs_bytevector_uint_set_x, "bytevector-uint-set!", 5, 0, 0,
 709             (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
 710             "Set the @var{size}-octet long unsigned integer at @var{index} "
 711             "to @var{value}.")
 712 #define FUNC_NAME s_scm_r6rs_bytevector_uint_set_x
 713 {
 714   INTEGER_ACCESSOR_PROLOGUE ();
 715
 716   bytevector_unsigned_set (&c_bv[c_index], c_size, value, endianness,
 717                            FUNC_NAME);
 718
 719   return SCM_UNSPECIFIED;
 720 }
 721 #undef FUNC_NAME
 722
 723 SCM_DEFINE (scm_r6rs_bytevector_sint_set_x, "bytevector-sint-set!", 5, 0, 0,
 724             (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
 725             "Set the @var{size}-octet long signed integer at @var{index} "
 726             "to @var{value}.")
 727 #define FUNC_NAME s_scm_r6rs_bytevector_sint_set_x
 728 {
 729   INTEGER_ACCESSOR_PROLOGUE ();
 730
 731   bytevector_signed_set (&c_bv[c_index], c_size, value, endianness,
 732                          FUNC_NAME);
 733
 734   return SCM_UNSPECIFIED;
 735 }
 736 #undef FUNC_NAME
 737
 738
 739 \f
 740 /* Operations on integers of arbitrary size.  */
 741
 742 #define INTEGERS_TO_LIST(_sign)                                          \
 743   SCM lst, pair;                                                         \
 744   const char *c_bv;                                                      \
 745   size_t i, c_len, c_size;                                               \
 746                                                                          \
 747   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);                                  \
 748   SCM_VALIDATE_SYMBOL (2, endianness);                                   \
 749   c_size = scm_to_uint (size);                                           \
 750                                                                          \
 751   c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);                     \
 752   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);                               \
 753                                                                          \
 754   lst = scm_make_list (scm_from_uint (c_len / c_size), SCM_UNSPECIFIED); \
 755   for (i = 0, pair = lst;                                                \
 756        i <= c_len - c_size;                                              \
 757        i += c_size, c_bv += c_size, pair = SCM_CDR (pair))               \
 758     {                                                                    \
 759       SCM_SETCAR (pair,                                                  \
 760                   bytevector_ ## _sign ## _ref (c_bv, c_size,            \
 761                                                 endianness));            \
 762     }                                                                    \
 763                                                                          \
 764   return lst;
 765
 766 SCM_DEFINE (scm_r6rs_bytevector_to_sint_list, "bytevector->sint-list",
 767             3, 0, 0,
 768             (SCM bv, SCM endianness, SCM size),
 769             "Return a list of signed integers of @var{size} octets "
 770             "representing the contents of @var{bv}.")
 771 #define FUNC_NAME s_scm_r6rs_bytevector_to_sint_list
 772 {
 773   INTEGERS_TO_LIST (signed);
 774 }
 775 #undef FUNC_NAME
 776
 777 SCM_DEFINE (scm_r6rs_bytevector_to_uint_list, "bytevector->uint-list",
 778             3, 0, 0,
 779             (SCM bv, SCM endianness, SCM size),
 780             "Return a list of unsigned integers of @var{size} octets "
 781             "representing the contents of @var{bv}.")
 782 #define FUNC_NAME s_scm_r6rs_bytevector_to_sint_list
 783 {
 784   INTEGERS_TO_LIST (unsigned);
 785 }
 786 #undef FUNC_NAME
 787
 788 #undef INTEGER_TO_LIST
 789
 790
 791 #define INTEGER_LIST_TO_BYTEVECTOR(_sign)                                \
 792   SCM result;                                                            \
 793   size_t c_len, c_size;                                                  \
 794   char *c_bv, *c_bv_ptr;                                                 \
 795                                                                          \
 796   SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len);                             \
 797   SCM_VALIDATE_SYMBOL (2, endianness);                                   \
 798   c_size = scm_to_uint (size);                                           \
 799                                                                          \
 800   if (EXPECT_FALSE ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L))))     \
 801     scm_out_of_range (FUNC_NAME, size);                                  \
 802                                                                          \
 803   c_bv = scm_gc_malloc (c_len * c_size, SCM_GC_BYTEVECTOR);              \
 804                                                                          \
 805   /* FIXME: We leak C_BV here if one of the elements in LST is incorrect \
 806      but `scm_dynwind_free ()' isn't appropriate.  */                    \
 807                                                                          \
 808   for (c_bv_ptr = c_bv;                                                  \
 809        !scm_is_null (lst);                                               \
 810        lst = SCM_CDR (lst), c_bv_ptr += c_size)                          \
 811     {                                                                    \
 812       bytevector_ ## _sign ## _set (c_bv_ptr, c_size,                    \
 813                                     SCM_CAR (lst), endianness,           \
 814                                     FUNC_NAME);                          \
 815     }                                                                    \
 816                                                                          \
 817   result = make_bytevector (c_len * c_size, (signed char *) c_bv);       \
 818                                                                          \
 819   return result;
 820
 821
 822 SCM_DEFINE (scm_r6rs_uint_list_to_bytevector, "uint-list->bytevector",
 823             3, 0, 0,
 824             (SCM lst, SCM endianness, SCM size),
 825             "Return a bytevector containing the unsigned integers "
 826             "listed in @var{lst} and encoded on @var{size} octets "
 827             "according to @var{endianness}.")
 828 #define FUNC_NAME s_scm_r6rs_uint_list_to_bytevector
 829 {
 830   INTEGER_LIST_TO_BYTEVECTOR (unsigned);
 831 }
 832 #undef FUNC_NAME
 833
 834 SCM_DEFINE (scm_r6rs_sint_list_to_bytevector, "sint-list->bytevector",
 835             3, 0, 0,
 836             (SCM lst, SCM endianness, SCM size),
 837             "Return a bytevector containing the signed integers "
 838             "listed in @var{lst} and encoded on @var{size} octets "
 839             "according to @var{endianness}.")
 840 #define FUNC_NAME s_scm_r6rs_sint_list_to_bytevector
 841 {
 842   INTEGER_LIST_TO_BYTEVECTOR (signed);
 843 }
 844 #undef FUNC_NAME
 845
 846 #undef INTEGER_LIST_TO_BYTEVECTOR
 847
 848
 849 /* FIXME: Unfinished! */
 850
 851 \f
 852 /* Initialization.  */
 853
 854 void
 855 scm_init_r6rs_bytevector (void)
 856 {
 857 #include "bytevector.c.x"
 858
 859 #ifdef WORDS_BIGENDIAN
 860   native_endianness = scm_sym_big;
 861 #else
 862   native_endianness = scm_sym_little;
 863 #endif
 864 }
 865
 866 /* arch-tag: e5a30664-90fc-40d7-8036-ee767aea5fb6
 867  */