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

with LexTokenManager.Relation_Algebra.String;
with LexTokenManager.Seq_Algebra;

separate (Sem.Wf_Package_Declaration.Wf_Package_Specification)
procedure Check_Modes (Node     : in     STree.SyntaxNode;
                       Pack_Sym : in     Dictionary.Symbol;
                       The_Heap : in out Heap.HeapRecord) is

   Priv_Type_It, Subprog_It, Param_It : Dictionary.Iterator;
   Type_Sym, Subprog_Sym, Param_Sym   : Dictionary.Symbol;
   Vis_Part_Rep_Node, Proc_Spec_Node  : STree.SyntaxNode;
   Subprograms_To_Mark                : Boolean;
   Current_Param_List                 : LexTokenManager.Seq_Algebra.Seq;
   The_Relation                       : LexTokenManager.Relation_Algebra.String.Relation;

   procedure Process_Procedure
     (Node       : in STree.SyntaxNode;
      Param_List : in LexTokenManager.Seq_Algebra.Seq;
      The_Heap   : in Heap.HeapRecord)
   --# 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,
   --#                                         Dictionary.Dict,
   --#                                         ErrorHandler.Error_Context,
   --#                                         LexTokenManager.State,
   --#                                         Node,
   --#                                         Param_List,
   --#                                         SPARK_IO.File_Sys,
   --#                                         STree.Table,
   --#                                         The_Heap;
   --# pre Syntax_Node_Type (Node, STree.Table) = SP_Symbols.formal_part;
   is
      It      : STree.Iterator;
      Id_Node : STree.SyntaxNode;
   begin
      It := Find_First_Node (Node_Kind    => SP_Symbols.identifier,
                             From_Root    => Node,
                             In_Direction => STree.Down);

      while not STree.IsNull (It) loop
         Id_Node := Get_Node (It => It);
         --# assert Syntax_Node_Type (Id_Node, STree.Table) = SP_Symbols.identifier and
         --#   Id_Node = Get_Node (It);
         if LexTokenManager.Seq_Algebra.Is_Member
           (The_Heap    => The_Heap,
            S           => Param_List,
            Given_Value => Node_Lex_String (Node => Id_Node)) then
            ErrorHandler.Semantic_Error
              (Err_Num   => 338,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => Id_Node),
               Id_Str    => Node_Lex_String (Node => Id_Node));
         end if;
         It := STree.NextNode (It);
      end loop;
   end Process_Procedure;

