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

----------------------------------------------------------------------------------------
-- Checks the following:
-- if not Dotted then SubProgSym has body and is not being called from within
-- itself
-- or, if not dotted but subprogram is declared remotely then it must be an
-- an inherited op associated with a tagged type and that is ok
-- if dotted then if proc in enclosing package then proc has body
--   else if
-- package embedded in something then package has body
--                             or, if package does not have body, does
--                             subprogram have body (might have pragma
--                             import/interface)
--   else if called from [descendent of] private child of proc's package
--        then error
--   else its Ok
--------------------------------------------------------------------------------

separate (Dictionary)
function Is_Callable
  (The_Subprogram : RawDict.Subprogram_Info_Ref;
   Prefix_Needed  : Boolean;
   Scope          : Scopes)
  return           Boolean
is
   The_Region  : Symbol;
   The_Package : RawDict.Package_Info_Ref;
   Result      : Boolean;

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

   function Get_Body (Compilation_Unit : Symbol) return RawDict.Declaration_Info_Ref
   --# global in Dict;
   is
      The_Body : RawDict.Declaration_Info_Ref := RawDict.Null_Declaration_Info_Ref;
   begin
      case RawDict.GetSymbolDiscriminant (Compilation_Unit) is
         when Package_Symbol =>
            The_Body := RawDict.Get_Package_Body (The_Package => RawDict.Get_Package_Info_Ref (Item => Compilation_Unit));
         when Type_Symbol =>
            case RawDict.Get_Type_Discriminant (Type_Mark => RawDict.Get_Type_Info_Ref (Item => Compilation_Unit)) is
               when Protected_Type_Item =>
                  The_Body :=
                    RawDict.Get_Protected_Type_Body (The_Protected_Type => RawDict.Get_Type_Info_Ref (Item => Compilation_Unit));
               when Task_Type_Item =>
                  The_Body := RawDict.Get_Task_Type_Body (The_Task_Type => RawDict.Get_Type_Info_Ref (Item => Compilation_Unit));
               when others => -- non-exec code
                  SystemErrors.Fatal_Error (Sys_Err => SystemErrors.Invalid_Symbol_Table,
                                            Msg     => "in Dictionary.Get_Body");
            end case;
         when Subprogram_Symbol =>
            The_Body :=
              RawDict.Get_Subprogram_Body (The_Subprogram => RawDict.Get_Subprogram_Info_Ref (Item => Compilation_Unit));
         when others => -- non-exec code
            SystemErrors.Fatal_Error (Sys_Err => SystemErrors.Invalid_Symbol_Table,
                                      Msg     => "in Dictionary.Get_Body");
      end case;
      return The_Body;
   end Get_Body;

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

   function Body_Is_Visible (The_Body : RawDict.Declaration_Info_Ref;
                             Scope    : Scopes) return Boolean
   --# global in Dict;
   is
      Region          : Symbol;
      Stop_At         : RawDict.Declaration_Info_Ref;
      Found           : Boolean := False;
      Current_Scope   : Scopes;
      Enclosing_Scope : Scopes;

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

      function Body_Is_Defined
        (The_Body : RawDict.Declaration_Info_Ref;
         Scope    : Scopes;
         Stop_At  : RawDict.Declaration_Info_Ref)
        return     Boolean
      --# global in Dict;
      is
         Found : Boolean;

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

         function Lookup_Local_Declarations
           (The_Body : RawDict.Declaration_Info_Ref;
            Region   : Symbol;
            Stop_At  : RawDict.Declaration_Info_Ref)
           return     Boolean
         --# global in Dict;
         is
            Found : Boolean := False;

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

            function Lookup_Declarations (The_Body, Head, Stop_At : RawDict.Declaration_Info_Ref) return Boolean
            --# global in Dict;
            is
               The_Declaration : RawDict.Declaration_Info_Ref;
            begin
               The_Declaration := Head;
               while The_Declaration /= RawDict.Null_Declaration_Info_Ref
                 and then The_Declaration /= Stop_At
                 and then The_Declaration /= The_Body loop
                  The_Declaration := RawDict.Get_Next_Declaration (The_Declaration => The_Declaration);
               end loop;
               return The_Declaration = The_Body;
            end Lookup_Declarations;

         begin -- Lookup_Local_Declarations
            case RawDict.GetSymbolDiscriminant (Region) is
               when Package_Symbol =>
                  Found :=
                    Lookup_Declarations
                    (The_Body => The_Body,
                     Head     => RawDict.Get_Package_First_Local_Declaration
                       (The_Package => RawDict.Get_Package_Info_Ref (Item => Region)),
                     Stop_At  => Stop_At);
               when Subprogram_Symbol =>
                  Found :=
                    Lookup_Declarations
                    (The_Body => The_Body,
                     Head     => RawDict.Get_Subprogram_First_Declaration
                       (The_Subprogram => RawDict.Get_Subprogram_Info_Ref (Item => Region)),
                     Stop_At  => Stop_At);
               when Type_Symbol =>
                  -- must be protected or task type since these are the only types that could contain
                  -- a subprogram call.
                  case RawDict.Get_Type_Discriminant (Type_Mark => RawDict.Get_Type_Info_Ref (Item => Region)) is
                     when Protected_Type_Item =>
                        Found :=
                          Lookup_Declarations
                          (The_Body => The_Body,
                           Head     => RawDict.Get_Protected_Type_First_Local_Declaration
                             (The_Protected_Type => RawDict.Get_Type_Info_Ref (Item => Region)),
                           Stop_At  => Stop_At);
                     when Task_Type_Item =>
                        Found :=
                          Lookup_Declarations
                          (The_Body => The_Body,
                           Head     => RawDict.Get_Task_Type_First_Local_Declaration
                             (The_Task_Type => RawDict.Get_Type_Info_Ref (Item => Region)),
                           Stop_At  => Stop_At);
                     when others => -- non-exec code
                        SystemErrors.Fatal_Error
                          (Sys_Err => SystemErrors.Invalid_Symbol_Table,
                           Msg     => "in Dictionary.Lookup_Local_Declarations");
                  end case;
               when others =>
                  null;
            end case;
            return Found;
         end Lookup_Local_Declarations;

      begin -- Body_Is_Defined
         case Get_Visibility (Scope => Scope) is
            when Visible | Privat =>
               Found := False;
            when Local =>
               Found := Lookup_Local_Declarations (The_Body => The_Body,
                                                   Region   => GetRegion (Scope),
                                                   Stop_At  => Stop_At);
         end case;
         return Found;
      end Body_Is_Defined;

   begin -- Body_Is_Visible
      if The_Body /= RawDict.Null_Declaration_Info_Ref then
         Found := Body_Is_Defined (The_Body => The_Body,
                                   Scope    => Scope,
                                   Stop_At  => RawDict.Null_Declaration_Info_Ref);
         if not Found then
            Current_Scope := Scope;
            loop
               Region := GetRegion (Current_Scope);
               exit when RawDict.GetSymbolDiscriminant (Region) = Package_Symbol
                 and then RawDict.Get_Package_Info_Ref (Item => Region) = Get_Predefined_Package_Standard;
               Enclosing_Scope := GetEnclosingScope (Current_Scope);
               if IsCompilationUnit (Region) then
                  Stop_At := Get_Body (Compilation_Unit => Region);
               elsif RawDict.GetSymbolDiscriminant (Region) = Type_Symbol
                 and then Is_Type (Type_Mark => RawDict.Get_Type_Info_Ref (Item => Region)) then -- Task or Protected body subunit
                  Stop_At := Get_Body (Compilation_Unit => Region);
               else
                  Stop_At := RawDict.Null_Declaration_Info_Ref;
               end if;
               Found := Body_Is_Defined (The_Body => The_Body,
                                         Scope    => Enclosing_Scope,
                                         Stop_At  => Stop_At);
               exit when Found;
               Current_Scope := Enclosing_Scope;
            end loop;
         end if;
      end if;
      return Found;
   end Body_Is_Visible;

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

   function Direct_Recursion (The_Subprogram : RawDict.Subprogram_Info_Ref;
                              Scope          : Scopes) return Boolean
   --# global in Dict;
   is
      Current_Scope  : Scopes;
      Current_Region : Symbol;
   begin
      Current_Scope := Scope;
      loop
         Current_Region := GetRegion (Current_Scope);
         exit when (RawDict.GetSymbolDiscriminant (Current_Region) = Subprogram_Symbol
                      and then RawDict.Get_Subprogram_Info_Ref (Item => Current_Region) = The_Subprogram)
           or else (RawDict.GetSymbolDiscriminant (Current_Region) = Package_Symbol
                      and then RawDict.Get_Package_Info_Ref (Item => Current_Region) = Get_Predefined_Package_Standard);
         Current_Scope := GetEnclosingScope (Current_Scope);
      end loop;
      return RawDict.GetSymbolDiscriminant (Current_Region) = Subprogram_Symbol
        and then RawDict.Get_Subprogram_Info_Ref (Item => Current_Region) = The_Subprogram;
   end Direct_Recursion;

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

   function Is_Inherited_Operation (The_Subprogram : RawDict.Subprogram_Info_Ref;
                                    Scope          : Scopes) return Boolean
   --# global in Dict;
   is
   begin
      -- a subprogram denoted by a simple name must be inherited if the
      -- library package in which it is declared is not the same as the
      -- package associated with the scope from which we are looking
      return Get_Library_Package (Scope => Get_Subprogram_Scope (The_Subprogram => The_Subprogram)) /=
        Get_Library_Package (Scope => Scope);
   end Is_Inherited_Operation;

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

   function Select_Protected_Body
     (The_Subprogram : RawDict.Subprogram_Info_Ref;
      Scope          : Scopes)
     return           RawDict.Declaration_Info_Ref
   --# global in Dict;
   is
      Result          : Symbol;
      Declared_Region : Symbol;
   begin
      -- If the subprogram is declared inside a protected type and we are not calling from inside the protected
      -- body itself then it is the body of the type we need to find not the body of the subprgoram
      -- itself.  Otherwise we return the Subprogram unchanged.
      Result          := RawDict.Get_Subprogram_Symbol (The_Subprogram);
      Declared_Region := GetRegion (Get_Subprogram_Scope (The_Subprogram => The_Subprogram));
      if RawDict.GetSymbolDiscriminant (Declared_Region) = Type_Symbol
        and then Is_Protected_Type (Type_Mark => RawDict.Get_Type_Info_Ref (Item => Declared_Region))
        and then not IsLocal (Scope, Set_Visibility (The_Visibility => Local,
                                                     The_Unit       => Declared_Region)) then
         Result := Declared_Region;
      end if;
      return Get_Body (Compilation_Unit => Result);
   end Select_Protected_Body;

