Handle vhdl08 if generate statements

6 files changed, 87 insertions, 83 deletions

diff --git a/src/grt/grt-avhpi.adb b/src/grt/grt-avhpi.adb
index f6c5c4138..1b8e5aa76 100644
--- a/src/grt/grt-avhpi.adb
+++ b/src/grt/grt-avhpi.adb
@@ -297,20 +297,13 @@ package body Grt.Avhpi is
                Error := AvhpiErrorOk;
                return;
             when Ghdl_Rtik_If_Generate =>
-               declare
-                  Gen : constant Ghdl_Rtin_Generate_Acc :=
-                    To_Ghdl_Rtin_Generate_Acc (Ch);
-               begin
-                  Res := (Kind => VhpiIfGenerateK,
-                          Ctxt => (Base => To_Addr_Acc (Iterator.Ctxt.Base
-                                                          + Gen.Loc).all,
-                                   Block => Gen.Child));
-                  --  Return only if the condition is true.
-                  if Res.Ctxt.Base /= Null_Address then
-                     Error := AvhpiErrorOk;
-                     return;
-                  end if;
-               end;
+               Res := (Kind => VhpiIfGenerateK,
+                       Ctxt => Get_If_Generate_Child (Iterator.Ctxt, Ch));
+               --  Return only if the condition is true.
+               if Res.Ctxt.Base /= Null_Address then
+                  Error := AvhpiErrorOk;
+                  return;
+               end if;
             when Ghdl_Rtik_For_Generate =>
                declare
                   Gen : constant Ghdl_Rtin_Generate_Acc :=
diff --git a/src/grt/grt-disp_rti.adb b/src/grt/grt-disp_rti.adb
index 1e029d151..ad45d087a 100644
--- a/src/grt/grt-disp_rti.adb
+++ b/src/grt/grt-disp_rti.adb
@@ -702,16 +702,21 @@ package body Grt.Disp_Rti is
          when Ghdl_Rtik_Generate_Body =>
             Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children,
                           Ctxt, Indent + 1);
+         when Ghdl_Rtik_If_Generate =>
+            Nctxt := Get_If_Generate_Child (Ctxt, To_Ghdl_Rti_Access (Blk));
+            Disp_Block
+              (To_Ghdl_Rtin_Block_Acc (Nctxt.Block), Nctxt, Indent + 1);
          when others =>
             Internal_Error ("disp_block");
       end case;
    end Disp_Block;
 
-   procedure Disp_Generate (Gen : Ghdl_Rtin_Generate_Acc;
-                            Ctxt : Rti_Context;
-                            Indent : Natural)
+   procedure Disp_For_Generate (Gen : Ghdl_Rtin_Generate_Acc;
+                                Ctxt : Rti_Context;
+                                Indent : Natural)
    is
       Nctxt : Rti_Context;
+      Length : Ghdl_Index_Type;
    begin
       Disp_Indent (Indent);
       Disp_Kind (Gen.Common.Kind);
@@ -721,31 +726,16 @@ package body Grt.Disp_Rti is
       Put (": ");
       Disp_Name (Gen.Name);
       New_Line;
-      case Gen.Common.Kind is
-         when Ghdl_Rtik_For_Generate =>
-            declare
-               Length : Ghdl_Index_Type;
-            begin
-               Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Gen.Loc).all,
-                         Block => Gen.Child);
-               Length := Get_For_Generate_Length (Gen, Ctxt);
-               for I in 1 .. Length loop
-                  Disp_Block (To_Ghdl_Rtin_Block_Acc (Gen.Child),
-                              Nctxt, Indent + 1);
-                  Nctxt.Base := Nctxt.Base + Gen.Size;
-               end loop;
-            end;
-         when Ghdl_Rtik_If_Generate =>
-            Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Gen.Loc).all,
-                      Block => Gen.Child);
-            if Nctxt.Base /= Null_Address then
-               Disp_Block (To_Ghdl_Rtin_Block_Acc (Gen.Child),
-                           Nctxt, Indent + 1);
-            end if;
-         when others =>
-            Internal_Error ("disp_generate");
-      end case;
-   end Disp_Generate;
+
+      Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Gen.Loc).all,
+                Block => Gen.Child);
+      Length := Get_For_Generate_Length (Gen, Ctxt);
+      for I in 1 .. Length loop
+         Disp_Block (To_Ghdl_Rtin_Block_Acc (Gen.Child),
+                     Nctxt, Indent + 1);
+         Nctxt.Base := Nctxt.Base + Gen.Size;
+      end loop;
+   end Disp_For_Generate;
 
    procedure Disp_Object (Obj : Ghdl_Rtin_Object_Acc;
                           Is_Sig : Boolean;
@@ -1083,9 +1073,10 @@ package body Grt.Disp_Rti is
            | Ghdl_Rtik_Process
            | Ghdl_Rtik_Block =>
             Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent);
