guile18/srfi/srfi-60.c

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