-------------------------------------------------------------------------------
-- (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 Dictionary;
with Cell_Storage;
with SP_Symbols;
with SystemErrors;

use type Dictionary.Symbol;

package body Cells.Utility is

   ------------------------------------------------------------------------------
   --  General utility
   ------------------------------------------------------------------------------

   procedure Create_Binary_Op_Cell
     (VCG_Heap : in out Cells.Heap_Record;
      Left     : in     Cells.Cell;
      Op       : in     SP_Symbols.SP_Symbol;
      Right    : in     Cells.Cell;
      Result   :    out Cells.Cell)
   is
   begin
      Cells.Create_Cell (VCG_Heap, Result);
      Cells.Set_Kind (VCG_Heap, Result, Cell_Storage.Op);
      Cells.Set_Op_Symbol (VCG_Heap, Result, Op);

      Cells.Set_A_Ptr (VCG_Heap, Result, Left);
      Cells.Set_B_Ptr (VCG_Heap, Result, Right);
   end Create_Binary_Op_Cell;

   ------------------------------------------------------------------------------
   --  Booleans
   ------------------------------------------------------------------------------

   function Is_True (VCG_Heap : in Cells.Heap_Record;
                     C        : in Cells.Cell) return Boolean is
   begin
      return Cells.Get_Kind (VCG_Heap, C) = Cell_Storage.Named_Const
        and then Cells.Get_Symbol_Value (VCG_Heap, C) = Dictionary.GetTrue;
   end Is_True;

   function Is_False (VCG_Heap : in Cells.Heap_Record;
                      C        : in Cells.Cell) return Boolean is
   begin
      return Cells.Get_Kind (VCG_Heap, C) = Cell_Storage.Named_Const
        and then Cells.Get_Symbol_Value (VCG_Heap, C) = Dictionary.GetFalse;
   end Is_False;

   procedure Create_Bool (VCG_Heap : in out Cells.Heap_Record;
                          Value    : in     Boolean;
                          C        :    out Cells.Cell) is
   begin
      Cells.Create_Cell (VCG_Heap, C);
      Cells.Set_Kind (VCG_Heap, C, Cell_Storage.Named_Const);
      if Value then
         Cells.Set_Symbol_Value (VCG_Heap, C, Dictionary.GetTrue);
      else
         Cells.Set_Symbol_Value (VCG_Heap, C, Dictionary.GetFalse);
      end if;
   end Create_Bool;

   procedure Create_Not (VCG_Heap  : in out Cells.Heap_Record;
                         Predicate : in     Cells.Cell;
                         Negation  :    out Cells.Cell) is
   begin
      Cells.Create_Cell (VCG_Heap, Negation);
      Cells.Set_Kind (VCG_Heap, Negation, Cell_Storage.Op);
      Cells.Set_Op_Symbol (VCG_Heap, Negation, SP_Symbols.RWnot);

      Cells.Set_B_Ptr (VCG_Heap, Negation, Predicate);
   end Create_Not;

   procedure Create_And
     (VCG_Heap : in out Cells.Heap_Record;
      Left     : in     Cells.Cell;
      Right    : in     Cells.Cell;
      Conjunct :    out Cells.Cell)
   is
   begin
      Create_Binary_Op_Cell (VCG_Heap, Left, SP_Symbols.RWand, Right, Conjunct);
   end Create_And;

   procedure Create_Implies
     (VCG_Heap    : in out Cells.Heap_Record;
      Antecedent  : in     Cells.Cell;
      Consequent  : in     Cells.Cell;
      Implication :    out Cells.Cell)
   is
   begin
      Create_Binary_Op_Cell (VCG_Heap, Antecedent, SP_Symbols.implies, Consequent, Implication);
   end Create_Implies;

   procedure Simplify (VCG_Heap : in out Cells.Heap_Record;
                       C        : in out Cells.Cell) is
      Left, Right : Cells.Cell;
   begin
      --  In general, we don't clean up here as we have no idea what
      --  other things could be pointing to sub-parts of this DAG.
      if Cells.Get_Kind (VCG_Heap, C) = Cell_Storage.Op then
         Left  := Cells.Get_A_Ptr (VCG_Heap, C);
         Right := Cells.Get_B_Ptr (VCG_Heap, C);
         case Cells.Get_Op_Symbol (VCG_Heap, C) is
            when SP_Symbols.RWand =>
               --  True /\ X  ==>  X
               if Is_True (VCG_Heap, Left) then
                  C := Right;
               elsif Is_True (VCG_Heap, Right) then
                  C := Left;

                  --  False /\ X  ==>  False
               elsif Is_False (VCG_Heap, Left) then
                  C := Left;
               elsif Is_False (VCG_Heap, Right) then
                  C := Right;
               end if;

            when SP_Symbols.implies =>
               --  True -> X  ==>  X
               if Is_True (VCG_Heap, Left) then
                  C := Right;

                  --  False -> X  ==>  True
               elsif Is_False (VCG_Heap, Left) then
                  Create_Bool (VCG_Heap, True, C);

                  --  X -> True  ==>  True
               elsif Is_True (VCG_Heap, Right) then
                  C := Right;

                  --  X -> False  ==>  not X
               elsif Is_False (VCG_Heap, Right) then
                  Create_Not (VCG_Heap, Left, C);

               end if;

            when SP_Symbols.is_equivalent_to =>
               --  True <-> X  ==>  X
               if Is_True (VCG_Heap, Left) then
                  C := Right;
               elsif Is_True (VCG_Heap, Right) then
                  C := Left;

                  --  False <-> X  ==>  not X
               elsif Is_False (VCG_Heap, Left) then
                  Create_Not (VCG_Heap, Right, C);
               elsif Is_False (VCG_Heap, Right) then
                  Create_Not (VCG_Heap, Left, C);
               end if;

            when others =>
               null;
         end case;
      end if;
   end Simplify;

   ------------------------------------------------------------------------------
   --  Utility
   ------------------------------------------------------------------------------

   procedure Conjoin (VCG_Heap : in out Cells.Heap_Record;
                      New_Term : in     Cells.Cell;
                      Conjunct : in out Cells.Cell) is
      New_Conjunct : Cells.Cell;
   begin
      if Cells.Is_Null_Cell (Conjunct) then
         Conjunct := New_Term;
      elsif Is_True (VCG_Heap, New_Term) then
         null;
      elsif Is_True (VCG_Heap, Conjunct) then
         Cells.Dispose_Of_Cell (VCG_Heap, Conjunct);
         Conjunct := New_Term;
      else
         Create_And (VCG_Heap, Conjunct, New_Term, New_Conjunct);
         Conjunct := New_Conjunct;
      end if;
   end Conjoin;

   ------------------------------------------------------------------------------
   --  Types (general)
   ------------------------------------------------------------------------------

   procedure Create_Type_Attribute
     (VCG_Heap      : in out Cells.Heap_Record;
      The_Type      : in     Dictionary.Symbol;
      The_Attribute : in     Type_Attribute;
      Result        :    out Cells.Cell)
   is
      Attribute_Cell : Cells.Cell;
      Type_Cell      : Cells.Cell;
   begin
      --  We need a cell for the actual attribute.
      Cells.Create_Cell (VCG_Heap, Attribute_Cell);
      Cells.Set_Kind (VCG_Heap, Attribute_Cell, Cell_Storage.Attrib_Value);
      case The_Attribute is
         when Tick_First =>
            Cells.Set_Lex_Str (VCG_Heap, Attribute_Cell, LexTokenManager.First_Token);
         when Tick_Last =>
            Cells.Set_Lex_Str (VCG_Heap, Attribute_Cell, LexTokenManager.Last_Token);
      end case;

      --  We need a cell for the type symbol.
      Cells.Create_Cell (VCG_Heap, Type_Cell);
      if Dictionary.IsParameterConstraint (The_Type) then
         Cells.Set_Kind (VCG_Heap, Type_Cell, Cell_Storage.Unconstrained_Attribute_Prefix);
      else
         Cells.Set_Kind (VCG_Heap, Type_Cell, Cell_Storage.Fixed_Var);
      end if;
      Cells.Set_Symbol_Value (VCG_Heap, Type_Cell, The_Type);

      --  Assemble the result cell.
      Cells.Create_Cell (VCG_Heap, Result);
      Cells.Set_Kind (VCG_Heap, Result, Cell_Storage.Op);
      Cells.Set_Op_Symbol (VCG_Heap, Result, SP_Symbols.apostrophe);

      Cells.Set_A_Ptr (VCG_Heap, Result, Type_Cell);
      Cells.Set_B_Ptr (VCG_Heap, Result, Attribute_Cell);
   end Create_Type_Attribute;

   ------------------------------------------------------------------------------
   --  Records
   ------------------------------------------------------------------------------

   procedure Create_Record_Access
     (VCG_Heap      : in out Cells.Heap_Record;
      The_Record    : in     Cells.Cell;
      The_Component : in     Dictionary.Symbol;
      The_Field     :    out Cells.Cell)
   is
   begin
      Cells.Create_Cell (VCG_Heap, The_Field);
      Cells.Set_Kind (VCG_Heap, The_Field, Cell_Storage.Field_Access_Function);

      Cells.Set_Symbol_Value (VCG_Heap, The_Field, The_Component);
      Cells.Set_Lex_Str (VCG_Heap, The_Field, Dictionary.GetSimpleName (The_Component));

      Cells.Set_B_Ptr (VCG_Heap, The_Field, The_Record);
   end Create_Record_Access;

   ------------------------------------------------------------------------------
   --  Arrays
   ------------------------------------------------------------------------------

   procedure Create_Array_Access
     (VCG_Heap    : in out Cells.Heap_Record;
      The_Array   : in     Cells.Cell;
      The_Index   : in     Cells.Cell;
      The_Element :    out Cells.Cell)
   is
      List_Cell  : Cells.Cell;
      Comma_Cell : Cells.Cell;
   begin
      --  Create "[" The_Index "]"
      Cells.Create_Cell (VCG_Heap, List_Cell);
      Cells.Set_Kind (VCG_Heap, List_Cell, Cell_Storage.List_Function);
      Cells.Set_B_Ptr (VCG_Heap, List_Cell, The_Index);

      --  Create The_Array "," List_Cell
      Create_Binary_Op_Cell (VCG_Heap, The_Array, SP_Symbols.comma, List_Cell, Comma_Cell);

      --  Create the element function call
      Cells.Create_Cell (VCG_Heap, The_Element);
      Cells.Set_Kind (VCG_Heap, The_Element, Cell_Storage.Element_Function);
      Cells.Set_B_Ptr (VCG_Heap, The_Element, Comma_Cell);
   end Create_Array_Access;

   ------------------------------------------------------------------------------
   --  Stashing things in cells that we probably shouldn't.
   ------------------------------------------------------------------------------

   procedure Create_Scope_Cell
     (VCG_Heap  : in out Cells.Heap_Record;
      The_Scope : in     Dictionary.Scopes;
      The_Cell  :    out Cells.Cell)
   is
   begin
      Cells.Create_Cell (VCG_Heap, The_Cell);
      Cells.Set_Kind (VCG_Heap, The_Cell, Cell_Storage.Internal_Scope);

      --  It may be tempting to store this using set_symbol, but this
      --  shares the field for the natural...
      Cells.Set_Assoc_Var (VCG_Heap, The_Cell, Dictionary.GetRegion (The_Scope));
      Cells.Set_Natural_Value (VCG_Heap, The_Cell, Dictionary.Visibility'Pos (Dictionary.Get_Visibility (The_Scope)));
   end Create_Scope_Cell;

   function Scope_Cell_Get_Scope (VCG_Heap   : in Cells.Heap_Record;
                                  Scope_Cell : in Cells.Cell) return Dictionary.Scopes is
      N : Natural;
   begin
      SystemErrors.RT_Assert
        (C       => Cells.Get_Kind (VCG_Heap, Scope_Cell) = Cell_Storage.Internal_Scope,
         Sys_Err => SystemErrors.VCG_Heap_Is_Corrupted,
         Msg     => "Cells.Utility.Scope_Cell_Get_Scope: Expected an `Internal_Scope' cell.");

      pragma Warnings (Off);
      N := Cells.Get_Natural_Value (VCG_Heap, Scope_Cell);
      SystemErrors.RT_Assert
        (C       => (N >= Dictionary.Visibility'Pos (Dictionary.Visibility'First) and
              N <= Dictionary.Visibility'Pos (Dictionary.Visibility'Last)),
         Sys_Err => SystemErrors.VCG_Heap_Is_Corrupted,
         Msg     => "Cells.Utility.Scope_Cell_Get_Scope: Expected a sane value for visibility.");
      pragma Warnings (On);

      return Dictionary.Set_Visibility
        (The_Visibility => Dictionary.Visibility'Val (N),
         The_Unit       => Cells.Get_Assoc_Var (VCG_Heap, Scope_Cell));
   end Scope_Cell_Get_Scope;

end Cells.Utility;
