--  Values in synthesis.
--  Copyright (C) 2017 Tristan Gingold
--
--  This file is part of GHDL.
--
--  This program is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This program 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
--  along with this program; if not, write to the Free Software
--  Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston,
--  MA 02110-1301, USA.

with Ada.Unchecked_Conversion;
with System;

with Grt.Types; use Grt.Types;

with Vhdl.Nodes; use Vhdl.Nodes;

package body Synth.Values is
   function To_Value_Acc is new Ada.Unchecked_Conversion
     (System.Address, Value_Acc);

   function Is_Static (Val : Value_Acc) return Boolean is
   begin
      case Val.Kind is
         when Value_Memory =>
            return True;
         when Value_Net
           | Value_Wire =>
            return False;
         when Value_File =>
            return True;
         when Value_Alias =>
            return Is_Static (Val.A_Obj);
         when Value_Const =>
            return True;
      end case;
   end Is_Static;

   function Is_Static_Val (Val : Value_Acc) return Boolean is
   begin
      case Val.Kind is
         when Value_Memory =>
            return True;
         when Value_Net =>
            return False;
         when Value_Wire =>
            return Is_Static_Wire (Val.W);
         when Value_File =>
            return True;
         when Value_Const =>
            return True;
         when Value_Alias =>
            return Is_Static_Val (Val.A_Obj);
      end case;
   end Is_Static_Val;

   function Strip_Alias_Const (V : Value_Acc) return Value_Acc
   is
      Res : Value_Acc;
   begin
      Res := V;
      loop
         case Res.Kind is
            when Value_Const =>
               Res := Res.C_Val;
            when Value_Alias =>
               if Res.A_Off /= (0, 0) then
                  raise Internal_Error;
               end if;
               Res := Res.A_Obj;
            when others =>
               return Res;
         end case;
      end loop;
   end Strip_Alias_Const;

   function Strip_Alias_Const (V : Valtyp) return Valtyp is
   begin
      return (V.Typ, Strip_Alias_Const (V.Val));
   end Strip_Alias_Const;

   function Is_Equal (L, R : Memtyp) return Boolean is
   begin
      if L = R then
         return True;
      end if;

      if L.Typ.Sz /= R.Typ.Sz then
         return False;
      end if;

      --  FIXME: not correct for records, not correct for floats!
      for I in 1 .. L.Typ.Sz loop
         if L.Mem (I - 1) /= R.Mem (I - 1) then
            return False;
         end if;
      end loop;
      return True;
   end Is_Equal;

   function Is_Equal (L, R : Valtyp) return Boolean is
   begin
      return Is_Equal (Get_Memtyp (L), Get_Memtyp (R));
   end Is_Equal;

   function Create_Value_Memtyp (Mt : Memtyp) return Valtyp
   is
      subtype Value_Type_Memory is Value_Type (Value_Memory);
      function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Memory);
      Res : Value_Acc;
   begin
      Res := To_Value_Acc (Alloc (Current_Pool, (Kind => Value_Memory,
                                                 Mem => Mt.Mem)));
      return (Mt.Typ, Res);
   end Create_Value_Memtyp;

   function Create_Value_Wire (W : Wire_Id) return Value_Acc
   is
      subtype Value_Type_Wire is Value_Type (Values.Value_Wire);
      function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Wire);
   begin
      return To_Value_Acc (Alloc (Current_Pool,
                                  (Kind => Value_Wire,
                                   W => W)));
   end Create_Value_Wire;

   function Create_Value_Wire (W : Wire_Id; Wtype : Type_Acc) return Valtyp
   is
      pragma Assert (Wtype /= null);
   begin
      return (Wtype, Create_Value_Wire (W));
   end Create_Value_Wire;

   function Create_Value_Net (N : Net) return Value_Acc
   is
      subtype Value_Type_Net is Value_Type (Value_Net);
      function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Net);
   begin
      return To_Value_Acc
        (Alloc (Current_Pool, Value_Type_Net'(Kind => Value_Net, N => N)));
   end Create_Value_Net;

   function Create_Value_Net (N : Net; Ntype : Type_Acc) return Valtyp
   is
      pragma Assert (Ntype /= null);
   begin
      return (Ntype, Create_Value_Net (N));
   end Create_Value_Net;

   function Create_Value_Memory (Vtype : Type_Acc) return Valtyp
   is
      subtype Value_Type_Memory is Value_Type (Value_Memory);
      function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Memory);
      function To_Memory_Ptr is new Ada.Unchecked_Conversion
        (System.Address, Memory_Ptr);
      V : Value_Acc;
      M : System.Address;
   begin
      Areapools.Allocate (Current_Pool.all, M,
                          Vtype.Sz, Size_Type (2 ** Natural (Vtype.Al)));
      V := To_Value_Acc
        (Alloc (Current_Pool, Value_Type_Memory'(Kind => Value_Memory,
                                                 Mem => To_Memory_Ptr (M))));

      return (Vtype, V);
   end Create_Value_Memory;

   function Create_Value_Memory (Mt : Memtyp) return Valtyp
   is
      subtype Value_Type_Memory is Value_Type (Value_Memory);
      function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Memory);
      V : Value_Acc;
   begin
      V := To_Value_Acc
        (Alloc (Current_Pool, Value_Type_Memory'(Kind => Value_Memory,
                                                 Mem => Mt.Mem)));

      return (Mt.Typ, V);
   end Create_Value_Memory;

   function Create_Value_File (File : File_Index) return Value_Acc
   is
      subtype Value_Type_File is Value_Type (Value_File);
      function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_File);
   begin
      return To_Value_Acc (Alloc (Current_Pool,
                                  (Kind => Value_File, File => File)));
   end Create_Value_File;

   function Create_Value_File (Vtype : Type_Acc; File : File_Index)
                              return Valtyp
   is
      pragma Assert (Vtype /= null);
   begin
      return (Vtype, Create_Value_File (File));
   end Create_Value_File;

   function Vec_Length (Typ : Type_Acc) return Iir_Index32 is
   begin
      return Iir_Index32 (Typ.Vbound.Len);
   end Vec_Length;

   function Get_Array_Flat_Length (Typ : Type_Acc) return Iir_Index32 is
   begin
      case Typ.Kind is
         when Type_Vector =>
            return Iir_Index32 (Typ.Vbound.Len);
         when Type_Array =>
            declare
               Len : Width;
            begin
               Len := 1;
               for I in Typ.Abounds.D'Range loop
                  Len := Len * Typ.Abounds.D (I).Len;
               end loop;
               return Iir_Index32 (Len);
            end;
         when others =>
            raise Internal_Error;
      end case;
   end Get_Array_Flat_Length;

   function Create_Value_Alias
     (Obj : Valtyp; Off : Value_Offsets; Typ : Type_Acc) return Valtyp
   is
      pragma Assert (Typ /= null);
      subtype Value_Type_Alias is Value_Type (Value_Alias);
      function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Alias);
      Val : Value_Acc;
   begin
      Val := To_Value_Acc (Alloc (Current_Pool,
                                  (Kind => Value_Alias,
                                   A_Obj => Obj.Val,
                                   A_Typ => Obj.Typ,
                                   A_Off => Off)));
      return (Typ, Val);
   end Create_Value_Alias;

   function Create_Value_Const (Val : Value_Acc; Loc : Syn_Src)
                               return Value_Acc
   is
      subtype Value_Type_Const is Value_Type (Value_Const);
      function Alloc is new Areapools.Alloc_On_Pool_Addr (Value_Type_Const);
   begin
      pragma Assert (Val = null or else Val.Kind /= Value_Const);
      return To_Value_Acc (Alloc (Current_Pool,
                                  (Kind => Value_Const,
                                   C_Val => Val,
                                   C_Loc => Loc,
                                   C_Net => No_Net)));
   end Create_Value_Const;

   function Create_Value_Const (Val : Valtyp; Loc : Syn_Src)
                               return Valtyp is
   begin
      return (Val.Typ, Create_Value_Const (Val.Val, Loc));
   end Create_Value_Const;
Operation mode
