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 #include <byteswap.h>
  24
  25 #ifdef HAVE_LIMITS_H
  26 # include <limits.h>
  27 #else
  28 /* Assuming 32-bit longs.  */
  29 # define ULONG_MAX 4294967295UL
  30 #endif
  31
  32 #include <string.h>
  33
  34 \f
  35 /* Utilities.  */
  36
  37 #ifdef __GNUC__
  38 # define EXPECT  __builtin_expect
  39 #else
  40 # define EXPECT(_expr, _value) (_expr)
  41 #endif
  42
  43 #define EXPECT_TRUE(_expr)  EXPECT ((_expr), 1)
  44 #define EXPECT_FALSE(_expr) EXPECT ((_expr), 0)
  45
  46 /* Convenience macros.  These are used by the various templates (macros) that
  47    are parameterized by integer signedness.  */
  48 #define INT8_T_signed           scm_t_int8
  49 #define INT8_T_unsigned         scm_t_uint8
  50 #define INT16_T_signed          scm_t_int16
  51 #define INT16_T_unsigned        scm_t_uint16
  52 #define is_signed_int8(_x)      (((_x) >= -128L) && ((_x) <= 127L))
  53 #define is_unsigned_int8(_x)    ((_x) <= 255UL)
  54 #define is_signed_int16(_x)     (((_x) >= -32768L) && ((_x) <= 32767L))
  55 #define is_unsigned_int16(_x)   ((_x) <= 65535UL)
  56
  57 #define INT_TYPE(_size, _sign)  INT ## _size ## _T_ ## _sign
  58 #define INT_SWAP(_size)         bswap_ ## _size
  59 #define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size
  60
  61
  62 #define INTEGER_ACCESSOR_PROLOGUE(_len, _sign)                  \
  63   unsigned c_len, c_index;                                      \
  64   _sign char *c_bv;                                             \
  65                                                                 \
  66   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);                         \
  67   c_index = scm_to_uint (index);                                \
  68                                                                 \
  69   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);                      \
  70   c_bv = (_sign char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);      \
  71                                                                 \
  72   if (EXPECT_FALSE (c_index + ((_len) >> 3UL) - 1 >= c_len))    \
  73     scm_out_of_range (FUNC_NAME, index);
  74
  75 /* Template for fixed-size integer access (only 8, 16 or 32-bit).  */
  76 #define INTEGER_REF(_len, _sign)                                \
  77   SCM result;                                                   \
  78                                                                 \
  79   INTEGER_ACCESSOR_PROLOGUE (_len, _sign);                      \
  80   SCM_VALIDATE_SYMBOL (3, endianness);                          \
  81                                                                 \
  82   {                                                             \
  83     INT_TYPE (_len, _sign)  c_result;                           \
  84                                                                 \
  85     c_result = * (INT_TYPE (_len, _sign) *) &c_bv[c_index];     \
  86     if (!scm_is_eq (endianness, native_endianness))             \
  87       c_result = INT_SWAP (_len) (c_result);                    \
  88                                                                 \
  89     result = SCM_I_MAKINUM (c_result);                          \
  90   }                                                             \
  91                                                                 \
  92   return result;
  93
  94 /* Template for fixed-size integer access using the native endianness.  */
  95 #define INTEGER_NATIVE_REF(_len, _sign)                         \
  96   SCM result;                                                   \
  97                                                                 \
  98   INTEGER_ACCESSOR_PROLOGUE (_len, _sign);                      \
  99                                                                 \
 100   {                                                             \
 101     INT_TYPE (_len, _sign)  c_result;                           \
 102                                                                 \
 103     c_result = * (INT_TYPE (_len, _sign) *) &c_bv[c_index];     \
 104     result = SCM_I_MAKINUM (c_result);                          \
 105   }                                                             \
 106                                                                 \
 107   return result;
 108
 109 /* Template for fixed-size integer modification (only 8, 16 or 32-bit).  */
 110 #define INTEGER_SET(_len, _sign)                                        \
 111   INTEGER_ACCESSOR_PROLOGUE (_len, _sign);                              \
 112   SCM_VALIDATE_SYMBOL (3, endianness);                                  \
 113                                                                         \
 114   {                                                                     \
 115     _sign long c_value;                                                 \
 116     INT_TYPE (_len, _sign) c_value_short;                               \
 117                                                                         \
 118     if (EXPECT_FALSE (!SCM_I_INUMP (value)))                            \
 119       scm_wrong_type_arg (FUNC_NAME, 3, value);                         \
 120                                                                         \
 121     c_value = SCM_I_INUM (value);                                       \
 122     if (EXPECT_FALSE (!INT_VALID_P (_len, _sign) (c_value)))            \
 123       scm_out_of_range (FUNC_NAME, value);                              \
 124                                                                         \
 125     c_value_short = (INT_TYPE (_len, _sign)) c_value;                   \
 126     if (!scm_is_eq (endianness, native_endianness))                     \
 127       c_value_short = INT_SWAP (_len) (c_value_short);                  \
 128                                                                         \
 129     * (INT_TYPE (_len, _sign) *) &c_bv[c_index] = c_value_short;        \
 130   }                                                                     \
 131                                                                         \
 132   return SCM_UNSPECIFIED;
 133
 134 /* Template for fixed-size integer modification using the native
 135    endianness.  */
 136 #define INTEGER_NATIVE_SET(_len, _sign)                                 \
 137   INTEGER_ACCESSOR_PROLOGUE (_len, _sign);                              \
 138                                                                         \
 139   {                                                                     \
 140     _sign long c_value;                                                 \
 141     INT_TYPE (_len, _sign) c_value_short;                               \
 142                                                                         \
 143     if (EXPECT_FALSE (!SCM_I_INUMP (value)))                            \
 144       scm_wrong_type_arg (FUNC_NAME, 3, value);                         \
 145                                                                         \
 146     c_value = SCM_I_INUM (value);                                       \
 147     if (EXPECT_FALSE (!INT_VALID_P (_len, _sign) (c_value)))            \
 148       scm_out_of_range (FUNC_NAME, value);                              \
 149                                                                         \
 150     c_value_short = (INT_TYPE (_len, _sign)) c_value;                   \
 151                                                                         \
 152     * (INT_TYPE (_len, _sign) *) &c_bv[c_index] = c_value_short;        \
 153   }                                                                     \
 154                                                                         \
 155   return SCM_UNSPECIFIED;
 156
 157
 158 \f
 159 /* Bytevector type.  */
 160
 161 SCM_SMOB (scm_tc16_r6rs_bytevector, "r6rs-bytevector", 0);
 162
 163 #define SCM_VALIDATE_R6RS_BYTEVECTOR(_pos, _obj)                \
 164   SCM_VALIDATE_SMOB ((_pos), (_obj), r6rs_bytevector);
 165
 166
 167 static inline SCM
 168 make_bytevector (unsigned len, signed char *contents)
 169 {
 170   SCM_RETURN_NEWSMOB2 (scm_tc16_r6rs_bytevector, len, contents);
 171 }
 172
 173 #define SCM_R6RS_BYTEVECTOR_LENGTH(_bv)         \
 174   ((unsigned) SCM_SMOB_DATA (_bv))
 175 #define SCM_R6RS_BYTEVECTOR_CONTENTS(_bv)       \
 176   ((signed char *) SCM_SMOB_DATA_2 (_bv))
 177
 178 #define SCM_GC_BYTEVECTOR "r6rs-bytevector"
 179
 180 SCM_SMOB_FREE (scm_tc16_r6rs_bytevector, free_bytevector, bv)
 181 {
 182   unsigned c_len;
 183   signed char *c_bv;
 184
 185   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
 186   c_bv = SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
 187
 188   scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
 189
 190   return 0;
 191 }
 192
 193
 194 \f
 195 /* General operations.  */
 196
 197 SCM_SYMBOL (scm_sym_big, "big");
 198 SCM_SYMBOL (scm_sym_little, "little");
 199
 200 /* Host endianness (a symbol).  */
 201 static SCM native_endianness = SCM_UNSPECIFIED;
 202
 203 /* Byte-swapping.  */
 204 #ifndef bswap_24
 205 # define bswap_24(_x)                           \
 206   ((((_x) & 0xff0000) >> 16) |                  \
 207    (((_x) & 0x00ff00))       |                  \
 208    (((_x) & 0x0000ff) << 16))
 209 #endif
 210
 211
 212 SCM_DEFINE (scm_r6rs_native_endianness, "native-endianness", 0, 0, 0,
 213             (void),
 214             "Return a symbol denoting the machine's native endianness.")
 215 #define FUNC_NAME s_scm_r6rs_native_endianness
 216 {
 217   return native_endianness;
 218 }
 219 #undef FUNC_NAME
 220
 221 SCM_DEFINE (scm_r6rs_bytevector_p, "bytevector?", 1, 0, 0,
 222             (SCM obj),
 223             "Return true if @var{obj} is a bytevector.")
 224 #define FUNC_NAME s_scm_r6rs_bytevector_p
 225 {
 226   return (scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_r6rs_bytevector,
 227                                              obj)));
 228 }
 229 #undef FUNC_NAME
 230
 231 SCM_DEFINE (scm_r6rs_make_bytevector, "make-bytevector", 1, 1, 0,
 232             (SCM len, SCM fill),
 233             "Return a newly allocated bytevector of @var{len} bytes, "
 234             "optionally filled with @var{fill}.")
 235 #define FUNC_NAME s_scm_r6rs_make_bytevector
 236 {
 237   unsigned c_len;
 238   signed char c_fill;
 239   signed char *contents;
 240
 241   SCM_VALIDATE_UINT_COPY (1, len, c_len);
 242   if (fill != SCM_UNDEFINED)
 243     {
 244       int value;
 245
 246       value = scm_to_int (fill);
 247       if (EXPECT_FALSE ((value < -128) || (value > 255)))
 248         scm_out_of_range (FUNC_NAME, fill);
 249       c_fill = (signed char) value;
 250     }
 251
 252   contents = (signed char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
 253   if (fill != SCM_UNDEFINED)
 254     {
 255       unsigned i;
 256
 257       for (i = 0; i < c_len; i++)
 258         contents[i] = c_fill;
 259     }
 260
 261   return (make_bytevector (c_len, contents));
 262 }
 263 #undef FUNC_NAME
 264
 265 SCM_DEFINE (scm_r6rs_bytevector_length, "bytevector-length", 1, 0, 0,
 266             (SCM bv),
 267             "Return the length (in bytes) of @var{bv}.")
 268 #define FUNC_NAME s_scm_r6rs_bytevector_length
 269 {
 270   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);
 271
 272   return (scm_from_uint (SCM_R6RS_BYTEVECTOR_LENGTH (bv)));
 273 }
 274 #undef FUNC_NAME
 275
 276 SCM_DEFINE (scm_r6rs_bytevector_eq_p, "bytevector=?", 2, 0, 0,
 277             (SCM bv1, SCM bv2),
 278             "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
 279             "have the same length and contents.")
 280 #define FUNC_NAME s_scm_r6rs_bytevector_eq_p
 281 {
 282   SCM result = SCM_BOOL_F;
 283   unsigned c_len1, c_len2;
 284
 285   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv1);
 286   SCM_VALIDATE_R6RS_BYTEVECTOR (2, bv2);
 287
 288   c_len1 = SCM_R6RS_BYTEVECTOR_LENGTH (bv1);
 289   c_len2 = SCM_R6RS_BYTEVECTOR_LENGTH (bv2);
 290
 291   if (c_len1 == c_len2)
 292     {
 293       signed char *c_bv1, *c_bv2;
 294
 295       c_bv1 = SCM_R6RS_BYTEVECTOR_CONTENTS (bv1);
 296       c_bv2 = SCM_R6RS_BYTEVECTOR_CONTENTS (bv2);
 297
 298       result = scm_from_bool (!memcmp (c_bv1, c_bv2, c_len1));
 299     }
 300
 301   return result;
 302 }
 303 #undef FUNC_NAME
 304
 305 SCM_DEFINE (scm_r6rs_bytevector_fill_x, "bytevector-fill!", 2, 0, 0,
 306             (SCM bv, SCM fill),
 307             "Fill bytevector @var{bv} with @var{fill}, a byte.")
 308 #define FUNC_NAME s_scm_r6rs_bytevector_fill_x
 309 {
 310   unsigned c_len, i;
 311   signed char *c_bv, c_fill;
 312
 313   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);
 314   c_fill = scm_to_int8 (fill);
 315
 316   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
 317   c_bv = SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
 318
 319   for (i = 0; i < c_len; i++)
 320     c_bv[i] = c_fill;
 321
 322   return SCM_UNSPECIFIED;
 323 }
 324 #undef FUNC_NAME
 325
 326 SCM_DEFINE (scm_r6rs_bytevector_copy_x, "bytevector-copy!", 5, 0, 0,
 327             (SCM source, SCM source_start, SCM target, SCM target_start,
 328              SCM len),
 329             "Copy @var{len} bytes from @var{source} into @var{target}, "
 330             "starting reading from @var{source_start} (a positive index "
 331             "within @var{source}) and start writing at "
 332             "@var{target_start}.")
 333 #define FUNC_NAME s_scm_r6rs_bytevector_copy_x
 334 {
 335   unsigned c_len, c_source_len, c_target_len;
 336   unsigned c_source_start, c_target_start;
 337   signed char *c_source, *c_target;
 338
 339   SCM_VALIDATE_R6RS_BYTEVECTOR (1, source);
 340   SCM_VALIDATE_R6RS_BYTEVECTOR (3, target);
 341
 342   c_len = scm_to_uint (len);
 343   c_source_start = scm_to_uint (source_start);
 344   c_target_start = scm_to_uint (target_start);
 345
 346   c_source = SCM_R6RS_BYTEVECTOR_CONTENTS (source);
 347   c_target = SCM_R6RS_BYTEVECTOR_CONTENTS (target);
 348   c_source_len = SCM_R6RS_BYTEVECTOR_LENGTH (source);
 349   c_target_len = SCM_R6RS_BYTEVECTOR_LENGTH (target);
 350
 351   if (EXPECT_FALSE (c_source_start + c_len > c_source_len))
 352     scm_out_of_range (FUNC_NAME, source_start);
 353   if (EXPECT_FALSE (c_target_start + c_len > c_target_len))
 354     scm_out_of_range (FUNC_NAME, target_start);
 355
 356   memcpy (c_target + c_target_start,
 357           c_source + c_source_start,
 358           c_len);
 359
 360   return SCM_UNSPECIFIED;
 361 }
 362 #undef FUNC_NAME
 363
 364 SCM_DEFINE (scm_r6rs_bytevector_copy, "bytevector-copy", 1, 0, 0,
 365             (SCM bv),
 366             "Return a newly allocated copy of @var{bv}.")
 367 #define FUNC_NAME s_scm_r6rs_bytevector_copy
 368 {
 369   unsigned c_len;
 370   signed char *c_bv, *c_copy;
 371
 372   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);
 373
 374   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
 375   c_bv = SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
 376
 377   c_copy = scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
 378   memcpy (c_copy, c_bv, c_len);
 379
 380   return (make_bytevector (c_len, c_copy));
 381 }
 382 #undef FUNC_NAME
 383
 384 \f
 385 /* Operations on bytes and octets.  */
 386
 387 SCM_DEFINE (scm_r6rs_bytevector_u8_ref, "bytevector-u8-ref", 2, 0, 0,
 388             (SCM bv, SCM index),
 389             "Return the octet located at @var{index} in @var{bv}.")
 390 #define FUNC_NAME s_scm_r6rs_bytevector_u8_ref
 391 {
 392   INTEGER_NATIVE_REF (8, unsigned);
 393 }
 394 #undef FUNC_NAME
 395
 396 SCM_DEFINE (scm_r6rs_bytevector_s8_ref, "bytevector-s8-ref", 2, 0, 0,
 397             (SCM bv, SCM index),
 398             "Return the byte located at @var{index} in @var{bv}.")
 399 #define FUNC_NAME s_scm_r6rs_bytevector_u8_ref
 400 {
 401   INTEGER_NATIVE_REF (8, signed);
 402 }
 403 #undef FUNC_NAME
 404
 405 SCM_DEFINE (scm_r6rs_bytevector_u8_set_x, "bytevector-u8-set!", 3, 0, 0,
 406             (SCM bv, SCM index, SCM value),
 407             "Return the octet located at @var{index} in @var{bv}.")
 408 #define FUNC_NAME s_scm_r6rs_bytevector_u8_set_x
 409 {
 410   INTEGER_NATIVE_SET (8, unsigned);
 411 }
 412 #undef FUNC_NAME
 413
 414 SCM_DEFINE (scm_r6rs_bytevector_s8_set_x, "bytevector-s8-set!", 3, 0, 0,
 415             (SCM bv, SCM index, SCM value),
 416             "Return the octet located at @var{index} in @var{bv}.")
 417 #define FUNC_NAME s_scm_r6rs_bytevector_u8_set_x
 418 {
 419   INTEGER_NATIVE_SET (8, signed);
 420 }
 421 #undef FUNC_NAME
 422
 423 #undef OCTET_ACCESSOR_PROLOGUE
 424
 425
 426 SCM_DEFINE (scm_r6rs_bytevector_to_u8_list, "bytevector->u8-list", 1, 0, 0,
 427             (SCM bv),
 428             "Return a newly allocated list of octets containing the "
 429             "contents of @var{bv}.")
 430 #define FUNC_NAME s_scm_r6rs_bytevector_to_u8_list
 431 {
 432   SCM lst, pair;
 433   unsigned c_len, i;
 434   unsigned char *c_bv;
 435
 436   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);
 437
 438   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
 439   c_bv = (unsigned char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
 440
 441   lst = scm_make_list (scm_from_uint (c_len), SCM_UNSPECIFIED);
 442   for (i = 0, pair = lst;
 443        i < c_len;
 444        i++, pair = SCM_CDR (pair))
 445     {
 446       SCM_SETCAR (pair, SCM_I_MAKINUM (c_bv[i]));
 447     }
 448
 449   return lst;
 450 }
 451 #undef FUNC_NAME
 452
 453 SCM_DEFINE (scm_r6rs_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0,
 454             (SCM lst),
 455             "Turn @var{lst}, a list of octets, into a bytevector.")
 456 #define FUNC_NAME s_scm_r6rs_u8_list_to_bytevector
 457 {
 458   SCM item;
 459   unsigned c_len, i;
 460   unsigned char *c_bv;
 461
 462   SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len);
 463
 464   c_bv = scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
 465   for (i = 0; i < c_len; lst = SCM_CDR (lst), i++)
 466     {
 467       item = SCM_CAR (lst);
 468
 469       if (EXPECT_TRUE (SCM_I_INUMP (item)))
 470         {
 471           long c_item;
 472
 473           c_item = SCM_I_INUM (item);
 474           if (EXPECT_TRUE ((c_item >= 0) && (c_item < 256)))
 475             c_bv[i] = (unsigned char) c_item;
 476           else
 477             goto type_error;
 478         }
 479       else
 480         goto type_error;
 481     }
 482
 483   return (make_bytevector (c_len, (signed char *) c_bv));
 484
 485  type_error:
 486   scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
 487   scm_wrong_type_arg (FUNC_NAME, 1, item);
 488
 489   return SCM_BOOL_F;
 490 }
 491 #undef FUNC_NAME
 492
 493 /* Compute the two's complement of VALUE (a positive integer) on SIZE octets
 494    using (2^(SIZE * 8) - VALUE).  */
 495 static inline void
 496 twos_complement (mpz_t value, size_t size)
 497 {
 498   unsigned long bit_count;
 499
 500   /* We expect BIT_COUNT to fit in a unsigned long thanks to the range
 501      checking on SIZE performed earlier.  */
 502   bit_count = (unsigned long) size << 3UL;
 503
 504   if (EXPECT_TRUE (bit_count < sizeof (unsigned long)))
 505     mpz_ui_sub (value, 1UL << bit_count, value);
 506   else
 507     {
 508       mpz_t max;
 509
 510       mpz_init (max);
 511       mpz_ui_pow_ui (max, 2, bit_count);
 512       mpz_sub (value, max, value);
 513       mpz_clear (max);
 514     }
 515 }
 516
 517 static inline SCM
 518 bytevector_large_ref (const char *c_bv, size_t c_size, int signed_p,
 519                       SCM endianness)
 520 {
 521   SCM result;
 522   mpz_t c_mpz;
 523   int c_endianness, negative_p = 0;
 524
 525   if (signed_p)
 526     {
 527       if (scm_is_eq (endianness, scm_sym_big))
 528         negative_p = c_bv[0] & 0x80;
 529       else
 530         negative_p = c_bv[c_size - 1] & 0x80;
 531     }
 532
 533   c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1;
 534
 535   mpz_init (c_mpz);
 536   mpz_import (c_mpz, 1 /* 1 word */, 1 /* word order doesn't matter */,
 537               c_size /* word is C_SIZE-byte long */,
 538               c_endianness,
 539               0 /* nails */, c_bv);
 540
 541   if (signed_p && negative_p)
 542     {
 543       twos_complement (c_mpz, c_size);
 544       mpz_neg (c_mpz, c_mpz);
 545     }
 546
 547   result = scm_from_mpz (c_mpz);
 548   mpz_clear (c_mpz);  /* FIXME: Needed? */
 549
 550   return result;
 551 }
 552
 553 static inline int
 554 bytevector_large_set (char *c_bv, size_t c_size, int signed_p,
 555                       SCM value, SCM endianness)
 556 {
 557   size_t word_count, value_size;
 558   mpz_t c_mpz;
 559   int c_endianness, err = 0;
 560
 561   c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1;
 562
 563   mpz_init (c_mpz);
 564   scm_to_mpz (value, c_mpz);
 565   if (mpz_sgn (c_mpz) < 0)
 566     {
 567       if (EXPECT_TRUE (signed_p))
 568         {
 569           mpz_neg (c_mpz, c_mpz);
 570           twos_complement (c_mpz, c_size);
 571         }
 572       else
 573         {
 574           err = -1;
 575           goto finish;
 576         }
 577     }
 578
 579   value_size = (mpz_sizeinbase (c_mpz, 2) + (8 * c_size)) / (8 * c_size);
 580   if (EXPECT_FALSE (value_size > c_size))
 581     {
 582       err = -2;
 583       goto finish;
 584     }
 585
 586   mpz_export (c_bv, &word_count, 1 /* word order doesn't matter */,
 587               c_size, c_endianness,
 588               0 /* nails */, c_mpz);
 589   if (EXPECT_FALSE (word_count != 1))
 590     abort ();
 591
 592  finish:
 593   mpz_clear (c_mpz);
 594
 595   return err;
 596 }
 597
 598 #define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign)                        \
 599   unsigned c_len, c_index, c_size;                                      \
 600   char *c_bv;                                                           \
 601                                                                         \
 602   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);                                 \
 603   c_index = scm_to_uint (index);                                        \
 604   c_size = scm_to_uint (size);                                          \
 605                                                                         \
 606   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);                              \
 607   c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);                    \
 608                                                                         \
 609   /* C_SIZE must have its 3 higher bits set to zero so that             \
 610      multiplying it by 8 yields a number that fits in an                \
 611      unsigned long.  */                                                 \
 612   if (EXPECT_FALSE ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L))))    \
 613     scm_out_of_range (FUNC_NAME, size);                                 \
 614   if (EXPECT_FALSE (c_index + c_size > c_len))                          \
 615     scm_out_of_range (FUNC_NAME, index);
 616
 617
 618 #define BV_SIGNED_signed 1
 619 #define BV_SIGNED_unsigned 0
 620
 621 /* Template of an integer reference function.  */
 622 #define GENERIC_INTEGER_REF(_sign)                                      \
 623   SCM result;                                                           \
 624                                                                         \
 625   if (c_size < 3)                                                       \
 626     {                                                                   \
 627       int swap;                                                         \
 628       _sign int value;                                                  \
 629                                                                         \
 630       swap = !scm_is_eq (endianness, native_endianness);                \
 631       switch (c_size)                                                   \
 632         {                                                               \
 633         case 1:                                                         \
 634           value = *(_sign char *) c_bv;                                 \
 635           break;                                                        \
 636         case 2:                                                         \
 637           value = * (INT_TYPE (16, _sign) *) c_bv;                      \
 638           if (swap)                                                     \
 639             value = (INT_TYPE (16, _sign)) bswap_16 (value);            \
 640           break;                                                        \
 641         default:                                                        \
 642           abort ();                                                     \
 643         }                                                               \
 644                                                                         \
 645       result = SCM_I_MAKINUM ((_sign int) value);                       \
 646     }                                                                   \
 647   else                                                                  \
 648     result = bytevector_large_ref ((char *) c_bv,                       \
 649                                    c_size,                              \
 650                                    BV_SIGNED_ ## _sign, endianness);    \
 651                                                                         \
 652   return result;
 653
 654 static inline SCM
 655 bytevector_signed_ref (const char *c_bv, size_t c_size, SCM endianness)
 656 {
 657   GENERIC_INTEGER_REF (signed);
 658 }
 659
 660 static inline SCM
 661 bytevector_unsigned_ref (const char *c_bv, size_t c_size, SCM endianness)
 662 {
 663   GENERIC_INTEGER_REF (unsigned);
 664 }
 665
 666
 667 /* Template of an integer assignment function.  */
 668 #define GENERIC_INTEGER_SET(_sign)                                      \
 669   if (c_size < 3)                                                       \
 670     {                                                                   \
 671       _sign int c_value;                                                \
 672                                                                         \
 673       if (EXPECT_FALSE (!SCM_I_INUMP (value)))                          \
 674         goto range_error;                                               \
 675                                                                         \
 676       c_value = SCM_I_INUM (value);                                     \
 677       switch (c_size)                                                   \
 678         {                                                               \
 679         case 1:                                                         \
 680           if (EXPECT_TRUE (INT_VALID_P (8, _sign) (c_value)))           \
 681             * (_sign char *) c_bv = (_sign char) c_value;               \
 682           else                                                          \
 683             goto range_error;                                           \
 684           break;                                                        \
 685                                                                         \
 686         case 2:                                                         \
 687           if (EXPECT_TRUE (INT_VALID_P (16, _sign) (c_value)))          \
 688             {                                                           \
 689               int swap;                                                 \
 690               INT_TYPE (16, _sign)  c_value16;                          \
 691                                                                         \
 692               swap = !scm_is_eq (endianness, native_endianness);        \
 693                                                                         \
 694               c_value16 =                                               \
 695                 swap ? bswap_16 (c_value) : c_value;                    \
 696               * (INT_TYPE (16, _sign) *) c_bv = c_value16;              \
 697             }                                                           \
 698           else                                                          \
 699             goto range_error;                                           \
 700           break;                                                        \
 701                                                                         \
 702         default:                                                        \
 703           abort ();                                                     \
 704         }                                                               \
 705     }                                                                   \
 706   else                                                                  \
 707     {                                                                   \
 708       int err;                                                          \
 709                                                                         \
 710       err = bytevector_large_set (c_bv, c_size,                         \
 711                                   BV_SIGNED_ ## _sign,                  \
 712                                   value, endianness);                   \
 713       if (err)                                                          \
 714         goto range_error;                                               \
 715     }                                                                   \
 716                                                                         \
 717   return;                                                               \
 718                                                                         \
 719  range_error:                                                           \
 720   scm_out_of_range (FUNC_NAME, value);                                  \
 721   return;
 722
 723 static inline void
 724 bytevector_signed_set (char *c_bv, size_t c_size,
 725                        SCM value, SCM endianness,
 726                        const char *func_name)
 727 #define FUNC_NAME func_name
 728 {
 729   GENERIC_INTEGER_SET (signed);
 730 }
 731 #undef FUNC_NAME
 732
 733 static inline void
 734 bytevector_unsigned_set (char *c_bv, size_t c_size,
 735                          SCM value, SCM endianness,
 736                          const char *func_name)
 737 #define FUNC_NAME func_name
 738 {
 739   GENERIC_INTEGER_SET (unsigned);
 740 }
 741 #undef FUNC_NAME
 742
 743 #undef GENERIC_INTEGER_SET
 744 #undef GENERIC_INTEGER_REF
 745 #undef BV_SIGNED_unsigned
 746 #undef BV_SIGNED_signed
 747
 748
 749 SCM_DEFINE (scm_r6rs_bytevector_uint_ref, "bytevector-uint-ref", 4, 0, 0,
 750             (SCM bv, SCM index, SCM endianness, SCM size),
 751             "Return the @var{size}-octet long unsigned integer at index "
 752             "@var{index} in @var{bv}.")
 753 #define FUNC_NAME s_scm_r6rs_bytevector_uint_ref
 754 {
 755   GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
 756
 757   return (bytevector_unsigned_ref (&c_bv[c_index], c_size, endianness));
 758 }
 759 #undef FUNC_NAME
 760
 761 SCM_DEFINE (scm_r6rs_bytevector_sint_ref, "bytevector-sint-ref", 4, 0, 0,
 762             (SCM bv, SCM index, SCM endianness, SCM size),
 763             "Return the @var{size}-octet long unsigned integer at index "
 764             "@var{index} in @var{bv}.")
 765 #define FUNC_NAME s_scm_r6rs_bytevector_sint_ref
 766 {
 767   GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
 768
 769   return (bytevector_signed_ref (&c_bv[c_index], c_size, endianness));
 770 }
 771 #undef FUNC_NAME
 772
 773 SCM_DEFINE (scm_r6rs_bytevector_uint_set_x, "bytevector-uint-set!", 5, 0, 0,
 774             (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
 775             "Set the @var{size}-octet long unsigned integer at @var{index} "
 776             "to @var{value}.")
 777 #define FUNC_NAME s_scm_r6rs_bytevector_uint_set_x
 778 {
 779   GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
 780
 781   bytevector_unsigned_set (&c_bv[c_index], c_size, value, endianness,
 782                            FUNC_NAME);
 783
 784   return SCM_UNSPECIFIED;
 785 }
 786 #undef FUNC_NAME
 787
 788 SCM_DEFINE (scm_r6rs_bytevector_sint_set_x, "bytevector-sint-set!", 5, 0, 0,
 789             (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
 790             "Set the @var{size}-octet long signed integer at @var{index} "
 791             "to @var{value}.")
 792 #define FUNC_NAME s_scm_r6rs_bytevector_sint_set_x
 793 {
 794   GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
 795
 796   bytevector_signed_set (&c_bv[c_index], c_size, value, endianness,
 797                          FUNC_NAME);
 798
 799   return SCM_UNSPECIFIED;
 800 }
 801 #undef FUNC_NAME
 802
 803
 804 \f
 805 /* Operations on integers of arbitrary size.  */
 806
 807 #define INTEGERS_TO_LIST(_sign)                                          \
 808   SCM lst, pair;                                                         \
 809   const char *c_bv;                                                      \
 810   size_t i, c_len, c_size;                                               \
 811                                                                          \
 812   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);                                  \
 813   SCM_VALIDATE_SYMBOL (2, endianness);                                   \
 814   c_size = scm_to_uint (size);                                           \
 815                                                                          \
 816   c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);                     \
 817   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);                               \
 818                                                                          \
 819   lst = scm_make_list (scm_from_uint (c_len / c_size), SCM_UNSPECIFIED); \
 820   for (i = 0, pair = lst;                                                \
 821        i <= c_len - c_size;                                              \
 822        i += c_size, c_bv += c_size, pair = SCM_CDR (pair))               \
 823     {                                                                    \
 824       SCM_SETCAR (pair,                                                  \
 825                   bytevector_ ## _sign ## _ref (c_bv, c_size,            \
 826                                                 endianness));            \
 827     }                                                                    \
 828                                                                          \
 829   return lst;
 830
 831 SCM_DEFINE (scm_r6rs_bytevector_to_sint_list, "bytevector->sint-list",
 832             3, 0, 0,
 833             (SCM bv, SCM endianness, SCM size),
 834             "Return a list of signed integers of @var{size} octets "
 835             "representing the contents of @var{bv}.")
 836 #define FUNC_NAME s_scm_r6rs_bytevector_to_sint_list
 837 {
 838   INTEGERS_TO_LIST (signed);
 839 }
 840 #undef FUNC_NAME
 841
 842 SCM_DEFINE (scm_r6rs_bytevector_to_uint_list, "bytevector->uint-list",
 843             3, 0, 0,
 844             (SCM bv, SCM endianness, SCM size),
 845             "Return a list of unsigned integers of @var{size} octets "
 846             "representing the contents of @var{bv}.")
 847 #define FUNC_NAME s_scm_r6rs_bytevector_to_sint_list
 848 {
 849   INTEGERS_TO_LIST (unsigned);
 850 }
 851 #undef FUNC_NAME
 852
 853 #undef INTEGER_TO_LIST
 854
 855
 856 #define INTEGER_LIST_TO_BYTEVECTOR(_sign)                                \
 857   SCM result;                                                            \
 858   size_t c_len, c_size;                                                  \
 859   char *c_bv, *c_bv_ptr;                                                 \
 860                                                                          \
 861   SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len);                             \
 862   SCM_VALIDATE_SYMBOL (2, endianness);                                   \
 863   c_size = scm_to_uint (size);                                           \
 864                                                                          \
 865   if (EXPECT_FALSE ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L))))     \
 866     scm_out_of_range (FUNC_NAME, size);                                  \
 867                                                                          \
 868   c_bv = scm_gc_malloc (c_len * c_size, SCM_GC_BYTEVECTOR);              \
 869                                                                          \
 870   /* FIXME: We leak C_BV here if one of the elements in LST is incorrect \
 871      but `scm_dynwind_free ()' isn't appropriate.  */                    \
 872                                                                          \
 873   for (c_bv_ptr = c_bv;                                                  \
 874        !scm_is_null (lst);                                               \
 875        lst = SCM_CDR (lst), c_bv_ptr += c_size)                          \
 876     {                                                                    \
 877       bytevector_ ## _sign ## _set (c_bv_ptr, c_size,                    \
 878                                     SCM_CAR (lst), endianness,           \
 879                                     FUNC_NAME);                          \
 880     }                                                                    \
 881                                                                          \
 882   result = make_bytevector (c_len * c_size, (signed char *) c_bv);       \
 883                                                                          \
 884   return result;
 885
 886
 887 SCM_DEFINE (scm_r6rs_uint_list_to_bytevector, "uint-list->bytevector",
 888             3, 0, 0,
 889             (SCM lst, SCM endianness, SCM size),
 890             "Return a bytevector containing the unsigned integers "
 891             "listed in @var{lst} and encoded on @var{size} octets "
 892             "according to @var{endianness}.")
 893 #define FUNC_NAME s_scm_r6rs_uint_list_to_bytevector
 894 {
 895   INTEGER_LIST_TO_BYTEVECTOR (unsigned);
 896 }
 897 #undef FUNC_NAME
 898
 899 SCM_DEFINE (scm_r6rs_sint_list_to_bytevector, "sint-list->bytevector",
 900             3, 0, 0,
 901             (SCM lst, SCM endianness, SCM size),
 902             "Return a bytevector containing the signed integers "
 903             "listed in @var{lst} and encoded on @var{size} octets "
 904             "according to @var{endianness}.")
 905 #define FUNC_NAME s_scm_r6rs_sint_list_to_bytevector
 906 {
 907   INTEGER_LIST_TO_BYTEVECTOR (signed);
 908 }
 909 #undef FUNC_NAME
 910
 911 #undef INTEGER_LIST_TO_BYTEVECTOR
 912
 913
 914 \f
 915 /* Operations on 16-bit integers.  */
 916
 917 SCM_DEFINE (scm_r6rs_bytevector_u16_ref, "bytevector-u16-ref",
 918             3, 0, 0,
 919             (SCM bv, SCM index, SCM endianness),
 920             "Return the unsigned 16-bit integer from @var{bv} at "
 921             "@var{index}.")
 922 #define FUNC_NAME s_scm_r6rs_bytevector_u16_ref
 923 {
 924   INTEGER_REF (16, unsigned);
 925 }
 926 #undef FUNC_NAME
 927
 928 SCM_DEFINE (scm_r6rs_bytevector_s16_ref, "bytevector-s16-ref",
 929             3, 0, 0,
 930             (SCM bv, SCM index, SCM endianness),
 931             "Return the signed 16-bit integer from @var{bv} at "
 932             "@var{index}.")
 933 #define FUNC_NAME s_scm_r6rs_bytevector_s16_ref
 934 {
 935   INTEGER_REF (16, signed);
 936 }
 937 #undef FUNC_NAME
 938
 939 SCM_DEFINE (scm_r6rs_bytevector_u16_native_ref, "bytevector-u16-native-ref",
 940             2, 0, 0,
 941             (SCM bv, SCM index),
 942             "Return the unsigned 16-bit integer from @var{bv} at "
 943             "@var{index} using the native endianness.")
 944 #define FUNC_NAME s_scm_r6rs_bytevector_u16_native_ref
 945 {
 946   INTEGER_NATIVE_REF (16, unsigned);
 947 }
 948 #undef FUNC_NAME
 949
 950 SCM_DEFINE (scm_r6rs_bytevector_s16_native_ref, "bytevector-s16-native-ref",
 951             2, 0, 0,
 952             (SCM bv, SCM index),
 953             "Return the unsigned 16-bit integer from @var{bv} at "
 954             "@var{index} using the native endianness.")
 955 #define FUNC_NAME s_scm_r6rs_bytevector_u16_native_ref
 956 {
 957   INTEGER_NATIVE_REF (16, signed);
 958 }
 959 #undef FUNC_NAME
 960
 961 SCM_DEFINE (scm_r6rs_bytevector_u16_set_x, "bytevector-u16-set!",
 962             4, 0, 0,
 963             (SCM bv, SCM index, SCM value, SCM endianness),
 964             "Store @var{value} in @var{bv} at @var{index} according to "
 965             "@var{endianness}.")
 966 #define FUNC_NAME s_scm_r6rs_bytevector_u16_set_x
 967 {
 968   INTEGER_SET (16, unsigned);
 969 }
 970 #undef FUNC_NAME
 971
 972 SCM_DEFINE (scm_r6rs_bytevector_s16_set_x, "bytevector-s16-set!",
 973             4, 0, 0,
 974             (SCM bv, SCM index, SCM value, SCM endianness),
 975             "Store @var{value} in @var{bv} at @var{index} according to "
 976             "@var{endianness}.")
 977 #define FUNC_NAME s_scm_r6rs_bytevector_s16_set_x
 978 {
 979   INTEGER_SET (16, signed);
 980 }
 981 #undef FUNC_NAME
 982
 983 SCM_DEFINE (scm_r6rs_bytevector_u16_native_set_x, "bytevector-u16-native-set!",
 984             3, 0, 0,
 985             (SCM bv, SCM index, SCM value),
 986             "Store the unsigned integer @var{value} at index @var{index} "
 987             "of @var{bv} using the native endianness.")
 988 #define FUNC_NAME s_scm_r6rs_bytevector_u16_native_set_x
 989 {
 990   INTEGER_NATIVE_SET (16, unsigned);
 991 }
 992 #undef FUNC_NAME
 993
 994 SCM_DEFINE (scm_r6rs_bytevector_s16_native_set_x, "bytevector-s16-native-set!",
 995             3, 0, 0,
 996             (SCM bv, SCM index, SCM value),
 997             "Store the signed integer @var{value} at index @var{index} "
 998             "of @var{bv} using the native endianness.")
 999 #define FUNC_NAME s_scm_r6rs_bytevector_u16_native_set_x
1000 {
1001   INTEGER_NATIVE_SET (16, signed);
1002 }
1003 #undef FUNC_NAME
1004
1005 /* FIXME: Unfinished! */
1006
1007 \f
1008 /* Initialization.  */
1009
1010 void
1011 scm_init_r6rs_bytevector (void)
1012 {
1013 #include "bytevector.c.x"
1014
1015 #ifdef WORDS_BIGENDIAN
1016   native_endianness = scm_sym_big;
1017 #else
1018   native_endianness = scm_sym_little;
1019 #endif
1020 }
1021
1022 /* arch-tag: e5a30664-90fc-40d7-8036-ee767aea5fb6
1023  */