-         when Ghdl_Rtik_If_Generate
-           | Ghdl_Rtik_For_Generate =>
-            Disp_Generate (To_Ghdl_Rtin_Generate_Acc (Rti), Ctxt, Indent);
+         when Ghdl_Rtik_If_Generate =>
+            Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent);
+         when Ghdl_Rtik_For_Generate =>
+            Disp_For_Generate (To_Ghdl_Rtin_Generate_Acc (Rti), Ctxt, Indent);
          when Ghdl_Rtik_Package_Body =>
             Disp_Rti (To_Ghdl_Rtin_Block_Acc (Rti).Parent, Ctxt, Indent);
             Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent);
diff --git a/src/grt/grt-disp_tree.adb b/src/grt/grt-disp_tree.adb
index 4afb64191..3eb715d3f 100644
--- a/src/grt/grt-disp_tree.adb
+++ b/src/grt/grt-disp_tree.adb
@@ -154,10 +154,11 @@ package body Grt.Disp_Tree is
          when Ghdl_Rtik_If_Generate =>
             Put (" [if-generate ");
             if Ctxt.Base = Null_Address then
-               Put ("false]");
+               Put ("false");
             else
-               Put ("true]");
+               Put ("true");
             end if;
+            Put ("]");
          when Ghdl_Rtik_Signal =>
             Put (" [signal]");
          when Ghdl_Rtik_Port =>
@@ -282,16 +283,13 @@ package body Grt.Disp_Tree is
                end;
             when Ghdl_Rtik_If_Generate =>
                declare
-                  Gen : constant Ghdl_Rtin_Generate_Acc :=
-                    To_Ghdl_Rtin_Generate_Acc (Child);
-                  Nctxt : Rti_Context;
+                  Nctxt : constant Rti_Context :=
+                    Get_If_Generate_Child (Ctxt, Child);
                begin
-                  Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Gen.Loc).all,
-                            Block => Gen.Child);
                   Disp_Header (Nctxt);
                   if Nctxt.Base /= Null_Address then
                      Disp_Sub_Block
-                       (To_Ghdl_Rtin_Block_Acc (Gen.Child), Nctxt);
+                       (To_Ghdl_Rtin_Block_Acc (Nctxt.Block), Nctxt);
                   end if;
                end;
             when Ghdl_Rtik_Instance =>
diff --git a/src/grt/grt-rtis_addr.adb b/src/grt/grt-rtis_addr.adb
index 199c449eb..444f1f033 100644
--- a/src/grt/grt-rtis_addr.adb
+++ b/src/grt/grt-rtis_addr.adb
@@ -135,6 +135,25 @@ package body Grt.Rtis_Addr is
       end if;
    end Get_Instance_Link;
 
+   function Get_If_Generate_Child (Ctxt : Rti_Context; Gen : Ghdl_Rti_Access)
+                                  return Rti_Context
+   is
+      pragma Assert (Gen.Kind = Ghdl_Rtik_If_Generate);
+      Blk : constant Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Gen);
+      Base_Addr : constant Address := Ctxt.Base + Blk.Loc;
+
+      --  Address of the block_id field.  It is just after the instance field.
+      --  Assume alignment is ok (it is on 32 and 64 bit platforms).
+      Id_Addr : constant Address :=
+        Base_Addr + Ghdl_Index_Type'(Address'Size / Storage_Unit);
+      Id : Ghdl_Index_Type;
+      pragma Import (Ada, Id);
+      for Id'Address use Id_Addr;
+   begin
+      return (Base => To_Addr_Acc (Base_Addr).all,
+              Block => Blk.Children (Id));
+   end Get_If_Generate_Child;
+
    function Loc_To_Addr (Depth : Ghdl_Rti_Depth;
                          Loc : Ghdl_Rti_Loc;
                          Ctxt : Rti_Context)
