synth: initial support of access types.

7 files changed, 181 insertions, 12 deletions

diff --git a/src/synth/synth-decls.adb b/src/synth/synth-decls.adb
index 436ade478..4d520e578 100644
--- a/src/synth/synth-decls.adb
+++ b/src/synth/synth-decls.adb
@@ -330,20 +330,15 @@ package body Synth.Decls is
       end case;
    end Synth_Array_Subtype_Indication;
 
-   procedure Synth_Subtype_Indication
-     (Syn_Inst : Synth_Instance_Acc; Atype : Node)
-   is
-      Typ : Type_Acc;
+   function Synth_Subtype_Indication
+     (Syn_Inst : Synth_Instance_Acc; Atype : Node) return Type_Acc is
    begin
       --  TODO: handle aliases directly.
       case Get_Kind (Atype) is
          when Iir_Kind_Array_Subtype_Definition =>
-            Typ := Synth_Array_Subtype_Indication (Syn_Inst, Atype);
+            return Synth_Array_Subtype_Indication (Syn_Inst, Atype);
          when Iir_Kind_Record_Subtype_Definition =>
-            Typ := Synth_Record_Type_Definition (Syn_Inst, Atype);
-            if Typ = null then
-               return;
-            end if;
+            return Synth_Record_Type_Definition (Syn_Inst, Atype);
          when Iir_Kind_Integer_Subtype_Definition
            | Iir_Kind_Physical_Subtype_Definition
            | Iir_Kind_Enumeration_Subtype_Definition =>
@@ -355,12 +350,13 @@ package body Synth.Decls is
             begin
                if Btype.Kind in Type_Nets then
                   --  A subtype of a bit/logic type is still a bit/logic.
-                  Typ := Btype;
+                  --  FIXME: bounds.
+                  return Btype;
                else
                   Rng := Synth_Discrete_Range_Constraint
                     (Syn_Inst, Get_Range_Constraint (Atype));
                   W := Discrete_Range_Width (Rng);
-                  Typ := Create_Discrete_Type (Rng, W);
+                  return Create_Discrete_Type (Rng, W);
                end if;
             end;
          when Iir_Kind_Floating_Subtype_Definition =>
@@ -369,11 +365,20 @@ package body Synth.Decls is
             begin
                Rng := Synth_Float_Range_Constraint
                  (Syn_Inst, Get_Range_Constraint (Atype));
-               Typ := Create_Float_Type (Rng);
+               return Create_Float_Type (Rng);
             end;
          when others =>
             Vhdl.Errors.Error_Kind ("synth_subtype_indication", Atype);
       end case;
+   end Synth_Subtype_Indication;
+
+   procedure Synth_Subtype_Indication
+     (Syn_Inst : Synth_Instance_Acc; Atype : Node)
+   is
+      Typ : Type_Acc;
+   begin
+      Typ := Synth_Subtype_Indication (Syn_Inst, Atype);
+      pragma Assert (Typ /= null);
       Create_Object (Syn_Inst, Atype, Create_Value_Subtype (Typ));
    end Synth_Subtype_Indication;
 
diff --git a/src/synth/synth-decls.ads b/src/synth/synth-decls.ads
index 08a548bc5..7fd104280 100644
--- a/src/synth/synth-decls.ads
+++ b/src/synth/synth-decls.ads
@@ -33,6 +33,8 @@ package Synth.Decls is
 
    procedure Synth_Subtype_Indication
      (Syn_Inst : Synth_Instance_Acc; Atype : Node);
+   function Synth_Subtype_Indication
+     (Syn_Inst : Synth_Instance_Acc; Atype : Node) return Type_Acc;
 
    --  Elaborate the type of DECL.
    procedure Synth_Declaration_Type
diff --git a/src/synth/synth-expr.adb b/src/synth/synth-expr.adb
index 54625936d..7f701edde 100644
--- a/src/synth/synth-expr.adb
+++ b/src/synth/synth-expr.adb
@@ -40,6 +40,7 @@ with Synth.Environment;
 with Synth.Decls;
 with Synth.Stmts; use Synth.Stmts;
 with Synth.Oper; use Synth.Oper;
