-------------------------------------------------------------------------------
-- (C) Altran Praxis Limited
-------------------------------------------------------------------------------
--
-- The SPARK toolset is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
-- Software Foundation; either version 3, or (at your option) any later
-- version. The SPARK toolset is distributed in the hope that it will be
-- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
-- Public License for more details. You should have received a copy of the GNU
-- General Public License distributed with the SPARK toolset; see file
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy of
-- the license.
--
--=============================================================================

-- This    procedure    is    to   expression    evaluation    what       --
-- CheckBinaryOperator  is to  type  checking.  It  is called  from       --
-- wf_term, wf_simple_expression, wf_relation, wf_expression  and         --
-- wf_factor  to  calculate   effect  of  binary  operators.   This       --
-- procedure    is    called    immediately    after    calls    to       --
-- CheckBinaryOperator  so  that   if  the  sub-expression  is  not       --
-- wellformed  then Result  =  Unknown_Type_Record on  entry to  this       --
-- procedure.                                                             --
----------------------------------------------------------------------------

separate (Sem.Walk_Expression_P)
procedure Calc_Binary_Operator
  (Node_Pos            : in     LexTokenManager.Token_Position;
   Operator            : in     SP_Symbols.SP_Symbol;
   Left_Val, Right_Val : in     Maths.Value;
   Is_Annotation       : in     Boolean;
   Result              : in out Sem.Exp_Record)
is

   type Err_Lookup is array (Boolean) of Natural;
   Which_Err : constant Err_Lookup := Err_Lookup'(False => 402,
                                                  True  => 399);

   Err : Maths.ErrorCode;
   Ans : Maths.Value;

   procedure Apply_Modulus_If_Necessary (Result : in     Sem.Exp_Record;
                                         Ans    : in out Maths.Value;
                                         Err    : in out Maths.ErrorCode)
   --# global in Dictionary.Dict;
   --#        in LexTokenManager.State;
   --# derives Ans,
   --#         Err from Ans,
   --#                  Dictionary.Dict,
   --#                  Err,
   --#                  LexTokenManager.State,
   --#                  Result;
   is
      Temp_Arg : Maths.Value;
   begin
      if Err = Maths.NoError then
         if Dictionary.TypeIsModular (Result.Type_Symbol) then
            Temp_Arg := Ans;
            Maths.Modulus
              (FirstNum  => Temp_Arg,
               SecondNum => Maths.ValueRep
                 (Dictionary.GetScalarAttributeValue
                    (Base     => False,
                     Name     => LexTokenManager.Modulus_Token,
                     TypeMark => Result.Type_Symbol)),
               Result    => Ans,
               Ok        => Err);
         end if;
      end if;
   end Apply_Modulus_If_Necessary;

