-------------------------------------------------------------------------------
-- (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.
--
--=============================================================================

separate (Sem.Walk_Expression_P.Check_Binary_Operator)
procedure Homo_Impl_Type_Conv
  (Operator              : in     SP_Symbols.SP_Symbol;
   Left_Type, Right_Type : in out Dictionary.Symbol;
   Left_Val              : in     Maths.Value;
   Right_Val             : in     Maths.Value;
   Left_Has_Operators    : in     Boolean;
   Right_Has_Operators   : in     Boolean;
   Left_Pos              : in     LexTokenManager.Token_Position;
   Right_Pos             : in     LexTokenManager.Token_Position;
   Is_Annotation         : in     Boolean;
   T_Stack               : in     Type_Context_Stack.T_Stack_Type;
   Scope                 : in     Dictionary.Scopes)
is
   Type_From_Context : Dictionary.Symbol;
   Base_Type         : Dictionary.Symbol;
   New_Val           : Maths.Value;

   procedure Debug_1
   --# derives ;
   is
      --# hide Debug_1;
   begin
      if CommandLineData.Content.Debug.Expressions then
         SPARK_IO.Put_Line
           (SPARK_IO.Standard_Output,
            "Homo_Impl_Type_Conv encounters a universal expression.  Context is Unknown so no change.",
            0);
      end if;
   end Debug_1;

   procedure Debug_2
   --# derives ;
   is
      --# hide Debug_2;
   begin
      if CommandLineData.Content.Debug.Expressions then
         SPARK_IO.Put_String
           (SPARK_IO.Standard_Output,
            "Homo_Impl_Type_Conv encounters a universal expression.  Resolving by context to type ",
            0);
         E_Strings.Put_Line
           (File  => SPARK_IO.Standard_Output,
            E_Str => LexTokenManager.Lex_String_To_String
              (Lex_Str => Dictionary.GetSimpleName (Type_Context_Stack.Top (Stack => T_Stack))));
      end if;
   end Debug_2;

   function Is_Relational_Operator (Operator : SP_Symbols.SP_Symbol) return Boolean is
   begin
      return Operator = SP_Symbols.equals
        or else Operator = SP_Symbols.not_equal
        or else Operator = SP_Symbols.less_than
        or else Operator = SP_Symbols.less_or_equal
        or else Operator = SP_Symbols.greater_than
        or else Operator = SP_Symbols.greater_or_equal;
   end Is_Relational_Operator;

begin
   if Dictionary.Types_Are_Equal (Left_Symbol        => Left_Type,
                                  Right_Symbol       => Right_Type,
                                  Full_Range_Subtype => False) then
      -- Types are the same. If both are universal integer, then the
      -- expression may be of a signed integer or modular type, and we
      -- need to use the context to resolve this.
      if Dictionary.IsUniversalIntegerType (Left_Type) and then Dictionary.IsUniversalIntegerType (Right_Type) then

         if Dictionary.IsUnknownTypeMark (Type_Context_Stack.Top (Stack => T_Stack))
           or else Dictionary.IsPredefinedBooleanType (Type_Context_Stack.Top (Stack => T_Stack)) then
            -- If the context is unknown or Boolean (as we might have for a subexpression
            -- below a relational operator for instance), then we can do nothing.
            -- We leave both operands as UniversalInteger to preserve existing
            -- Examiner behaviour in that case.
            null;
            Debug_1;
         else
            -- If we do know a definite type from the context, then we convert
            -- the Universal operands to that type here.
            --
            -- The visibility of the operator (which will be determined later) is
            -- dependent on the _base_ type of the type, so...
            Type_From_Context := Dictionary.GetRootType (Type_Context_Stack.Top (Stack => T_Stack));

            Left_Type  := Type_From_Context;
            Right_Type := Type_From_Context;
            Debug_2;
         end if;
      end if;
   else
      -- Types are different.
      if Dictionary.IsUniversalIntegerType (Left_Type) then

         if Dictionary.IsIntegerTypeMark (Right_Type, Scope) then
            -- Right is a signed integer type - implicit conversion OK.
            Left_Type := Right_Type;

            -- For a signed integer type T, a literal must lie
            -- in the range of T'Base. If this is known (via
            -- a type assertion and the config file), then a static
            -- constraint check can be done here.
            Base_Type := Dictionary.GetBaseType (Left_Type);
            if not Dictionary.Is_Null_Symbol (Base_Type) then
               --# accept F, 10, New_Val, "Final value of New_Val not used";
               Sem.Constraint_Check
                 (Val           => Left_Val,
                  New_Val       => New_Val,
                  Is_Annotation => Is_Annotation,
                  Typ           => Base_Type,
                  Position      => Left_Pos);
               --# end accept;
            end if;

         elsif Dictionary.IsModularTypeMark (Right_Type, Scope) then
            -- Right is a Modular type - implicit conversion OK unless
            -- we're below a relational operator AND the Left subexpression
            -- contains operators itself.
            if not (Is_Relational_Operator (Operator => Operator) and then Left_Has_Operators) then
               Left_Type := Right_Type;

               -- For a modular type T, a literal must lie in the range
               -- of T'First .. T'Last, so
               --# accept F, 10, New_Val, "Final value of New_Val not used";
               Sem.Constraint_Check
                 (Val           => Left_Val,
                  New_Val       => New_Val,
                  Is_Annotation => Is_Annotation,
                  Typ           => Left_Type,
                  Position      => Left_Pos);
               --# end accept;
            end if;
         end if;

      elsif Dictionary.IsUniversalIntegerType (Right_Type) then

         if Dictionary.IsIntegerTypeMark (Left_Type, Scope) then
            -- Left is a signed integer type - implicit conversion OK.
            Right_Type := Left_Type;

            -- For a signed integer type T, a literal must lie
            -- in the range of T'Base. If this is known (via
            -- a type assertion and the config file), then a static
            -- constraint check can be done here.
            Base_Type := Dictionary.GetBaseType (Right_Type);
            if not Dictionary.Is_Null_Symbol (Base_Type) then
               --# accept F, 10, New_Val, "Final value of New_Val not used";
               Sem.Constraint_Check
                 (Val           => Right_Val,
                  New_Val       => New_Val,
                  Is_Annotation => Is_Annotation,
                  Typ           => Base_Type,
                  Position      => Right_Pos);
               --# end accept;
            end if;
         elsif Dictionary.IsModularTypeMark (Left_Type, Scope) then
            -- Left is a Modular type - implicit conversion OK unless
            -- we're below a relational operator AND the Right subexpression
            -- contains operators itself.
            if not (Is_Relational_Operator (Operator => Operator) and then Right_Has_Operators) then
               Right_Type := Left_Type;
               -- For a modular type T, a literal must lie in the range
               -- of T'First .. T'Last, so
               --# accept F, 10, New_Val, "Final value of New_Val not used";
               Sem.Constraint_Check
                 (Val           => Right_Val,
                  New_Val       => New_Val,
                  Is_Annotation => Is_Annotation,
                  Typ           => Right_Type,
                  Position      => Right_Pos);
               --# end accept;
            end if;
         end if;
      elsif Dictionary.IsUniversalRealType (Left_Type) then
         if Dictionary.IsRealTypeMark (Right_Type, Scope) then
            Left_Type := Right_Type;
         end if;
      elsif Dictionary.IsUniversalRealType (Right_Type) then
         if Dictionary.IsRealTypeMark (Left_Type, Scope) then
            Right_Type := Left_Type;
         end if;
      end if;
   end if;
   --# accept F, 33, New_Val, "Final value of New_Val not used";
end Homo_Impl_Type_Conv;
