--  -----------------------------------------------------------------------
--  Title:       generic_primitive_functions
--  Last Mod:    Fri Mar 29 14:07:20 1991
--  Author:      Vincent Broman <broman@nosc.mil>
--   Copyright 1990 Vincent Broman
--     Permission granted to copy, modify, or compile this software for
--   one's own use, provided that this copyright notice is preserved intact.
--     Permission granted to distribute compiled binary copies of this
--   software which are linked in with some other application.
--     Permission granted to distribute other copies of this software,
--   provided that (1) any copy which is not source code, i.e. not in the
--   form in which the software is usually maintained, must be accompanied
--   by a copy of the source code from which it was compiled, and (2) the
--   one distributing it must refrain from imposing on the recipient
--   further restrictions on the distribution of this software.
--   
--  Visibility:  
--  Description: 
--		 functions on floating point types whose implementation
--		 depends on access to the mantissa/exponent representation
--		 of the floating point number.  this includes
--		 integer/fraction operations.
--		 
--		 you want to optimize this code so that constant-folding 
--		 and dead-code elimination can win big.
--		 
--  Exceptions:  numeric_error upon overflow of function scale,
--		 constraint_error only if type float_type is constrained.
--  -----------------------------------------------------------------------
with float_types,
     single_primitive_functions,
     double_primitive_functions;

use float_types;

package body generic_primitive_functions is
-- 

   is_single: constant boolean := float_type'digits <= single'base'digits;
   -- only other case possible is double.

   package sgl_fun renames single_primitive_functions;
   package dbl_fun renames double_primitive_functions;


   function exponent( x: float_type) return exponent_type is
--
-- return the exponent k such that 1/2 <= x/(2**k) < 1,
-- or zero for x = 0.0 .
-- 
   begin
      if is_single then
	 return exponent_type( sgl_fun.exponent( single( x)));
      else
	 return exponent_type( dbl_fun.exponent( double( x)));
      end if;
   end exponent;


   function mantissa (x: float_type) return float_type is
--
-- return scale( x, - exponent( x)) if x is nonzero,  0.0 otherwise.
--
   begin
      if is_single then
	 return float_type( sgl_fun.mantissa( single( x)));
      else
	 return float_type( dbl_fun.mantissa( double( x)));
      end if;
   end mantissa;
      

   function scale (x: float_type;
		   k: exponent_type) return float_type is
--
-- return x * 2**k quickly, or quietly underflow to zero,
-- or raise an exception on overflow.
-- 
   begin
      if is_single then
	 return float_type( sgl_fun.scale( single( x), integer( k)));
      else
	 return float_type( dbl_fun.scale( double( x), integer( k)));
      end if;
   end scale;


   function leading_part (x: float_type;
      	       	     	  k: exponent_type) return float_type is
-- 
-- set all but the k most significant bits in the mantissa of x to zero,
-- i.e. reduce the precision to k bits, truncating, not rounding.
-- leading_part( x, k) = 0.0 if k < 1 and
-- leading_part( x, k) = x   if k >= float_type'machine_mantissa.
-- 
   begin
      if is_single then
      	 return float_type( sgl_fun.leading_part( single( x), integer( k)));
      else
      	 return float_type( dbl_fun.leading_part( double( x), integer( k)));
      end if;
   end leading_part;


   function odd (x: float_type) return boolean is
--
-- predicate indicates whether or not truncate( x) is an odd integer.
--
   begin
      if is_single then
      	 return sgl_fun.odd( single( x));
      else
      	 return dbl_fun.odd( double( x));
      end if;
   end odd;


   function truncate (x: float_type) return float_type is
--
-- truncate x to the nearest integer value with absolute value
-- not exceeding abs( x).  No conversion to an integer type
-- is expected, so truncate cannot overflow for large arguments.
--
   begin
      if is_single then
      	 return float_type( sgl_fun.truncate( single( x)));
      else
      	 return float_type( dbl_fun.truncate( double( x)));
      end if;
   end truncate;