begin -- Calc_Binary_Operator
   Err := Maths.NoError;
   if Result /= Sem.Unknown_Type_Record then
      -- expression was wellformed so we must try and calculate result
      case Operator is
         when SP_Symbols.multiply =>
            Maths.Multiply (Left_Val, Right_Val,
                            -- to get
                            Ans, Err);
            -- multiply might need a modulo reduction (See LRM 4.5.5(10))
            Apply_Modulus_If_Necessary (Result => Result,
                                        Ans    => Ans,
                                        Err    => Err);
         when SP_Symbols.divide =>
            Maths.Divide (Left_Val, Right_Val,
                          -- to get
                          Ans, Err);
            -- Divide never needs a modulo reduction (See LRM 4.5.5(10))
         when SP_Symbols.RWmod =>
            Maths.Modulus (Left_Val, Right_Val,
                           -- to get
                           Ans, Err);
            -- mod never needs a modulo reduction (See LRM 4.5.5(10))
         when SP_Symbols.RWrem =>
            Maths.Remainder (Left_Val, Right_Val,
                             -- to get
                             Ans, Err);
            -- rem never needs a modulo reduction (See LRM 4.5.5(10))
         when SP_Symbols.plus =>
            Maths.Add (Left_Val, Right_Val,
                       -- to get
                       Ans, Err);
            -- plus might need a modulo reduction (See LRM 4.5.3(11))
            Apply_Modulus_If_Necessary (Result => Result,
                                        Ans    => Ans,
                                        Err    => Err);
         when SP_Symbols.minus =>
            Maths.Subtract (Left_Val, Right_Val,
                            -- to get
                            Ans, Err);
            -- minus might need a modulo reduction (See LRM 4.5.3(11))
            Apply_Modulus_If_Necessary (Result => Result,
                                        Ans    => Ans,
                                        Err    => Err);
         when SP_Symbols.RWand | SP_Symbols.RWandthen =>
            Ans := Maths.AndOp (Left_Val, Right_Val);
         when SP_Symbols.RWor | SP_Symbols.RWorelse =>
            Ans := Maths.OrOp (Left_Val, Right_Val);
         when SP_Symbols.RWxor =>
            Ans := Maths.XorOp (Left_Val, Right_Val);
         when SP_Symbols.double_star =>
            Maths.RaiseByPower (Left_Val, Right_Val,
                                -- to get
                                Ans, Err);
            -- ** might need a modulo reduction (See LRM 4.5.6(11))
            Apply_Modulus_If_Necessary (Result => Result,
                                        Ans    => Ans,
                                        Err    => Err);
         when SP_Symbols.equals =>
            if Left_Val = Maths.NoValue or else Right_Val = Maths.NoValue then
               Ans := Maths.NoValue;
            else
               Ans := Maths.BoolToValue (Left_Val = Right_Val);
            end if;
            Err := Maths.NoError;
         when SP_Symbols.not_equal =>
            if Left_Val = Maths.NoValue or else Right_Val = Maths.NoValue then
               Ans := Maths.NoValue;
            else
               Ans := Maths.BoolToValue (Left_Val /= Right_Val);
            end if;
            Err := Maths.NoError;
         when SP_Symbols.less_than =>
            Maths.Lesser (Left_Val, Right_Val,
                          -- to get
                          Ans, Err);
         when SP_Symbols.less_or_equal =>
            Maths.LesserOrEqual (Left_Val, Right_Val,
                                 -- to get
                                 Ans, Err);
         when SP_Symbols.greater_or_equal =>
            Maths.GreaterOrEqual (Left_Val, Right_Val,
                                  -- to get
                                  Ans, Err);
         when SP_Symbols.greater_than =>
            Maths.Greater (Left_Val, Right_Val,
                           -- to get
                           Ans, Err);
         when others =>
            SystemErrors.Fatal_Error (Sys_Err => SystemErrors.Math_Error,
                                      Msg     => "in Calc_Binary_Operator");
            Ans := Maths.NoValue; -- define Ans here to avoid subsequent flow errors
      end case;

      Result.Value := Ans;

      case Err is
         when Maths.NoError =>
            null;
         when Maths.DivideByZero =>
            ErrorHandler.Semantic_Error
              (Err_Num   => 400,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Pos,
               Id_Str    => LexTokenManager.Null_String);
         when Maths.ConstraintError =>
            ErrorHandler.Semantic_Error
              (Err_Num   => Which_Err (Is_Annotation),
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Pos,
               Id_Str    => LexTokenManager.Null_String);
         when Maths.OverFlow =>
            Result.Value := Maths.NoValue;
            ErrorHandler.Semantic_Warning (Err_Num  => 200,
                                           Position => Node_Pos,
                                           Id_Str   => LexTokenManager.Null_String);
         when others => -- indicates internal error in maths package
            SystemErrors.Fatal_Error (Sys_Err => SystemErrors.Math_Error,
                                      Msg     => "in Calc_Binary_Operator (2nd case)");
      end case;
   end if;
end Calc_Binary_Operator;
