vhdl08: add support of case-generate statement

7 files changed, 41 insertions, 27 deletions

diff --git a/src/grt/grt-avhpi.adb b/src/grt/grt-avhpi.adb
index 31a60e85a..1777f54cf 100644
--- a/src/grt/grt-avhpi.adb
+++ b/src/grt/grt-avhpi.adb
@@ -312,7 +312,7 @@ package body Grt.Avhpi is
                return;
             when Ghdl_Rtik_If_Generate =>
                Res := (Kind => VhpiIfGenerateK,
-                       Ctxt => Get_If_Generate_Child (Iterator.Ctxt, Ch));
+                       Ctxt => Get_If_Case_Generate_Child (Iterator.Ctxt, Ch));
                --  Return only if the condition is true.
                if Res.Ctxt.Base /= Null_Address then
                   Error := AvhpiErrorOk;
diff --git a/src/grt/grt-disp_rti.adb b/src/grt/grt-disp_rti.adb
index ad1798f99..2a49281a7 100644
--- a/src/grt/grt-disp_rti.adb
+++ b/src/grt/grt-disp_rti.adb
@@ -383,6 +383,8 @@ package body Grt.Disp_Rti is
             Put ("ghdl_rtik_block");
          when Ghdl_Rtik_If_Generate =>
             Put ("ghdl_rtik_if_generate");
+         when Ghdl_Rtik_Case_Generate =>
+            Put ("ghdl_rtik_case_generate");
          when Ghdl_Rtik_For_Generate =>
             Put ("ghdl_rtik_for_generate");
          when Ghdl_Rtik_Generate_Body =>
@@ -737,8 +739,10 @@ 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));
+         when Ghdl_Rtik_If_Generate
+           | Ghdl_Rtik_Case_Generate =>
+            Nctxt := Get_If_Case_Generate_Child
+              (Ctxt, To_Ghdl_Rti_Access (Blk));
             if Nctxt /= Null_Context then
                --  There might be no blocks.
                Disp_Block
@@ -1149,7 +1153,8 @@ 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 =>
+         when Ghdl_Rtik_If_Generate
+           | Ghdl_Rtik_Case_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);
diff --git a/src/grt/grt-disp_tree.adb b/src/grt/grt-disp_tree.adb
index 8ff87eebb..ce2144445 100644
--- a/src/grt/grt-disp_tree.adb
+++ b/src/grt/grt-disp_tree.adb
@@ -61,6 +61,7 @@ package body Grt.Disp_Tree is
               | Ghdl_Rtik_Block
               | Ghdl_Rtik_For_Generate
               | Ghdl_Rtik_If_Generate
+              | Ghdl_Rtik_Case_Generate
               | Ghdl_Rtik_Instance =>
                return;
             when Ghdl_Rtik_Signal
@@ -88,7 +89,8 @@ package body Grt.Disp_Tree is
            | Ghdl_Rtik_Process
            | Ghdl_Rtik_Architecture
            | Ghdl_Rtik_Block
-           | Ghdl_Rtik_If_Generate =>
+           | Ghdl_Rtik_If_Generate
+           | Ghdl_Rtik_Case_Generate =>
             declare
                Blk : constant Ghdl_Rtin_Block_Acc :=
                  To_Ghdl_Rtin_Block_Acc (Rti);
@@ -159,6 +161,8 @@ package body Grt.Disp_Tree is
                Put ("true");
             end if;
             Put ("]");
+         when Ghdl_Rtik_Case_Generate =>
+            Put (" [case-generate]");
          when Ghdl_Rtik_Signal =>
             Put (" [signal]");
          when Ghdl_Rtik_Port =>
@@ -281,10 +285,11 @@ package body Grt.Disp_Tree is
                   end loop;
                   Child2 := Old_Child2;
                end;
-            when Ghdl_Rtik_If_Generate =>
+            when Ghdl_Rtik_If_Generate
+              | Ghdl_Rtik_Case_Generate =>
                declare
                   Nctxt : constant Rti_Context :=
-                    Get_If_Generate_Child (Ctxt, Child);
+                    Get_If_Case_Generate_Child (Ctxt, Child);
                begin
                   Disp_Header (Nctxt);
                   if Nctxt.Base /= Null_Address then
diff --git a/src/grt/grt-rtis.ads b/src/grt/grt-rtis.ads
index 703649c47..4d5571147 100644
--- a/src/grt/grt-rtis.ads
+++ b/src/grt/grt-rtis.ads
@@ -41,54 +41,56 @@ package Grt.Rtis is
       Ghdl_Rtik_Process,
       Ghdl_Rtik_Block,
       Ghdl_Rtik_If_Generate,
-      Ghdl_Rtik_For_Generate,
+      Ghdl_Rtik_Case_Generate,
 
-      Ghdl_Rtik_Generate_Body, -- 10
+      Ghdl_Rtik_For_Generate, -- 10
+      Ghdl_Rtik_Generate_Body,
       Ghdl_Rtik_Instance,
       Ghdl_Rtik_Constant,
       Ghdl_Rtik_Iterator,
