Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/math/logical.ada

Text File | 1988-05-03 | 8.4 KB | 242 lines

-------- SIMTEL20 Ada Software Repository Prologue ------------
--                                                           -*
-- Unit name    : package LOGICAL
-- Version      : 1.0
-- Author       : Joseph M. Orost
--              : Concurrent Computer Corporation
--              : 106 Apple St.
--              : Tinton Falls, NJ  07724
-- DDN Address  : vax135!petsd!joe@BERKELEY
-- Copyright    : ** not copyright **
-- Date created :  June 1, 1986
-- Release date :  June 13, 1986
-- Last update  :
-- Machine/System Compiled/Run on : CCUR_3200MPS, C3-Ada R00-00
--                                                           -*
---------------------------------------------------------------
--                                                           -*
-- Keywords     :  LOGICAL OPERATIONS
--
-- Abstract     :  This package provides logical operations
----------------:  such as AND, OR, XOR, NOT, SHIFT, ROTATE,
----------------:  on operands of type INTEGER.  It is portable
----------------:  to any two's complement machine.  For
----------------:  increased efficiency, the body can be
----------------:  re-implemented via PRAGMA interface(assembler.
--                                                           -*
------------------ Revision history ---------------------------
--                                                           -*
-- DATE         VERSION    AUTHOR                  HISTORY
-- 06/13/86      1.0    Orost           Initial Release
--                                                           -*
------------------ Distribution and Copyright -----------------
--                                                           -*
-- This software is released to the Ada community.
-- This software is released to the Public Domain (note:
--   software released to the Public Domain is not subject
--   to copyright protection).
-- Restrictions on use or distribution:  NONE
--                                                           -*
------------------ Disclaimer ---------------------------------
--                                                           -*
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered.  The user is advised to
-- test the software thoroughly before relying on it.  The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
--                                                           -*
-------------------END-PROLOGUE--------------------------------

package logical is

   -- return arg rotated count bits.
   -- If count < 0, rotate is to the right,
   -- else, rotate is to the left.
   function rotate(arg, count : integer) return integer;

   -- return arg logically shifted count bits.
   -- bits shifted out either end are lost
   -- If count < 0, shift is to the right,
   -- else, shift is to the left
   function shift(arg, count : integer) return integer;

   -- return left XOR right
   function "xor"(left, right : integer) return integer;

   --return left AND right
   function "and"(left, right : integer) return integer;

   --return left OR right
   function "or" (left, right : integer) return integer;

   --return NOT right
   function "not"(right       : integer) return integer;
end logical;
---
package body logical is

   -- These functions work on all two's complement machines
   -- where -integer'last-1 = integer'first

   two_to_the_i : array(integer(0)..integer(integer'size-1)) of integer;

   --Utility function to rotate left
   function rotate(arg, count : integer) return integer is
      result : integer := arg;
      big      : CONSTANT integer := integer'last/2+1;
      c        : integer := count;
   begin
      if c < 0 then
         c := integer'size + c;
      end if;
      for i in 1..(c MOD integer'size) loop
     if result < 0 then                     -- -16#80000000#..-1
        result := result + big;
        if result >= 0 then
           result := result * 2 - integer'last;
        else
           result := (result + big) * 2 + 1;
        end if;
     elsif result < big then       -- 0 .. 16#3FFFFFFF#
        result := result * 2;
     else                          -- 16#40000000#..16#7FFFFFFF#
        result := (result - big) * 2 - integer'last;
            result := result - 1;
     end if;
      end loop;
      return result;
   end rotate;
   --
   --Utility function to logical shift
   function shift(arg, count : integer) return integer is
      result : integer := arg;
      big      : CONSTANT integer := integer'last/2+1;
      c        : integer;
   begin -- shift
      if count < 0 then                  --shift to the right
         c := -count;
         if c >= integer'size then
            return 0;
         end if;
     if result >= 0 then
        result := result / two_to_the_i(c);
     else
            result := result + integer'last;
        result := (result + 1) / two_to_the_i(c) +
              big / two_to_the_i(c - 1);
     end if;
      elsif count > 0 then                --shift to the left
         if count >= integer'size then
            return 0;
         end if;
         for i in 1..count loop
            if result < 0 then   --top bit gets shifted out
               result := result + integer'last;
               result := result + 1;
            end if;
            if result >= big then
               result := ((result - big) * 2 - integer'last);
               result := result - 1;
            else
               result := result * 2;
            end if;
         end loop;
      end if;
      return result;
   end shift;
   --
   --Utility function to logical shift right 1
   function shift_right_1(arg : integer) return integer is
      result : integer := arg;
      big      : CONSTANT integer := integer'last/2+1;
   begin -- shift_right_1
      if result >= 0 then
     result := result / 2;
      else
         result := result + integer'last;
     result := (result + 1) / 2 + big;
      end if;
      return result;
   end shift_right_1;
   --
   --Utility function to exclusive or
   function "xor"(left, right : integer) return integer is
      result : integer := 0;
      a1 : integer := left;
      a2 : integer := right;
   begin -- "xor"
      for i in integer(0)..integer'size-1 loop
     result := shift_right_1(result);
     if a1 MOD 2 /= a2 MOD 2 then
            result := result - integer'last;
        result := result - 1;
     end if;
     a1 := shift_right_1(a1);
     a2 := shift_right_1(a2);
      end loop;
      return result;
   end "xor";
   --
   --Utility function to and
   function "and"(left, right : integer) return integer is
      result : integer := 0;
      a1 : integer := left;
      a2 : integer := right;
   begin -- "and"
      for i in integer(0)..integer'size-1 loop
     result := shift_right_1(result);
     if (a1 MOD 2) + (a2 MOD 2) = 2 then
            result := result - integer'last;
        result := result - 1;
     end if;
     a1 := shift_right_1(a1);
     a2 := shift_right_1(a2);
      end loop;
      return result;
   end "and";
   --
   --Utility function to or
   function "or"(left, right : integer) return integer is
      result : integer := 0;
      a1 : integer := left;
      a2 : integer := right;
   begin -- "or"
      for i in integer(0)..integer'size-1 loop
     result := shift_right_1(result);
     if (a1 MOD 2) + (a2 MOD 2) /= 0 then
            result := result - integer'last;
        result := result - 1;
     end if;
     a1 := shift_right_1(a1);
     a2 := shift_right_1(a2);
      end loop;
      return result;
   end "or";
   --
   function "not"(right : integer) return integer is
   begin
      if right /= integer'first and then
         right /= integer'first + 1 then
         return (-1)-right;
      else
         return -(right + 1);
      end if;
   end "not";
   --
begin
   for i in two_to_the_i'first..two_to_the_i'last-1 loop
      two_to_the_i(i) := 2**i;
   end loop;
   two_to_the_i(two_to_the_i'last) := (-2)**two_to_the_i'last;
end logical;