-------------------------------------------------------------------------------
-- (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.Check_No_Overloading_From_Tagged_Ops)
function Successfully_Overrides (Root_Subprog, Second_Subprog, Actual_Tagged_Parameter_Type : Dictionary.Symbol) return Boolean is
   function Subtype_Bounds_Statically_Match (First_Subtype, Second_Subtype : Dictionary.Symbol) return Boolean
   --# global in Dictionary.Dict;
   --#        in LexTokenManager.State;
   -- pre Dictionary.GetType (First_Subtype) = Dictionary.GetType (Second_Subtype);
   is
      Result : Boolean;

      function Scalar_Bounds_Match (Src_Sym, Tgt_Sym : Dictionary.Symbol) return Boolean
      --# global in Dictionary.Dict;
      --#        in LexTokenManager.State;
      is
         Result : Boolean;
      begin
         Result :=
           LexTokenManager.Lex_String_Case_Insensitive_Compare
           (Lex_Str1 => Dictionary.GetScalarAttributeValue (False, LexTokenManager.First_Token, Src_Sym),
            Lex_Str2 => Dictionary.GetScalarAttributeValue (False, LexTokenManager.First_Token, Tgt_Sym)) =
           LexTokenManager.Str_Eq
           and then LexTokenManager.Lex_String_Case_Insensitive_Compare
           (Lex_Str1 => Dictionary.GetScalarAttributeValue (False, LexTokenManager.Last_Token, Src_Sym),
            Lex_Str2 => Dictionary.GetScalarAttributeValue (False, LexTokenManager.Last_Token, Tgt_Sym)) =
           LexTokenManager.Str_Eq;
         return Result;
      end Scalar_Bounds_Match;

   begin -- Subtype_Bounds_Statically_Match
      if Dictionary.TypeIsScalar (First_Subtype) then
         Result := Scalar_Bounds_Match (Src_Sym => First_Subtype,
                                        Tgt_Sym => Second_Subtype);
      elsif Dictionary.TypeIsArray (First_Subtype) then
         Result := Indexes_Match (Target => First_Subtype,
                                  Source => Second_Subtype);
      elsif Dictionary.TypeIsRecord (First_Subtype) then
         Result := True;
      elsif Dictionary.TypeIsPrivate (TheType => First_Subtype) then
         Result := True;
      else
         Result := False; -- unexpected case, above should trap everything
      end if;
      return Result;
   end Subtype_Bounds_Statically_Match;

   function Same_Type (First_Subtype, Second_Subtype : Dictionary.Symbol) return Boolean
   --# global in Dictionary.Dict;
   is
      FirstType, SecondType : Dictionary.Symbol;
   begin
      if Dictionary.IsType (First_Subtype) then
         FirstType := First_Subtype;
      else
         -- compare parent types
         FirstType := Dictionary.GetType (First_Subtype);
      end if;
      if Dictionary.IsType (Second_Subtype) then
         SecondType := Second_Subtype;
      else
         -- compare parent types
         SecondType := Dictionary.GetType (Second_Subtype);
      end if;
      return Dictionary.Types_Are_Equal (Left_Symbol        => FirstType,
                                         Right_Symbol       => SecondType,
                                         Full_Range_Subtype => False);
   end Same_Type;

   function Both_Procedures (Root_Subprog, Second_Subprog : Dictionary.Symbol) return Boolean
   --# global in Dictionary.Dict;
   is
   begin
      return Dictionary.IsProcedure (Root_Subprog) and then Dictionary.IsProcedure (Second_Subprog);
   end Both_Procedures;

   function Both_Functions (Root_Subprog, Second_Subprog : Dictionary.Symbol) return Boolean
   --# global in Dictionary.Dict;
   --#        in LexTokenManager.State;
   is
      Result : Boolean;
   begin
      Result :=
        Dictionary.IsFunction (Root_Subprog)
        and then Dictionary.IsFunction (Second_Subprog)
        and then Same_Type
        (First_Subtype  => Dictionary.GetType (Root_Subprog),
         Second_Subtype => Dictionary.GetType (Second_Subprog))
        and then Subtype_Bounds_Statically_Match
        (First_Subtype  => Dictionary.GetType (Root_Subprog),
         Second_Subtype => Dictionary.GetType (Second_Subprog));

      return Result;
   end Both_Functions;

   function Have_Same_Number_Of_Parameters (Root_Subprog, Second_Subprog : Dictionary.Symbol) return Boolean
   --# global in Dictionary.Dict;
   is
   begin
      return Dictionary.GetNumberOfSubprogramParameters (Root_Subprog) =
        Dictionary.GetNumberOfSubprogramParameters (Second_Subprog);
   end Have_Same_Number_Of_Parameters;

   function Parameter_Types_Ok (Root_Param, Second_Param, Actual_Tagged_Parameter_Type : Dictionary.Symbol) return Boolean
   --# global in Dictionary.Dict;
   --#        in LexTokenManager.State;
   is
      Root_Param_Type, Second_Param_Type : Dictionary.Symbol;
      Inheritance_In_Force, Result       : Boolean;
   begin
      Root_Param_Type      := Dictionary.GetType (Root_Param);
      Second_Param_Type    := Dictionary.GetType (Second_Param);
      Inheritance_In_Force :=
        Dictionary.Types_Are_Equal
        (Left_Symbol        => Second_Param_Type,
         Right_Symbol       => Actual_Tagged_Parameter_Type,
         Full_Range_Subtype => False);
      Result               :=
        (Inheritance_In_Force and then Dictionary.IsAnExtensionOf (Root_Param_Type, Second_Param_Type))
        or else (not Inheritance_In_Force
                   and then Same_Type (First_Subtype  => Root_Param_Type,
                                       Second_Subtype => Second_Param_Type)
                   and then Subtype_Bounds_Statically_Match (First_Subtype  => Root_Param_Type,
                                                             Second_Subtype => Second_Param_Type));

      return Result;
   end Parameter_Types_Ok;

   function Modes_Match (Root_Param, Second_Param : Dictionary.Symbol) return Boolean
   --# global in Dictionary.Dict;
   is
      Root_Mode, Second_Mode : Dictionary.Modes;
   begin
      Root_Mode   := Dictionary.GetSubprogramParameterMode (Root_Param);
      Second_Mode := Dictionary.GetSubprogramParameterMode (Second_Param);
      return Root_Mode = Second_Mode
        or else (Root_Mode = Dictionary.InMode and then Second_Mode = Dictionary.DefaultMode)
        or else (Second_Mode = Dictionary.InMode and then Root_Mode = Dictionary.DefaultMode);

   end Modes_Match;

   function Valid_Type_Symbol (The_Subtype : Dictionary.Symbol) return Boolean
   --# global in Dictionary.Dict;
   is
   begin
      return not Dictionary.Is_Null_Symbol (The_Subtype) and then not Dictionary.IsUnknownTypeMark (The_Subtype);
   end Valid_Type_Symbol;

   function Parameters_Match (Root_Subprog, Second_Subprog, Actual_Tagged_Parameter_Type : Dictionary.Symbol) return Boolean
   --# global in Dictionary.Dict;
   --#        in LexTokenManager.State;
   is
      Result                          : Boolean := True;
      Root_Param, Second_Param        : Dictionary.Symbol;
      Number_Of_Subprogram_Parameters : Natural;
   begin
      Number_Of_Subprogram_Parameters := Dictionary.GetNumberOfSubprogramParameters (Root_Subprog);
      for I in Natural range 1 .. Number_Of_Subprogram_Parameters loop
         Root_Param   := Dictionary.GetSubprogramParameter (Root_Subprog, I);
         Second_Param := Dictionary.GetSubprogramParameter (Second_Subprog, I);
         if not (Valid_Type_Symbol (The_Subtype => Dictionary.GetType (Root_Param))
                   and then Valid_Type_Symbol (The_Subtype => Dictionary.GetType (Second_Param))
                   and then Parameter_Types_Ok
                   (Root_Param                   => Root_Param,
                    Second_Param                 => Second_Param,
                    Actual_Tagged_Parameter_Type => Actual_Tagged_Parameter_Type)
                   and then Modes_Match (Root_Param   => Root_Param,
                                         Second_Param => Second_Param)) then
            Result := False;
            exit;
         end if;
      end loop;

      return Result;
   end Parameters_Match;

begin -- Successfully_Overrides
   return (Both_Procedures (Root_Subprog   => Root_Subprog,
                            Second_Subprog => Second_Subprog)
             or else Both_Functions (Root_Subprog   => Root_Subprog,
                                     Second_Subprog => Second_Subprog))
     and then Have_Same_Number_Of_Parameters (Root_Subprog   => Root_Subprog,
                                              Second_Subprog => Second_Subprog)
     and then Parameters_Match
     (Root_Subprog                 => Root_Subprog,
      Second_Subprog               => Second_Subprog,
      Actual_Tagged_Parameter_Type => Actual_Tagged_Parameter_Type);
end Successfully_Overrides;
