-------------------------------------------------------------------------------
-- (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 (Dictionary)
procedure Search_For_Inherited_Operations
  (Name               : in     LexTokenManager.Lex_String;
   Scope              : in     Scopes;
   Prefix             : in     RawDict.Package_Info_Ref;
   Context            : in     Contexts;
   OpSym              :    out Symbol;
   Actual_Tagged_Type :    out RawDict.Type_Info_Ref) is

   type KindsOfOp is (AProcedure, AFunction, NotASubprogram);

   Current_Package  : RawDict.Package_Info_Ref;
   Calling_Package  : RawDict.Package_Info_Ref;
   PossibleOpSym    : Symbol := NullSymbol;
   PossibleKindOfOp : KindsOfOp;

   --------------------------------------------------------------------------------

   function Get_Package_Extended_Type (The_Package : RawDict.Package_Info_Ref) return RawDict.Type_Info_Ref
   --# global in Dict;
   is
      The_Declaration : RawDict.Declaration_Info_Ref;
      Item            : Symbol;
      Result          : RawDict.Type_Info_Ref := RawDict.Null_Type_Info_Ref;
   begin
      if RawDict.Get_Package_Extends (The_Package => The_Package) /= RawDict.Null_Package_Info_Ref then
         -- search for a tagged type
         The_Declaration := RawDict.Get_Package_First_Visible_Declaration (The_Package => The_Package);
         while The_Declaration /= RawDict.Null_Declaration_Info_Ref loop
            Item := RawDict.Get_Declaration_Item (The_Declaration => The_Declaration);
            if RawDict.GetSymbolDiscriminant (Item) = Type_Symbol
              and then Is_Type (Type_Mark => RawDict.Get_Type_Info_Ref (Item => Item))
              and then Type_Is_Tagged (Type_Mark => RawDict.Get_Type_Info_Ref (Item => Item)) then
               Result          := RawDict.Get_Type_Info_Ref (Item => Item);
               The_Declaration := RawDict.Null_Declaration_Info_Ref;
            else
               The_Declaration := RawDict.Get_Next_Declaration (The_Declaration => The_Declaration);
            end if;
         end loop;
         -- if we haven't succeeded already then check private declarations
         if Result = RawDict.Null_Type_Info_Ref then
            The_Declaration := RawDict.Get_Package_First_Private_Declaration (The_Package => The_Package);
            while The_Declaration /= RawDict.Null_Declaration_Info_Ref loop
               Item := RawDict.Get_Declaration_Item (The_Declaration => The_Declaration);
               if RawDict.GetSymbolDiscriminant (Item) = Type_Symbol
                 and then Is_Type (Type_Mark => RawDict.Get_Type_Info_Ref (Item => Item))
                 and then Type_Is_Tagged (Type_Mark => RawDict.Get_Type_Info_Ref (Item => Item)) then
                  Result          := RawDict.Get_Type_Info_Ref (Item => Item);
                  The_Declaration := RawDict.Null_Declaration_Info_Ref;
               else
                  The_Declaration := RawDict.Get_Next_Declaration (The_Declaration => The_Declaration);
               end if;
            end loop;
         end if;
      end if;
      return Result;
   end Get_Package_Extended_Type;

   --------------------------------------------------------------------------------

   function OperationCanBeInherited
     (TheOpSym        : Symbol;
      Calling_Package : RawDict.Package_Info_Ref;
      Current_Package : RawDict.Package_Info_Ref)
     return            Boolean
   --# global in Dict;
   is
      It           : Iterator;
      Current_Type : RawDict.Type_Info_Ref;
      Valid        : Boolean := False;

      function Is_Locally_Declared
        (Type_Mark       : RawDict.Type_Info_Ref;
         Current_Package : RawDict.Package_Info_Ref)
        return            Boolean
      --# global in Dict;
      is
      begin
         return RawDict.GetSymbolDiscriminant (GetRegion (Get_Type_Scope (Type_Mark => Type_Mark))) = Package_Symbol
           and then RawDict.Get_Package_Info_Ref (Item => GetRegion (Get_Type_Scope (Type_Mark => Type_Mark))) =
           Current_Package;
      end Is_Locally_Declared;

   begin -- OperationCanBeInherited

      -- a subprogram is suitable for inheritance if it has a parameter
      -- of a tagged type declared in the same package and which the caller extends
      It := FirstSubprogramParameter (TheOpSym);
      while not IsNullIterator (It) loop
         Current_Type := Get_Type (The_Symbol => CurrentSymbol (It));
         if Type_Is_Tagged (Type_Mark => Current_Type)
           and then Is_Locally_Declared (Type_Mark       => Current_Type,
                                         Current_Package => Current_Package)
           and then Is_An_Extension_Of
           (Root_Type     => Current_Type,
            Extended_Type => Get_Package_Extended_Type (The_Package => Calling_Package)) then
            Valid := True;
            exit;
         end if;
         It := NextSymbol (It);
      end loop;
      return Valid;
   end OperationCanBeInherited;

begin -- Search_For_Inherited_Operations

   -- this procedure will only be called when a normal search for an
   -- operation using LookUpItem or LookUpSelectedItem has failed.  We may
   -- be in some local scope so the first step is to get to the enclosing
   -- library package of the scope we start in if there is no prefix or
   -- the prefix package if there is one
   if Prefix = RawDict.Null_Package_Info_Ref then
      Current_Package := Get_Library_Package (Scope => Scope);
   else
      Current_Package := Prefix;
   end if;
   Calling_Package := Current_Package;
   -- now we can chain up the package "Extends" pointers looking for the
   -- required operation
   loop
      Current_Package := RawDict.Get_Package_Extends (The_Package => Current_Package);
      if Current_Package = RawDict.Null_Package_Info_Ref then -- no more inherited packs
         PossibleKindOfOp := NotASubprogram;
         exit;
      end if;
      -- Prior to release 7.1, a potentially inheritable operation must have
      -- been declared in the visible part of its package so LookupImmediateScope
      -- was a good choice for seeing if such an operation exists

      -- After release 7.1 the operation might be in the private part so we use
      -- LookUpSelectedItem instead; this makes operations correctly visible
      -- depending on whether we are looking from a child package or not.
      PossibleOpSym := LookupSelectedItem (RawDict.Get_Package_Symbol (Current_Package), Name, Scope, Context);

      if RawDict.GetSymbolDiscriminant (PossibleOpSym) = Subprogram_Symbol
        and then Is_Procedure (The_Subprogram => RawDict.Get_Subprogram_Info_Ref (Item => PossibleOpSym)) then
         PossibleKindOfOp := AProcedure;
         exit;
      end if;

      if IsFunction (PossibleOpSym) then
         PossibleKindOfOp := AFunction;
         exit;
      end if;

      if PossibleOpSym /= NullSymbol then -- something else found
         PossibleKindOfOp := NotASubprogram;
         exit;
      end if;
   end loop;

   -- At this point we have either found something and PossibleKindOfOp will say
   -- what it is or we have failed and PossibleOpSym is NullSymbol (and PossibleKindOfOp
   -- is NotASubprogram.  In any case a result of NotASubprogam is a failure and no further
   -- checks are required.
   if PossibleKindOfOp = NotASubprogram then
      OpSym              := NullSymbol;
      Actual_Tagged_Type := RawDict.Null_Type_Info_Ref;
   else
      -- some kind of subprogram found so we need to check whether it has a parameter of
      -- a locally-declared tagged type
      if OperationCanBeInherited
        (TheOpSym        => PossibleOpSym,
         Calling_Package => Calling_Package,
         Current_Package => Current_Package) then
         OpSym              := PossibleOpSym;
         Actual_Tagged_Type := Get_Package_Extended_Type (The_Package => Calling_Package);
      else -- not a suitable subprog to inherit
         OpSym              := NullSymbol;
         Actual_Tagged_Type := RawDict.Null_Type_Info_Ref;
      end if;
   end if;
end Search_For_Inherited_Operations;