-      Ghdl_Rtik_Variable,
 
+      Ghdl_Rtik_Variable,
       Ghdl_Rtik_Signal,
       Ghdl_Rtik_File,
       Ghdl_Rtik_Port,
       Ghdl_Rtik_Generic,
-      Ghdl_Rtik_Alias,
 
-      Ghdl_Rtik_Guard,          -- 20
+      Ghdl_Rtik_Alias,        -- 20
+      Ghdl_Rtik_Guard,
       Ghdl_Rtik_Component,
       Ghdl_Rtik_Attribute,
       Ghdl_Rtik_Type_B1,        --  Enum
-      Ghdl_Rtik_Type_E8,
 
+      Ghdl_Rtik_Type_E8,
       Ghdl_Rtik_Type_E32,
       Ghdl_Rtik_Type_I32,       --  Scalar
       Ghdl_Rtik_Type_I64,
       Ghdl_Rtik_Type_F64,
-      Ghdl_Rtik_Type_P32,
 
-      Ghdl_Rtik_Type_P64,       -- 30
+      Ghdl_Rtik_Type_P32,      -- 30
+      Ghdl_Rtik_Type_P64,
       Ghdl_Rtik_Type_Access,
       Ghdl_Rtik_Type_Array,
       Ghdl_Rtik_Type_Record,
-      Ghdl_Rtik_Type_File,
 
+      Ghdl_Rtik_Type_File,
       Ghdl_Rtik_Subtype_Scalar,
       Ghdl_Rtik_Subtype_Array,
       Ghdl_Rtik_Subtype_Unconstrained_Array,
       Ghdl_Rtik_Subtype_Record,
-      Ghdl_Rtik_Subtype_Access,
 
-      Ghdl_Rtik_Type_Protected, -- 40
+      Ghdl_Rtik_Subtype_Access, -- 40
+      Ghdl_Rtik_Type_Protected,
       Ghdl_Rtik_Element,
       Ghdl_Rtik_Unit64,
       Ghdl_Rtik_Unitptr,
-      Ghdl_Rtik_Attribute_Transaction,
 
+      Ghdl_Rtik_Attribute_Transaction,
       Ghdl_Rtik_Attribute_Quiet,
       Ghdl_Rtik_Attribute_Stable,
       Ghdl_Rtik_Psl_Assert,
       Ghdl_Rtik_Psl_Cover,
+
       Ghdl_Rtik_Psl_Endpoint,
 
       Ghdl_Rtik_Error);
diff --git a/src/grt/grt-rtis_addr.adb b/src/grt/grt-rtis_addr.adb
index f8a35bd1f..8be2a2e75 100644
--- a/src/grt/grt-rtis_addr.adb
+++ b/src/grt/grt-rtis_addr.adb
@@ -135,10 +135,11 @@ 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
+   function Get_If_Case_Generate_Child
+     (Ctxt : Rti_Context; Gen : Ghdl_Rti_Access) return Rti_Context
    is
-      pragma Assert (Gen.Kind = Ghdl_Rtik_If_Generate);
+      pragma Assert (Gen.Kind = Ghdl_Rtik_If_Generate
+                       or Gen.Kind = Ghdl_Rtik_Case_Generate);
       Blk : constant Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Gen);
       Base_Addr : constant Address := Ctxt.Base + Blk.Loc;
 
@@ -152,7 +153,7 @@ package body Grt.Rtis_Addr is
    begin
       return (Base => To_Addr_Acc (Base_Addr).all,
               Block => Blk.Children (Id));
-   end Get_If_Generate_Child;
+   end Get_If_Case_Generate_Child;
 
    function Loc_To_Addr (Depth : Ghdl_Rti_Depth;
                          Loc : Ghdl_Rti_Loc;
diff --git a/src/grt/grt-rtis_addr.ads b/src/grt/grt-rtis_addr.ads
index dd0ca1546..574f5cba5 100644
--- a/src/grt/grt-rtis_addr.ads
+++ b/src/grt/grt-rtis_addr.ads
@@ -66,8 +66,8 @@ package Grt.Rtis_Addr is
 
    --  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;
+   function Get_If_Case_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;
diff --git a/src/grt/grt-rtis_utils.adb b/src/grt/grt-rtis_utils.adb
index 1206d3f1f..a43a20066 100644
--- a/src/grt/grt-rtis_utils.adb
+++ b/src/grt/grt-rtis_utils.adb
@@ -76,8 +76,9 @@ package body Grt.Rtis_Utils is
                         Nctxt.Base := Nctxt.Base + Gen.Size;
                      end loop;
                   end;
-               when Ghdl_Rtik_If_Generate =>
-                  Nctxt := Get_If_Generate_Child (Ctxt, Child);
+               when Ghdl_Rtik_If_Generate
+                 | Ghdl_Rtik_Case_Generate =>
+                  Nctxt := Get_If_Case_Generate_Child (Ctxt, Child);
                   if Nctxt.Base /= Null_Address then
                      Res := Traverse_Blocks_1 (Nctxt);
                   end if;