diff --git a/src/grt/grt-rtis_addr.ads b/src/grt/grt-rtis_addr.ads
index 5dd070334..dd0ca1546 100644
--- a/src/grt/grt-rtis_addr.ads
+++ b/src/grt/grt-rtis_addr.ads
@@ -64,6 +64,11 @@ package Grt.Rtis_Addr is
                                 Ctxt : out Rti_Context;
                                 Stmt : out Ghdl_Rti_Access);
 
+   --  Get the child context of if-generate statement GEN.  Return Null_Context
+   --  if there is no child.
+   function Get_If_Generate_Child (Ctxt : Rti_Context; Gen : Ghdl_Rti_Access)
+                                  return Rti_Context;
+
    --  Convert a location to an address.
    function Loc_To_Addr (Depth : Ghdl_Rti_Depth;
                          Loc : Ghdl_Rti_Loc;
diff --git a/src/grt/grt-rtis_utils.adb b/src/grt/grt-rtis_utils.adb
index 1994e90cb..9d7a56f2f 100644
--- a/src/grt/grt-rtis_utils.adb
+++ b/src/grt/grt-rtis_utils.adb
@@ -77,16 +77,10 @@ package body Grt.Rtis_Utils is
                      end loop;
                   end;
                when Ghdl_Rtik_If_Generate =>
-                  declare
-                     Gen : constant Ghdl_Rtin_Generate_Acc :=
-                       To_Ghdl_Rtin_Generate_Acc (Child);
-                  begin
-                     Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Gen.Loc).all,
-                               Block => Gen.Child);
-                     if Nctxt.Base /= Null_Address then
-                        Res := Traverse_Blocks_1 (Nctxt);
-                     end if;
-                  end;
+                  Nctxt := Get_If_Generate_Child (Ctxt, Child);
+                  if Nctxt.Base /= Null_Address then
+                     Res := Traverse_Blocks_1 (Nctxt);
+                  end if;
                when Ghdl_Rtik_Instance =>
                   Res := Process (Ctxt, Child);
                   if Res = Traverse_Ok then
@@ -567,12 +561,6 @@ package body Grt.Rtis_Utils is
       loop
          Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
          case Ctxt.Block.Kind is
-            when Ghdl_Rtik_Process
-              | Ghdl_Rtik_Block
-              | Ghdl_Rtik_If_Generate =>
-               Prepend (Rstr, Blk.Name);
-               Prepend (Rstr, Sep);
-               Ctxt := Get_Parent_Context (Ctxt);
             when Ghdl_Rtik_Entity =>
                declare
                   Link : Ghdl_Entity_Link_Acc;
@@ -626,20 +614,30 @@ package body Grt.Rtis_Utils is
                      Prepend (Rstr, Sep);
                   end if;
                end;
-            when Ghdl_Rtik_For_Generate =>
-               declare
-                  Iter : Ghdl_Rtin_Object_Acc;
-                  Addr : Address;
-               begin
-                  Prepend (Rstr, ')');
-                  Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0));
-                  Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt);
-                  Get_Value (Rstr, Addr, Get_Base_Type (Iter.Obj_Type));
-                  Prepend (Rstr, '(');
-                  Prepend (Rstr, Blk.Name);
-                  Prepend (Rstr, Sep);
-                  Ctxt := Get_Parent_Context (Ctxt);
-               end;
+            when Ghdl_Rtik_Process
+              | Ghdl_Rtik_Block
+              | Ghdl_Rtik_If_Generate =>
+               Prepend (Rstr, Blk.Name);
+               Prepend (Rstr, Sep);
+               Ctxt := Get_Parent_Context (Ctxt);
+            when Ghdl_Rtik_Generate_Body =>
+               if Blk.Parent.Kind = Ghdl_Rtik_For_Generate then
+                  declare
+                     Gen : constant Ghdl_Rtin_Generate_Acc :=
+                       To_Ghdl_Rtin_Generate_Acc (Blk.Parent);
+                     Iter : Ghdl_Rtin_Object_Acc;
+                     Addr : Address;
+                  begin
+                     Prepend (Rstr, ')');
+                     Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0));
+                     Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt);
+                     Get_Value (Rstr, Addr, Get_Base_Type (Iter.Obj_Type));
+                     Prepend (Rstr, '(');
+                     Prepend (Rstr, Gen.Name);
+                     Prepend (Rstr, Sep);
+                  end;
+               end if;
+               Ctxt := Get_Parent_Context (Ctxt);
             when others =>
                Internal_Error ("grt.rtis_utils.get_path_name");
          end case;