begin -- Is_Callable
   if Prefix_Needed or else Is_Renamed_Local (The_Subprogram => The_Subprogram,
                                              Scope          => Scope) then
      The_Region := GetRegion (Get_Subprogram_Scope (The_Subprogram => The_Subprogram));
      case RawDict.GetSymbolDiscriminant (The_Region) is
         when Type_Symbol =>
            SystemErrors.RT_Assert
              (C       => Is_Task_Type (Type_Mark => RawDict.Get_Type_Info_Ref (Item => The_Region))
                 or else Is_Protected_Type (Type_Mark => RawDict.Get_Type_Info_Ref (Item => The_Region)),
               Sys_Err => SystemErrors.Invalid_Symbol_Table,
               Msg     => "in Dictionary.Is_Callable");
            if IsLocal (Scope, Set_Visibility (The_Visibility => Local,
                                               The_Unit       => The_Region)) then
               Result :=
                 Body_Is_Visible (The_Body => RawDict.Get_Subprogram_Body (The_Subprogram => The_Subprogram),
                                  Scope    => Scope);
            else
               Result := True;
            end if;
         when Package_Symbol =>
            The_Package := RawDict.Get_Package_Info_Ref (Item => The_Region);
            if IsLocal
              (Scope,
               Set_Visibility (The_Visibility => Local,
                               The_Unit       => RawDict.Get_Package_Symbol (The_Package))) then
               Result :=
                 Body_Is_Visible (The_Body => RawDict.Get_Subprogram_Body (The_Subprogram => The_Subprogram),
                                  Scope    => Scope);
            elsif Is_Embedded_Package (The_Package => The_Package) then
               Result :=
                 Body_Is_Visible (The_Body => RawDict.Get_Package_Body (The_Package => The_Package),
                                  Scope    => Scope)
                 or else Body_Is_Visible
                 (The_Body => RawDict.Get_Subprogram_Body (The_Subprogram => The_Subprogram),
                  Scope    => Set_Visibility
                    (The_Visibility => Local,
                     The_Unit       => RawDict.Get_Subprogram_Symbol (The_Subprogram)));
            elsif Is_Descendent_Of_Private_Child
              (Candidate   => Get_Library_Package (Scope => Scope),
               The_Package => The_Package) then
               Result := False;
            else
               Result := True;
            end if;
         when others =>
            Result := False;
            SystemErrors.Fatal_Error (Sys_Err => SystemErrors.Invalid_Symbol_Table,
                                      Msg     => "in Dictionary.Is_Callable");
      end case;
   else
      Result :=
        (Body_Is_Visible (The_Body => Select_Protected_Body (The_Subprogram => The_Subprogram,
                                                             Scope          => Scope),
                          Scope    => Scope)
           and then not Direct_Recursion (The_Subprogram => The_Subprogram,
                                          Scope          => Scope))
        or else Is_Inherited_Operation (The_Subprogram => The_Subprogram,
                                        Scope          => Scope);
   end if;
   return Result;
end Is_Callable;