begin -- Check_Modes
   LexTokenManager.Relation_Algebra.String.Create_Relation (The_Heap => The_Heap,
                                                            R        => The_Relation);
   Subprograms_To_Mark := False;
   Priv_Type_It        := Dictionary.First_Private_Type (The_Package => Pack_Sym);
   while not Dictionary.IsNullIterator (Priv_Type_It) loop
      Type_Sym := Dictionary.CurrentSymbol (Priv_Type_It);
      if Dictionary.Is_Declared (Item => Type_Sym) and then Dictionary.TypeIsScalar (Type_Sym) then
         -- we have a scalar private type which may affect subprog params
         Subprog_It := Dictionary.First_Visible_Subprogram (The_Package_Or_Type => Pack_Sym);
         while not Dictionary.IsNullIterator (Subprog_It) loop
            Subprog_Sym := Dictionary.CurrentSymbol (Subprog_It);

            Param_It := Dictionary.FirstSubprogramParameter (Subprog_Sym);
            while not Dictionary.IsNullIterator (Param_It) loop
               Param_Sym := Dictionary.CurrentSymbol (Param_It);
               if Dictionary.Types_Are_Equal
                 (Left_Symbol        => Dictionary.GetType (Param_Sym),
                  Right_Symbol       => Type_Sym,
                  Full_Range_Subtype => False)
                 and then Dictionary.GetSubprogramParameterMode (Param_Sym) = Dictionary.InOutMode
                 and then not Dictionary.IsImport (Dictionary.IsAbstract, Subprog_Sym, Param_Sym) then
                  Subprograms_To_Mark := True;
                  LexTokenManager.Relation_Algebra.String.Insert_Pair
                    (The_Heap => The_Heap,
                     R        => The_Relation,
                     I        => Dictionary.GetSimpleName (Subprog_Sym),
                     J        => Dictionary.GetSimpleName (Param_Sym));
               end if;
               Param_It := Dictionary.NextSymbol (Param_It);
            end loop;

            Subprog_It := Dictionary.NextSymbol (Subprog_It);
         end loop;
      end if;
      Priv_Type_It := Dictionary.NextSymbol (Priv_Type_It);
   end loop;

   -- At this point we have created in SubprogList a data structure listing
   -- all the procedures made illegal by the private types' full declarations
   -- and for each of them a list of affected parameters.  We now walk the
   -- syntax tree marking each parameter occurrence found.
   if Subprograms_To_Mark then
      Vis_Part_Rep_Node := Child_Node (Current_Node => Node);
      -- ASSUME Vis_Part_Rep_Node = visible_part_rep OR NULL
      while Syntax_Node_Type (Node => Vis_Part_Rep_Node) = SP_Symbols.visible_part_rep loop
         -- ASSUME Vis_Part_Rep_Node = visible_part_rep
         Proc_Spec_Node := Next_Sibling (Current_Node => Vis_Part_Rep_Node);
         -- ASSUME Proc_Spec_Node = basic_declarative_item OR private_type_declaration OR deferred_constant_declaration OR
         --                         subprogram_declaration OR generic_subprogram_instantiation OR apragma OR
         --                         renaming_declaration
         if Syntax_Node_Type (Node => Proc_Spec_Node) = SP_Symbols.subprogram_declaration then
            -- ASSUME Proc_Spec_Node = subprogram_declaration
            Proc_Spec_Node := Child_Node (Current_Node => Proc_Spec_Node);
            -- ASSUME Proc_Spec_Node = overriding_indicator OR procedure_specification OR function_specification OR
            --                         proof_function_declaration
            if Syntax_Node_Type (Node => Proc_Spec_Node) = SP_Symbols.overriding_indicator then
               -- ASSUME Proc_Spec_Node = overriding_indicator
               Proc_Spec_Node := Next_Sibling (Current_Node => Proc_Spec_Node);
            elsif Syntax_Node_Type (Node => Proc_Spec_Node) /= SP_Symbols.function_specification
              and then Syntax_Node_Type (Node => Proc_Spec_Node) /= SP_Symbols.procedure_specification
              and then Syntax_Node_Type (Node => Proc_Spec_Node) /= SP_Symbols.proof_function_declaration then
               SystemErrors.Fatal_Error
                 (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
                  Msg     => "Expect Proc_Spec_Node = overriding_indicator OR procedure_specification OR " &
                    "function_specification OR proof_function_declaration in Check_Modes");
            end if;
            -- ASSUME Proc_Spec_Node = procedure_specification OR function_specification OR proof_function_declaration
            if Syntax_Node_Type (Node => Proc_Spec_Node) = SP_Symbols.procedure_specification then
               -- ASSUME Proc_Spec_Node = procedure_specification
               LexTokenManager.Relation_Algebra.String.Row_Extraction
                 (The_Heap    => The_Heap,
                  R           => The_Relation,
                  Given_Index => Node_Lex_String (Node => Child_Node (Current_Node => Child_Node (Current_Node => Proc_Spec_Node))),
                  S           => Current_Param_List);
               if not LexTokenManager.Seq_Algebra.Is_Null_Seq (S => Current_Param_List) then
                  Proc_Spec_Node := Next_Sibling (Current_Node => Child_Node (Current_Node => Proc_Spec_Node));
                  -- ASSUME Proc_Spec_Node = formal_part OR NULL
                  if Syntax_Node_Type (Node => Proc_Spec_Node) = SP_Symbols.formal_part then
                     Process_Procedure (Node       => Proc_Spec_Node,
                                        Param_List => Current_Param_List,
                                        The_Heap   => The_Heap);
                  elsif Proc_Spec_Node /= STree.NullNode then
                     SystemErrors.Fatal_Error
                       (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
                        Msg     => "Expect Proc_Spec_Node = formal_part OR NULL in Check_Modes");
                  end if;
               end if;
            elsif Syntax_Node_Type (Node => Proc_Spec_Node) /= SP_Symbols.function_specification
              and then Syntax_Node_Type (Node => Proc_Spec_Node) /= SP_Symbols.proof_function_declaration then
               SystemErrors.Fatal_Error
                 (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
                  Msg     => "Expect Proc_Spec_Node = procedure_specification OR " &
                    "function_specification OR proof_function_declaration in Check_Modes");
            end if;
         elsif Syntax_Node_Type (Node => Proc_Spec_Node) /= SP_Symbols.basic_declarative_item
           and then Syntax_Node_Type (Node => Proc_Spec_Node) /= SP_Symbols.private_type_declaration
           and then Syntax_Node_Type (Node => Proc_Spec_Node) /= SP_Symbols.deferred_constant_declaration
           and then Syntax_Node_Type (Node => Proc_Spec_Node) /= SP_Symbols.generic_subprogram_instantiation
           and then Syntax_Node_Type (Node => Proc_Spec_Node) /= SP_Symbols.apragma
           and then Syntax_Node_Type (Node => Proc_Spec_Node) /= SP_Symbols.renaming_declaration then
            SystemErrors.Fatal_Error
              (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
               Msg     => "Expect Proc_Spec_Node = basic_declarative_item OR private_type_declaration OR " &
                 "deferred_constant_declaration OR subprogram_declaration OR generic_subprogram_instantiation OR " &
                 "apragma OR renaming_declaration in Check_Modes");
         end if;
         Vis_Part_Rep_Node := Child_Node (Current_Node => Vis_Part_Rep_Node);
      end loop;
   end if;
end Check_Modes;
