-------------------------------------------------------------------------------
-- (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 DAG;
with Debug;
with Pile;

separate (VCG)
procedure ProduceVCs
  (VCG_Heap                      : in out Cells.Heap_Record;
   Start_Node                    : in     STree.SyntaxNode;
   Subprog_Sym                   : in     Dictionary.Symbol;
   Scope                         : in     Dictionary.Scopes;
   VCG_Output_File               : in     SPARK_IO.File_Type;
   DPC_Output_File               : in     SPARK_IO.File_Type;
   Output_Filename               : in     E_Strings.T;
   End_Position                  : in     LexTokenManager.Token_Position;
   Flow_Heap                     : in out Heap.HeapRecord;
   Semantic_Error_In_Subprogram  : in     Boolean;
   Data_Flow_Error_In_Subprogram : in     Boolean;
   Type_Check_Exports            : in     Boolean)
is
   VCG_Failure  : Boolean;
   Verbose_Echo : Boolean;

   procedure Put_Line (S : in String)
   --# global in     Verbose_Echo;
   --#        in out SPARK_IO.File_Sys;
   --# derives SPARK_IO.File_Sys from *,
   --#                                S,
   --#                                Verbose_Echo;
   is
   begin
      if Verbose_Echo then
         ScreenEcho.Put_Line (S);
      end if;
   end Put_Line;

   procedure New_Line
   --# global in     Verbose_Echo;
   --#        in out SPARK_IO.File_Sys;
   --# derives SPARK_IO.File_Sys from *,
   --#                                Verbose_Echo;
   is
   begin
      if Verbose_Echo then
         ScreenEcho.New_Line (1);
      end if;
   end New_Line;

   procedure Dump_Used_Symbols (S : in String)
   --# derives null from S;
   is
      --# hide Dump_Used_Symbols;
      Iterator : Declarations.UsedSymbolIterator;
      CN       : Cells.Cell;
      CS       : Dictionary.Symbol;
      CDAG     : Cells.Cell;
   begin
      Debug.PrintMsg (S, True);
      Declarations.Initialize (Iterator);
      while not Declarations.IsNullIterator (Iterator) loop
         CN := Declarations.CurrentNode (Iterator);
         CS := Cells.Get_Symbol_Value (VCG_Heap, CN);
         Debug.Print_Sym (Msg => "Symbol: ",
                          Sym => CS);

         if Dictionary.Is_Constant (CS) then
            Debug.PrintMsg ("is a constant and ", False);
            if Dictionary.IsPrivateType (Dictionary.GetType (CS), Scope) then
               Debug.PrintMsg ("is a private type in this scope", True);
            else
               if Dictionary.TypeIsScalar (Dictionary.GetType (CS)) then
                  Debug.PrintMsg ("is a scalar in this scope", True);
               elsif Dictionary.TypeIsArray (Dictionary.GetType (CS)) then
                  Debug.PrintMsg ("is an array in this scope", True);
                  CDAG := Pile.DAG (VCG_Heap, CN);
                  if Cells.Is_Null_Cell (CDAG) then
                     Debug.PrintMsg ("and its DAG is Null", True);
                  else
                     Debug.PrintDAG ("and its DAG is ", CDAG, VCG_Heap, Scope);
                  end if;

               elsif Dictionary.TypeIsRecord (Dictionary.GetType (CS)) then
                  Debug.PrintMsg ("is an array in this scope", True);
                  CDAG := Pile.DAG (VCG_Heap, CN);
                  if Cells.Is_Null_Cell (CDAG) then
                     Debug.PrintMsg ("and its DAG is Null", True);
                  else
                     Debug.PrintDAG ("and its DAG is ", CDAG, VCG_Heap, Scope);
                  end if;
               else
                  Debug.PrintMsg ("is OTHER in this scope", True);
               end if;
            end if;
         else
            Debug.PrintMsg ("is not a constant", True);
         end if;

         Iterator := Declarations.NextNode (VCG_Heap, Iterator);
      end loop;
      Debug.PrintMsg ("---End---", True);
   end Dump_Used_Symbols;
   pragma Unreferenced (Dump_Used_Symbols);

   procedure Process_Composite_Constants
   --# global in     CommandLineData.Content;
   --#        in     End_Position;
   --#        in     Scope;
   --#        in     STree.Table;
   --#        in out Declarations.State;
   --#        in out Dictionary.Dict;
   --#        in out ErrorHandler.Error_Context;
   --#        in out Flow_Heap;
   --#        in out Graph.Table;
   --#        in out LexTokenManager.State;
   --#        in out SPARK_IO.File_Sys;
   --#        in out Statistics.TableUsage;
   --#        in out StmtStack.S;
   --#        in out VCG_Heap;
   --# derives Declarations.State,
   --#         Dictionary.Dict,
   --#         Flow_Heap,
   --#         Graph.Table,
   --#         LexTokenManager.State,
   --#         Statistics.TableUsage,
   --#         StmtStack.S,
   --#         VCG_Heap                   from *,
   --#                                         CommandLineData.Content,
   --#                                         Declarations.State,
   --#                                         Dictionary.Dict,
   --#                                         Flow_Heap,
   --#                                         Graph.Table,
   --#                                         LexTokenManager.State,
   --#                                         Scope,
   --#                                         StmtStack.S,
   --#                                         STree.Table,
   --#                                         VCG_Heap &
   --#         ErrorHandler.Error_Context,
   --#         SPARK_IO.File_Sys          from CommandLineData.Content,
   --#                                         Declarations.State,
   --#                                         Dictionary.Dict,
   --#                                         End_Position,
   --#                                         ErrorHandler.Error_Context,
   --#                                         Flow_Heap,
   --#                                         Graph.Table,
   --#                                         LexTokenManager.State,
   --#                                         Scope,
   --#                                         SPARK_IO.File_Sys,
   --#                                         StmtStack.S,
   --#                                         STree.Table,
   --#                                         VCG_Heap;
   is
      Iterator    : Declarations.UsedSymbolIterator;
      CN          : Cells.Cell;
      CS          : Dictionary.Symbol;
      CT          : Dictionary.Symbol;
      CDAG        : Cells.Cell;
      Change_Made : Boolean;
      Exp_Node    : STree.SyntaxNode;

      function Rule_Is_Required (CS : Dictionary.Symbol) return Boolean
      --# global in CommandLineData.Content;
      --#        in Dictionary.Dict;
      --#        in Scope;
      is
      begin
         return CommandLineData.Content.Constant_Rules = CommandLineData.All_Rules
           or else (CommandLineData.Content.Constant_Rules = CommandLineData.Keen
                      and then not (Dictionary.GetConstantRulePolicy (CS, Scope) = Dictionary.No_Rule_Requested))
           or else (CommandLineData.Content.Constant_Rules = CommandLineData.Lazy
                      and then Dictionary.GetConstantRulePolicy (CS, Scope) = Dictionary.Rule_Requested);
      end Rule_Is_Required;

      procedure Raise_Warnings
      --# global in     CommandLineData.Content;
      --#        in     Declarations.State;
      --#        in     Dictionary.Dict;
      --#        in     End_Position;
      --#        in     LexTokenManager.State;
      --#        in     Scope;
      --#        in     VCG_Heap;
      --#        in out ErrorHandler.Error_Context;
      --#        in out SPARK_IO.File_Sys;
      --# derives ErrorHandler.Error_Context,
      --#         SPARK_IO.File_Sys          from CommandLineData.Content,
      --#                                         Declarations.State,
      --#                                         Dictionary.Dict,
      --#                                         End_Position,
      --#                                         ErrorHandler.Error_Context,
      --#                                         LexTokenManager.State,
      --#                                         Scope,
      --#                                         SPARK_IO.File_Sys,
      --#                                         VCG_Heap;
      is
         Iterator : Declarations.UsedSymbolIterator;
         CN       : Cells.Cell;
         CS       : Dictionary.Symbol;
         CT       : Dictionary.Symbol;
         CDAG     : Cells.Cell;
      begin
         Declarations.Initialize (Iterator);

         while not Declarations.IsNullIterator (Iterator) loop

            CN := Declarations.CurrentNode (Iterator);
            CS := Cells.Get_Symbol_Value (VCG_Heap, CN);
            CT := Dictionary.GetType (CS);

            -- We're interested in visible (not private), composite constants...
            if Dictionary.Is_Constant (CS)
              and then not Dictionary.IsPrivateType (CT, Scope)
              and then not Dictionary.IsGenericParameterSymbol (CS)
              and then (Dictionary.TypeIsArray (CT) or else Dictionary.TypeIsRecord (CT))
              and then Rule_Is_Required (CS => CS) then

               CDAG := Pile.DAG (VCG_Heap, CN);
               if Cells.Is_Null_Cell (CDAG) then
                  if Dictionary.ConstantExpIsWellformed (CS) then

                     if Dictionary.TypeIsArray (CT) and then Dictionary.GetNumberOfDimensions (CT) > 1 then

                        -- At present, FDL cannot represent multi-dimensional array aggregates,
                        -- so we simply issue a warning and continue.  The warning
                        -- appears at the end of the listing for the subprogram that
                        -- we are generating VCs for.
                        ErrorHandler.Semantic_Warning_Sym
                          (Err_Num  => 312,
                           Position => End_Position,
                           Sym      => CS,
                           Scope    => Dictionary.GetScope (CS));
                     end if;

                  else

                     -- Cannot produce rule due to semantic errors in Expression
                     -- we simply issue a warning and continue.  The warning
                     -- appears at the end of the listing for the subprogram that
                     -- we are generating VCs for.
                     ErrorHandler.Semantic_Warning_Sym
                       (Err_Num  => 313,
                        Position => End_Position,
                        Sym      => CS,
                        Scope    => Dictionary.GetScope (CS));
                  end if;
               end if;

            end if;

            Iterator := Declarations.NextNode (VCG_Heap, Iterator);
         end loop;

      end Raise_Warnings;

   begin

      loop
         Change_Made := False;
         Declarations.Initialize (Iterator);

         while not Declarations.IsNullIterator (Iterator) loop

            CN := Declarations.CurrentNode (Iterator);
            CS := Cells.Get_Symbol_Value (VCG_Heap, CN);
            CT := Dictionary.GetType (CS);

            -- We're interested in visible (not private), composite constants...
            if Dictionary.Is_Constant (CS)
              and then not Dictionary.IsPrivateType (CT, Scope)
              and then not Dictionary.IsGenericParameterSymbol (CS)
              and then (Dictionary.TypeIsArray (CT) or else Dictionary.TypeIsRecord (CT))
              and then Rule_Is_Required (CS => CS) then

               CDAG := Pile.DAG (VCG_Heap, CN);
               if Cells.Is_Null_Cell (CDAG) then
                  if Dictionary.ConstantExpIsWellformed (CS) then

                     Exp_Node := STree.RefToNode (Dictionary.GetConstantExpNode (CS));
                     if (not Dictionary.TypeIsArray (CT)) or else Dictionary.GetNumberOfDimensions (CT) = 1 then

                        -- Build the DAG for this initializing expression, and store the
                        -- resulting root Cell in the Pile Node for this constant.
                        -- The initializing expression must be evaluation in the Scope where
                        -- it is declared.
                        DAG.BuildConstantInitializationDAG (Exp_Node, Dictionary.GetScope (CS), VCG_Heap, Flow_Heap, CDAG);
                        Pile.SetDAG (VCG_Heap, CN, CDAG);

                        -- This newly generated DAG might contain references to other
                        -- constants and so on which need FDL declarations and Rules, so...
                        Declarations.Find_DAG_Declarations (Heap => VCG_Heap,
                                                            Root => CDAG);

                        -- ...that might have changed the state of the Declarations package,
                        -- which we are currrently iterating over.  This means our Iterator
                        -- is no longer valid, so we have to give up here and start a new
                        -- pass.
                        Change_Made := True;

                     end if;

                  end if;
               end if;

            end if;

            exit when Change_Made;

            Iterator := Declarations.NextNode (VCG_Heap, Iterator);
         end loop;

         -- No changes at all made - that means we must have processed all the constants,
         -- so we can terminate.
         exit when not Change_Made;
      end loop;

      Raise_Warnings;

   end Process_Composite_Constants;

begin -- ProduceVCs;
   Verbose_Echo := CommandLineData.Content.Echo and not CommandLineData.Content.Brief;

   New_Line;
   Put_Line (S => "           Building model of subprogram ...");

   Graph.Reinitialize_Graph;
   VCG_Failure := False;

   DAG.BuildGraph
     (Start_Node,
      Subprog_Sym,
      Scope,
      VCG_Output_File,
      End_Position,
      VCG_Failure,
      VCG_Heap,
      Flow_Heap,
      Semantic_Error_In_Subprogram,
      Data_Flow_Error_In_Subprogram,
      Type_Check_Exports);

   if VCG_Failure then
      ErrorHandler.Semantic_Error
        (Err_Num   => 962,
         Reference => 0,
         Position  => End_Position,
         Id_Str    => LexTokenManager.Null_String);
   else
      if CommandLineData.Content.Debug.VCG then
         Debug.PrintMsg ("----------- Dump of VCG State after DAG.BuildGraph ---------------", True);
         Graph.Dump_Graph_Table (VCG_Heap, Scope, Graph.PFs);
         Graph.Dump_Graph_Dot (VCG_Heap, Output_Filename, 0, Scope, Graph.PFs);
         Debug.PrintMsg ("------------------------------------------------------------------", True);
      end if;

      New_Line;
      Put_Line (S => "           Generating VCs ...");
      Graph.Gen_VCs
        (Heap             => VCG_Heap,
         Output_File      => VCG_Output_File,
         Output_File_Name => Output_Filename,
         Scope            => Scope,
         Gen_VC_Failure   => VCG_Failure);
      if VCG_Failure then
         New_Line;
         ErrorHandler.Semantic_Error
           (Err_Num   => 962,
            Reference => 0,
            Position  => End_Position,
            Id_Str    => LexTokenManager.Null_String);
      else
         if CommandLineData.Content.VCG then
            New_Line;
            Put_Line (S => "           Writing VCs ...");
            Graph.Print_VCs_Or_DPCs (VCG_Heap, VCG_Output_File, Scope, Graph.VCs);
         end if;

         if CommandLineData.Content.DPC then
            New_Line;
            Put_Line (S => "           Writing DPCs ...");
            Graph.Print_VCs_Or_DPCs (VCG_Heap, DPC_Output_File, Scope, Graph.DPCs);
         end if;

         -- We also need to generate DAGs and Declarations for the
         -- initializing expressions of any composite constants that
         -- have been referenced in the VCs printed above.
         if CommandLineData.Content.Constant_Rules /= CommandLineData.No_Rules then
            Process_Composite_Constants;
         end if;

      end if;
   end if;
end ProduceVCs;
