ash using shifts (was: ratio implementation)

[Kevin Ryde <user42@zip.com.au>]

[-- Attachment #1: Type: text/plain, Size: 256 bytes --]

Speaking of ash, the bit of code below is what I'm looking at for
shifts instead of mul or div.  Untested as yet, but hopefully not too
far wrong.  Anyone who wants to take it forward should feel free ...
or kick it into touch and do something different.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: ash.c --]
[-- Type: text/x-csrc, Size: 3395 bytes --]

SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
            (SCM n, SCM cnt),
	    "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
	    "if @var{cnt} is negative.  This is an ``arithmetic'' shift.\n"
	    "\n"
	    "This is effectively a multiplication by @m{2^{cnt},\n"
	    "2^@var{cnt}}, and when @var{cnt} is negative it's a division,\n"
	    "rounded towards negative infinity.  (Note that this is not the\n"
	    "same rounding as @code{quotient} does.)\n"
	    "\n"
	    "With @var{n} viewed as an infinite precision twos complement,\n"
	    "@code{ash} means a left shift introducing zero bits, or a right\n"
	    "shift dropping bits.\n"
	    "\n"
	    "@lisp\n"
	    "(number->string (ash #b1 3) 2)     @result{} \"1000\"\n"
	    "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
	    "\n"
	    ";; -23 is bits ...11101001, -6 is bits ...111010\n"
	    "(ash -23 -2) @result{} -6\n"
	    "@end lisp")
#define FUNC_NAME s_scm_ash
{
  long  bits_to_shift;
  SCM_VALIDATE_INUM (2, cnt);
  bits_to_shift = SCM_INUM (cnt);

  if (SCM_INUMP (y)) {
    long in = SCM_INUM (n);

    if (bits_to_shift > 0)
      {
        /* Left shift of more than SCM_I_FIXNUM_BIT-1 will certainly
           overflow a non-zero fixnum.  For smaller shifts we check the bits
           going into positions above SCM_I_FIXNUM_BIT-1.  If they're all 0s
           for in>=0, or all 1s for in<0 then there's no overflow.  Those
           bits are "in >> (SCM_I_FIXNUM_BIT-1 - bits_to_shift".  */

        if (in == 0)
          return n;

        /* FIXME: This relies on signed right shifts being arithmetic, which
           is not guaranteed by C99.  */
        if (bits_to_shift < SCM_I_FIXNUM_BIT-1
            && ((unsigned long) ((in >> (SCM_I_FIXNUM_BIT-1 - bits_to_shift))
                                 + 1 <= 1)))
          {
            return SCM_MKINUM (in << bits_to_shift);
          }
        else
          {
            SCM result = scm_i_long2big (z);
            mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
                          bits_to_shift);
            return result;
          }
      }
    else
      {
        bits_to_shift = -bits_to_shift;
        if (bits_to_shift >= LONG_BIT)
          return (in >= ? 0 : -1);
        else
          {
            /* FIXME: This relies on signed right shifts being arithmetic,
               which is not guaranteed by C99.  */
            return SCM_MKINUM (in >> bits_to_shift);
          }
      }

  } else if (SCM_BIGP (n)) {
    SCM result;

    if (bits_to_shift == 0)
      return n;

    result = scm_i_mkbig ();
    if (bits_to_shift >= 0)
      {
        mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n),
                      bits_to_shift);
        return result;
      }
    else
      {
        /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
           we have to allocate a bignum even if the result is going to be a
           fixnum.  We could detect the case of bits_to_shift being so big
           as to leave us with only 0 or -1, and avoid allocating a bignum,
           but that doesn't seem worth worrying about.  */
        mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n),
                         -bits_to_shift);
        return scm_i_normbig (result);
      }

  } else {
    SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
  }
}
#undef FUNC_NAME

[-- Attachment #3: Type: text/plain, Size: 142 bytes --]

_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-devel