diff options
author | Tristan Gingold <tgingold@free.fr> | 2016-07-05 03:58:37 +0200 |
---|---|---|
committer | Tristan Gingold <tgingold@free.fr> | 2016-07-07 19:26:43 +0200 |
commit | e305214943ba24c32b4c4883447d14da0bbf9d02 (patch) | |
tree | 71bf746c57dd27ff11b9619f5f74514bbec963d1 | |
parent | a2c0bdd3a58297c9d3ef649d565c371c30c2a6cc (diff) | |
download | ghdl-e305214943ba24c32b4c4883447d14da0bbf9d02.tar.gz ghdl-e305214943ba24c32b4c4883447d14da0bbf9d02.tar.bz2 ghdl-e305214943ba24c32b4c4883447d14da0bbf9d02.zip |
vhdl08: add support of case-generate statement
-rw-r--r-- | src/grt/grt-avhpi.adb | 2 | ||||
-rw-r--r-- | src/grt/grt-disp_rti.adb | 11 | ||||
-rw-r--r-- | src/grt/grt-disp_tree.adb | 11 | ||||
-rw-r--r-- | src/grt/grt-rtis.ads | 26 | ||||
-rw-r--r-- | src/grt/grt-rtis_addr.adb | 9 | ||||
-rw-r--r-- | src/grt/grt-rtis_addr.ads | 4 | ||||
-rw-r--r-- | src/grt/grt-rtis_utils.adb | 5 | ||||
-rw-r--r-- | src/vhdl/canon.adb | 82 | ||||
-rw-r--r-- | src/vhdl/configuration.adb | 13 | ||||
-rw-r--r-- | src/vhdl/disp_vhdl.adb | 31 | ||||
-rw-r--r-- | src/vhdl/iirs.adb | 18 | ||||
-rw-r--r-- | src/vhdl/iirs.ads | 20 | ||||
-rw-r--r-- | src/vhdl/nodes_meta.adb | 61 | ||||
-rw-r--r-- | src/vhdl/nodes_meta.ads | 2 | ||||
-rw-r--r-- | src/vhdl/parse.adb | 10 | ||||
-rw-r--r-- | src/vhdl/sem_stmts.adb | 111 | ||||
-rw-r--r-- | src/vhdl/translate/trans-chap1.adb | 82 | ||||
-rw-r--r-- | src/vhdl/translate/trans-chap3.adb | 6 | ||||
-rw-r--r-- | src/vhdl/translate/trans-chap7.adb | 2 | ||||
-rw-r--r-- | src/vhdl/translate/trans-chap8.adb | 3 | ||||
-rw-r--r-- | src/vhdl/translate/trans-chap9.adb | 417 | ||||
-rw-r--r-- | src/vhdl/translate/trans-rtis.adb | 65 | ||||
-rw-r--r-- | src/vhdl/translate/trans-rtis.ads | 1 | ||||
-rw-r--r-- | testsuite/gna/issue106/case1.vhdl | 29 | ||||
-rwxr-xr-x | testsuite/gna/issue106/testsuite.sh | 3 |
25 files changed, 766 insertions, 258 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; diff --git a/src/vhdl/canon.adb b/src/vhdl/canon.adb index 129ce95da..f3cc675e8 100644 --- a/src/vhdl/canon.adb +++ b/src/vhdl/canon.adb @@ -1677,6 +1677,27 @@ package body Canon is end if; end Canon_Psl_Directive; + procedure Canon_If_Case_Generate_Statement_Body + (Bod : Iir; Alt_Num : in out Natural; Top : Iir_Design_Unit) is + begin + if Canon_Flag_Add_Labels + and then Get_Alternative_Label (Bod) = Null_Identifier + then + declare + Str : String := Natural'Image (Alt_Num); + begin + -- Note: the label starts with a capitalized + -- letter, to avoid any clash with user's + -- identifiers. + Str (1) := 'B'; + Set_Alternative_Label (Bod, Name_Table.Get_Identifier (Str)); + end; + end if; + + Canon_Generate_Statement_Body (Top, Bod); + Alt_Num := Alt_Num + 1; + end Canon_If_Case_Generate_Statement_Body; + procedure Canon_Concurrent_Stmts (Top : Iir_Design_Unit; Parent : Iir) is -- Current element in the chain of concurrent statements. @@ -1898,38 +1919,43 @@ package body Canon is when Iir_Kind_If_Generate_Statement => declare Clause : Iir; - Bod : Iir; Cond : Iir; Alt_Num : Natural; begin Clause := El; Alt_Num := 1; while Clause /= Null_Iir loop - Bod := Get_Generate_Statement_Body (Clause); - if Canon_Flag_Add_Labels - and then Get_Alternative_Label (Bod) = Null_Identifier - then - declare - Str : String := Natural'Image (Alt_Num); - begin - -- Note: the label starts with a capitalized - -- letter, to avoid any clash with user's - -- identifiers. - Str (1) := 'B'; - Set_Alternative_Label - (Bod, Name_Table.Get_Identifier (Str)); - end; - end if; - if Canon_Flag_Expressions then Cond := Get_Condition (El); if Cond /= Null_Iir then Canon_Expression (Cond); end if; end if; - Canon_Generate_Statement_Body (Top, Bod); + + Canon_If_Case_Generate_Statement_Body + (Get_Generate_Statement_Body (Clause), Alt_Num, Top); + Clause := Get_Generate_Else_Clause (Clause); - Alt_Num := Alt_Num + 1; + end loop; + end; + + when Iir_Kind_Case_Generate_Statement => + declare + Alt : Iir; + Alt_Num : Natural; + begin + Alt_Num := 1; + if Canon_Flag_Expressions then + Canon_Expression (Get_Expression (El)); + end if; + Alt := Get_Case_Statement_Alternative_Chain (El); + while Alt /= Null_Iir loop + if not Get_Same_Alternative_Flag (Alt) then + Canon_If_Case_Generate_Statement_Body + (Get_Associated_Block (Alt), Alt_Num, Top); + end if; + + Alt := Get_Chain (Alt); end loop; end; @@ -2839,6 +2865,24 @@ package body Canon is Clause := Get_Generate_Else_Clause (Clause); end loop; end; + when Iir_Kind_Case_Generate_Statement => + declare + Alt : Iir; + Bod : Iir; + Blk_Config : Iir_Block_Configuration; + begin + Alt := Get_Case_Statement_Alternative_Chain (El); + while Alt /= Null_Iir loop + if not Get_Same_Alternative_Flag (Alt) then + Bod := Get_Associated_Block (Alt); + Blk_Config := Get_Generate_Block_Configuration (Bod); + if Blk_Config = Null_Iir then + Create_Default_Block_Configuration (Bod); + end if; + end if; + Alt := Get_Chain (Alt); + end loop; + end; when Iir_Kind_For_Generate_Statement => declare Bod : constant Iir := Get_Generate_Statement_Body (El); diff --git a/src/vhdl/configuration.adb b/src/vhdl/configuration.adb index 8c442dd76..c4bc0434f 100644 --- a/src/vhdl/configuration.adb +++ b/src/vhdl/configuration.adb @@ -248,6 +248,19 @@ package body Configuration is Clause := Get_Generate_Else_Clause (Clause); end loop; end; + when Iir_Kind_Case_Generate_Statement => + declare + Alt : Iir; + begin + Alt := Get_Case_Statement_Alternative_Chain (Stmt); + while Alt /= Null_Iir loop + if not Get_Same_Alternative_Flag (Alt) then + Add_Design_Concurrent_Stmts + (Get_Associated_Block (Alt)); + end if; + Alt := Get_Chain (Alt); + end loop; + end; when Iir_Kind_Process_Statement | Iir_Kind_Sensitized_Process_Statement | Iir_Kind_Psl_Assert_Statement diff --git a/src/vhdl/disp_vhdl.adb b/src/vhdl/disp_vhdl.adb index ffe8e3f10..63a03ddca 100644 --- a/src/vhdl/disp_vhdl.adb +++ b/src/vhdl/disp_vhdl.adb @@ -224,6 +224,7 @@ package body Disp_Vhdl is Disp_Identifier (Decl); when Iir_Kind_Block_Statement | Iir_Kind_If_Generate_Statement + | Iir_Kind_Case_Generate_Statement | Iir_Kind_For_Generate_Statement => declare Ident : constant Name_Id := Get_Label (Decl); @@ -2979,6 +2980,34 @@ package body Disp_Vhdl is Disp_End (Stmt, "generate"); end Disp_If_Generate_Statement; + procedure Disp_Case_Generate_Statement (Stmt : Iir) + is + Indent : constant Count := Col; + Bod : Iir; + Assoc : Iir; + begin + Disp_Label (Stmt); + Put ("case "); + Disp_Expression (Get_Expression (Stmt)); + Put_Line (" generate"); + Assoc := Get_Case_Statement_Alternative_Chain (Stmt); + while Assoc /= Null_Iir loop + Set_Col (Indent + Indentation); + Put ("when "); + Bod := Get_Associated_Block (Assoc); + if Get_Has_Label (Bod) then + Disp_Ident (Get_Alternative_Label (Bod)); + Put (": "); + end if; + Disp_Choice (Assoc); + Put (" "); + Put_Line ("=>"); + Disp_Generate_Statement_Body (Bod, Indent + 2 * Indentation); + end loop; + Set_Col (Indent); + Disp_End (Stmt, "generate"); + end Disp_Case_Generate_Statement; + procedure Disp_Psl_Default_Clock (Stmt : Iir) is begin Put ("--psl default clock is "); @@ -3110,6 +3139,8 @@ package body Disp_Vhdl is Disp_Block_Statement (Stmt); when Iir_Kind_If_Generate_Statement => Disp_If_Generate_Statement (Stmt); + when Iir_Kind_Case_Generate_Statement => + Disp_Case_Generate_Statement (Stmt); when Iir_Kind_For_Generate_Statement => Disp_For_Generate_Statement (Stmt); when Iir_Kind_Psl_Default_Clock => diff --git a/src/vhdl/iirs.adb b/src/vhdl/iirs.adb index e9dc2dbe3..72cb6daa4 100644 --- a/src/vhdl/iirs.adb +++ b/src/vhdl/iirs.adb @@ -390,8 +390,8 @@ package body Iirs is | Iir_Kind_Psl_Default_Clock | Iir_Kind_Concurrent_Procedure_Call_Statement | Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement | Iir_Kind_Case_Generate_Statement + | Iir_Kind_For_Generate_Statement | Iir_Kind_Generate_Statement_Body | Iir_Kind_If_Generate_Else_Clause | Iir_Kind_Simple_Signal_Assignment_Statement @@ -1452,6 +1452,22 @@ package body Iirs is Set_Field3 (Target, Associated); end Set_Associated_Expr; + function Get_Associated_Block (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Associated_Block (Get_Kind (Target)), + "no field Associated_Block"); + return Get_Field3 (Target); + end Get_Associated_Block; + + procedure Set_Associated_Block (Target : Iir; Associated : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Associated_Block (Get_Kind (Target)), + "no field Associated_Block"); + Set_Field3 (Target, Associated); + end Set_Associated_Block; + function Get_Associated_Chain (Target : Iir) return Iir is begin pragma Assert (Target /= Null_Iir); diff --git a/src/vhdl/iirs.ads b/src/vhdl/iirs.ads index 7ecdcafc1..aaf366f28 100644 --- a/src/vhdl/iirs.ads +++ b/src/vhdl/iirs.ads @@ -478,13 +478,16 @@ package Iirs is -- -- Get/Set what is associated with the choice. There are two different -- nodes, one for simple association and the other for chain association. - -- This simplifies walkers. But both nodes are never used at the same - -- time. + -- They don't have the same properties (normal vs chain), so the right + -- field must be selected according to the property to have working + -- walkers. Both fields are never used at the same time. -- -- For: -- * an expression for an aggregate -- * an individual association + -- * a generate_statement_body chain for a case_generate_statement -- Get/Set_Associated_Expr (Field3) + -- Get/Set_Associated_Block (Alias Field3) -- -- For -- * a waveform_chain for a concurrent_select_signal_assignment, @@ -3864,8 +3867,8 @@ package Iirs is Iir_Kind_Concurrent_Procedure_Call_Statement, Iir_Kind_Block_Statement, Iir_Kind_If_Generate_Statement, - Iir_Kind_For_Generate_Statement, Iir_Kind_Case_Generate_Statement, + Iir_Kind_For_Generate_Statement, Iir_Kind_Component_Instantiation_Statement, Iir_Kind_Simple_Simultaneous_Statement, @@ -4810,8 +4813,8 @@ package Iirs is --Iir_Kind_Concurrent_Procedure_Call_Statement --Iir_Kind_Block_Statement --Iir_Kind_If_Generate_Statement - --Iir_Kind_For_Generate_Statement --Iir_Kind_Case_Generate_Statement + --Iir_Kind_For_Generate_Statement Iir_Kind_Component_Instantiation_Statement; subtype Iir_Kinds_Concurrent_Signal_Assignment is Iir_Kind range @@ -4819,6 +4822,10 @@ package Iirs is --Iir_Kind_Concurrent_Conditional_Signal_Assignment Iir_Kind_Concurrent_Selected_Signal_Assignment; + subtype Iir_Kinds_If_Case_Generate_Statement is Iir_Kind range + Iir_Kind_If_Generate_Statement .. + Iir_Kind_Case_Generate_Statement; + subtype Iir_Kinds_Sequential_Statement is Iir_Kind range Iir_Kind_Simple_Signal_Assignment_Statement .. --Iir_Kind_Conditional_Signal_Assignment_Statement @@ -5553,6 +5560,11 @@ package Iirs is function Get_Associated_Expr (Target : Iir) return Iir; procedure Set_Associated_Expr (Target : Iir; Associated : Iir); + -- Node associated with a choice. + -- Field: Field3 + function Get_Associated_Block (Target : Iir) return Iir; + procedure Set_Associated_Block (Target : Iir; Associated : Iir); + -- Chain associated with a choice. -- Field: Field4 Chain function Get_Associated_Chain (Target : Iir) return Iir; diff --git a/src/vhdl/nodes_meta.adb b/src/vhdl/nodes_meta.adb index 7f846dbda..ed62794cb 100644 --- a/src/vhdl/nodes_meta.adb +++ b/src/vhdl/nodes_meta.adb @@ -77,6 +77,7 @@ package body Nodes_Meta is Field_We_Value => Type_Iir, Field_Time => Type_Iir, Field_Associated_Expr => Type_Iir, + Field_Associated_Block => Type_Iir, Field_Associated_Chain => Type_Iir, Field_Choice_Name => Type_Iir, Field_Choice_Expression => Type_Iir, @@ -449,6 +450,8 @@ package body Nodes_Meta is return "time"; when Field_Associated_Expr => return "associated_expr"; + when Field_Associated_Block => + return "associated_block"; when Field_Associated_Chain => return "associated_chain"; when Field_Choice_Name => @@ -1309,10 +1312,10 @@ package body Nodes_Meta is return "block_statement"; when Iir_Kind_If_Generate_Statement => return "if_generate_statement"; - when Iir_Kind_For_Generate_Statement => - return "for_generate_statement"; when Iir_Kind_Case_Generate_Statement => return "case_generate_statement"; + when Iir_Kind_For_Generate_Statement => + return "for_generate_statement"; when Iir_Kind_Component_Instantiation_Statement => return "component_instantiation_statement"; when Iir_Kind_Simple_Simultaneous_Statement => @@ -1581,6 +1584,8 @@ package body Nodes_Meta is return Attr_None; when Field_Associated_Expr => return Attr_None; + when Field_Associated_Block => + return Attr_None; when Field_Associated_Chain => return Attr_Chain; when Field_Choice_Name => @@ -3554,25 +3559,25 @@ package body Nodes_Meta is Field_Generate_Statement_Body, Field_Generate_Else_Clause, Field_Parent, - -- Iir_Kind_For_Generate_Statement + -- Iir_Kind_Case_Generate_Statement Field_Label, Field_Visible_Flag, Field_Is_Within_Flag, Field_End_Has_Reserved_Id, Field_End_Has_Identifier, - Field_Parameter_Specification, + Field_Case_Statement_Alternative_Chain, Field_Chain, - Field_Generate_Statement_Body, + Field_Expression, Field_Parent, - -- Iir_Kind_Case_Generate_Statement + -- Iir_Kind_For_Generate_Statement Field_Label, Field_Visible_Flag, Field_Is_Within_Flag, Field_End_Has_Reserved_Id, Field_End_Has_Identifier, - Field_Case_Statement_Alternative_Chain, + Field_Parameter_Specification, Field_Chain, - Field_Expression, + Field_Generate_Statement_Body, Field_Parent, -- Iir_Kind_Component_Instantiation_Statement Field_Label, @@ -4270,8 +4275,8 @@ package body Nodes_Meta is Iir_Kind_Concurrent_Procedure_Call_Statement => 1271, Iir_Kind_Block_Statement => 1284, Iir_Kind_If_Generate_Statement => 1294, - Iir_Kind_For_Generate_Statement => 1303, - Iir_Kind_Case_Generate_Statement => 1312, + Iir_Kind_Case_Generate_Statement => 1303, + Iir_Kind_For_Generate_Statement => 1312, Iir_Kind_Component_Instantiation_Statement => 1322, Iir_Kind_Simple_Simultaneous_Statement => 1329, Iir_Kind_Generate_Statement_Body => 1340, @@ -4746,6 +4751,8 @@ package body Nodes_Meta is return Get_Time (N); when Field_Associated_Expr => return Get_Associated_Expr (N); + when Field_Associated_Block => + return Get_Associated_Block (N); when Field_Associated_Chain => return Get_Associated_Chain (N); when Field_Choice_Name => @@ -5114,6 +5121,8 @@ package body Nodes_Meta is Set_Time (N, V); when Field_Associated_Expr => Set_Associated_Expr (N, V); + when Field_Associated_Block => + Set_Associated_Block (N, V); when Field_Associated_Chain => Set_Associated_Chain (N, V); when Field_Choice_Name => @@ -6575,6 +6584,20 @@ package body Nodes_Meta is end case; end Has_Associated_Expr; + function Has_Associated_Block (K : Iir_Kind) return Boolean is + begin + case K is + when Iir_Kind_Choice_By_Others + | Iir_Kind_Choice_By_Expression + | Iir_Kind_Choice_By_Range + | Iir_Kind_Choice_By_None + | Iir_Kind_Choice_By_Name => + return True; + when others => + return False; + end case; + end Has_Associated_Block; + function Has_Associated_Chain (K : Iir_Kind) return Boolean is begin case K is @@ -6801,8 +6824,8 @@ package body Nodes_Meta is | Iir_Kind_Concurrent_Procedure_Call_Statement | Iir_Kind_Block_Statement | Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement | Iir_Kind_Case_Generate_Statement + | Iir_Kind_For_Generate_Statement | Iir_Kind_Component_Instantiation_Statement | Iir_Kind_Simple_Simultaneous_Statement | Iir_Kind_Simple_Signal_Assignment_Statement @@ -7533,8 +7556,8 @@ package body Nodes_Meta is | Iir_Kind_Concurrent_Procedure_Call_Statement | Iir_Kind_Block_Statement | Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement | Iir_Kind_Case_Generate_Statement + | Iir_Kind_For_Generate_Statement | Iir_Kind_Component_Instantiation_Statement | Iir_Kind_Simple_Simultaneous_Statement | Iir_Kind_Generate_Statement_Body @@ -7582,8 +7605,8 @@ package body Nodes_Meta is | Iir_Kind_Concurrent_Procedure_Call_Statement | Iir_Kind_Block_Statement | Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement | Iir_Kind_Case_Generate_Statement + | Iir_Kind_For_Generate_Statement | Iir_Kind_Component_Instantiation_Statement | Iir_Kind_Simple_Simultaneous_Statement | Iir_Kind_Simple_Signal_Assignment_Statement @@ -7662,8 +7685,8 @@ package body Nodes_Meta is | Iir_Kind_Concurrent_Procedure_Call_Statement | Iir_Kind_Block_Statement | Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement | Iir_Kind_Case_Generate_Statement + | Iir_Kind_For_Generate_Statement | Iir_Kind_Component_Instantiation_Statement | Iir_Kind_Simple_Simultaneous_Statement | Iir_Kind_If_Generate_Else_Clause @@ -8638,8 +8661,8 @@ package body Nodes_Meta is | Iir_Kind_Concurrent_Procedure_Call_Statement | Iir_Kind_Block_Statement | Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement | Iir_Kind_Case_Generate_Statement + | Iir_Kind_For_Generate_Statement | Iir_Kind_Component_Instantiation_Statement | Iir_Kind_Simple_Simultaneous_Statement | Iir_Kind_Generate_Statement_Body @@ -9535,8 +9558,8 @@ package body Nodes_Meta is | Iir_Kind_Process_Statement | Iir_Kind_Block_Statement | Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement | Iir_Kind_Case_Generate_Statement + | Iir_Kind_For_Generate_Statement | Iir_Kind_Generate_Statement_Body | Iir_Kind_For_Loop_Statement => return True; @@ -9653,8 +9676,8 @@ package body Nodes_Meta is | Iir_Kind_Process_Statement | Iir_Kind_Block_Statement | Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement - | Iir_Kind_Case_Generate_Statement => + | Iir_Kind_Case_Generate_Statement + | Iir_Kind_For_Generate_Statement => return True; when others => return False; @@ -9682,8 +9705,8 @@ package body Nodes_Meta is | Iir_Kind_Process_Statement | Iir_Kind_Block_Statement | Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement | Iir_Kind_Case_Generate_Statement + | Iir_Kind_For_Generate_Statement | Iir_Kind_Generate_Statement_Body | Iir_Kind_For_Loop_Statement | Iir_Kind_While_Loop_Statement diff --git a/src/vhdl/nodes_meta.ads b/src/vhdl/nodes_meta.ads index fdca99ff4..3ffff9e7e 100644 --- a/src/vhdl/nodes_meta.ads +++ b/src/vhdl/nodes_meta.ads @@ -117,6 +117,7 @@ package Nodes_Meta is Field_We_Value, Field_Time, Field_Associated_Expr, + Field_Associated_Block, Field_Associated_Chain, Field_Choice_Name, Field_Choice_Expression, @@ -603,6 +604,7 @@ package Nodes_Meta is function Has_We_Value (K : Iir_Kind) return Boolean; function Has_Time (K : Iir_Kind) return Boolean; function Has_Associated_Expr (K : Iir_Kind) return Boolean; + function Has_Associated_Block (K : Iir_Kind) return Boolean; function Has_Associated_Chain (K : Iir_Kind) return Boolean; function Has_Choice_Name (K : Iir_Kind) return Boolean; function Has_Choice_Expression (K : Iir_Kind) return Boolean; diff --git a/src/vhdl/parse.adb b/src/vhdl/parse.adb index 78d151224..4f07c3e59 100644 --- a/src/vhdl/parse.adb +++ b/src/vhdl/parse.adb @@ -6925,7 +6925,7 @@ package body Parse is Expect (Tok_Double_Arrow); Scan; - Set_Associated_Chain + Set_Associated_Block (Assoc, Parse_Generate_Statement_Body (Parent, Alt_Label)); return Assoc; @@ -6977,7 +6977,13 @@ package body Parse is else Set_Chain (Last_Alt, Alt); end if; - Last_Alt := Alt; + + -- Skip until last choice of the choices list. + loop + Last_Alt := Alt; + Alt := Get_Chain (Alt); + exit when Alt = Null_Iir; + end loop; end loop; Expect (Tok_Generate); diff --git a/src/vhdl/sem_stmts.adb b/src/vhdl/sem_stmts.adb index 00b8be27b..d0ca64a06 100644 --- a/src/vhdl/sem_stmts.adb +++ b/src/vhdl/sem_stmts.adb @@ -1070,17 +1070,17 @@ package body Sem_Stmts is El: Iir; begin Expr := Get_Expression (Stmt); + Chain := Get_Case_Statement_Alternative_Chain (Stmt); -- FIXME: overload. Expr := Sem_Case_Expression (Expr); - if Expr = Null_Iir then - return; + if Expr /= Null_Iir then + Check_Read (Expr); + Set_Expression (Stmt, Expr); + + Sem_Case_Choices (Expr, Chain, Get_Location (Stmt)); + Set_Case_Statement_Alternative_Chain (Stmt, Chain); end if; - Check_Read (Expr); - Set_Expression (Stmt, Expr); - Chain := Get_Case_Statement_Alternative_Chain (Stmt); - Sem_Case_Choices (Expr, Chain, Get_Location (Stmt)); - Set_Case_Statement_Alternative_Chain (Stmt, Chain); - -- Sem on associated. + El := Chain; while El /= Null_Iir loop Sem_Sequential_Statements_Internal (Get_Associated_Chain (El)); @@ -1695,12 +1695,30 @@ package body Sem_Stmts is Close_Declarative_Region; end Sem_For_Generate_Statement; + procedure Sem_If_Case_Generate_Statement_Body (Bod : Iir) + is + Alt_Label : Name_Id; + begin + Alt_Label := Get_Alternative_Label (Bod); + if Alt_Label /= Null_Identifier then + -- Declare label. This doesn't appear in the LRM (bug ?), but + -- used here to detect duplicated labels. + Sem_Scopes.Add_Name (Bod); + Xref_Decl (Bod); + end if; + + -- Contrary to the LRM, a new declarative region is declared. This + -- is required so that declarations in a generate statement body are + -- not in the scope of the following generate bodies. + Open_Declarative_Region; + Sem_Generate_Statement_Body (Bod); + Close_Declarative_Region; + end Sem_If_Case_Generate_Statement_Body; + procedure Sem_If_Generate_Statement (Stmt : Iir) is Clause : Iir; - Bod : Iir; Condition : Iir; - Alt_Label : Name_Id; begin -- LRM93 10.1 Declarative region. -- 12. A generate statement. @@ -1730,21 +1748,8 @@ package body Sem_Stmts is null; end if; - Bod := Get_Generate_Statement_Body (Clause); - Alt_Label := Get_Alternative_Label (Bod); - if Alt_Label /= Null_Identifier then - -- Declare label. This doesn't appear in the LRM (bug ?), but - -- used here to detect duplicated labels. - Sem_Scopes.Add_Name (Bod); - Xref_Decl (Bod); - end if; - - -- Contrary to the LRM, a new declarative region is declared. This - -- is required so that declarations in a generate statement body are - -- not in the scope of the following generate bodies. - Open_Declarative_Region; - Sem_Generate_Statement_Body (Bod); - Close_Declarative_Region; + Sem_If_Case_Generate_Statement_Body + (Get_Generate_Statement_Body (Clause)); Clause := Get_Generate_Else_Clause (Clause); end loop; @@ -1753,6 +1758,46 @@ package body Sem_Stmts is Close_Declarative_Region; end Sem_If_Generate_Statement; + procedure Sem_Case_Generate_Statement (Stmt : Iir) + is + Expr : Iir; + Chain : Iir; + El : Iir; + begin + -- LRM93 10.1 Declarative region. + -- 12. A generate statement. + Open_Declarative_Region; + Set_Is_Within_Flag (Stmt, True); + + Expr := Get_Expression (Stmt); + Chain := Get_Case_Statement_Alternative_Chain (Stmt); + -- FIXME: overload. + Expr := Sem_Case_Expression (Expr); + if Expr /= Null_Iir then + Check_Read (Expr); + Set_Expression (Stmt, Expr); + + if Get_Expr_Staticness (Expr) < Globally then + Error_Msg_Sem + ("case expression must be a static expression", Expr); + end if; + + Sem_Case_Choices (Expr, Chain, Get_Location (Stmt)); + Set_Case_Statement_Alternative_Chain (Stmt, Chain); + end if; + + El := Chain; + while El /= Null_Iir loop + if not Get_Same_Alternative_Flag (El) then + Sem_If_Case_Generate_Statement_Body (Get_Associated_Block (El)); + end if; + El := Get_Chain (El); + end loop; + + Set_Is_Within_Flag (Stmt, False); + Close_Declarative_Region; + end Sem_Case_Generate_Statement; + procedure Sem_Process_Statement (Proc: Iir) is begin Set_Is_Within_Flag (Proc, True); @@ -1804,15 +1849,14 @@ package body Sem_Stmts is Sem_Signal_Assignment (Stmt); -- The choices. + Chain := Get_Selected_Waveform_Chain (Stmt); Expr := Sem_Case_Expression (Get_Expression (Stmt)); - if Expr = Null_Iir then - return; + if Expr /= Null_Iir then + Check_Read (Expr); + Set_Expression (Stmt, Expr); + Sem_Case_Choices (Expr, Chain, Get_Location (Stmt)); + Set_Selected_Waveform_Chain (Stmt, Chain); end if; - Check_Read (Expr); - Set_Expression (Stmt, Expr); - Chain := Get_Selected_Waveform_Chain (Stmt); - Sem_Case_Choices (Expr, Chain, Get_Location (Stmt)); - Set_Selected_Waveform_Chain (Stmt, Chain); Sem_Guard (Stmt); end Sem_Concurrent_Selected_Signal_Assignment; @@ -1906,6 +1950,9 @@ package body Sem_Stmts is when Iir_Kind_For_Generate_Statement => No_Generate_Statement; Sem_For_Generate_Statement (El); + when Iir_Kind_Case_Generate_Statement => + No_Generate_Statement; + Sem_Case_Generate_Statement (El); when Iir_Kind_Concurrent_Procedure_Call_Statement => New_El := Sem_Concurrent_Procedure_Call_Statement (El, Is_Passive); diff --git a/src/vhdl/translate/trans-chap1.adb b/src/vhdl/translate/trans-chap1.adb index c54c6aa13..3bff1a42e 100644 --- a/src/vhdl/translate/trans-chap1.adb +++ b/src/vhdl/translate/trans-chap1.adb @@ -777,7 +777,7 @@ package body Trans.Chap1 is end case; end Translate_For_Generate_Block_Configuration_Calls; - procedure Translate_If_Generate_Block_Configuration_Calls + procedure Translate_If_Case_Generate_Block_Configuration_Calls (Block_Config : Iir_Block_Configuration; Parent_Info : Block_Info_Acc) is @@ -815,13 +815,52 @@ package body Trans.Chap1 is Close_Temp; Finish_If_Stmt (If_Blk); - end Translate_If_Generate_Block_Configuration_Calls; + end Translate_If_Case_Generate_Block_Configuration_Calls; procedure Translate_Block_Configuration_Calls (Block_Config : Iir_Block_Configuration; Base_Block : Iir; Base_Info : Block_Info_Acc) is + procedure Translate_Block_Block_Configuration_Calls (Item : Iir) + is + Block : Iir; + begin + Block := Get_Block_Specification (Item); + case Get_Kind (Block) is + when Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name => + Block := Get_Named_Entity (Get_Prefix (Block)); + when Iir_Kinds_Denoting_Name + | Iir_Kind_Parenthesis_Name => + Block := Get_Named_Entity (Block); + when others => + null; + end case; + + case Get_Kind (Block) is + when Iir_Kind_Block_Statement => + Translate_Block_Configuration_Calls + (Item, Base_Block, Get_Info (Block)); + when Iir_Kind_Generate_Statement_Body => + case Get_Kind (Get_Parent (Block)) is + when Iir_Kind_If_Generate_Statement + | Iir_Kind_If_Generate_Else_Clause + | Iir_Kind_Case_Generate_Statement => -- FIXME + Translate_If_Case_Generate_Block_Configuration_Calls + (Item, Base_Info); + when Iir_Kind_For_Generate_Statement => + Translate_For_Generate_Block_Configuration_Calls + (Item, Base_Info); + when others => + Error_Kind ("translate_block_configuration_calls(3)", + Get_Parent (Block)); + end case; + when others => + Error_Kind ("translate_block_configuration_calls(4)", Block); + end case; + end Translate_Block_Block_Configuration_Calls; + El : Iir; begin El := Get_Configuration_Item_Chain (Block_Config); @@ -832,44 +871,7 @@ package body Trans.Chap1 is Translate_Component_Configuration_Call (El, Base_Block, Base_Info); when Iir_Kind_Block_Configuration => - declare - Block : Iir; - begin - Block := Get_Block_Specification (El); - case Get_Kind (Block) is - when Iir_Kind_Indexed_Name - | Iir_Kind_Slice_Name => - Block := Get_Named_Entity (Get_Prefix (Block)); - when Iir_Kinds_Denoting_Name - | Iir_Kind_Parenthesis_Name => - Block := Get_Named_Entity (Block); - when others => - null; - end case; - - case Get_Kind (Block) is - when Iir_Kind_Block_Statement => - Translate_Block_Configuration_Calls - (El, Base_Block, Get_Info (Block)); - when Iir_Kind_Generate_Statement_Body => - case Get_Kind (Get_Parent (Block)) is - when Iir_Kind_If_Generate_Statement - | Iir_Kind_If_Generate_Else_Clause => - Translate_If_Generate_Block_Configuration_Calls - (El, Base_Info); - when Iir_Kind_For_Generate_Statement => - Translate_For_Generate_Block_Configuration_Calls - (El, Base_Info); - when others => - Error_Kind - ("translate_block_configuration_calls(3)", - Get_Parent (Block)); - end case; - when others => - Error_Kind - ("translate_block_configuration_calls(4)", Block); - end case; - end; + Translate_Block_Block_Configuration_Calls (El); when others => Error_Kind ("translate_block_configuration_calls(2)", El); end case; diff --git a/src/vhdl/translate/trans-chap3.adb b/src/vhdl/translate/trans-chap3.adb index a01c4c088..e39d42ed6 100644 --- a/src/vhdl/translate/trans-chap3.adb +++ b/src/vhdl/translate/trans-chap3.adb @@ -306,8 +306,7 @@ package body Trans.Chap3 is end if; end Get_Type_Precision; - procedure Translate_Integer_Type - (Def : Iir_Integer_Type_Definition) + procedure Translate_Integer_Type (Def : Iir_Integer_Type_Definition) is Info : Type_Info_Acc; begin @@ -2284,9 +2283,8 @@ package body Trans.Chap3 is function Range_To_Dir (R : Mnode) return Mnode is - Tinfo : Type_Info_Acc; + Tinfo : constant Type_Info_Acc := Get_Type_Info (R); begin - Tinfo := Get_Type_Info (R); return Lv2M (New_Selected_Element (M2Lv (R), Tinfo.T.Range_Dir), Tinfo, diff --git a/src/vhdl/translate/trans-chap7.adb b/src/vhdl/translate/trans-chap7.adb index 6b375d71c..8706dd3b3 100644 --- a/src/vhdl/translate/trans-chap7.adb +++ b/src/vhdl/translate/trans-chap7.adb @@ -4292,7 +4292,7 @@ package body Trans.Chap7 is | Iir_Kind_Range_Expression => Translate_Range (Res, Arange, Get_Type (Arange)); when others => - Error_Kind ("translate_discrete_range_ptr", Arange); + Error_Kind ("translate_discrete_range", Arange); end case; end Translate_Discrete_Range; diff --git a/src/vhdl/translate/trans-chap8.adb b/src/vhdl/translate/trans-chap8.adb index c2dbf4ed7..c8f270174 100644 --- a/src/vhdl/translate/trans-chap8.adb +++ b/src/vhdl/translate/trans-chap8.adb @@ -1158,8 +1158,7 @@ package body Trans.Chap8 is if not Get_Same_Alternative_Flag (Choice) then Choice_State := Choice_State + 1; State_Start (Choice_State); - Translate_Statements_Chain - (Get_Associated_Chain (Choice)); + Translate_Statements_Chain (Get_Associated_Chain (Choice)); State_Jump (Next_State); end if; Choice := Get_Chain (Choice); diff --git a/src/vhdl/translate/trans-chap9.adb b/src/vhdl/translate/trans-chap9.adb index 9500bbd88..9b453bf4c 100644 --- a/src/vhdl/translate/trans-chap9.adb +++ b/src/vhdl/translate/trans-chap9.adb @@ -662,55 +662,94 @@ package body Trans.Chap9 is end case; end Translate_Psl_Directive_Statement; - procedure Translate_If_Generate_Statement (Stmt : Iir; Origin : Iir) + procedure Translate_If_Case_Generate_Statement_Body + (Bod : Iir; Num : Int32; Origin : Iir) is - Clause : Iir; - Bod : Iir; Info : Block_Info_Acc; - Stmt_Info : Ortho_Info_Acc; - Mark : Id_Mark_Type; Mark2 : Id_Mark_Type; - Num : Int32; begin - Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Info := Add_Info (Bod, Kind_Block); + + Push_Identifier_Prefix (Mark2, Get_Alternative_Label (Bod)); + Chap1.Start_Block_Decl (Bod); + Push_Instance_Factory (Info.Block_Scope'Access); + + -- Add a parent field in the current instance. + Info.Block_Origin_Field := Add_Instance_Factory_Field + (Get_Identifier ("ORIGIN"), + Get_Info (Origin).Block_Decls_Ptr_Type); + + Info.Block_Id := Num; + + Chap9.Translate_Block_Declarations (Bod, Bod); + + Pop_Instance_Factory (Info.Block_Scope'Access); + + Pop_Identifier_Prefix (Mark2); + end Translate_If_Case_Generate_Statement_Body; + + procedure Translate_If_Case_Generate_Statement (Stmt : Iir) + is + Stmt_Info : Ortho_Info_Acc; + begin Stmt_Info := Add_Info (Stmt, Kind_Generate); Stmt_Info.Generate_Parent_Field := Add_Instance_Factory_Field (Create_Identifier_Without_Prefix (Stmt), Ghdl_Ptr_Type); Stmt_Info.Generate_Body_Id := Add_Instance_Factory_Field (Create_Identifier_Without_Prefix (Get_Identifier (Stmt), "_ID"), Ghdl_Index_Type); + end Translate_If_Case_Generate_Statement; + + procedure Translate_If_Generate_Statement (Stmt : Iir; Origin : Iir) + is + Clause : Iir; + Bod : Iir; + Mark : Id_Mark_Type; + Num : Int32; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + + Translate_If_Case_Generate_Statement (Stmt); -- Translate generate statement body. Num := 0; Clause := Stmt; while Clause /= Null_Iir loop Bod := Get_Generate_Statement_Body (Clause); - Info := Add_Info (Bod, Kind_Block); - - Push_Identifier_Prefix (Mark2, Get_Alternative_Label (Bod)); - - Chap1.Start_Block_Decl (Bod); - Push_Instance_Factory (Info.Block_Scope'Access); - - -- Add a parent field in the current instance. - Info.Block_Origin_Field := Add_Instance_Factory_Field - (Get_Identifier ("ORIGIN"), - Get_Info (Origin).Block_Decls_Ptr_Type); + Translate_If_Case_Generate_Statement_Body (Bod, Num, Origin); + Clause := Get_Generate_Else_Clause (Clause); + Num := Num + 1; + end loop; - Info.Block_Id := Num; + Pop_Identifier_Prefix (Mark); + end Translate_If_Generate_Statement; - Chap9.Translate_Block_Declarations (Bod, Bod); + procedure Translate_Case_Generate_Statement (Stmt : Iir; Origin : Iir) + is + Alt : Iir; + Bod : Iir; + Mark : Id_Mark_Type; + Num : Int32; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); - Pop_Instance_Factory (Info.Block_Scope'Access); + Translate_If_Case_Generate_Statement (Stmt); - Pop_Identifier_Prefix (Mark2); - Clause := Get_Generate_Else_Clause (Clause); - Num := Num + 1; + -- Translate generate statement body. + Num := 0; + Alt := Get_Case_Statement_Alternative_Chain (Stmt); + while Alt /= Null_Iir loop + if not Get_Same_Alternative_Flag (Alt) then + Bod := Get_Associated_Block (Alt); + Translate_If_Case_Generate_Statement_Body (Bod, Num, Origin); + Num := Num + 1; + end if; + Alt := Get_Chain (Alt); end loop; Pop_Identifier_Prefix (Mark); - end Translate_If_Generate_Statement; + end Translate_Case_Generate_Statement; procedure Translate_For_Generate_Statement (Stmt : Iir; Origin : Iir) is @@ -835,6 +874,8 @@ package body Trans.Chap9 is Translate_For_Generate_Statement (El, Origin); when Iir_Kind_If_Generate_Statement => Translate_If_Generate_Statement (El, Origin); + when Iir_Kind_Case_Generate_Statement => + Translate_Case_Generate_Statement (El, Origin); when others => Error_Kind ("translate_block_declarations", El); end case; @@ -1012,6 +1053,25 @@ package body Trans.Chap9 is Clause := Get_Generate_Else_Clause (Clause); end loop; end; + when Iir_Kind_Case_Generate_Statement => + declare + Alt : Iir; + Bod : Iir; + Mark2 : Id_Mark_Type; + begin + Alt := Get_Case_Statement_Alternative_Chain (Stmt); + while Alt /= Null_Iir loop + if not Get_Same_Alternative_Flag (Alt) then + Bod := Get_Associated_Block (Alt); + Push_Identifier_Prefix + (Mark2, Get_Alternative_Label (Bod)); + Translate_Generate_Statement_Body_Subprograms + (Bod, Base_Info); + Pop_Identifier_Prefix (Mark2); + end if; + Alt := Get_Chain (Alt); + end loop; + end; when others => Error_Kind ("translate_block_subprograms", Stmt); end case; @@ -1687,15 +1747,18 @@ package body Trans.Chap9 is end; end Translate_Entity_Instantiation; - procedure Elab_Decl_If_Generate_Statement - (Stmt : Iir_Generate_Statement; Parent : Iir; Base_Block : Iir) + procedure Elab_Decl_If_Case_Generate_Statement + (Stmt : Iir; Parent : Iir; Base_Block : Iir) is + Kind : constant Iir_Kinds_If_Case_Generate_Statement := Get_Kind (Stmt); Parent_Info : constant Block_Info_Acc := Get_Info (Parent); -- Used to get Block_Parent_Field, set in the first generate statement -- body. Stmt_Info : constant Generate_Info_Acc := Get_Info (Stmt); + Label : O_Snode; + -- Set the instance field in the parent. procedure Set_Parent_Field (Val : O_Enode; Num : Nat32) is @@ -1710,21 +1773,13 @@ package body Trans.Chap9 is New_Assign_Stmt (V, New_Lit (New_Index_Lit (Unsigned_64 (Num)))); end Set_Parent_Field; - procedure Elab_If_Clause (Clause : Iir) + procedure Elab_Decl_If_Case_Generate_Body (Bod : Iir) is - Condition : constant Iir := Get_Condition (Clause); - Bod : constant Iir := Get_Generate_Statement_Body (Clause); Info : constant Block_Info_Acc := Get_Info (Bod); Var : O_Dnode; - Blk : O_If_Block; - N_Clause : Iir; begin - Open_Temp; - Var := Create_Temp (Info.Block_Decls_Ptr_Type); - if Condition /= Null_Iir then - Start_If_Stmt (Blk, Chap7.Translate_Expression (Condition)); - end if; + New_Assign_Stmt (New_Obj (Var), Gen_Alloc (Alloc_System, @@ -1741,31 +1796,186 @@ package body Trans.Chap9 is New_Assign_Stmt (New_Selected_Acc_Value (New_Obj (Var), Info.Block_Origin_Field), Get_Instance_Access (Base_Block)); - -- Elaborate block + -- Elaborate block Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); Elab_Block_Declarations (Bod, Bod); Clear_Scope (Info.Block_Scope); - - if Condition /= Null_Iir then - New_Else_Stmt (Blk); - N_Clause := Get_Generate_Else_Clause (Clause); - if N_Clause /= Null_Iir then - Elab_If_Clause (N_Clause); - else - Set_Parent_Field - (New_Lit (New_Null_Access (Ghdl_Ptr_Type)), - Info.Block_Id + 1); - end if; - Finish_If_Stmt (Blk); - end if; - Close_Temp; - end Elab_If_Clause; + end Elab_Decl_If_Case_Generate_Body; begin - Elab_If_Clause (Stmt); - end Elab_Decl_If_Generate_Statement; + Start_Loop_Stmt (Label); - procedure Elab_Stmt_If_Generate_Statement - (Stmt : Iir_Generate_Statement; Parent : Iir) + case Kind is + when Iir_Kind_If_Generate_Statement => + declare + Clause : Iir; + Condition : Iir; + Blk : O_If_Block; + Num : Nat32; + begin + Clause := Stmt; + Num := 0; + loop + Condition := Get_Condition (Clause); + Open_Temp; + + if Condition /= Null_Iir then + Start_If_Stmt + (Blk, Chap7.Translate_Expression (Condition)); + end if; + + Open_Temp; + Elab_Decl_If_Case_Generate_Body + (Get_Generate_Statement_Body (Clause)); + Close_Temp; + + Num := Num + 1; + + New_Exit_Stmt (Label); + + if Condition /= Null_Iir then + Finish_If_Stmt (Blk); + end if; + + Close_Temp; + + exit when Condition = Null_Iir; + + Clause := Get_Generate_Else_Clause (Clause); + if Clause = Null_Iir then + -- No block. + Set_Parent_Field + (New_Lit (New_Null_Access (Ghdl_Ptr_Type)), Num); + New_Exit_Stmt (Label); + exit; + end if; + end loop; + end; + when Iir_Kind_Case_Generate_Statement => + -- FIXME: handle one-dimensional expressions. + declare + Expr : constant Iir := Get_Expression (Stmt); + Expr_Type : constant Iir := Get_Type (Expr); + Base_Type : constant Iir := Get_Base_Type (Expr_Type); + Tinfo : constant Type_Info_Acc := Get_Info (Base_Type); + E : O_Dnode; + Alt : Iir; + Cur_Alt : Iir; + Cond : O_Enode; + Sub_Cond : O_Enode; + Var_Rng : O_Dnode; + Rng : Mnode; + C1, C2 : O_Enode; + Blk : O_If_Block; + begin + Open_Temp; + Alt := Get_Case_Statement_Alternative_Chain (Stmt); + E := Create_Temp_Init + (Tinfo.Ortho_Type (Mode_Value), + Chap7.Translate_Expression (Expr, Base_Type)); + + loop + Open_Temp; + + Cur_Alt := Alt; + Cond := O_Enode_Null; + loop + case Get_Kind (Alt) is + when Iir_Kind_Choice_By_Others => + pragma Assert (Cond = O_Enode_Null); + pragma Assert (Get_Chain (Alt) = Null_Iir); + Sub_Cond := O_Enode_Null; + when Iir_Kind_Choice_By_Expression => + Sub_Cond := New_Compare_Op + (ON_Eq, + New_Obj_Value (E), + Chap7.Translate_Expression + (Get_Choice_Expression (Alt), Base_Type), + Ghdl_Bool_Type); + when Iir_Kind_Choice_By_Range => + Var_Rng := Create_Temp (Tinfo.T.Range_Type); + Rng := Dv2M (Var_Rng, Tinfo, Mode_Value, + Tinfo.T.Range_Type, + Tinfo.T.Range_Ptr_Type); + Chap7.Translate_Discrete_Range + (Rng, Get_Choice_Range (Alt)); + C1 := New_Dyadic_Op + (ON_And, + New_Compare_Op + (ON_Eq, + M2E (Chap3.Range_To_Dir (Rng)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type), + New_Dyadic_Op + (ON_And, + New_Compare_Op + (ON_Ge, + New_Obj_Value (E), + M2E (Chap3.Range_To_Left (Rng)), + Ghdl_Bool_Type), + New_Compare_Op + (ON_Le, + New_Obj_Value (E), + M2E (Chap3.Range_To_Right (Rng)), + Ghdl_Bool_Type))); + C2 := New_Dyadic_Op + (ON_And, + New_Compare_Op + (ON_Eq, + M2E (Chap3.Range_To_Dir (Rng)), + New_Lit (Ghdl_Dir_Downto_Node), + Ghdl_Bool_Type), + New_Dyadic_Op + (ON_And, + New_Compare_Op + (ON_Le, + New_Obj_Value (E), + M2E (Chap3.Range_To_Left (Rng)), + Ghdl_Bool_Type), + New_Compare_Op + (ON_Ge, + New_Obj_Value (E), + M2E (Chap3.Range_To_Right (Rng)), + Ghdl_Bool_Type))); + Sub_Cond := New_Dyadic_Op (ON_Or, C1, C2); + when others => + Error_Kind + ("Elab_Decl_If_Case_Generate_Statement", Alt); + end case; + if Cond = O_Enode_Null then + Cond := Sub_Cond; + else + Cond := New_Dyadic_Op (ON_Or, Cond, Sub_Cond); + end if; + Alt := Get_Chain (Alt); + exit when Alt = Null_Iir; + exit when not Get_Same_Alternative_Flag (Alt); + end loop; + + if Cond /= O_Enode_Null then + Start_If_Stmt (Blk, Cond); + end if; + + Open_Temp; + Elab_Decl_If_Case_Generate_Body + (Get_Associated_Block (Cur_Alt)); + Close_Temp; + + New_Exit_Stmt (Label); + + if Cond /= O_Enode_Null then + Finish_If_Stmt (Blk); + end if; + + Close_Temp; + exit when Alt = Null_Iir; + end loop; + Close_Temp; + end; + end case; + Finish_Loop_Stmt (Label); + end Elab_Decl_If_Case_Generate_Statement; + + procedure Elab_Stmt_If_Case_Generate_Statement (Stmt : Iir; Parent : Iir) is Parent_Info : constant Block_Info_Acc := Get_Info (Parent); @@ -1774,46 +1984,68 @@ package body Trans.Chap9 is Stmt_Info : constant Generate_Info_Acc := Get_Info (Stmt); Case_Blk : O_Case_Block; - Clause : Iir; - Var : O_Dnode; + + procedure Elab_Stmt_If_Case_Generate_Statement_Body (Bod : Iir) + is + Info : constant Block_Info_Acc := Get_Info (Bod); + Var : O_Dnode; + begin + Start_Choice (Case_Blk); + New_Expr_Choice + (Case_Blk, New_Index_Lit (Unsigned_64 (Info.Block_Id))); + Finish_Choice (Case_Blk); + + Open_Temp; + Var := Create_Temp_Init + (Info.Block_Decls_Ptr_Type, + New_Convert_Ov + (New_Value (New_Selected_Element + (Get_Instance_Ref (Parent_Info.Block_Scope), + Stmt_Info.Generate_Parent_Field)), + Info.Block_Decls_Ptr_Type)); + + Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); + Elab_Block_Statements (Bod, Bod); + Clear_Scope (Info.Block_Scope); + Close_Temp; + end Elab_Stmt_If_Case_Generate_Statement_Body; begin Start_Case_Stmt (Case_Blk, New_Value (New_Selected_Element (Get_Instance_Ref (Parent_Info.Block_Scope), Stmt_Info.Generate_Body_Id))); - Clause := Stmt; - while Clause /= Null_Iir loop - declare - Bod : constant Iir := Get_Generate_Statement_Body (Clause); - Info : constant Block_Info_Acc := Get_Info (Bod); - begin - Start_Choice (Case_Blk); - New_Expr_Choice - (Case_Blk, New_Index_Lit (Unsigned_64 (Info.Block_Id))); - Finish_Choice (Case_Blk); - - Open_Temp; - Var := Create_Temp_Init - (Info.Block_Decls_Ptr_Type, - New_Convert_Ov - (New_Value (New_Selected_Element - (Get_Instance_Ref (Parent_Info.Block_Scope), - Stmt_Info.Generate_Parent_Field)), - Info.Block_Decls_Ptr_Type)); - - Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); - Elab_Block_Statements (Bod, Bod); - Clear_Scope (Info.Block_Scope); - Close_Temp; - end; - Clause := Get_Generate_Else_Clause (Clause); - end loop; + case Iir_Kinds_If_Case_Generate_Statement (Get_Kind (Stmt)) is + when Iir_Kind_If_Generate_Statement => + declare + Clause : Iir; + begin + Clause := Stmt; + while Clause /= Null_Iir loop + Elab_Stmt_If_Case_Generate_Statement_Body + (Get_Generate_Statement_Body (Clause)); + Clause := Get_Generate_Else_Clause (Clause); + end loop; + end; + when Iir_Kind_Case_Generate_Statement => + declare + Alt : Iir; + begin + Alt := Get_Case_Statement_Alternative_Chain (Stmt); + while Alt /= Null_Iir loop + if not Get_Same_Alternative_Flag (Alt) then + Elab_Stmt_If_Case_Generate_Statement_Body + (Get_Associated_Block (Alt)); + end if; + Alt := Get_Chain (Alt); + end loop; + end; + end case; Start_Choice (Case_Blk); New_Default_Choice (Case_Blk); Finish_Choice (Case_Blk); Finish_Case_Stmt (Case_Blk); - end Elab_Stmt_If_Generate_Statement; + end Elab_Stmt_If_Case_Generate_Statement; procedure Elab_Decl_For_Generate_Statement (Stmt : Iir_Generate_Statement; Parent : Iir; Base_Block : Iir) @@ -2266,12 +2498,14 @@ package body Trans.Chap9 is Elab_Block_Declarations (Stmt, Base_Block); Pop_Identifier_Prefix (Mark); end; - when Iir_Kind_If_Generate_Statement => + when Iir_Kind_If_Generate_Statement + | Iir_Kind_Case_Generate_Statement => declare Mark : Id_Mark_Type; begin Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); - Elab_Decl_If_Generate_Statement (Stmt, Block, Base_Block); + Elab_Decl_If_Case_Generate_Statement + (Stmt, Block, Base_Block); Pop_Identifier_Prefix (Mark); end; when Iir_Kind_For_Generate_Statement => @@ -2318,12 +2552,13 @@ package body Trans.Chap9 is Elab_Block_Statements (Stmt, Base_Block); Pop_Identifier_Prefix (Mark); end; - when Iir_Kind_If_Generate_Statement => + when Iir_Kind_If_Generate_Statement + | Iir_Kind_Case_Generate_Statement => declare Mark : Id_Mark_Type; begin Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); - Elab_Stmt_If_Generate_Statement (Stmt, Block); + Elab_Stmt_If_Case_Generate_Statement (Stmt, Block); Pop_Identifier_Prefix (Mark); end; when Iir_Kind_For_Generate_Statement => diff --git a/src/vhdl/translate/trans-rtis.adb b/src/vhdl/translate/trans-rtis.adb index 8dd86b282..297edaf8c 100644 --- a/src/vhdl/translate/trans-rtis.adb +++ b/src/vhdl/translate/trans-rtis.adb @@ -190,6 +190,9 @@ package body Trans.Rtis is (Constr, Get_Identifier ("__ghdl_rtik_if_generate"), Ghdl_Rtik_If_Generate); New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_case_generate"), + Ghdl_Rtik_Case_Generate); + New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_for_generate"), Ghdl_Rtik_For_Generate); New_Enum_Literal @@ -2032,7 +2035,8 @@ package body Trans.Rtis is end Generate_Psl_Directive; procedure Generate_Block (Blk : Iir; Parent_Rti : O_Dnode); - procedure Generate_If_Generate_Statement (Blk : Iir; Parent_Rti : O_Dnode); + procedure Generate_If_Case_Generate_Statement + (Blk : Iir; Parent_Rti : O_Dnode); procedure Generate_For_Generate_Statement (Blk : Iir; Parent_Rti : O_Dnode); procedure Generate_Declaration_Chain (Chain : Iir); @@ -2305,9 +2309,10 @@ package body Trans.Rtis is Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); Generate_Block (Stmt, Parent_Rti); Pop_Identifier_Prefix (Mark); - when Iir_Kind_If_Generate_Statement => + when Iir_Kind_If_Generate_Statement + | Iir_Kind_Case_Generate_Statement => Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); - Generate_If_Generate_Statement (Stmt, Parent_Rti); + Generate_If_Case_Generate_Statement (Stmt, Parent_Rti); Pop_Identifier_Prefix (Mark); when Iir_Kind_For_Generate_Statement => Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); @@ -2350,10 +2355,10 @@ package body Trans.Rtis is end loop; end Generate_Concurrent_Statement_Chain; - procedure Generate_If_Generate_Statement (Blk : Iir; Parent_Rti : O_Dnode) + procedure Generate_If_Case_Generate_Statement + (Blk : Iir; Parent_Rti : O_Dnode) is Info : constant Generate_Info_Acc := Get_Info (Blk); - Clause : Iir; Bod : Iir; Name : O_Dnode; @@ -2361,6 +2366,7 @@ package body Trans.Rtis is Num : Natural; Rti : O_Dnode; + Rtik : O_Cnode; Arr : O_Dnode; Prev : Rti_Block; @@ -2374,16 +2380,43 @@ package body Trans.Rtis is O_Storage_Public, Ghdl_Rtin_Block); Push_Rti_Node (Prev); - Clause := Blk; Num := 0; - while Clause /= Null_Iir loop - Bod := Get_Generate_Statement_Body (Clause); - Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); - Generate_Block (Bod, Rti); - Pop_Identifier_Prefix (Mark); - Clause := Get_Generate_Else_Clause (Clause); - Num := Num + 1; - end loop; + case Get_Kind (Blk) is + when Iir_Kind_If_Generate_Statement => + declare + Clause : Iir; + begin + Clause := Blk; + while Clause /= Null_Iir loop + Bod := Get_Generate_Statement_Body (Clause); + Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); + Generate_Block (Bod, Rti); + Pop_Identifier_Prefix (Mark); + Clause := Get_Generate_Else_Clause (Clause); + Num := Num + 1; + end loop; + Rtik := Ghdl_Rtik_If_Generate; + end; + when Iir_Kind_Case_Generate_Statement => + declare + Alt : Iir; + begin + Alt := Get_Case_Statement_Alternative_Chain (Blk); + while Alt /= Null_Iir loop + if not Get_Same_Alternative_Flag (Alt) then + Bod := Get_Associated_Block (Alt); + Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); + Generate_Block (Bod, Rti); + Pop_Identifier_Prefix (Mark); + Num := Num + 1; + end if; + Alt := Get_Chain (Alt); + end loop; + Rtik := Ghdl_Rtik_Case_Generate; + end; + when others => + raise Internal_Error; + end case; Name := Generate_Name (Blk); @@ -2392,7 +2425,7 @@ package body Trans.Rtis is Start_Init_Value (Rti); Start_Record_Aggr (List, Ghdl_Rtin_Block); - New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_If_Generate)); + New_Record_Aggr_El (List, Generate_Common (Rtik)); New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); -- Field Loc: offset in the instance of the entity. @@ -2421,7 +2454,7 @@ package body Trans.Rtis is -- Store the RTI. Info.Generate_Rti_Const := Rti; - end Generate_If_Generate_Statement; + end Generate_If_Case_Generate_Statement; procedure Generate_For_Generate_Statement (Blk : Iir; Parent_Rti : O_Dnode) is diff --git a/src/vhdl/translate/trans-rtis.ads b/src/vhdl/translate/trans-rtis.ads index a1b5b456b..8f51957f3 100644 --- a/src/vhdl/translate/trans-rtis.ads +++ b/src/vhdl/translate/trans-rtis.ads @@ -28,6 +28,7 @@ package Trans.Rtis is Ghdl_Rtik_Process : O_Cnode; Ghdl_Rtik_Block : O_Cnode; Ghdl_Rtik_If_Generate : O_Cnode; + Ghdl_Rtik_Case_Generate : O_Cnode; Ghdl_Rtik_For_Generate : O_Cnode; Ghdl_Rtik_Generate_Body : O_Cnode; Ghdl_Rtik_Instance : O_Cnode; diff --git a/testsuite/gna/issue106/case1.vhdl b/testsuite/gna/issue106/case1.vhdl new file mode 100644 index 000000000..082612807 --- /dev/null +++ b/testsuite/gna/issue106/case1.vhdl @@ -0,0 +1,29 @@ +library ieee; +use ieee.std_logic_1164.all; +use ieee.numeric_std.all; + +entity ent is +end entity ent; + +architecture arch of ent is + signal test: natural; + constant e : natural := 3; +begin + LL: case e generate + when 0 => + when 1 to 4 => + test <= 1; + when l5: 5 | 7=> + test <= 2; + when others => + end generate ll; + + process + begin + wait for 0 ns; + assert test = 2; + wait; + end process; +end architecture arch; + + diff --git a/testsuite/gna/issue106/testsuite.sh b/testsuite/gna/issue106/testsuite.sh index 011b30fc0..c01c6cf35 100755 --- a/testsuite/gna/issue106/testsuite.sh +++ b/testsuite/gna/issue106/testsuite.sh @@ -12,6 +12,9 @@ elab_simulate ent analyze ent2.vhdl elab_simulate ent +analyze case1.vhdl +elab_simulate ent + clean echo "Test successful" |