libguile/srfi-60.c

   1 /* srfi-60.c --- Integers as Bits
   2  *
   3  * Copyright (C) 2005, 2006, 2008, 2010, 2014 Free Software Foundation, Inc.
   4  *
   5  * This library is free software; you can redistribute it and/or
   6  * modify it under the terms of the GNU Lesser General Public License
   7  * as published by the Free Software Foundation; either version 3 of
   8  * the License, or (at your option) any later version.
   9  *
  10  * This library is distributed in the hope that it will be useful, but
  11  * WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13  * Lesser General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU Lesser General Public
  16  * License along with this library; if not, write to the Free Software
  17  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  18  * 02110-1301 USA
  19  */
  20
  21
  22 \f
  23 #ifdef HAVE_CONFIG_H
  24 # include <config.h>
  25 #endif
  26
  27 #include "libguile/_scm.h"
  28 #include "libguile/eq.h"
  29
  30 #include "libguile/validate.h"
  31 #include "libguile/numbers.h"
  32
  33 #include "libguile/srfi-60.h"
  34
  35
  36 SCM_DEFINE (scm_srfi60_log2_binary_factors, "log2-binary-factors", 1, 0, 0,
  37             (SCM n),
  38             "Return a count of how many factors of 2 are present in @var{n}.\n"
  39             "This is also the bit index of the lowest 1 bit in @var{n}.  If\n"
  40             "@var{n} is 0, the return is @math{-1}.\n"
  41             "\n"
  42             "@example\n"
  43             "(log2-binary-factors 6) @result{} 1\n"
  44             "(log2-binary-factors -8) @result{} 3\n"
  45             "@end example")
  46 #define FUNC_NAME s_scm_srfi60_log2_binary_factors
  47 {
  48   SCM ret = SCM_EOL;
  49
  50   if (SCM_I_INUMP (n))
  51     {
  52       long nn = SCM_I_INUM (n);
  53       if (nn == 0)
  54         return SCM_I_MAKINUM (-1);
  55       nn = nn ^ (nn-1);  /* 1 bits for each low 0 and lowest 1 */
  56       return scm_logcount (SCM_I_MAKINUM (nn >> 1));
  57     }
  58   else if (SCM_BIGP (n))
  59     {
  60       /* no need for scm_remember_upto_here_1 here, mpz_scan1 doesn't do
  61          anything that could result in a gc */
  62       return SCM_I_MAKINUM (mpz_scan1 (SCM_I_BIG_MPZ (n), 0L));
  63     }
  64   else
  65     SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
  66
  67   return ret;
  68 }
  69 #undef FUNC_NAME
  70
  71
  72 SCM_DEFINE (scm_srfi60_copy_bit, "copy-bit", 3, 0, 0,
  73             (SCM index, SCM n, SCM newbit),
  74             "Return @var{n} with the bit at @var{index} set according to\n"
  75             "@var{newbit}.  @var{newbit} should be @code{#t} to set the bit\n"
  76             "to 1, or @code{#f} to set it to 0.  Bits other than at\n"
  77             "@var{index} are unchanged in the return.\n"
  78             "\n"
  79             "@example\n"
  80             "(copy-bit 1 #b0101 #t) @result{} 7\n"
  81             "@end example")
  82 #define FUNC_NAME s_scm_srfi60_copy_bit
  83 {
  84   SCM r;
  85   unsigned long ii;
  86   int bb;
  87
  88   ii = scm_to_ulong (index);
  89   bb = scm_to_bool (newbit);
  90
  91   if (SCM_I_INUMP (n))
  92     {
  93       long nn = SCM_I_INUM (n);
  94
  95       /* can't set high bit ii==SCM_LONG_BIT-1, that would change the sign,
  96          which is not what's wanted */
  97       if (ii < SCM_LONG_BIT-1)
  98         {
  99           nn &= ~(1L << ii);  /* zap bit at index */
 100           nn |= ((long) bb << ii);   /* insert desired bit */
 101           return scm_from_long (nn);
 102         }
 103       else
 104         {
 105           /* bits at ii==SCM_LONG_BIT-1 and above are all copies of the sign
 106              bit, if this is already the desired "bit" value then no need to
 107              make a new bignum value */
 108           if (bb == (nn < 0))
 109             return n;
 110
 111           r = scm_i_long2big (nn);
 112           goto big;
 113         }
 114     }
 115   else if (SCM_BIGP (n))
 116     {
 117       /* if the bit is already what's wanted then no need to make a new
 118          bignum */
 119       if (bb == mpz_tstbit (SCM_I_BIG_MPZ (n), ii))
 120         return n;
 121
 122       r = scm_i_clonebig (n, 1);
 123     big:
 124       if (bb)
 125         mpz_setbit (SCM_I_BIG_MPZ (r), ii);
 126       else
 127         mpz_clrbit (SCM_I_BIG_MPZ (r), ii);
 128
 129       /* changing a high bit might put the result into range of a fixnum */
 130       return scm_i_normbig (r);
 131     }
 132   else
 133     SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
 134 }
 135 #undef FUNC_NAME
 136
 137
 138 SCM_DEFINE (scm_srfi60_rotate_bit_field, "rotate-bit-field", 4, 0, 0,
 139             (SCM n, SCM count, SCM start, SCM end),
 140             "Return @var{n} with the bit field from @var{start} (inclusive)\n"
 141             "to @var{end} (exclusive) rotated upwards by @var{count} bits.\n"
 142             "\n"
 143             "@var{count} can be positive or negative, and it can be more\n"
 144             "than the field width (it'll be reduced modulo the width).\n"
 145             "\n"
 146             "@example\n"
 147             "(rotate-bit-field #b0110 2 1 4) @result{} #b1010\n"
 148             "@end example")
 149 #define FUNC_NAME s_scm_srfi60_rotate_bit_field
 150 {
 151   unsigned long ss = scm_to_ulong (start);
 152   unsigned long ee = scm_to_ulong (end);
 153   unsigned long ww, cc;
 154
 155   SCM_ASSERT_RANGE (3, end, (ee >= ss));
 156   ww = ee - ss;
 157
 158   /* we must avoid division by zero, and a field whose width is 0 or 1
 159      will be left unchanged anyway, so in that case we set cc to 0. */
 160   if (ww <= 1)
 161     cc = 0;
 162   else
 163     cc = scm_to_ulong (scm_modulo (count, scm_difference (end, start)));
 164
 165   if (SCM_I_INUMP (n))
 166     {
 167       long nn = SCM_I_INUM (n);
 168
 169       if (ee <= SCM_LONG_BIT-1)
 170         {
 171           /* Everything fits within a long.  To avoid undefined behavior
 172              when shifting negative numbers, we do all operations using
 173              unsigned values, and then convert to signed at the end. */
 174           unsigned long unn = nn;
 175           unsigned long below = unn &  ((1UL << ss) - 1);  /* below start */
 176           unsigned long above = unn & ~((1UL << ee) - 1);  /* above end */
 177           unsigned long fmask = ((1UL << ww) - 1) << ss;   /* field mask */
 178           unsigned long ff = unn & fmask;                  /* field */
 179           unsigned long uresult = (above
 180                                    | ((ff << cc) & fmask)
 181                                    | ((ff >> (ww-cc)) & fmask)
 182                                    | below);
 183           long result;
 184
 185           if (uresult > LONG_MAX)
 186             /* The high bit is set in uresult, so the result is
 187                negative.  We have to handle the conversion to signed
 188                integer carefully, to avoid undefined behavior.  First we
 189                compute ~uresult, equivalent to (ULONG_MAX - uresult),
 190                which will be between 0 and LONG_MAX (inclusive): exactly
 191                the set of numbers that can be represented as both signed
 192                and unsigned longs and thus convertible between them.  We
 193                cast that difference to a signed long and then substract
 194                it from -1. */
 195             result = -1 - (long) ~uresult;
 196           else
 197             result = (long) uresult;
 198
 199           return scm_from_long (result);
 200         }
 201       else
 202         {
 203           /* if there's no movement, avoid creating a bignum. */
 204           if (cc == 0)
 205             return n;
 206
 207           n = scm_i_long2big (nn);
 208           goto big;
 209         }
 210     }
 211   else if (SCM_BIGP (n))
 212     {
 213       mpz_t tmp;
 214       SCM r;
 215
 216       /* if there's no movement, avoid creating a new bignum. */
 217       if (cc == 0)
 218         return n;
 219
 220     big:
 221       r = scm_i_ulong2big (0);
 222       mpz_init (tmp);
 223
 224       /* portion above end */
 225       mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (n), ee);
 226       mpz_mul_2exp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), ee);
 227
 228       /* field high part, width-count bits from start go to start+count */
 229       mpz_fdiv_q_2exp (tmp, SCM_I_BIG_MPZ (n), ss);
 230       mpz_fdiv_r_2exp (tmp, tmp, ww - cc);
 231       mpz_mul_2exp (tmp, tmp, ss + cc);
 232       mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp);
 233
 234       /* field low part, count bits from end-count go to start */
 235       mpz_fdiv_q_2exp (tmp, SCM_I_BIG_MPZ (n), ee - cc);
 236       mpz_fdiv_r_2exp (tmp, tmp, cc);
 237       mpz_mul_2exp (tmp, tmp, ss);
 238       mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp);
 239
 240       /* portion below start */
 241       mpz_fdiv_r_2exp (tmp, SCM_I_BIG_MPZ (n), ss);
 242       mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp);
 243
 244       mpz_clear (tmp);
 245
 246       /* bits moved around might leave us in range of an inum */
 247       return scm_i_normbig (r);
 248     }
 249   else
 250     SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
 251 }
 252 #undef FUNC_NAME
 253
 254
 255 SCM_DEFINE (scm_srfi60_reverse_bit_field, "reverse-bit-field", 3, 0, 0,
 256             (SCM n, SCM start, SCM end),
 257             "Return @var{n} with the bits between @var{start} (inclusive) to\n"
 258             "@var{end} (exclusive) reversed.\n"
 259             "\n"
 260             "@example\n"
 261             "(reverse-bit-field #b101001 2 4) @result{} #b100101\n"
 262             "@end example")
 263 #define FUNC_NAME s_scm_srfi60_reverse_bit_field
 264 {
 265   long ss = scm_to_long (start);
 266   long ee = scm_to_long (end);
 267   long swaps = (ee - ss) / 2;  /* number of swaps */
 268   SCM b;
 269
 270   if (SCM_I_INUMP (n))
 271     {
 272       long nn = SCM_I_INUM (n);
 273
 274       if (ee <= SCM_LONG_BIT-1)
 275         {
 276           /* all within a long */
 277           long smask = 1L << ss;
 278           long emask = 1L << (ee-1);
 279           for ( ; swaps > 0; swaps--)
 280             {
 281               long sbit = nn & smask;
 282               long ebit = nn & emask;
 283               nn ^= sbit ^ (ebit ? smask : 0)  /* zap sbit, put ebit value */
 284                 ^   ebit ^ (sbit ? emask : 0); /* zap ebit, put sbit value */
 285
 286               smask <<= 1;
 287               emask >>= 1;
 288             }
 289           return scm_from_long (nn);
 290         }
 291       else
 292         {
 293           /* avoid creating a new bignum if reversing only 0 or 1 bits */
 294           if (ee - ss <= 1)
 295             return n;
 296
 297           b = scm_i_long2big (nn);
 298           goto big;
 299         }
 300     }
 301   else if (SCM_BIGP (n))
 302     {
 303       /* avoid creating a new bignum if reversing only 0 or 1 bits */
 304       if (ee - ss <= 1)
 305         return n;
 306
 307       b = scm_i_clonebig (n, 1);
 308     big:
 309
 310       ee--;
 311       for ( ; swaps > 0; swaps--)
 312         {
 313           int sbit = mpz_tstbit (SCM_I_BIG_MPZ (b), ss);
 314           int ebit = mpz_tstbit (SCM_I_BIG_MPZ (b), ee);
 315           if (sbit ^ ebit)
 316             {
 317               /* the two bits are different, flip them */
 318               if (sbit)
 319                 {
 320                   mpz_clrbit (SCM_I_BIG_MPZ (b), ss);
 321                   mpz_setbit (SCM_I_BIG_MPZ (b), ee);
 322                 }
 323               else
 324                 {
 325                   mpz_setbit (SCM_I_BIG_MPZ (b), ss);
 326                   mpz_clrbit (SCM_I_BIG_MPZ (b), ee);
 327                 }
 328             }
 329           ss++;
 330           ee--;
 331         }
 332       /* swapping zero bits into the high might make us fit a fixnum */
 333       return scm_i_normbig (b);
 334     }
 335   else
 336     SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
 337 }
 338 #undef FUNC_NAME
 339
 340
 341 SCM_DEFINE (scm_srfi60_integer_to_list, "integer->list", 1, 1, 0,
 342             (SCM n, SCM len),
 343             "Return bits from @var{n} in the form of a list of @code{#t} for\n"
 344             "1 and @code{#f} for 0.  The least significant @var{len} bits\n"
 345             "are returned, and the first list element is the most\n"
 346             "significant of those bits.  If @var{len} is not given, the\n"
 347             "default is @code{(integer-length @var{n})} (@pxref{Bitwise\n"
 348             "Operations}).\n"
 349             "\n"
 350             "@example\n"
 351             "(integer->list 6)   @result{} (#t #t #f)\n"
 352             "(integer->list 1 4) @result{} (#f #f #f #t)\n"
 353             "@end example")
 354 #define FUNC_NAME s_scm_srfi60_integer_to_list
 355 {
 356   SCM ret = SCM_EOL;
 357   unsigned long ll, i;
 358
 359   if (SCM_UNBNDP (len))
 360     len = scm_integer_length (n);
 361   ll = scm_to_ulong (len);
 362
 363   if (SCM_I_INUMP (n))
 364     {
 365       long nn = SCM_I_INUM (n);
 366       for (i = 0; i < ll; i++)
 367         {
 368           unsigned long shift =
 369             (i < ((unsigned long) SCM_LONG_BIT-1))
 370             ? i : ((unsigned long) SCM_LONG_BIT-1);
 371           int bit = (nn >> shift) & 1;
 372           ret = scm_cons (scm_from_bool (bit), ret);
 373         }
 374     }
 375   else if (SCM_BIGP (n))
 376     {
 377       for (i = 0; i < ll; i++)
 378         ret = scm_cons (scm_from_bool (mpz_tstbit (SCM_I_BIG_MPZ (n), i)),
 379                         ret);
 380       scm_remember_upto_here_1 (n);
 381     }
 382   else
 383     SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
 384
 385   return ret;
 386 }
 387 #undef FUNC_NAME
 388
 389
 390 SCM_DEFINE (scm_srfi60_list_to_integer, "list->integer", 1, 0, 0,
 391             (SCM lst),
 392             "Return an integer formed bitwise from the given @var{lst} list\n"
 393             "of booleans.  Each boolean is @code{#t} for a 1 and @code{#f}\n"
 394             "for a 0.  The first element becomes the most significant bit in\n"
 395             "the return.\n"
 396             "\n"
 397             "@example\n"
 398             "(list->integer '(#t #f #t #f)) @result{} 10\n"
 399             "@end example")
 400 #define FUNC_NAME s_scm_srfi60_list_to_integer
 401 {
 402   long len;
 403
 404   /* strip high zero bits from lst; after this the length tells us whether
 405      an inum or bignum is required */
 406   while (scm_is_pair (lst) && scm_is_false (SCM_CAR (lst)))
 407     lst = SCM_CDR (lst);
 408
 409   SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, lst, len);
 410
 411   if (len <= SCM_I_FIXNUM_BIT - 1)
 412     {
 413       /* fits an inum (a positive inum) */
 414       long n = 0;
 415       while (scm_is_pair (lst))
 416         {
 417           n <<= 1;
 418           if (! scm_is_false (SCM_CAR (lst)))
 419             n++;
 420           lst = SCM_CDR (lst);
 421         }
 422       return SCM_I_MAKINUM (n);
 423     }
 424   else
 425     {
 426       /* need a bignum */
 427       SCM n = scm_i_ulong2big (0);
 428       while (scm_is_pair (lst))
 429         {
 430           len--;
 431           if (! scm_is_false (SCM_CAR (lst)))
 432             mpz_setbit (SCM_I_BIG_MPZ (n), len);
 433           lst = SCM_CDR (lst);
 434         }
 435       return n;
 436     }
 437 }
 438 #undef FUNC_NAME
 439
 440
 441 /* note: don't put "scm_srfi60_list_to_integer" arg on its own line, a
 442    newline breaks the snarfer */
 443 SCM_REGISTER_PROC (s_srfi60_booleans_to_integer, "booleans->integer", 0, 0, 1, scm_srfi60_list_to_integer);
 444
 445
 446 void
 447 scm_register_srfi_60 (void)
 448 {
 449   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
 450                             "scm_init_srfi_60",
 451                             (scm_t_extension_init_func)scm_init_srfi_60, NULL);
 452 }
 453
 454 void
 455 scm_init_srfi_60 (void)
 456 {
 457 #ifndef SCM_MAGIC_SNARFER
 458 #include "libguile/srfi-60.x"
 459 #endif
 460 }