-------------------------------------------------------------------------------
-- (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 (DAG.BuildGraph)
procedure ModelAssignmentStmt is
   AssignedVarCell, AssignedVarRoot, DAGRoot, StmtCell, MkAggregateCell, ModList : Cells.Cell;
   ExpnNode, VariableComponentNode                                               : STree.SyntaxNode;
   StmtLabel                                                                     : Labels.Label;
   StreamSymbol                                                                  : Dictionary.Symbol;
   OthersAggregate                                                               : Boolean;

   -- Synthesize the DAG for mk__T(E), plugging in DAGRoot for E
   -- and the unconstrained array type name for T
   procedure CreateMkAggregateCell
   --# global in     AssignedVarRoot;
   --#        in     DAGRoot;
   --#        in     Dictionary.Dict;
   --#        in     OthersAggregate;
   --#        in out Statistics.TableUsage;
   --#        in out VCGHeap;
   --#           out MkAggregateCell;
   --# derives MkAggregateCell       from OthersAggregate,
   --#                                    VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    OthersAggregate,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    AssignedVarRoot,
   --#                                    DAGRoot,
   --#                                    Dictionary.Dict,
   --#                                    OthersAggregate;
   is
      Sym : Dictionary.Symbol;
   begin
      if OthersAggregate then
         -- Create "mk__" cell
         CreateCellKind (MkAggregateCell, VCGHeap, Cell_Storage.Mk_Aggregate);

         -- The type for the RHS is the same as the type of the LHS
         Sym := Dictionary.GetType (Cells.Get_Symbol_Value (VCGHeap, AssignedVarRoot));
         Cells.Set_Symbol_Value (VCGHeap, MkAggregateCell, Sym);

         -- The expression is given by DAGRoot, calculated above.
         SetRightArgument (MkAggregateCell, DAGRoot, VCGHeap);
      else
         -- Defensive, and avoids flow error, but MkAggregateCell should not
         -- be used if assignment isn't an unconstrained_array_assignment.
         MkAggregateCell := Cells.Null_Cell;
      end if;
   end CreateMkAggregateCell;

   procedure CreateAssignedVarCell
   --# global in     AssignedVarRoot;
   --#        in out Statistics.TableUsage;
   --#        in out VCGHeap;
   --#           out AssignedVarCell;
   --# derives AssignedVarCell       from VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    AssignedVarRoot;
   is
      LocalCell : Cells.Cell;
   begin
      LocalCell := AssignedVarRoot;
      loop
         exit when (Cells.Get_Kind (VCGHeap, LocalCell) /= Cell_Storage.Op) and
           (Cells.Get_Kind (VCGHeap, LocalCell) /= Cell_Storage.Element_Function) and
           (Cells.Get_Kind (VCGHeap, LocalCell) /= Cell_Storage.Field_Access_Function);
         if (Cells.Get_Kind (VCGHeap, LocalCell) = Cell_Storage.Op) then
            LocalCell := LeftPtr (VCGHeap, LocalCell);
         elsif (Cells.Get_Kind (VCGHeap, LocalCell) = Cell_Storage.Element_Function) or
           (Cells.Get_Kind (VCGHeap, LocalCell) = Cell_Storage.Field_Access_Function) then
            LocalCell := RightPtr (VCGHeap, LocalCell);
         end if;
      end loop;
      Cells.Create_Cell (VCGHeap, AssignedVarCell);
      Cells.Copy_Contents (VCGHeap, LocalCell, AssignedVarCell);
      Cells.Set_Kind (VCGHeap, AssignedVarCell, Cell_Storage.Modified_Op);
   end CreateAssignedVarCell;

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

   -- Digs down to primary node where the wf_primary will have planted a symbol
   -- if the primary references a stream variable.  The returned symbol is either
   -- the stream variable itself if it is a direct assignement or the symbol of a
   -- function if it is a function that globally references one or more streams
   function AssignedStreamSymbol (ExpnNode : STree.SyntaxNode) return Dictionary.Symbol
   --# global in STree.Table;
   is
      LocalNode : STree.SyntaxNode;
      Result    : Dictionary.Symbol;
   begin
      Result    := Dictionary.NullSymbol; --default answer
      LocalNode := ExpnNode;
      loop
         -- to have any chance of success the chain must lead to a primary
         if STree.Syntax_Node_Type (Node => LocalNode) = SP_Symbols.primary then
            Result := STree.NodeSymbol (LocalNode);
            exit;
         end if;

         -- failure cases, if these are found it can't possibly be a simple stream or stream
         -- function assignment so we need to get out of the loop
         exit when STree.Syntax_Node_Type (Node => LocalNode) = SP_Symbols.unary_adding_operator;
         exit when STree.Syntax_Node_Type (Node => LocalNode) = SP_Symbols.RWabs;
         exit when STree.Syntax_Node_Type (Node => LocalNode) = SP_Symbols.RWnot;

         LocalNode := STree.Child_Node (Current_Node => LocalNode);
      end loop;
      return Result;
   end AssignedStreamSymbol;

   -- Complete an assignment model LHS := RHS and chain it into graph
   procedure SetStreamAssignment (LHS, RHS : in Cells.Cell)
   --# global in out Graph.Table;
   --#        in out Statistics.TableUsage;
   --#        in out StmtStack.S;
   --#        in out VCGHeap;
   --# derives Graph.Table,
   --#         StmtStack.S,
   --#         VCGHeap               from Graph.Table,
   --#                                    LHS,
   --#                                    RHS,
   --#                                    StmtStack.S,
   --#                                    VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    LHS,
   --#                                    RHS,
   --#                                    VCGHeap;
   is
      StmtLabel         : Labels.Label;
      StmtCell, ModList : Cells.Cell;
   begin
      PrepareLabel (VCGHeap, StmtLabel, StmtCell);
      Clists.CreateList (VCGHeap, ModList);
      Clists.AppendCell (VCGHeap, LHS, ModList);
      SetRightArgument (LHS, RHS, VCGHeap);
      SetAuxPtr (StmtCell, ModList, VCGHeap);
      Chain (StmtLabel, VCGHeap);
   end SetStreamAssignment;

   -- Build volatility model for a direct read of a stream variable
   procedure ModelStreamVariableSideEffect
   --# global in     StreamSymbol;
   --#        in out Graph.Table;
   --#        in out Statistics.TableUsage;
   --#        in out StmtStack.S;
   --#        in out VCGHeap;
   --# derives Graph.Table,
   --#         StmtStack.S,
   --#         VCGHeap               from Graph.Table,
   --#                                    StmtStack.S,
   --#                                    StreamSymbol,
   --#                                    VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    StreamSymbol,
   --#                                    VCGHeap;
   is
      StreamTargetVar, StreamFunction, StreamExpn : Cells.Cell;

   begin -- ModelStreamVariableSideEffect
      CreateReferenceCell (StreamExpn, VCGHeap, StreamSymbol);

      -- now create the proof attribute function.
      BuildStreamRHS (VCGHeap, StreamSymbol, StreamExpn,
                      --to get
                      StreamFunction);

      CreateModifiedCell (StreamTargetVar, VCGHeap, StreamSymbol);
      --set up assignment
      SetStreamAssignment (StreamTargetVar, StreamFunction);
   end ModelStreamVariableSideEffect;

   -- Build a volatility model for an assignment of a function that globally
   -- references one or more stream variables
   procedure ModelStreamFunctionSideEffect
   --# global in     Dictionary.Dict;
   --#        in     LScope;
   --#        in     StreamSymbol;
   --#        in out Graph.Table;
   --#        in out Statistics.TableUsage;
   --#        in out StmtStack.S;
   --#        in out VCGHeap;
   --# derives Graph.Table,
   --#         Statistics.TableUsage,
   --#         StmtStack.S,
   --#         VCGHeap               from *,
   --#                                    Dictionary.Dict,
   --#                                    Graph.Table,
   --#                                    LScope,
   --#                                    StmtStack.S,
   --#                                    StreamSymbol,
   --#                                    VCGHeap;
   is
      ImportIt                                    : Dictionary.Iterator;
      ImportSym                                   : Dictionary.Symbol;
      StreamTargetVar, StreamFunction, StreamExpn : Cells.Cell;

   begin -- ModelStreamFunctionSideEffect
      ImportIt := Dictionary.FirstGlobalVariable (Dictionary.GetAbstraction (StreamSymbol, LScope), StreamSymbol);
      while not Dictionary.IsNullIterator (ImportIt) loop
         ImportSym := Dictionary.CurrentSymbol (ImportIt);
         if Dictionary.IsOwnVariableOrConstituentWithMode (ImportSym) then
            -- a side effect model is needed
            CreateModifiedCell (StreamTargetVar, VCGHeap, ImportSym);
            CreateReferenceCell (StreamExpn, VCGHeap, ImportSym);
            BuildStreamRHS (VCGHeap, ImportSym, StreamExpn,
                            -- to get
                            StreamFunction);
            SetStreamAssignment (StreamTargetVar, StreamFunction);
         end if;
         ImportIt := Dictionary.NextSymbol (ImportIt);
      end loop;
   end ModelStreamFunctionSideEffect;

   -- construct model of form StreamVar := StreamVar'Append (StreamVar, Expn);
   procedure ModelOutputStreamVolatility (AssignedVar : in     Dictionary.Symbol;
                                          DAGRoot     : in out Cells.Cell)
   --# global in out Statistics.TableUsage;
   --#        in out VCGHeap;
   --# derives DAGRoot               from VCGHeap &
   --#         Statistics.TableUsage from *,
   --#                                    AssignedVar,
   --#                                    VCGHeap &
   --#         VCGHeap               from *,
   --#                                    AssignedVar,
   --#                                    DAGRoot;
   is
      TickCell, PrefixCell, IdentCell, CommaCell, LHArgCell, RHArgCell : Cells.Cell;

   begin -- ModelOutputStreamVolatility
      CreateOpCell (TickCell, VCGHeap, SP_Symbols.apostrophe);
      CreateOpCell (CommaCell, VCGHeap, SP_Symbols.comma);
      CreateFixedVarCell (PrefixCell, VCGHeap, AssignedVar);

      CreateCellKind (IdentCell, VCGHeap, Cell_Storage.Attrib_Function);
      Cells.Set_Lex_Str (VCGHeap, IdentCell, LexTokenManager.Append_Token);

      -- function arguments
      RHArgCell := DAGRoot;
      CreateReferenceCell (LHArgCell, VCGHeap, AssignedVar);
      --assemble into a function attribute
      SetLeftArgument (TickCell, PrefixCell, VCGHeap);
      SetRightArgument (TickCell, IdentCell, VCGHeap);
      SetRightArgument (IdentCell, CommaCell, VCGHeap);
      SetLeftArgument (CommaCell, LHArgCell, VCGHeap);
      SetRightArgument (CommaCell, RHArgCell, VCGHeap);

      -- return build up function as new expression to be assigned
      DAGRoot := TickCell;
   end ModelOutputStreamVolatility;

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

   function AssignedVarIsAnExport (TheSubprogram, TheAssignedVar : Dictionary.Symbol) return Boolean
   --# global in Dictionary.Dict;
   is
   begin
      return Dictionary.IsProcedure (TheSubprogram)
        and then -- only procedures have exports
        (Dictionary.IsExport (Dictionary.IsAbstract, TheSubprogram, TheAssignedVar)
           or else Dictionary.IsExport (Dictionary.IsRefined, TheSubprogram, TheAssignedVar));
   end AssignedVarIsAnExport;

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

   -- Following procedure converts an "assignment" so that it has an
   -- entire variable on the LHS.  Thus R.F := 0 becomes r := upf_f (0);
   -- The procedure is here because it is used by ModelAssignmentStmt and
   -- ModelProcedureCall.
   procedure ConvertToEntireVariable (AssignedVarRoot : in     Cells.Cell;
                                      DAGRoot         : in out Cells.Cell)
   --# global in out Statistics.TableUsage;
   --#        in out VCGHeap;
   --# derives DAGRoot,
   --#         Statistics.TableUsage,
   --#         VCGHeap               from *,
   --#                                    AssignedVarRoot,
   --#                                    DAGRoot,
   --#                                    VCGHeap;
   is
      type ExtractorKind is (ArrayExtractor, RecordExtractor);

      ExtractorFound                                 : Boolean;
      ExtractorCell, PrefixRoot, RHSRoot, NewRHSRoot : Cells.Cell;
      Kind                                           : ExtractorKind;

      procedure FormNewRHS (PrefixRoot, RHSRoot : in     Cells.Cell;
                            NewRHSRoot          :    out Cells.Cell;
                            Kind                : in     ExtractorKind)
      --# global in out Statistics.TableUsage;
      --#        in out VCGHeap;
      --# derives NewRHSRoot            from VCGHeap &
      --#         Statistics.TableUsage from *,
      --#                                    Kind,
      --#                                    PrefixRoot,
      --#                                    VCGHeap &
      --#         VCGHeap               from *,
      --#                                    Kind,
      --#                                    PrefixRoot,
      --#                                    RHSRoot;
      is
         CommaCell, LocalNewRHSRoot : Cells.Cell;
      begin
         if Kind = ArrayExtractor then
            CreateCellKind (LocalNewRHSRoot, VCGHeap, Cell_Storage.Update_Function);
         else
            CreateUpfCell
              (LocalNewRHSRoot,
               VCGHeap,
               Cells.Get_Symbol_Value (VCGHeap, PrefixRoot),
               Cells.Get_Lex_Str (VCGHeap, PrefixRoot));
         end if;
         CreateOpCell (CommaCell, VCGHeap, SP_Symbols.comma);
         SetRightArgument (LocalNewRHSRoot, CommaCell, VCGHeap);
         SetLeftArgument (CommaCell, RightPtr (VCGHeap, PrefixRoot), VCGHeap);
         SetRightArgument (CommaCell, RHSRoot, VCGHeap);

         NewRHSRoot := LocalNewRHSRoot;
         --# accept F, 601, NewRHSRoot, Kind, "False coupling here OK";
      end FormNewRHS;

      procedure SearchForExtractor
        (Root           : in     Cells.Cell;
         ExtractorFound :    out Boolean;
         ExtractorCell  :    out Cells.Cell;
         Kind           :    out ExtractorKind)
      --# global in VCGHeap;
      --# derives ExtractorCell,
      --#         ExtractorFound,
      --#         Kind           from Root,
      --#                             VCGHeap;
      is
         LocalCell : Cells.Cell;
      begin
         LocalCell      := Root;
         ExtractorFound := False;
         ExtractorCell  := Cells.Null_Cell;  -- ensure vals for out pars
         Kind           := ArrayExtractor;           -- ensure vals for out pars
         loop
            exit when (Cells.Get_Kind (VCGHeap, LocalCell) /= Cell_Storage.Op) and
              (Cells.Get_Kind (VCGHeap, LocalCell) /= Cell_Storage.Update_Function) and
              (Cells.Get_Kind (VCGHeap, LocalCell) /= Cell_Storage.Element_Function) and
              (Cells.Get_Kind (VCGHeap, LocalCell) /= Cell_Storage.Field_Access_Function) and
              (Cells.Get_Kind (VCGHeap, LocalCell) /= Cell_Storage.Field_Update_Function);
            if (Cells.Get_Kind (VCGHeap, LocalCell) = Cell_Storage.Element_Function) then
               ExtractorFound := True;
               ExtractorCell  := LocalCell;
               Kind           := ArrayExtractor;
               exit;
            end if;

            if (Cells.Get_Kind (VCGHeap, LocalCell) = Cell_Storage.Field_Access_Function) then
               ExtractorFound := True;
               ExtractorCell  := LocalCell;
               Kind           := RecordExtractor;
               exit;
            end if;

            if (Cells.Get_Kind (VCGHeap, LocalCell) = Cell_Storage.Op) then
               LocalCell := LeftPtr (VCGHeap, LocalCell);
            elsif (Cells.Get_Kind (VCGHeap, LocalCell) = Cell_Storage.Update_Function) then
               LocalCell := RightPtr (VCGHeap, LocalCell);
            elsif (Cells.Get_Kind (VCGHeap, LocalCell) = Cell_Storage.Field_Update_Function) then
               LocalCell := RightPtr (VCGHeap, LocalCell);
            end if;
         end loop;
      end SearchForExtractor;

   begin -- ConvertToEntireVariable
      RHSRoot := DAGRoot;
      --# accept F, 10, ExtractorCell, "Ineffective assignment here OK";
      SearchForExtractor (AssignedVarRoot, ExtractorFound, ExtractorCell, Kind);
      --# end accept;

      if ExtractorFound then
         PrefixRoot := AssignedVarRoot;
         loop
            FormNewRHS (PrefixRoot, RHSRoot, NewRHSRoot, Kind);
            RHSRoot := NewRHSRoot;
            SearchForExtractor (RHSRoot, ExtractorFound, ExtractorCell, Kind);
            exit when not ExtractorFound;
            Structures.CopyStructure (VCGHeap, ExtractorCell, PrefixRoot);
         end loop;
      end if;
      DAGRoot := RHSRoot;
   end ConvertToEntireVariable;

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

begin -- ModelAssignmentStmt

   PrepareLabel (VCGHeap, StmtLabel, StmtCell);
   Clists.CreateList (VCGHeap, ModList);

   -- VariableComponentNode is LHS of assignment.
   VariableComponentNode := STree.Child_Node (Current_Node => Node);

   if STree.Syntax_Node_Type (Node => VariableComponentNode) = SP_Symbols.unconstrained_array_assignment then
      -- For an others aggregate the LHS of the assignment is child of child
      VariableComponentNode := STree.Child_Node (Current_Node => VariableComponentNode);
      OthersAggregate       := True;
   else
      OthersAggregate := False;
   end if;

   -- ExpnNode is RHS of assignment
   ExpnNode := STree.Next_Sibling (Current_Node => VariableComponentNode);

   BuildExpnDAG
     (VariableComponentNode,
      LScope,
      Scope,
      LineNmbr,
      True,
      False,
      LoopStack,
      FlowHeap,
      VCGHeap,
      ContainsReals,
      VCGFailure,
      ShortCircuitStack,
      CheckStack,
      KindOfStackedCheck,
      -- to get
      AssignedVarRoot);

   -- For a normal assignment statement we call BuildExpnDAG for the LHS, then again for
   -- the RHS, and glue the two together. However, if this is an unconstrained_array_assignment then the
   -- LHS will be OK but the RHS will only contain the expression after the arrow in the
   -- others aggregate. In this case we need to synthesize the DAG for the RHS which will
   -- be of the form "mk__T(E)" where T is the unconstrained array type and E is the
   -- expression after the arrow in the aggregate (which is given by ExpnNode).

   BuildExpnDAG
     (ExpnNode,
      LScope,
      Scope,
      LineNmbr,
      True,
      DoAssumeLocalRvalues,
      LoopStack,
      FlowHeap,
      VCGHeap,
      ContainsReals,
      VCGFailure,
      ShortCircuitStack,
      CheckStack,
      KindOfStackedCheck,
      -- to get
      DAGRoot);

   -- If this is an unconstrained_array_assignment then create the necessary model structure
   CreateMkAggregateCell;

   CreateAssignedVarCell; -- moved from below generation of RTC to make assigned var symbol available

   -- if the assigned expression represents a stream variable of mode in then
   -- wf_assignment_statement will have put its subtype into the syntax tree.
   -- If this subtype is the same as that of the variable assigned to we do not
   -- want to generate a RTC for the assignment.  wf_assignment_statement
   -- similarly plants the type for the results of an unchecked_conversion.
   --
   -- If the assigned variable is an export of the subprogram then we _do_ generate
   -- a check even if the subtypes are the same.  This is to prevent the result of
   -- an unchecked conversion escaping to the calling environment without any checks.
   -- There is a similar situation with the exporting of Ports; however, these generate
   -- a check in CheckTypeOfExports in IncorporateConstraints.  The modifications
   -- for unchecked conversion will result in an additional VC in the case streams.

   -- If we do need a check then use original RHS DAG structure before
   -- ConvertToEntireVariable

   if STree.NodeSymbol (ExpnNode) /= STree.NodeSymbol (Node)
     or else AssignedVarIsAnExport (Dictionary.GetRegion (Scope), Cells.Get_Symbol_Value (VCGHeap, AssignedVarCell)) then
      CheckConstraintRunTimeError (STree.NodeSymbol (Node), DAGRoot, Scope, VCGHeap, ShortCircuitStack, CheckStack, ContainsReals);
   end if;
   UnStackRtcs (LineNmbr, VCGHeap, CheckStack, KindOfStackedCheck);

   Clists.AppendCell (VCGHeap, AssignedVarCell, ModList);
   ConvertToEntireVariable (AssignedVarRoot, DAGRoot);

   -- if the assigned var is an output stream then we need to model volatility
   if Dictionary.IsOwnVariableOrConstituentWithMode (Cells.Get_Symbol_Value (VCGHeap, AssignedVarCell)) then
      ModelOutputStreamVolatility (Cells.Get_Symbol_Value (VCGHeap, AssignedVarCell), DAGRoot);
   end if;

   -- Complete model of assignment. In general the RHS is given by DAGRoot but for
   -- the special case of an unconstrained_array_assignment it is MkAggregateCell.
   if not OthersAggregate then
      SetRightArgument (AssignedVarCell, DAGRoot, VCGHeap);
   else
      SetRightArgument (AssignedVarCell, MkAggregateCell, VCGHeap);
   end if;

   SetAuxPtr (StmtCell, ModList, VCGHeap);
   Chain (StmtLabel, VCGHeap);

   -- see if an assignment of stream is involved and model side effect if it is
   StreamSymbol := AssignedStreamSymbol (ExpnNode);
   if not Dictionary.Is_Null_Symbol (StreamSymbol) then
      -- we must model side effect of stream assignment
      if Dictionary.IsAdaFunction (StreamSymbol) then
         ModelStreamFunctionSideEffect;
      else
         -- since it is not null and is not a function it must be a variable
         -- so create side-effect model for a stream variable assignment
         ModelStreamVariableSideEffect;
      end if;
   end if;
end ModelAssignmentStmt;