+with Synth.Heap; use Synth.Heap;
 
 package body Synth.Expr is
    function Synth_Name (Syn_Inst : Synth_Instance_Acc; Name : Node)
@@ -1781,6 +1782,16 @@ package body Synth.Expr is
             end;
          when Iir_Kind_Null_Literal =>
             return Create_Value_Access (Expr_Type, Null_Heap_Index);
+         when Iir_Kind_Allocator_By_Subtype =>
+            declare
+               T : Type_Acc;
+               Acc : Heap_Index;
+            begin
+               T := Synth.Decls.Synth_Subtype_Indication
+                 (Syn_Inst, Get_Subtype_Indication (Expr));
+               Acc := Allocate_By_Type (T);
+               return Create_Value_Access (Expr_Type, Acc);
+            end;
          when Iir_Kind_Overflow_Literal =>
             declare
                N : Net;
diff --git a/src/synth/synth-heap.adb b/src/synth/synth-heap.adb
new file mode 100644
index 000000000..d92d4c561
--- /dev/null
+++ b/src/synth/synth-heap.adb
@@ -0,0 +1,94 @@
+--  Heap for 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 Types; use Types;
+with Tables;
+
+with Vhdl.Nodes; use Vhdl.Nodes;
+
+package body Synth.Heap is
+
+   package Heap_Table is new Tables
+     (Table_Component_Type => Value_Acc,
+      Table_Index_Type => Heap_Index,
+      Table_Low_Bound => 1,
+      Table_Initial => 16);
+
+   function Allocate_By_Type (T : Type_Acc) return Value_Acc is
+   begin
+      case T.Kind is
+         when Type_Bit
+           | Type_Logic =>
+            return new Value_Type'
+              (Kind => Value_Discrete, Typ => T, Scal => 0);
+         when Type_Discrete =>
+            return new Value_Type'
+              (Kind => Value_Discrete, Typ => T, Scal => T.Drange.Left);
+         when Type_Array =>
+            declare
+               Len : constant Uns32 := Get_Array_Flat_Length (T);
+               El_Typ : constant Type_Acc := Get_Array_Element (T);
+               Arr : Value_Array_Acc;
+            begin
+               Arr := new Value_Array_Type (Iir_Index32 (Len));
+               for I in Arr.V'Range loop
+                  Arr.V (I) := Allocate_By_Type (El_Typ);
+               end loop;
+               return new Value_Type'
+                 (Kind => Value_Const_Array, Typ => T, Arr => Arr);
+            end;
+         when others =>
+            raise Internal_Error;
+      end case;
+   end Allocate_By_Type;
+
+   function Allocate_By_Type (T : Type_Acc) return Heap_Index is
+   begin
+      --  FIXME: allocate type.
+      Heap_Table.Append (Allocate_By_Type (T));
+      return Heap_Table.Last;
+   end Allocate_By_Type;
+
+   function Allocate_By_Value (V : Value_Acc) return Heap_Index is
+   begin
+      raise Internal_Error;
+      return Null_Heap_Index;
+   end Allocate_By_Value;
+
+   function Synth_Dereference (Idx : Heap_Index) return Value_Acc is
+   begin
+      return Heap_Table.Table (Idx);
+   end Synth_Dereference;
+
+   procedure Free (Obj : in out Value_Acc) is
+   begin
+      -- TODO
+      Obj := null;
+   end Free;
+
+   procedure Synth_Deallocate (Idx : Heap_Index) is
+   begin
+      if Heap_Table.Table (Idx) = null then
+         return;
+      end if;
+      Free (Heap_Table.Table (Idx));
+   end Synth_Deallocate;
+
+end Synth.Heap;
diff --git a/src/synth/synth-heap.ads b/src/synth/synth-heap.ads
new file mode 100644
index 000000000..5568a3772
--- /dev/null
+++ b/src/synth/synth-heap.ads
@@ -0,0 +1,31 @@
+--  Heap for 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 Synth.Values; use Synth.Values;
+
+package Synth.Heap is
+   --  Allocate a value.
+   function Allocate_By_Type (T : Type_Acc) return Heap_Index;
+   function Allocate_By_Value (V : Value_Acc) return Heap_Index;
+
+   function Synth_Dereference (Idx : Heap_Index) return Value_Acc;
+
+   procedure Synth_Deallocate (Idx : Heap_Index);
+end Synth.Heap;
diff --git a/src/synth/synth-static_proc.adb b/src/synth/synth-static_proc.adb
index 2eb71c09c..c93f3bb1f 100644
--- a/src/synth/synth-static_proc.adb
+++ b/src/synth/synth-static_proc.adb
@@ -20,11 +20,22 @@
 
 with Vhdl.Errors; use Vhdl.Errors;
 
