-------------------------------------------------------------------------------
-- (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)
package body Substitutions is

   procedure Substitute_Parameters
     (Called_Function : in     Cells.Cell;
      Constraint      : in out Cells.Cell;
      VCG_Heap        : in out Cells.Heap_Record)
   is
      Index_Subtype, P, Persistent_Actual : Cells.Cell;
      S                                   : CStacks.Stack;
      Function_Sym, Var_Sym               : Dictionary.Symbol;
      Function_Dec                        : Dictionary.Symbol;
      Change                              : Boolean;

      --  Walks the data structure produced by Setup_Function_Call to
      --  find the actual parameter DAG associated with a particular
      --  function parameter number of the called function.
      function Get_Actual (Called_Function : in Cells.Cell;
                           Arg_No          : in Positive) return Cells.Cell
      --# global in VCG_Heap;
      is
         DAGCell : Cells.Cell;
      begin
         DAGCell := Called_Function;
         for I in Positive range 1 .. Arg_No loop
            DAGCell := DAG.RightPtr (VCG_Heap, DAGCell);
         end loop;

         if Cells.Get_Kind (VCG_Heap, DAGCell) = Cell_Storage.Op
           and then Cells.Get_Op_Symbol (VCG_Heap, DAGCell) = SP_Symbols.comma then
            DAGCell := DAG.LeftPtr (VCG_Heap, DAGCell);
         end if;

         return DAGCell;
      end Get_Actual;

      --  Similar to Get_Actual above but returns the constraining
      --  index type associated with a constrained actual parameter
      --  associated with an unconstrained formal parameter
      procedure Get_Actual_Constraint
        (Called_Function : in     Cells.Cell;
         Sym             : in     Dictionary.Symbol;
         Change          :    out Boolean;
         Result          :    out Cells.Cell)
      --# global in     Dictionary.Dict;
      --#        in out Statistics.TableUsage;
      --#        in out VCG_Heap;
      --# derives Change,
      --#         Result,
      --#         VCG_Heap              from Called_Function,
      --#                                    Dictionary.Dict,
      --#                                    Sym,
      --#                                    VCG_Heap &
      --#         Statistics.TableUsage from *,
      --#                                    Called_Function,
      --#                                    Dictionary.Dict,
      --#                                    Sym,
      --#                                    VCG_Heap;
      is
         Arg_No         : Positive;
         LResult        : Cells.Cell;
         ActualCell     : Cells.Cell;
         ConstraintCell : Cells.Cell;

         Constraint_Sym : Dictionary.Symbol;
         Function_Sym   : Dictionary.Symbol;

         Object_Sym     : Dictionary.Symbol;
         ArrayDimension : Positive;
      begin
         --  The Sym passed to this routine will be a
         --  Dictionary.ParameterConstraintSymbol.  From this we can
         --  obtain the object itself and the dimension of that object
         --  that appears in the expression we may be making
         --  substitutions to.

         Function_Sym := Cells.Get_Symbol_Value (VCG_Heap, Called_Function);

         Object_Sym := Dictionary.GetParameterAssociatedWithParameterConstraint (Sym);

         if Dictionary.IsFormalParameter (Function_Sym, Object_Sym) then
            --  There may be something to do.  Only in the case of
            --  formal/actual parameter matching can constraints be
            --  introduced and constraint substitution requires.  If
            --  Object_Sym is global to Function_Sym (as it may be
            --  with nested subprogram calls) then the constraint will
            --  left unchanged
            Change         := True;
            ArrayDimension := Dictionary.GetSubprogramParameterConstraintDimension (Sym);

            Arg_No         := Dictionary.GetSubprogramParameterNumber (Object_Sym);
            ActualCell     := Get_Actual (Called_Function => Called_Function,
                                          Arg_No          => Arg_No);
            ConstraintCell := DAG.AuxPtr (VCG_Heap, ActualCell);

            Cells.Create_Cell (VCG_Heap, LResult);
            if Cells.Is_Null_Cell (ConstraintCell) then
               Cells.Copy_Contents (VCG_Heap, ActualCell, -- no constraint present
                                    LResult);
            else
               Cells.Copy_Contents (VCG_Heap, ConstraintCell, LResult);
            end if;

            --  LResult contains either:
            --
            --  (1) an array subtype symbol in the case where the
            --      actual paramater is of a constrained array subtype
            --
            --  (2) a scalar index type symbol in the case of a string
            --      literal being passed to string
            --
            --  (3) a symbol of a subprogram parameter in the case
            --      where the actual parameter is also an unconstrained
            --      array and no constraint has been planted (this final
            --      behaviour occurs because GetConstraintCell returns the
            --      actual parameter DAG if no constraint is present)
            Constraint_Sym := Cells.Get_Symbol_Value (VCG_Heap, LResult);
            if Dictionary.IsSubprogramParameter (Constraint_Sym) then
               --  Case 3.  We substitute "actual__index__subtype__n" for "formal__index__subtype__n"
               Cells.Set_Symbol_Value
                 (VCG_Heap,
                  LResult,
                  Dictionary.GetSubprogramParameterConstraint (Constraint_Sym, ArrayDimension));
            elsif Dictionary.TypeIsArray (Constraint_Sym) then
               --  Case 2. We substitute array index n of constraining subtype for "formal__index__subtype__n"
               Cells.Set_Symbol_Value (VCG_Heap, LResult, Dictionary.GetArrayIndex (Constraint_Sym, ArrayDimension));
            else
               --  Case 1. we already have the constraining index directly
               null;
            end if;

         else
            --  Not a formal parameter so leave constraint unchanged.
            LResult := Cells.Null_Cell;
            Change  := False;
         end if;
         Result := LResult;
      end Get_Actual_Constraint;

   begin -- Substitute_Parameters

      -- DAG traversal algorithm of D.E. Knuth, Fundamental Algorithms, p.317;
      Function_Sym := Cells.Get_Symbol_Value (VCG_Heap, Called_Function);
      if Dictionary.IsImplicitProofFunction (Function_Sym) then
         Function_Dec := Dictionary.GetAdaFunction (Function_Sym);
      else
         Function_Dec := Function_Sym;
      end if;

      CStacks.CreateStack (S);
      P := Constraint;
      loop
         loop
            exit when Cells.Is_Null_Cell (P);
            CStacks.Push (VCG_Heap, P, S);
            if DAG.Is_Leaf (Node     => P,
                            VCG_Heap => VCG_Heap) then
               P := Cells.Null_Cell;
            else
               P := DAG.LeftPtr (VCG_Heap, P);
            end if;
         end loop;
         exit when CStacks.IsEmpty (S);
         P := CStacks.Top (VCG_Heap, S);
         CStacks.Pop (VCG_Heap, S);
         if DAG.Is_Leaf (Node     => P,
                         VCG_Heap => VCG_Heap) then
            Var_Sym := Cells.Get_Symbol_Value (VCG_Heap, P);
            if Cells.Get_Kind (VCG_Heap, P) = Cell_Storage.Reference then
               if Dictionary.IsFormalParameter (Function_Dec, Var_Sym) then

                  --  A persistent copy of the actual parameter has to
                  --  be made from the temporary version which exists
                  --  on the ExpnStack.
                  Structures.CopyStructure
                    (VCG_Heap,
                     Get_Actual (Called_Function => Called_Function,
                                 Arg_No          => Dictionary.GetSubprogramParameterNumber (Var_Sym)),
                     Persistent_Actual);

                  Cells.Copy_Contents (VCG_Heap, Persistent_Actual, P);
               end if;
            elsif Cells.Get_Kind (VCG_Heap, P) = Cell_Storage.Unconstrained_Attribute_Prefix then

               Get_Actual_Constraint (Called_Function, Var_Sym,
                                      -- to get
                                      Change, Index_Subtype);
               if Change then
                  Cells.Copy_Contents (VCG_Heap, Index_Subtype, P);
               end if;
            end if;
            P := Cells.Null_Cell;
         else
            P := DAG.RightPtr (VCG_Heap, P);
         end if;
      end loop;
      --# accept F, 31, Constraint, "Constraint is updated indirectly via local pointer P" &
      --#        F, 50, Constraint, Dictionary.Dict, "Indirectly used via local pointer P" &
      --#        F, 50, Constraint, VCG_Heap, "Indirectly used via local pointer P" &
      --#        F, 50, Constraint, Called_Function, "Indirectly used via local pointer P" &
      --#        W, 3, "Suppress warnings on Constraint";
      -- Constraint appears to be just an input but is actually exported.
      -- (It is effectively a pointer to a data structure which is updated).
      pragma Warnings (Off, Constraint);
   end Substitute_Parameters;

   procedure Substitute_Implicit_Vars
     (Proof_Function       : in     Cells.Cell;
      Implicit_Var         : in     Dictionary.Symbol;
      Implicit_Return_Expr : in out Cells.Cell;
      VCG_Heap             : in out Cells.Heap_Record)
   is
      P, Persistent_Call : Cells.Cell;
      S                  : CStacks.Stack;
      Var_Sym            : Dictionary.Symbol;
   begin
      -- DAG traversal algorithm of D.E. Knuth, Fundamental Algorithms, p.317;
      CStacks.CreateStack (S);
      P := Implicit_Return_Expr;
      loop
         loop
            exit when Cells.Is_Null_Cell (P);
            CStacks.Push (VCG_Heap, P, S);
            if DAG.Is_Leaf (Node     => P,
                            VCG_Heap => VCG_Heap) then
               P := Cells.Null_Cell;
            else
               P := DAG.LeftPtr (VCG_Heap, P);
            end if;
         end loop;
         exit when CStacks.IsEmpty (S);
         P := CStacks.Top (VCG_Heap, S);
         CStacks.Pop (VCG_Heap, S);
         if DAG.Is_Leaf (Node     => P,
                         VCG_Heap => VCG_Heap) then
            Var_Sym := Cells.Get_Symbol_Value (VCG_Heap, P);
            if not Dictionary.Is_Null_Symbol (Implicit_Var)
              and then Dictionary.IsImplicitReturnVariable (Var_Sym)
              and then Dictionary.Implicit_Return_Variables_Are_Equal (Left_Symbol  => Var_Sym,
                                                                       Right_Symbol => Implicit_Var) then

               --  A persistent copy of the function call has to be
               --  made from the temporary version which exists on the
               --  ExpnStack.
               Structures.CopyStructure (Heap     => VCG_Heap,
                                         Root     => Proof_Function,
                                         RootCopy => Persistent_Call);

               Cells.Copy_Contents (VCG_Heap, Persistent_Call, P);
            end if;
            P := Cells.Null_Cell;
         else
            P := DAG.RightPtr (VCG_Heap, P);
         end if;
      end loop;
      --# accept F, 31, Implicit_Return_Expr, "Constraint is updated indirectly via local pointer P" &
      --#        F, 50, Implicit_Return_Expr, VCG_Heap, "Indirectly used via local pointer P" &
      --#        F, 50, Implicit_Return_Expr, Proof_Function, "Indirectly used via local pointer P" &
      --#        F, 50, Implicit_Return_Expr, Implicit_Var, "Indirectly used via local pointer P" &
      --#        F, 50, Implicit_Return_Expr, Dictionary.Dict, "Indirectly used via local pointer P" &
      --#        W, 3, "Suppress warnings on Implicit_Return_Expr";
      -- Implicit_Return_Expr appears to be just an input but is actually
      -- exported.
      -- (It is effectively a pointer to a data structure which is updated).
      pragma Warnings (Off, Implicit_Return_Expr);
   end Substitute_Implicit_Vars;

end Substitutions;
