/* These three macro procedures implement the equivalents of the Fortran */
/* functions BTEST, IBSET, and IBCLR. */
/* There are companion procedures that do not require the macro processor */
/* but they are not as efficient. */
/* Copyright (c) 2001 by R. A. Vowels.  Date written 10/11/2001. */

   %declare precision character;
   %precision = 31;

/* In the following procedures, the bit position <p> is measured from the */
/* least-significant end of the integer; bits number from 0 through <precision>. */

/* Test bit <p> of integer <a>. The result is BIT(1). */
%btest:
   procedure (a, p) returns (character);
      declare (a, p) character;

      return ( '(iand (' || a ||', isll (1,' || p || ')) ^= 0)' );
   %end btest;

/* Set bit <p> of integer <a>. The result is FIXED BINARY. */
%ibset:
   procedure (a, p) returns (character);
      declare (a, p) character;

      return( 'ior (' ||a || ', isll (1,' || p || '))' );
   %end ibset;

/* Clear bit <p> of integer <a>. The result is FIXED BINARY. */
%ibclr:
   procedure (a, p) returns (character);
      declare (a, p) character;

      return ( 'iand (' || a || ', inot(isll (1,' || p || ')))' );
   %end ibclr;

/* Extract <len> bits from a binary integer value, beginning at bit <p>.   */
/* Bits in positions <p> through positions <p> + <len> - 1 are taken.      */
/* The extracted bits are then brought to the least significant end of the */
/* integer.                                                                */
%ibits:
   procedure (a, p, len) returns (character);
      declare (a, p, len) character;

      return ( 'iand ( isrl(' || a || ',' || p || '), isrl (-1,' || precision-len-p+2 || '))' );
   %end ibits;

   declare ishftc generic (
      ishftc2 when (*, *),
      ishftc3 when (*, *, *));
/* Perforns a circular shift to the left or to the right.         */
/* If No_Positions > 0, the shift is <No_Positions> to the left;  */
/* otherwise the shift is <No_Positions> to the right.            */
/* Date written 16 November 2001.                                 */

(nofixedoverflow):
ishftc2:
   procedure (a, No_Positions) returns (fixed binary (precision));
      declare a fixed binary (precision), No_positions fixed binary (7);

      if No_Positions > 0 then
         return ( ior (isll(a, No_Positions), isrl (a, precision+1-No_Positions)));
      else
         return ( ior (isrl(a, No_Positions), isll (a, precision+1-No_Positions)));
   end ishftc2;

/* Performs a circular shift of the <len> least-significant bits. */
/* If No_Positions > 0, the shift is <No_Positions> to the left;  */
/* otherwise the shift is <No_Positions> to the right.            */
/* Date written 16 November 2001.                                 */
(nofixedoverflow):
ishftc3:
   procedure (a, No_Positions, len) returns (fixed binary (precision));
      declare a fixed binary (precision), No_positions fixed binary (7);
      declare len fixed binary (precision);
      declare (upper_bits, lower_bits, mask) fixed binary (precision);

      if len > precision then return (ishftc(a, No_Positions));

      mask = isrl(-1, precision+1-len);
      lower_bits = iand(a, mask);
      upper_bits = iand(a, inot(mask));

      if No_Positions > 0 then
         return ( ior (upper_bits,
                       iand(isll(lower_bits, No_Positions), mask),
                            isrl (lower_bits, len-No_Positions)));
      else
         return ( ior (upper_bits,
                       iand(isll(lower_bits, len+No_Positions), mask),
                            isrl (lower_bits, -No_Positions)));
   end ishftc3;

   %activate btest, ibset, ibclr, ibits;