+with Synth.Values; use Synth.Values;
 with Synth.Errors; use Synth.Errors;
 with Synth.Files_Operations; use Synth.Files_Operations;
+with Synth.Heap;
 
 package body Synth.Static_Proc is
 
+   procedure Synth_Deallocate (Syn_Inst : Synth_Instance_Acc; Imp : Node)
+   is
+      Inter : constant Node := Get_Interface_Declaration_Chain (Imp);
+      Param : constant Value_Acc := Get_Value (Syn_Inst, Inter);
+   begin
+      Synth.Heap.Synth_Deallocate (Param.Acc);
+      Param.Acc := Null_Heap_Index;
+   end Synth_Deallocate;
+
    procedure Synth_Static_Procedure (Syn_Inst : Synth_Instance_Acc;
                                      Imp : Node;
                                      Loc : Node) is
@@ -32,6 +43,8 @@ package body Synth.Static_Proc is
       case Get_Implicit_Definition (Imp) is
          when Iir_Predefined_Foreign_Untruncated_Text_Read =>
             Synth_Untruncated_Text_Read (Syn_Inst, Imp, Loc);
+         when Iir_Predefined_Deallocate =>
+            Synth_Deallocate (Syn_Inst, Imp);
          when others =>
             Error_Msg_Synth
               (+Loc, "call to implicit %n is not supported", +Imp);
diff --git a/src/synth/synth-stmts.adb b/src/synth/synth-stmts.adb
index 8402dcec5..7527045c8 100644
--- a/src/synth/synth-stmts.adb
+++ b/src/synth/synth-stmts.adb
@@ -44,6 +44,7 @@ with Synth.Expr; use Synth.Expr;
 with Synth.Insts; use Synth.Insts;
 with Synth.Source;
 with Synth.Static_Proc;
+with Synth.Heap;
 
 with Netlists.Builders; use Netlists.Builders;
 with Netlists.Gates;
@@ -315,6 +316,16 @@ package body Synth.Stmts is
                end if;
             end;
 
+         when Iir_Kind_Implicit_Dereference =>
+            Synth_Assignment_Prefix
+              (Syn_Inst, Get_Prefix (Pfx),
+               Dest_Obj, Dest_Off, Dest_Voff, Dest_Rdwd, Dest_Type);
+            if Dest_Off /= 0 and then Dest_Voff /= No_Net then
+               raise Internal_Error;
+            end if;
+            Dest_Obj := Heap.Synth_Dereference (Dest_Obj.Acc);
+            Dest_Type := Dest_Obj.Typ;
+
          when others =>
             Error_Kind ("synth_assignment_prefix", Pfx);
       end case;
@@ -419,6 +430,8 @@ package body Synth.Stmts is
       case Targ.Kind is
          when Value_Discrete =>
             Targ.Scal := Val.Scal;
+         when Value_Access =>
+            Targ.Acc := Val.Acc;
          when Value_Const_Array
            | Value_Array =>
             declare