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_ARPA_INET_H
  24 # include <arpa/inet.h>
  25 #endif
  26
  27 #include <string.h>
  28
  29 \f
  30 /* Utilities.  */
  31
  32 #ifdef __GNUC__
  33 # define EXPECT  __builtin_expect
  34 #else
  35 # define EXPECT(_expr, _value) (_expr)
  36 #endif
  37
  38 #define EXPECT_TRUE(_expr)  EXPECT ((_expr), 1)
  39 #define EXPECT_FALSE(_expr) EXPECT ((_expr), 0)
  40
  41
  42 \f
  43 /* Bytevector type.  */
  44
  45 SCM_SMOB (scm_tc16_r6rs_bytevector, "r6rs-bytevector", 0);
  46
  47 #define SCM_VALIDATE_R6RS_BYTEVECTOR(_pos, _obj)                \
  48   SCM_VALIDATE_SMOB ((_pos), (_obj), r6rs_bytevector);
  49
  50
  51 static inline SCM
  52 make_bytevector (unsigned len, signed char *contents)
  53 {
  54   SCM_RETURN_NEWSMOB2 (scm_tc16_r6rs_bytevector, len, contents);
  55 }
  56
  57 #define SCM_R6RS_BYTEVECTOR_LENGTH(_bv)         \
  58   ((unsigned) SCM_SMOB_DATA (_bv))
  59 #define SCM_R6RS_BYTEVECTOR_CONTENTS(_bv)       \
  60   ((signed char *) SCM_SMOB_DATA_2 (_bv))
  61
  62 #define SCM_GC_BYTEVECTOR "r6rs-bytevector"
  63
  64 SCM_SMOB_FREE (scm_tc16_r6rs_bytevector, free_bytevector, bv)
  65 {
  66   unsigned c_len;
  67   signed char *c_bv;
  68
  69   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
  70   c_bv = SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
  71
  72   scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
  73
  74   return 0;
  75 }
  76
  77
  78 \f
  79 /* General operations.  */
  80
  81 SCM_SYMBOL (scm_sym_big, "big");
  82 SCM_SYMBOL (scm_sym_little, "little");
  83
  84 /* Host endianness (a symbol).  */
  85 static SCM native_endianness = SCM_UNSPECIFIED;
  86
  87 #ifdef WORDS_BIGENDIAN
  88 # define non_native_byteswap_16(_x) htons(_x)
  89 # define non_native_byteswap_32(_x) htonl(_x)
  90 #else
  91 # define non_native_byteswap_16(_x) (_x)
  92 # define non_native_byteswap_32(_x) (_x)
  93 #endif
  94
  95
  96 SCM_DEFINE (scm_r6rs_native_endianness, "native-endianness", 0, 0, 0,
  97             (void),
  98             "Return a symbol denoting the machine's native endianness.")
  99 #define FUNC_NAME s_scm_r6rs_native_endianness
 100 {
 101   return native_endianness;
 102 }
 103 #undef FUNC_NAME
 104
 105 SCM_DEFINE (scm_r6rs_bytevector_p, "bytevector?", 1, 0, 0,
 106             (SCM obj),
 107             "Return true if @var{obj} is a bytevector.")
 108 #define FUNC_NAME s_scm_r6rs_bytevector_p
 109 {
 110   return (scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_r6rs_bytevector,
 111                                              obj)));
 112 }
 113 #undef FUNC_NAME
 114
 115 SCM_DEFINE (scm_r6rs_make_bytevector, "make-bytevector", 1, 1, 0,
 116             (SCM len, SCM fill),
 117             "Return a newly allocated bytevector of @var{len} bytes, "
 118             "optionally filled with @var{fill}.")
 119 #define FUNC_NAME s_scm_r6rs_make_bytevector
 120 {
 121   unsigned c_len;
 122   signed char c_fill;
 123   signed char *contents;
 124
 125   SCM_VALIDATE_UINT_COPY (1, len, c_len);
 126   if (fill != SCM_UNDEFINED)
 127     {
 128       int value;
 129
 130       value = scm_to_int (fill);
 131       if (EXPECT_FALSE ((value < -128) || (value > 255)))
 132         scm_out_of_range (FUNC_NAME, fill);
 133       c_fill = (signed char) value;
 134     }
 135
 136   contents = (signed char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
 137   if (fill != SCM_UNDEFINED)
 138     {
 139       unsigned i;
 140
 141       for (i = 0; i < c_len; i++)
 142         contents[i] = c_fill;
 143     }
 144
 145   return (make_bytevector (c_len, contents));
 146 }
 147 #undef FUNC_NAME
 148
 149 SCM_DEFINE (scm_r6rs_bytevector_length, "bytevector-length", 1, 0, 0,
 150             (SCM bv),
 151             "Return the length (in bytes) of @var{bv}.")
 152 #define FUNC_NAME s_scm_r6rs_bytevector_length
 153 {
 154   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);
 155
 156   return (scm_from_uint (SCM_R6RS_BYTEVECTOR_LENGTH (bv)));
 157 }
 158 #undef FUNC_NAME
 159
 160 SCM_DEFINE (scm_r6rs_bytevector_eq_p, "bytevector=?", 2, 0, 0,
 161             (SCM bv1, SCM bv2),
 162             "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
 163             "have the same length and contents.")
 164 #define FUNC_NAME s_scm_r6rs_bytevector_eq_p
 165 {
 166   SCM result = SCM_BOOL_F;
 167   unsigned c_len1, c_len2;
 168
 169   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv1);
 170   SCM_VALIDATE_R6RS_BYTEVECTOR (2, bv2);
 171
 172   c_len1 = SCM_R6RS_BYTEVECTOR_LENGTH (bv1);
 173   c_len2 = SCM_R6RS_BYTEVECTOR_LENGTH (bv2);
 174
 175   if (c_len1 == c_len2)
 176     {
 177       signed char *c_bv1, *c_bv2;
 178
 179       c_bv1 = SCM_R6RS_BYTEVECTOR_CONTENTS (bv1);
 180       c_bv2 = SCM_R6RS_BYTEVECTOR_CONTENTS (bv2);
 181
 182       result = scm_from_bool (!memcmp (c_bv1, c_bv2, c_len1));
 183     }
 184
 185   return result;
 186 }
 187 #undef FUNC_NAME
 188
 189 SCM_DEFINE (scm_r6rs_bytevector_fill_x, "bytevector-fill!", 2, 0, 0,
 190             (SCM bv, SCM fill),
 191             "Fill bytevector @var{bv} with @var{fill}, a byte.")
 192 #define FUNC_NAME s_scm_r6rs_bytevector_fill_x
 193 {
 194   unsigned c_len, i;
 195   signed char *c_bv, c_fill;
 196
 197   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);
 198   c_fill = scm_to_int8 (fill);
 199
 200   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
 201   c_bv = SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
 202
 203   for (i = 0; i < c_len; i++)
 204     c_bv[i] = c_fill;
 205
 206   return SCM_UNSPECIFIED;
 207 }
 208 #undef FUNC_NAME
 209
 210 SCM_DEFINE (scm_r6rs_bytevector_copy_x, "bytevector-copy!", 5, 0, 0,
 211             (SCM source, SCM source_start, SCM target, SCM target_start,
 212              SCM len),
 213             "Copy @var{len} bytes from @var{source} into @var{target}, "
 214             "starting reading from @var{source_start} (a positive index "
 215             "within @var{source}) and start writing at "
 216             "@var{target_start}.")
 217 #define FUNC_NAME s_scm_r6rs_bytevector_copy_x
 218 {
 219   unsigned c_len, c_source_len, c_target_len;
 220   unsigned c_source_start, c_target_start;
 221   signed char *c_source, *c_target;
 222
 223   SCM_VALIDATE_R6RS_BYTEVECTOR (1, source);
 224   SCM_VALIDATE_R6RS_BYTEVECTOR (3, target);
 225
 226   c_len = scm_to_uint (len);
 227   c_source_start = scm_to_uint (source_start);
 228   c_target_start = scm_to_uint (target_start);
 229
 230   c_source = SCM_R6RS_BYTEVECTOR_CONTENTS (source);
 231   c_target = SCM_R6RS_BYTEVECTOR_CONTENTS (target);
 232   c_source_len = SCM_R6RS_BYTEVECTOR_LENGTH (source);
 233   c_target_len = SCM_R6RS_BYTEVECTOR_LENGTH (target);
 234
 235   if (EXPECT_FALSE (c_source_start + c_len > c_source_len))
 236     scm_out_of_range (FUNC_NAME, source_start);
 237   if (EXPECT_FALSE (c_target_start + c_len > c_target_len))
 238     scm_out_of_range (FUNC_NAME, target_start);
 239
 240   memcpy (c_target + c_target_start,
 241           c_source + c_source_start,
 242           c_len);
 243
 244   return SCM_UNSPECIFIED;
 245 }
 246 #undef FUNC_NAME
 247
 248 SCM_DEFINE (scm_r6rs_bytevector_copy, "bytevector-copy", 1, 0, 0,
 249             (SCM bv),
 250             "Return a newly allocated copy of @var{bv}.")
 251 #define FUNC_NAME s_scm_r6rs_bytevector_copy
 252 {
 253   unsigned c_len;
 254   signed char *c_bv, *c_copy;
 255
 256   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);
 257
 258   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
 259   c_bv = SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
 260
 261   c_copy = scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
 262   memcpy (c_copy, c_bv, c_len);
 263
 264   return (make_bytevector (c_len, c_copy));
 265 }
 266 #undef FUNC_NAME
 267
 268 \f
 269 /* Operations on bytes and octets.  */
 270
 271 #define OCTET_ACCESSOR_PROLOGUE(_sign)                          \
 272   unsigned c_len, c_index;                                      \
 273   _sign char *c_bv;                                             \
 274                                                                 \
 275   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);                         \
 276   c_index = scm_to_uint (index);                                \
 277                                                                 \
 278   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);                      \
 279   c_bv = (_sign char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);      \
 280                                                                 \
 281   if (EXPECT_FALSE (c_index >= c_len))                          \
 282     scm_out_of_range (FUNC_NAME, index);
 283
 284
 285 SCM_DEFINE (scm_r6rs_bytevector_u8_ref, "bytevector-u8-ref", 2, 0, 0,
 286             (SCM bv, SCM index),
 287             "Return the octet located at @var{index} in @var{bv}.")
 288 #define FUNC_NAME s_scm_r6rs_bytevector_u8_ref
 289 {
 290   OCTET_ACCESSOR_PROLOGUE (unsigned);
 291
 292   return (SCM_I_MAKINUM (c_bv[c_index]));
 293 }
 294 #undef FUNC_NAME
 295
 296 SCM_DEFINE (scm_r6rs_bytevector_s8_ref, "bytevector-s8-ref", 2, 0, 0,
 297             (SCM bv, SCM index),
 298             "Return the byte located at @var{index} in @var{bv}.")
 299 #define FUNC_NAME s_scm_r6rs_bytevector_u8_ref
 300 {
 301   OCTET_ACCESSOR_PROLOGUE (signed);
 302
 303   return (SCM_I_MAKINUM (c_bv[c_index]));
 304 }
 305 #undef FUNC_NAME
 306
 307 SCM_DEFINE (scm_r6rs_bytevector_u8_set_x, "bytevector-u8-set!", 3, 0, 0,
 308             (SCM bv, SCM index, SCM value),
 309             "Return the octet located at @var{index} in @var{bv}.")
 310 #define FUNC_NAME s_scm_r6rs_bytevector_u8_set_x
 311 {
 312   unsigned char c_value;
 313
 314   OCTET_ACCESSOR_PROLOGUE (unsigned);
 315   c_value = scm_to_uint8 (value);
 316
 317   c_bv[c_index] = c_value;
 318
 319   return SCM_UNSPECIFIED;
 320 }
 321 #undef FUNC_NAME
 322
 323 SCM_DEFINE (scm_r6rs_bytevector_s8_set_x, "bytevector-s8-set!", 3, 0, 0,
 324             (SCM bv, SCM index, SCM value),
 325             "Return the octet located at @var{index} in @var{bv}.")
 326 #define FUNC_NAME s_scm_r6rs_bytevector_u8_set_x
 327 {
 328   unsigned char c_value;
 329
 330   OCTET_ACCESSOR_PROLOGUE (signed);
 331   c_value = scm_to_int8 (value);
 332
 333   c_bv[c_index] = c_value;
 334
 335   return SCM_UNSPECIFIED;
 336 }
 337 #undef FUNC_NAME
 338
 339 #undef OCTET_ACCESSOR_PROLOGUE
 340
 341
 342 SCM_DEFINE (scm_r6rs_bytevector_to_u8_list, "bytevector->u8-list", 1, 0, 0,
 343             (SCM bv),
 344             "Return a newly allocated list of octets containing the "
 345             "contents of @var{bv}.")
 346 #define FUNC_NAME s_scm_r6rs_bytevector_to_u8_list
 347 {
 348   SCM lst, pair;
 349   unsigned c_len, i;
 350   unsigned char *c_bv;
 351
 352   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);
 353
 354   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
 355   c_bv = (unsigned char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
 356
 357   lst = scm_make_list (scm_from_uint (c_len), SCM_UNSPECIFIED);
 358   for (i = 0, pair = lst;
 359        i < c_len;
 360        i++, pair = SCM_CDR (pair))
 361     {
 362       SCM_SETCAR (pair, SCM_I_MAKINUM (c_bv[i]));
 363     }
 364
 365   return lst;
 366 }
 367 #undef FUNC_NAME
 368
 369 SCM_DEFINE (scm_r6rs_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0,
 370             (SCM lst),
 371             "Turn @var{lst}, a list of octets, into a bytevector.")
 372 #define FUNC_NAME s_scm_r6rs_u8_list_to_bytevector
 373 {
 374   SCM item;
 375   unsigned c_len, i;
 376   unsigned char *c_bv;
 377
 378   SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len);
 379
 380   c_bv = scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
 381   for (i = 0; i < c_len; lst = SCM_CDR (lst), i++)
 382     {
 383       item = SCM_CAR (lst);
 384
 385       if (EXPECT_TRUE (SCM_I_INUMP (item)))
 386         {
 387           long c_item;
 388
 389           c_item = SCM_I_INUM (item);
 390           if (EXPECT_TRUE ((c_item >= 0) && (c_item < 256)))
 391             c_bv[i] = (unsigned char) c_item;
 392           else
 393             goto type_error;
 394         }
 395       else
 396         goto type_error;
 397     }
 398
 399   return (make_bytevector (c_len, (signed char *) c_bv));
 400
 401  type_error:
 402   scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
 403   scm_wrong_type_arg (FUNC_NAME, 1, item);
 404
 405   return SCM_BOOL_F;
 406 }
 407 #undef FUNC_NAME
 408
 409 static inline SCM
 410 bytevector_large_ref (const char *c_bv, size_t c_size, int signed_p,
 411                       SCM endianness)
 412 {
 413   mpz_t c_mpz;
 414
 415   mpz_init (c_mpz);
 416   mpz_import (c_mpz, 1 /* 1 word */, 1 /* MSW first */,
 417               c_size /* word is C_SIZE-byte long */,
 418               (scm_is_eq (endianness, scm_sym_big) ? 1 : -1),
 419               0, c_bv);
 420   mpz_clear (c_mpz);  /* FIXME: Needed? */
 421
 422   if (signed_p)
 423     {
 424       /* FIXME: Handle sign.  */
 425       abort ();
 426     }
 427
 428   return (scm_from_mpz (c_mpz));
 429 }
 430
 431 #define BV_SIGNED_signed 1
 432 #define BV_SIGNED_unsigned 0
 433
 434 #define INTEGER_REF(_sign)                                              \
 435   SCM result;                                                           \
 436   unsigned c_len, c_index, c_size;                                      \
 437   _sign char *c_bv;                                                     \
 438                                                                         \
 439   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);                                 \
 440   SCM_VALIDATE_SYMBOL (3, endianness);                                  \
 441   c_index = scm_to_uint (index);                                        \
 442   c_size = scm_to_uint (size);                                          \
 443                                                                         \
 444   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);                              \
 445   c_bv = (_sign char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);              \
 446                                                                         \
 447   if (EXPECT_FALSE (c_index + c_size >= c_len))                         \
 448     scm_out_of_range (FUNC_NAME, index);                                \
 449   if (EXPECT_FALSE (c_size == 0))                                       \
 450     scm_out_of_range (FUNC_NAME, size);                                 \
 451                                                                         \
 452                                                                         \
 453   if (c_size < 4)                                                       \
 454     {                                                                   \
 455       int swap;                                                         \
 456       unsigned int value;                                               \
 457                                                                         \
 458       swap = !scm_is_eq (endianness, native_endianness);                \
 459       switch (c_size)                                                   \
 460         {                                                               \
 461         case 1:                                                         \
 462           value = c_bv[c_index];                                        \
 463           break;                                                        \
 464         case 2:                                                         \
 465           value = *(scm_t_int16 *)&c_bv[c_index];                       \
 466           if (swap)                                                     \
 467             value = non_native_byteswap_16 (value);                     \
 468           break;                                                        \
 469         case 3:                                                         \
 470           value = *(scm_t_int32 *)&c_bv[c_index];                       \
 471           if (swap)                                                     \
 472             value = non_native_byteswap_32 (value);                     \
 473           break;                                                        \
 474         default:                                                        \
 475           abort ();                                                     \
 476         }                                                               \
 477                                                                         \
 478       result = SCM_I_MAKINUM ((_sign int) value);                       \
 479     }                                                                   \
 480   else                                                                  \
 481     result = bytevector_large_ref ((char *) c_bv + c_index,             \
 482                                    c_size,                              \
 483                                    BV_SIGNED_ ## _sign, endianness);    \
 484                                                                         \
 485   return result;
 486
 487
 488 SCM_DEFINE (scm_r6rs_bytevector_uint_ref, "bytevector-uint-ref", 2, 0, 0,
 489             (SCM bv, SCM index, SCM endianness, SCM size),
 490             "Return the @var{size}-octet long unsigned integer at index "
 491             "@var{index} in @var{bv}.")
 492 #define FUNC_NAME s_scm_r6rs_bytevector_uint_ref
 493 {
 494   INTEGER_REF (unsigned);
 495 }
 496 #undef FUNC_NAME
 497
 498 SCM_DEFINE (scm_r6rs_bytevector_sint_ref, "bytevector-sint-ref", 2, 0, 0,
 499             (SCM bv, SCM index, SCM endianness, SCM size),
 500             "Return the @var{size}-octet long unsigned integer at index "
 501             "@var{index} in @var{bv}.")
 502 #define FUNC_NAME s_scm_r6rs_bytevector_sint_ref
 503 {
 504   INTEGER_REF (signed);
 505 }
 506 #undef FUNC_NAME
 507
 508 #undef INTEGER_REF
 509 #undef BV_SIGNED_unsigned
 510 #undef BV_SIGNED_signed
 511
 512
 513 /* FIXME: Unfinished! */
 514
 515 \f
 516 /* Initialization.  */
 517
 518 void
 519 scm_init_r6rs_bytevector (void)
 520 {
 521 #include "bytevector.c.x"
 522
 523 #ifdef WORDS_BIGENDIAN
 524   native_endianness = scm_sym_big;
 525 #else
 526   native_endianness = scm_sym_little;
 527 #endif
 528 }
 529
 530 /* arch-tag: e5a30664-90fc-40d7-8036-ee767aea5fb6
 531  */