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

-- Overview:
-- Checks an inherit clause for Sem starting at node inherit_clause.
-- Directly capable of rasing errors for: undeclared item in inherit list,
-- duplicate item in inherit list or inheriting of something which is not a
-- package.
--------------------------------------------------------------------------------

with SLI;

separate (Sem)
procedure Wf_Inherit_Clause (Node     : in STree.SyntaxNode;
                             Comp_Sym : in Dictionary.Symbol;
                             Scope    : in Dictionary.Scopes) is
   It        : STree.Iterator;
   Next_Node : STree.SyntaxNode;

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

   procedure Process_Dotted_Simple_Name
     (Node     : in STree.SyntaxNode;
      Comp_Sym : in Dictionary.Symbol;
      Scope    : in Dictionary.Scopes)
   --# global in     CommandLineData.Content;
   --#        in     ContextManager.Ops.Unit_Stack;
   --#        in     LexTokenManager.State;
   --#        in out Dictionary.Dict;
   --#        in out ErrorHandler.Error_Context;
   --#        in out SPARK_IO.File_Sys;
   --#        in out STree.Table;
   --# derives Dictionary.Dict,
   --#         STree.Table                from CommandLineData.Content,
   --#                                         Comp_Sym,
   --#                                         ContextManager.Ops.Unit_Stack,
   --#                                         Dictionary.Dict,
   --#                                         LexTokenManager.State,
   --#                                         Node,
   --#                                         Scope,
   --#                                         STree.Table &
   --#         ErrorHandler.Error_Context,
   --#         SPARK_IO.File_Sys          from CommandLineData.Content,
   --#                                         Comp_Sym,
   --#                                         ContextManager.Ops.Unit_Stack,
   --#                                         Dictionary.Dict,
   --#                                         ErrorHandler.Error_Context,
   --#                                         LexTokenManager.State,
   --#                                         Node,
   --#                                         Scope,
   --#                                         SPARK_IO.File_Sys,
   --#                                         STree.Table;
   --# pre Syntax_Node_Type (Node, STree.Table) = SP_Symbols.dotted_simple_name;
   --# post STree.Table = STree.Table~;
   is
      Prefix_Sym         : Dictionary.Symbol := Dictionary.NullSymbol;
      Current_Sym        : Dictionary.Symbol;
      Current_Node       : STree.SyntaxNode;
      Explicit_Duplicate : Boolean;
      Ok                 : Boolean;

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

      function Dotted_Identifier_Found (Node : STree.SyntaxNode) return Boolean
      --# global in STree.Table;
      --# pre Syntax_Node_Type (Node, STree.Table) = SP_Symbols.dotted_simple_name;
      is
         Current_Node : STree.SyntaxNode;
      begin
         Current_Node := Child_Node (Current_Node => Node);
         -- ASSUME Current_Node = dotted_simple_name OR identifier
         SystemErrors.RT_Assert
           (C       => Syntax_Node_Type (Node => Current_Node) = SP_Symbols.dotted_simple_name or
              Syntax_Node_Type (Node => Current_Node) = SP_Symbols.identifier,
            Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Current_Node = dotted_simple_name OR identifier in Dotted_Simple_Name");
         return Syntax_Node_Type (Node => Current_Node) = SP_Symbols.dotted_simple_name;
      end Dotted_Identifier_Found;

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

      function Look_Up
        (Prefix : in Dictionary.Symbol;
         Str    : in LexTokenManager.Lex_String;
         Scope  : in Dictionary.Scopes)
        return   Dictionary.Symbol
      --# global in CommandLineData.Content;
      --#        in Dictionary.Dict;
      --#        in LexTokenManager.State;
      is
         Sym : Dictionary.Symbol;
      begin
         if Dictionary.Is_Null_Symbol (Prefix) then
            Sym :=
              Dictionary.LookupItem (Name              => Str,
                                     Scope             => Scope,
                                     Context           => Dictionary.ProofContext,
                                     Full_Package_Name => False);
         else
            Sym :=
              Dictionary.LookupSelectedItem
              (Prefix   => Prefix,
               Selector => Str,
               Scope    => Scope,
               Context  => Dictionary.ProofContext);
         end if;
         return Sym;
      end Look_Up;

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

      -- Note: A package owner (if it exists) is the parent of the closest
      -- private anscestor.
      procedure Check_Package_Owner
        (Current_Node          : in     STree.SyntaxNode;
         Comp_Sym, Current_Sym : in     Dictionary.Symbol;
         Ok                    :    out Boolean)
      --# global in     CommandLineData.Content;
      --#        in     Dictionary.Dict;
      --#        in     LexTokenManager.State;
      --#        in     STree.Table;
      --#        in out ErrorHandler.Error_Context;
      --#        in out SPARK_IO.File_Sys;
      --# derives ErrorHandler.Error_Context,
      --#         SPARK_IO.File_Sys          from CommandLineData.Content,
      --#                                         Comp_Sym,
      --#                                         Current_Node,
      --#                                         Current_Sym,
      --#                                         Dictionary.Dict,
      --#                                         ErrorHandler.Error_Context,
      --#                                         LexTokenManager.State,
      --#                                         SPARK_IO.File_Sys,
      --#                                         STree.Table &
      --#         Ok                         from Comp_Sym,
      --#                                         Current_Sym,
      --#                                         Dictionary.Dict;
      --# pre Syntax_Node_Type (Current_Node, STree.Table) = SP_Symbols.identifier;
      is
         Owner : Dictionary.Symbol;
      begin
         Ok    := True;
         Owner := Dictionary.GetPackageOwner (Comp_Sym);
         if not Dictionary.Is_Null_Symbol (Owner)
           and then not Dictionary.Packages_Are_Equal (Left_Symbol  => Current_Sym,
                                                       Right_Symbol => Owner) then
            if Dictionary.IsProperDescendent (Current_Sym, Owner) then
               if not Dictionary.IsPrivateDescendent (Current_Sym, Owner) then
                  ErrorHandler.Semantic_Error
                    (Err_Num   => 617,
                     Reference => ErrorHandler.No_Reference,
                     Position  => Node_Position (Node => Current_Node),
                     Id_Str    => Node_Lex_String (Node => Current_Node));
                  Ok := False;
               end if;
            elsif not Dictionary.IsInherited (Current_Sym, Owner) then
               ErrorHandler.Semantic_Error
                 (Err_Num   => 618,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Current_Node),
                  Id_Str    => Node_Lex_String (Node => Current_Node));
               Ok := False;
            end if;
         end if;
      end Check_Package_Owner;

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

      -- Detects eg P.Q inheriting both R and P.R
      procedure Check_For_Redeclaration
        (Current_Node          : in     STree.SyntaxNode;
         Comp_Sym, Current_Sym : in     Dictionary.Symbol;
         Ok                    :    out Boolean)
      --# global in     CommandLineData.Content;
      --#        in     Dictionary.Dict;
      --#        in     LexTokenManager.State;
      --#        in out ErrorHandler.Error_Context;
      --#        in out SPARK_IO.File_Sys;
      --#        in out STree.Table;
      --# derives ErrorHandler.Error_Context,
      --#         SPARK_IO.File_Sys          from CommandLineData.Content,
      --#                                         Comp_Sym,
      --#                                         Current_Node,
      --#                                         Current_Sym,
      --#                                         Dictionary.Dict,
      --#                                         ErrorHandler.Error_Context,
      --#                                         LexTokenManager.State,
      --#                                         SPARK_IO.File_Sys,
      --#                                         STree.Table &
      --#         Ok,
      --#         STree.Table                from CommandLineData.Content,
      --#                                         Comp_Sym,
      --#                                         Current_Node,
      --#                                         Current_Sym,
      --#                                         Dictionary.Dict,
      --#                                         LexTokenManager.State,
      --#                                         STree.Table;
      --# pre Syntax_Node_Type (Current_Node, STree.Table) = SP_Symbols.identifier;
      --# post STree.Table = STree.Table~;
      is
         Parent_Sym  : Dictionary.Symbol;
         Visible_Sym : Dictionary.Symbol;
      begin
         Ok := True;
         if not Dictionary.IsEmbeddedPackage (Comp_Sym) and then Dictionary.IsPackage (Current_Sym) then
            -- guard for next line's call
            Parent_Sym := Dictionary.GetPackageParent (Current_Sym);
            if Dictionary.Is_Null_Symbol (Parent_Sym) or else Dictionary.IsProperDescendent (Comp_Sym, Parent_Sym) then
               -- Current_Sym will be directly visible
               Visible_Sym :=
                 Dictionary.LookupItem
                 (Name              => Node_Lex_String (Node => Current_Node),
                  Scope             => Dictionary.Set_Visibility (The_Visibility => Dictionary.Visible,
                                                                  The_Unit       => Comp_Sym),
                  Context           => Dictionary.ProofContext,
                  Full_Package_Name => False);
               if not Dictionary.Is_Null_Symbol (Visible_Sym)
                 and then not Dictionary.Packages_Are_Equal (Left_Symbol  => Visible_Sym,
                                                             Right_Symbol => Current_Sym) then
                  -- name is already directly visible (and not duplicate)
                  ErrorHandler.Semantic_Error
                    (Err_Num   => 10,
                     Reference => ErrorHandler.No_Reference,
                     Position  => Node_Position (Node => Current_Node),
                     Id_Str    => Node_Lex_String (Node => Current_Node));
                  Ok := False;
               elsif not Dictionary.Is_Null_Symbol (Visible_Sym) then
                  STree.Set_Node_Lex_String (Sym  => Visible_Sym,
                                             Node => Current_Node);
               end if;
            end if;
         end if;
      end Check_For_Redeclaration;

   begin -- Process_Dotted_Simple_Name
      if Dotted_Identifier_Found (Node => Node) and then CommandLineData.Content.Language_Profile = CommandLineData.SPARK83 then
         ErrorHandler.Semantic_Error
           (Err_Num   => 610,
            Reference => ErrorHandler.No_Reference,
            Position  => Node_Position (Node => Node),
            Id_Str    => LexTokenManager.Null_String);
      else
         Current_Node := Last_Child_Of (Start_Node => Node);
         loop
            --# assert STree.Table = STree.Table~;
            -- ASSUME Current_Node = identifier
            SystemErrors.RT_Assert
              (C       => Syntax_Node_Type (Node => Current_Node) = SP_Symbols.identifier,
               Sys_Err => SystemErrors.Invalid_Syntax_Tree,
               Msg     => "Expect Current_Node = identifier in Process_Dotted_Simple_Name");
            Current_Sym := Look_Up (Prefix => Prefix_Sym,
                                    Str    => Node_Lex_String (Node => Current_Node),
                                    Scope  => Scope);
            if Dictionary.Is_Null_Symbol (Current_Sym) then
               ErrorHandler.Semantic_Error
                 (Err_Num   => 135,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Current_Node),
                  Id_Str    => Node_Lex_String (Node => Current_Node));
               exit;
            end if;

            if not Dictionary.IsPackage (Current_Sym)
              and then not Dictionary.Is_Generic_Subprogram (The_Symbol => Current_Sym) then
               -- can't be inherited
               ErrorHandler.Semantic_Error
                 (Err_Num   => 18,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Current_Node),
                  Id_Str    => Node_Lex_String (Node => Current_Node));
               exit;
            end if;

            if Current_Sym = Comp_Sym then -- trying to inherit self
               ErrorHandler.Semantic_Error
                 (Err_Num   => 134,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Current_Node),
                  Id_Str    => Node_Lex_String (Node => Current_Node));
               exit;
            end if;

            -- check for valid inheriting of private packages
            if Dictionary.IsPackage (Current_Sym)
              and then -- guard for next call
              Dictionary.IsPrivatePackage (Current_Sym)
              and then not Dictionary.Is_Null_Symbol (Dictionary.GetPackageParent (Current_Sym))
              and then (Dictionary.IsMainProgram (Comp_Sym)
                          or else not (Dictionary.IsEmbeddedPackage (Comp_Sym)
                                         or else Dictionary.IsDescendentOfPrivateSibling (Comp_Sym, Current_Sym))) then
               ErrorHandler.Semantic_Error
                 (Err_Num   => 616,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Current_Node),
                  Id_Str    => Node_Lex_String (Node => Current_Node));
               exit;
            end if;

            -- check rules for what a child package may and may not inherit (i.e. siblings of
            -- same kind (public/private) etc).  Note guard so that we don't do this if the
            -- inherited things is a generic subprogram since these are library-level units that
            -- aren't covered by the child package hierarchy rules
            Ok := True;
            if CommandLineData.Content.Language_Profile /= CommandLineData.SPARK83
              and then Dictionary.IsPackage (Comp_Sym)
              and then not Dictionary.Is_Generic_Subprogram (The_Symbol => Current_Sym) then
               Check_Package_Owner (Current_Node => Current_Node,
                                    Comp_Sym     => Comp_Sym,
                                    Current_Sym  => Current_Sym,
                                    Ok           => Ok);
               if Ok then
                  Check_For_Redeclaration
                    (Current_Node => Current_Node,
                     Comp_Sym     => Comp_Sym,
                     Current_Sym  => Current_Sym,
                     Ok           => Ok);
               end if;
            end if;
            exit when not Ok;

            Dictionary.AddInheritsReference
              (The_Unit             => Comp_Sym,
               The_Inherited_Symbol => Current_Sym,
               Explicit             => Parent_Node (Current_Node => Current_Node) = Node,
               Comp_Unit            => ContextManager.Ops.Current_Unit,
               Declaration          => Dictionary.Location'(Start_Position => Node_Position (Node => Current_Node),
                                                            End_Position   => Node_Position (Node => Current_Node)),
               Already_Present      => Explicit_Duplicate);
            if Explicit_Duplicate then
               ErrorHandler.Semantic_Error_Sym
                 (Err_Num   => 190,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Node),
                  Sym       => Current_Sym,
                  Scope     => Scope);
            end if;
            STree.Set_Node_Lex_String (Sym  => Current_Sym,
                                       Node => Current_Node);

            Current_Node := Parent_Node (Current_Node => Current_Node);
            -- ASSUME Current_Node = dotted_simple_name
            SystemErrors.RT_Assert
              (C       => Syntax_Node_Type (Node => Current_Node) = SP_Symbols.dotted_simple_name,
               Sys_Err => SystemErrors.Invalid_Syntax_Tree,
               Msg     => "Expect Current_Node = dotted_simple_name in Process_Dotted_Simple_Name");
            exit when Current_Node = Node;
            Prefix_Sym   := Current_Sym; -- ready for next lookup
            Current_Node := Next_Sibling (Current_Node => Current_Node);
         end loop;
      end if;
   end Process_Dotted_Simple_Name;

begin -- Wf_Inherit_Clause
   It := Find_First_Node (Node_Kind    => SP_Symbols.dotted_simple_name,
                          From_Root    => Node,
                          In_Direction => STree.Down);
   while not STree.IsNull (It) loop
      Next_Node := Get_Node (It => It);
      --# assert STree.Table = STree.Table~ and
      --#   Syntax_Node_Type (Next_Node, STree.Table) = SP_Symbols.dotted_simple_name and
      --#   Next_Node = Get_Node (It);
      Process_Dotted_Simple_Name (Node     => Next_Node,
                                  Comp_Sym => Comp_Sym,
                                  Scope    => Scope);
      It := STree.NextNode (It);
   end loop;

   if ErrorHandler.Generate_SLI then
      SLI.Generate_Xref_Inherit (Comp_Unit  => ContextManager.Ops.Current_Unit,
                                 Parse_Tree => Node,
                                 Scope      => Scope);
   end if;
end Wf_Inherit_Clause;