--
-- all the other integer/fraction functions are based on truncate.
--

   function floor (x: float_type) return float_type is
--
-- return as a float_type the greatest integer value <= x.
--
   begin
      if is_single then
      	 return float_type( sgl_fun.floor( single( x)));
      else
      	 return float_type( dbl_fun.floor( double( x)));
      end if;
   end floor;


   function ceiling (x: float_type) return float_type is
--
-- return as a float_type the least integer value >= x.
--
   begin
      if is_single then
      	 return float_type( sgl_fun.ceiling( single( x)));
      else
      	 return float_type( dbl_fun.ceiling( double( x)));
      end if;
   end ceiling;


   function round (x: float_type) return float_type is
--
-- return as a float_type the integer value nearest x.
-- in case of a tie, prefer the even value.
--
   begin
      if is_single then
      	 return float_type( sgl_fun.round( single( x)));
      else
      	 return float_type( dbl_fun.round( double( x)));
      end if;
   end round;


   function "rem"( x, y: float_type) return float_type is
--
-- returns the machine-representable value closest to
-- x - y * round( x/ y), evaluated with exact arithmetic.
-- The result is exact, except for y near zero,
-- and only if the implementation does not handle denormalized numbers.
-- numeric_error is raised if y = 0.0 .
-- 
   begin
      if is_single then
	 return float_type( sgl_fun."rem"( single( x),
					   single( y)));
      else
	 return float_type( dbl_fun."rem"( double( x),
					   double( y)));
      end if;
   end "rem";


   function adjacent( x: float_type;
		      towards: float_type) return float_type is
--
-- returns x if x = towards, otherwise returns the float_point number
-- nearest to x in the direction toward towards.
--
   begin
      if is_single then
	 return float_type( sgl_fun.adjacent( single( x),
					      single( towards)));
      else
	 return float_type( dbl_fun.adjacent( double( x),
					      double( towards)));
      end if;
   end adjacent;


   function successor( x: float_type) return float_type is
--
-- return the next floating point number greater than x,
-- or overflow if x = float_type'base'last.
--
   begin
      if is_single then
      	 return float_type( sgl_fun.successor( single( x)));
      else
      	 return float_type( dbl_fun.successor( double( x)));
      end if;
   end successor;


   function predecessor( x: float_type) return float_type is
--
-- return the next floating point number less than x,
-- or overflow if x = float_type'base'first.
--
   begin
      if is_single then
      	 return float_type( sgl_fun.predecessor( single( x)));
      else
      	 return float_type( dbl_fun.predecessor( double( x)));
      end if;
   end predecessor;


   function copy_sign( value: float_type;
		       sign: float_type) return float_type is
-- 
-- returns abs( value) with the sign of sign, i.e.
-- when sign > 0.0 or sign = +0.0   returns abs( value),
-- when sign < 0.0 or sign = -0.0   returns - abs( value).
-- 
   begin
      if is_single then
	 return float_type( sgl_fun.copy_sign( single( value),
					       single( sign)));
      else
	 return float_type( dbl_fun.copy_sign( double( value),
					       double( sign)));
      end if;
   end copy_sign;


   function multiply_sign( value: float_type;
      	       	     	   sign: float_type) return float_type is
-- 
-- returns value multiplied by the sign of sign, i.e.
-- when sign > 0.0 or sign = +0.0   returns value,
-- when sign < 0.0 or sign = -0.0   returns - value.
-- 
   begin
      if is_single then
	 return float_type( sgl_fun.multiply_sign( single( value),
					       	   single( sign)));
      else
	 return float_type( dbl_fun.multiply_sign( double( value),
					       	   double( sign)));
      end if;
   end multiply_sign;


end generic_primitive_functions;

-- $Header: g2_primitive_functions_b.a,v 3.23 91/03/29 15:32:08 broman Stab $