diff options
| author | Tristan Gingold <tgingold@free.fr> | 2014-07-17 20:34:57 +0200 |
|---|---|---|
| committer | Tristan Gingold <tgingold@free.fr> | 2014-07-17 20:34:57 +0200 |
| commit | caba1d1b21d9756ede50f40d53fbc816d3b84320 (patch) | |
| tree | ee0b8459472a8e7aba4ab7465bc46c74be56cd33 | |
| parent | 1bc00453a725214de4964add2b7f8423d1a5d2da (diff) | |
| download | ghdl-caba1d1b21d9756ede50f40d53fbc816d3b84320.tar.gz ghdl-caba1d1b21d9756ede50f40d53fbc816d3b84320.tar.bz2 ghdl-caba1d1b21d9756ede50f40d53fbc816d3b84320.zip | |
vhdl 2008: visibility, more implicit subprograms, alias...
Use Type_Definition in type_declarator.
42 files changed, 1406 insertions, 543 deletions
@@ -2237,7 +2237,7 @@ package body Canon is declare Def : Iir; begin - Def := Get_Type (Decl); + Def := Get_Type_Definition (Decl); if Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration then Canon_Declarations (Decl, Def, Null_Iir); end if; @@ -2617,6 +2617,14 @@ package body Canon is when Iir_Kind_Configuration_Declaration => Canon_Declarations (Unit, El, Null_Iir); Canon_Block_Configuration (Unit, Get_Block_Configuration (El)); + when Iir_Kind_Package_Instantiation_Declaration => + Set_Generic_Map_Aspect_Chain + (El, + Canon_Association_Chain_And_Actuals + (Get_Generic_Chain + (Get_Package_Header + (Get_Named_Entity (Get_Uninstantiated_Name (El)))), + Get_Generic_Map_Aspect_Chain (El), El)); when others => Error_Kind ("canonicalize2", El); end case; diff --git a/disp_tree.adb b/disp_tree.adb index a14030bf7..c02951977 100644 --- a/disp_tree.adb +++ b/disp_tree.adb @@ -1009,21 +1009,28 @@ package body Disp_Tree is Disp_Tree (Get_File_Open_Kind (Tree), Ntab); Header ("attribute_value_chain:"); Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration => + when Iir_Kind_Type_Declaration => if Flat_Decl then return; end if; Header ("type (definition):"); - Disp_Tree (Get_Type (Tree), Ntab); + Disp_Tree (Get_Type_Definition (Tree), Ntab); Header ("attribute_value_chain:"); Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); when Iir_Kind_Anonymous_Type_Declaration => if Flat_Decl then return; end if; - Header ("type (definition):"); + Header ("type definition:"); + Disp_Tree (Get_Type_Definition (Tree), Ntab); + when Iir_Kind_Subtype_Declaration => + if Flat_Decl then + return; + end if; + Header ("subtype indication:"); Disp_Tree (Get_Type (Tree), Ntab); + Header ("attribute_value_chain:"); + Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); when Iir_Kind_Nature_Declaration | Iir_Kind_Subnature_Declaration => if Flat_Decl then diff --git a/disp_vhdl.adb b/disp_vhdl.adb index 0b4627a44..94aba076b 100644 --- a/disp_vhdl.adb +++ b/disp_vhdl.adb @@ -613,36 +613,36 @@ package body Disp_Vhdl is -- Display the full definition of a type, ie the sequence that can create -- such a type. - procedure Disp_Type_Definition (Decl: in Iir; Indent: Count) is + procedure Disp_Type_Definition (Def: Iir; Indent: Count) is begin - case Get_Kind (Decl) is + case Get_Kind (Def) is when Iir_Kind_Enumeration_Type_Definition => - Disp_Enumeration_Type_Definition (Decl); + Disp_Enumeration_Type_Definition (Def); when Iir_Kind_Enumeration_Subtype_Definition => - Disp_Enumeration_Subtype_Definition (Decl); + Disp_Enumeration_Subtype_Definition (Def); when Iir_Kind_Integer_Subtype_Definition => - Disp_Integer_Subtype_Definition (Decl); + Disp_Integer_Subtype_Definition (Def); when Iir_Kind_Floating_Subtype_Definition => - Disp_Floating_Subtype_Definition (Decl); + Disp_Floating_Subtype_Definition (Def); when Iir_Kind_Array_Type_Definition => - Disp_Array_Type_Definition (Decl); + Disp_Array_Type_Definition (Def); when Iir_Kind_Array_Subtype_Definition => - Disp_Array_Subtype_Definition (Decl); + Disp_Array_Subtype_Definition (Def); when Iir_Kind_Physical_Subtype_Definition => - Disp_Physical_Subtype_Definition (Decl, Indent); + Disp_Physical_Subtype_Definition (Def, Indent); when Iir_Kind_Record_Type_Definition => - Disp_Record_Type_Definition (Decl, Indent); + Disp_Record_Type_Definition (Def, Indent); when Iir_Kind_Access_Type_Definition => Put ("access "); - Disp_Subtype_Indication (Get_Designated_Type (Decl)); + Disp_Subtype_Indication (Get_Designated_Type (Def)); Put (';'); when Iir_Kind_File_Type_Definition => Put ("file of "); - Disp_Subtype_Indication (Get_Type_Mark (Decl)); + Disp_Subtype_Indication (Get_Type_Mark (Def)); Put (';'); when Iir_Kind_Protected_Type_Declaration => Put_Line ("protected"); - Disp_Declaration_Chain (Decl, Indent + Indentation); + Disp_Declaration_Chain (Def, Indent + Indentation); Set_Col (Indent); Put ("end protected;"); when Iir_Kind_Integer_Type_Definition => @@ -652,7 +652,7 @@ package body Disp_Vhdl is when Iir_Kind_Physical_Type_Definition => Put ("<physical base type>"); when others => - Error_Kind ("disp_type_definition", Decl); + Error_Kind ("disp_type_definition", Def); end case; end Disp_Type_Definition; @@ -664,7 +664,7 @@ package body Disp_Vhdl is Indent := Col; Put ("type "); Disp_Name_Of (Decl); - Def := Get_Type (Decl); + Def := Get_Type_Definition (Decl); if Def = Null_Iir or else Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then @@ -686,7 +686,7 @@ package body Disp_Vhdl is Put ("-- type "); Disp_Name_Of (Decl); Put (" is "); - Def := Get_Type (Decl); + Def := Get_Type_Definition (Decl); Disp_Type_Definition (Def, Indent); if Get_Kind (Def) = Iir_Kind_Physical_Type_Definition then declare diff --git a/evaluation.adb b/evaluation.adb index 61ec39f12..1815c2b7c 100644 --- a/evaluation.adb +++ b/evaluation.adb @@ -1221,7 +1221,7 @@ package body Evaluation is | Iir_Predefined_Attribute_Last_Active | Iir_Predefined_Attribute_Driving | Iir_Predefined_Attribute_Driving_Value - | Iir_Predefined_Array_To_String + | Iir_Predefined_Array_Char_To_String | Iir_Predefined_Bit_Vector_To_Ostring | Iir_Predefined_Bit_Vector_To_Hstring => -- Not binary or never locally static. @@ -1981,11 +1981,11 @@ package body Evaluation is when Iir_Kind_Pred_Attribute => Res := Eval_Incdec (Eval_Static_Expr (Get_Parameter (Expr)), -1); - Eval_Check_Bound (Res, Get_Type (Get_Prefix (Expr))); + Eval_Check_Bound (Res, Get_Type_Of_Type_Mark (Get_Prefix (Expr))); return Res; when Iir_Kind_Succ_Attribute => Res := Eval_Incdec (Eval_Static_Expr (Get_Parameter (Expr)), +1); - Eval_Check_Bound (Res, Get_Type (Get_Prefix (Expr))); + Eval_Check_Bound (Res, Get_Type_Of_Type_Mark (Get_Prefix (Expr))); return Res; when Iir_Kind_Leftof_Attribute | Iir_Kind_Rightof_Attribute => @@ -1995,7 +1995,7 @@ package body Evaluation is Prefix_Type : Iir; Res : Iir; begin - Prefix_Type := Get_Type (Get_Prefix (Expr)); + Prefix_Type := Get_Type_Of_Type_Mark (Get_Prefix (Expr)); Rng := Eval_Range (Prefix_Type); case Get_Direction (Rng) is when Iir_To => @@ -2426,9 +2426,10 @@ package body Evaluation is Natural (Eval_Pos (Get_Parameter (Expr))) - 1); end; when Iir_Kind_Subtype_Declaration - | Iir_Kind_Type_Declaration | Iir_Kind_Base_Attribute => return Eval_Range (Get_Type (Expr)); + when Iir_Kind_Type_Declaration => + return Eval_Range (Get_Type_Definition (Expr)); when others => Error_Kind ("eval_range", Expr); end case; diff --git a/ieee-std_logic_1164.adb b/ieee-std_logic_1164.adb index 8ecd1acee..4accb0a3f 100644 --- a/ieee-std_logic_1164.adb +++ b/ieee-std_logic_1164.adb @@ -19,6 +19,7 @@ with Types; use Types; with Std_Names; use Std_Names; with Errorout; use Errorout; with Std_Package; +with Iirs_Utils; use Iirs_Utils; package body Ieee.Std_Logic_1164 is function Skip_Implicit (Decl : Iir) return Iir @@ -62,7 +63,7 @@ package body Ieee.Std_Logic_1164 is raise Error; end if; - Def := Get_Type (Decl); + Def := Get_Type_Definition (Decl); if Get_Kind (Def) /= Iir_Kind_Enumeration_Type_Definition then raise Error; end if; @@ -77,7 +78,7 @@ package body Ieee.Std_Logic_1164 is then raise Error; end if; - Def := Get_Type (Decl); + Def := Get_Type_Definition (Decl); if Get_Kind (Def) /= Iir_Kind_Array_Type_Definition then raise Error; end if; @@ -119,7 +120,7 @@ package body Ieee.Std_Logic_1164 is then raise Error; end if; - Def := Get_Type (Decl); + Def := Get_Type_Of_Type_Mark (Decl); -- if Get_Kind (Def) /= Iir_Kind_Array_Type_Definition then -- raise Error; -- end if; diff --git a/ieee-vital_timing.adb b/ieee-vital_timing.adb index 07a579d5e..72053ebaf 100644 --- a/ieee-vital_timing.adb +++ b/ieee-vital_timing.adb @@ -121,22 +121,22 @@ package body Ieee.Vital_Timing is when Iir_Kind_Type_Declaration => Id := Get_Identifier (Decl); if Id = VitalDelayArrayType_Id then - VitalDelayArrayType := Get_Type (Decl); + VitalDelayArrayType := Get_Type_Definition (Decl); elsif Id = VitalDelayArrayType01_Id then - VitalDelayArrayType01 := Get_Type (Decl); + VitalDelayArrayType01 := Get_Type_Definition (Decl); elsif Id = VitalDelayArrayType01Z_Id then - VitalDelayArrayType01Z := Get_Type (Decl); + VitalDelayArrayType01Z := Get_Type_Definition (Decl); elsif Id = VitalDelayArrayType01ZX_Id then - VitalDelayArrayType01ZX := Get_Type (Decl); + VitalDelayArrayType01ZX := Get_Type_Definition (Decl); end if; when Iir_Kind_Anonymous_Type_Declaration => Id := Get_Identifier (Decl); if Id = VitalDelayType01_Id then - VitalDelayType01 := Get_Type (Decl); + VitalDelayType01 := Get_Type_Definition (Decl); elsif Id = VitalDelayType01Z_Id then - VitalDelayType01Z := Get_Type (Decl); + VitalDelayType01Z := Get_Type_Definition (Decl); elsif Id = VitalDelayType01ZX_Id then - VitalDelayType01ZX := Get_Type (Decl); + VitalDelayType01ZX := Get_Type_Definition (Decl); end if; when others => null; @@ -525,11 +525,11 @@ package body Iirs is | Iir_Kind_Free_Quantity_Declaration | Iir_Kind_Across_Quantity_Declaration | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Enumeration_Literal | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration | Iir_Kind_Procedure_Declaration - | Iir_Kind_Enumeration_Literal | Iir_Kind_File_Declaration | Iir_Kind_Guard_Signal_Declaration | Iir_Kind_Signal_Declaration @@ -1871,11 +1871,11 @@ package body Iirs is | Iir_Kind_Free_Quantity_Declaration | Iir_Kind_Across_Quantity_Declaration | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Enumeration_Literal | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration | Iir_Kind_Procedure_Declaration - | Iir_Kind_Enumeration_Literal | Iir_Kind_File_Declaration | Iir_Kind_Guard_Signal_Declaration | Iir_Kind_Signal_Declaration @@ -2155,11 +2155,11 @@ package body Iirs is | Iir_Kind_Free_Quantity_Declaration | Iir_Kind_Across_Quantity_Declaration | Iir_Kind_Through_Quantity_Declaration - | Iir_Kind_Function_Body | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration | Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Body | Iir_Kind_Procedure_Body | Iir_Kind_Object_Alias_Declaration | Iir_Kind_File_Declaration @@ -2249,6 +2249,7 @@ package body Iirs is case Get_Kind (Target) is when Iir_Kind_Block_Header | Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Package_Header | Iir_Kind_Component_Declaration | Iir_Kind_Function_Declaration @@ -2290,8 +2291,6 @@ package body Iirs is | Iir_Kind_Record_Element_Constraint | Iir_Kind_Disconnection_Specification | Iir_Kind_Range_Expression - | Iir_Kind_Type_Declaration - | Iir_Kind_Anonymous_Type_Declaration | Iir_Kind_Subtype_Declaration | Iir_Kind_Unit_Declaration | Iir_Kind_Attribute_Declaration @@ -2299,9 +2298,9 @@ package body Iirs is | Iir_Kind_Free_Quantity_Declaration | Iir_Kind_Across_Quantity_Declaration | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Enumeration_Literal | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration - | Iir_Kind_Enumeration_Literal | Iir_Kind_Object_Alias_Declaration | Iir_Kind_File_Declaration | Iir_Kind_Guard_Signal_Declaration @@ -2428,6 +2427,29 @@ package body Iirs is Set_Field1 (Target, Atype); end Set_Type; + procedure Check_Kind_For_Type_Definition (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration => + null; + when others => + Failed ("Type_Definition", Target); + end case; + end Check_Kind_For_Type_Definition; + + function Get_Type_Definition (Decl : Iir) return Iir is + begin + Check_Kind_For_Type_Definition (Decl); + return Get_Field1 (Decl); + end Get_Type_Definition; + + procedure Set_Type_Definition (Decl : Iir; Atype : Iir) is + begin + Check_Kind_For_Type_Definition (Decl); + Set_Field1 (Decl, Atype); + end Set_Type_Definition; + procedure Check_Kind_For_Subtype_Definition (Target : Iir) is begin case Get_Kind (Target) is @@ -2750,11 +2772,11 @@ package body Iirs is procedure Check_Kind_For_Subprogram_Hash (Target : Iir) is begin case Get_Kind (Target) is - when Iir_Kind_Function_Declaration + when Iir_Kind_Enumeration_Literal + | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration - | Iir_Kind_Procedure_Declaration - | Iir_Kind_Enumeration_Literal => + | Iir_Kind_Procedure_Declaration => null; when others => Failed ("Subprogram_Hash", Target); @@ -2800,9 +2822,9 @@ package body Iirs is begin case Get_Kind (Target) is when Iir_Kind_Signature + | Iir_Kind_Enumeration_Literal | Iir_Kind_Function_Declaration - | Iir_Kind_Implicit_Function_Declaration - | Iir_Kind_Enumeration_Literal => + | Iir_Kind_Implicit_Function_Declaration => null; when others => Failed ("Return_Type", Target); @@ -3451,11 +3473,11 @@ package body Iirs is | Iir_Kind_Free_Quantity_Declaration | Iir_Kind_Across_Quantity_Declaration | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Enumeration_Literal | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration | Iir_Kind_Procedure_Declaration - | Iir_Kind_Enumeration_Literal | Iir_Kind_Object_Alias_Declaration | Iir_Kind_File_Declaration | Iir_Kind_Guard_Signal_Declaration @@ -3587,11 +3609,11 @@ package body Iirs is | Iir_Kind_Free_Quantity_Declaration | Iir_Kind_Across_Quantity_Declaration | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Enumeration_Literal | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration | Iir_Kind_Procedure_Declaration - | Iir_Kind_Enumeration_Literal | Iir_Kind_Object_Alias_Declaration | Iir_Kind_File_Declaration | Iir_Kind_Guard_Signal_Declaration @@ -4598,11 +4620,11 @@ package body Iirs is procedure Check_Kind_For_Seen_Flag (Target : Iir) is begin case Get_Kind (Target) is - when Iir_Kind_Function_Declaration + when Iir_Kind_Enumeration_Literal + | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration | Iir_Kind_Procedure_Declaration - | Iir_Kind_Enumeration_Literal | Iir_Kind_Sensitized_Process_Statement | Iir_Kind_Process_Statement => null; @@ -5524,13 +5546,13 @@ package body Iirs is | Iir_Kind_Free_Quantity_Declaration | Iir_Kind_Across_Quantity_Declaration | Iir_Kind_Through_Quantity_Declaration - | Iir_Kind_Function_Body + | Iir_Kind_Enumeration_Literal | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration | Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Body | Iir_Kind_Procedure_Body - | Iir_Kind_Enumeration_Literal | Iir_Kind_Object_Alias_Declaration | Iir_Kind_File_Declaration | Iir_Kind_Guard_Signal_Declaration @@ -7015,11 +7037,11 @@ package body Iirs is case Get_Kind (Target) is when Iir_Kind_Entity_Declaration | Iir_Kind_Architecture_Declaration + | Iir_Kind_Enumeration_Literal | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration | Iir_Kind_Procedure_Declaration - | Iir_Kind_Enumeration_Literal | Iir_Kind_Sensitized_Process_Statement | Iir_Kind_Process_Statement | Iir_Kind_Block_Statement @@ -712,6 +712,8 @@ package Iirs is -- -- Get/Set_Identifier (Field3) -- + -- Get/Set_Generic_Chain (Field6) + -- -- Get/Set_Generic_Map_Aspect_Chain (Field8) -- -- Get/Set_Visible_Flag (Flag4) @@ -800,7 +802,7 @@ package Iirs is -- -- Get/Set_Parent (Field0) -- - -- Get/Set_Type (Field1) + -- Get/Set_Type_Definition (Field1) -- -- Get/Set_Chain (Field2) -- @@ -820,7 +822,7 @@ package Iirs is -- The parser set this field to null_iir for an incomplete type declaration. -- This field is set to an incomplete_type_definition node when first -- semantized. - -- Get/Set_Type (Field1) + -- Get/Set_Type_Definition (Field1) -- -- Get/Set_Chain (Field2) -- @@ -2869,13 +2871,13 @@ package Iirs is Iir_Kind_Across_Quantity_Declaration, Iir_Kind_Through_Quantity_Declaration, - Iir_Kind_Function_Body, + Iir_Kind_Enumeration_Literal, Iir_Kind_Function_Declaration, -- Subprg, Func Iir_Kind_Implicit_Function_Declaration, -- Subprg, Func, Imp_Subprg Iir_Kind_Implicit_Procedure_Declaration, -- Subprg, Proc, Imp_Subprg Iir_Kind_Procedure_Declaration, -- Subprg, Proc + Iir_Kind_Function_Body, Iir_Kind_Procedure_Body, - Iir_Kind_Enumeration_Literal, Iir_Kind_Object_Alias_Declaration, -- object Iir_Kind_File_Declaration, -- object @@ -3323,7 +3325,7 @@ package Iirs is Iir_Predefined_Endfile, -- To_String - Iir_Predefined_Array_To_String, + Iir_Predefined_Array_Char_To_String, Iir_Predefined_Bit_Vector_To_Ostring, Iir_Predefined_Bit_Vector_To_Hstring, @@ -3372,6 +3374,13 @@ package Iirs is --Iir_Predefined_Element_Array_Concat Iir_Predefined_Element_Element_Concat; + subtype Iir_Predefined_Std_Ulogic_Match_Ordering_Functions is + Iir_Predefined_Functions range + Iir_Predefined_Std_Ulogic_Match_Less .. + --Iir_Predefined_Std_Ulogic_Match_Less_Equal + --Iir_Predefined_Std_Ulogic_Match_Greater + Iir_Predefined_Std_Ulogic_Match_Greater_Equal; + -- Staticness as defined by LRM93 §6.1 and §7.4 type Iir_Staticness is (Unknown, None, Globally, Locally); @@ -3582,6 +3591,11 @@ package Iirs is Iir_Kind_Function_Declaration .. Iir_Kind_Implicit_Function_Declaration; + subtype Iir_Kinds_Functions_And_Literals is Iir_Kind range + Iir_Kind_Enumeration_Literal .. + --Iir_Kind_Function_Declaration + Iir_Kind_Implicit_Function_Declaration; + subtype Iir_Kinds_Procedure_Declaration is Iir_Kind range Iir_Kind_Implicit_Procedure_Declaration .. Iir_Kind_Procedure_Declaration; @@ -3825,13 +3839,13 @@ package Iirs is --Iir_Kind_Free_Quantity_Declaration --Iir_Kind_Across_Quantity_Declaration --Iir_Kind_Through_Quantity_Declaration - --Iir_Kind_Function_Body + --Iir_Kind_Enumeration_Literal --Iir_Kind_Function_Declaration --Iir_Kind_Implicit_Function_Declaration --Iir_Kind_Implicit_Procedure_Declaration --Iir_Kind_Procedure_Declaration + --Iir_Kind_Function_Body --Iir_Kind_Procedure_Body - --Iir_Kind_Enumeration_Literal --Iir_Kind_Object_Alias_Declaration --Iir_Kind_File_Declaration --Iir_Kind_Guard_Signal_Declaration @@ -4626,6 +4640,10 @@ package Iirs is procedure Set_Type (Target : Iir; Atype : Iir); pragma Inline (Get_Type); + -- Field: Field1 + function Get_Type_Definition (Decl : Iir) return Iir; + procedure Set_Type_Definition (Decl : Iir; Atype : Iir); + -- The subtype definition associated with the type declaration (if any). -- Field: Field4 function Get_Subtype_Definition (Target : Iir) return Iir; diff --git a/iirs_utils.adb b/iirs_utils.adb index 060c3f74e..178f90ef3 100644 --- a/iirs_utils.adb +++ b/iirs_utils.adb @@ -549,6 +549,19 @@ package body Iirs_Utils is or else Get_Constraint_State (Def) = Fully_Constrained; end Is_Fully_Constrained_Type; + function Get_Type_Of_Type_Mark (Mark : Iir) return Iir is + begin + case Get_Kind (Mark) is + when Iir_Kind_Type_Declaration => + return Get_Type_Definition (Mark); + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Base_Attribute => + return Get_Type (Mark); + when others => + Error_Kind ("get_type_of_type_mark", Mark); + end case; + end Get_Type_Of_Type_Mark; + function Is_Same_Profile (L, R: Iir) return Boolean is L1, R1 : Iir; @@ -890,7 +903,6 @@ package body Iirs_Utils is and then Get_Generic_Map_Aspect_Chain (Header) /= Null_Iir; end Is_Generic_Mapped_Package; - function Get_HDL_Node (N : PSL_Node) return Iir is begin return Iir (PSL.Nodes.Get_HDL_Node (N)); diff --git a/iirs_utils.ads b/iirs_utils.ads index 1477d8e20..b628aec8d 100644 --- a/iirs_utils.ads +++ b/iirs_utils.ads @@ -88,6 +88,10 @@ package Iirs_Utils is -- Return TRUE iff DEF is a fully constrained type (or subtype) definition. function Is_Fully_Constrained_Type (Def : Iir) return Boolean; + -- Return the type of a type name (type declaration, subtype declaration or + -- base attribute). + function Get_Type_Of_Type_Mark (Mark : Iir) return Iir; + -- Return true iff L and R have the same profile. -- L and R must be subprograms specification (or spec_body). function Is_Same_Profile (L, R: Iir) return Boolean; diff --git a/libraries/Makefile.inc b/libraries/Makefile.inc index 5d1cc76f1..a6dfe61a9 100644 --- a/libraries/Makefile.inc +++ b/libraries/Makefile.inc @@ -58,14 +58,12 @@ ieee2008/numeric_std-body.vhdl \ ieee2008/numeric_std_unsigned.vhdl ieee2008/numeric_std_unsigned-body.vhdl \ ieee2008/fixed_float_types.vhdl \ ieee2008/fixed_generic_pkg.vhdl \ -ieee2008/fixed_pkg.vhdl -# ieee2008/numeric_bit-body.vhdl \ -# -#ieee2008/fixed_generic_pkg-body.vhdl - -# -#ieee2008/float_generic_pkg-body.vhdl +ieee2008/fixed_pkg.vhdl \ +ieee2008/numeric_bit-body.vhdl \ +ieee2008/fixed_generic_pkg-body.vhdl #ieee2008/float_generic_pkg.vhdl +#ieee2008/float_generic_pkg-body.vhdl +# #ieee2008/float_pkg.vhdl STD87_BSRCS := $(STD_SRCS:.vhdl=.v87) diff --git a/libraries/ieee2008/std_logic_1164-body.vhdl b/libraries/ieee2008/std_logic_1164-body.vhdl index 7a9c91d9e..e5c56de74 100644 --- a/libraries/ieee2008/std_logic_1164-body.vhdl +++ b/libraries/ieee2008/std_logic_1164-body.vhdl @@ -1108,7 +1108,8 @@ package body std_logic_1164 is variable c : CHARACTER; begin while L /= null and L.all'length /= 0 loop - if (L.all(1) = ' ' or L.all(1) = NBSP or L.all(1) = HT) then + c := l (l'left); + if c = ' ' or c = NBSP or c = HT then read (l, c, readOk); else exit; diff --git a/libraries/std/textio.vhdl b/libraries/std/textio.vhdl index 49e404325..25d90ec04 100644 --- a/libraries/std/textio.vhdl +++ b/libraries/std/textio.vhdl @@ -122,6 +122,10 @@ package Textio is procedure writeline (variable f: out text; l: inout line); --V87 procedure writeline (file f: text; l: inout line); --V93 + --START-V08 + procedure Tee (file f : Text; L : inout LINE); + --END-V08 + -- This implementation accept any value for all the types. procedure write (l: inout line; value: in bit; @@ -161,5 +165,13 @@ package Textio is alias Bwrite is write [Line, Bit_Vector, Side, Width]; alias Binary_Write is write [Line, Bit_Vector, Side, Width]; - --END-V08 + + procedure Owrite (L : inout line; value : in Bit_Vector; + Justified : in Side := Right; Field : in Width := 0); + alias Octal_Write is Owrite [Line, Bit_Vector, Side, Width]; + + procedure Hwrite (L : inout line; value : in Bit_Vector; + Justified : in Side := Right; Field : in Width := 0); + alias Hex_Write is Hwrite [Line, Bit_Vector, Side, Width]; +--END-V08 end textio; diff --git a/libraries/std/textio_body.vhdl b/libraries/std/textio_body.vhdl index a57ed03c3..b402174a4 100644 --- a/libraries/std/textio_body.vhdl +++ b/libraries/std/textio_body.vhdl @@ -102,6 +102,28 @@ package body textio is end if; end writeline; + --START-V08 + procedure Tee (file f : Text; L : inout LINE) is + begin + if l = null then + -- LRM93 14.3 + -- If parameter L contains a null access value at the start of the call, + -- the a null string is written to the file. + write (f, ""); + write (Output, ""); + else + -- LRM93 14.3 + -- Procedure WRITELINE causes the current line designated by parameter L + -- to be written to the file and returns with the value of parameter L + -- designating a null string. + write (f, l.all); + write (Output, l.all); + deallocate (l); + l := new string'(""); + end if; + end Tee; + --END-V08 + procedure write (l: inout line; value: in string; justified: in side := right; field: in width := 0) @@ -460,6 +482,20 @@ package body textio is write (l, str (1 to pos - 1), justified, field); end write; + --START-V08 + procedure Owrite (L : inout line; value : in Bit_Vector; + Justified : in Side := Right; Field : in Width := 0) is + begin + write (l, to_ostring (value), justified, field); + end Owrite; + + procedure Hwrite (L : inout line; value : in Bit_Vector; + Justified : in Side := Right; Field : in Width := 0) is + begin + write (l, to_hstring (value), justified, field); + end Hwrite; +--END-V08 + procedure untruncated_text_read --V87 (variable f : text; str : out string; len : out natural); --V87 procedure untruncated_text_read --V93 @@ -1670,7 +1670,7 @@ package body Parse is Decl := Create_Iir (Iir_Kind_Type_Declaration); Res := Create_Iir (Iir_Kind_Protected_Type_Declaration); Set_Location (Res, Loc); - Set_Type (Decl, Res); + Set_Type_Definition (Decl, Res); end if; Set_Identifier (Decl, Ident); Set_Location (Decl, Loc); @@ -1759,7 +1759,7 @@ package body Parse is Set_Identifier (Decl, Ident); Set_Location (Decl, Loc); Def := Parse_Range_Constraint; - Set_Type (Decl, Def); + Set_Type_Definition (Decl, Def); if Current_Token = Tok_Units then declare Unit_Def : Iir; @@ -1784,7 +1784,7 @@ package body Parse is Decl := Create_Iir (Iir_Kind_Type_Declaration); Set_Identifier (Decl, Ident); Set_Location (Decl, Loc); - Set_Type (Decl, Parse_Record_Definition); + Set_Type_Definition (Decl, Parse_Record_Definition); if Current_Token = Tok_Identifier then if Flags.Vhdl_Std = Vhdl_87 then Error_Msg_Parse ("simple_name not allowed here in vhdl87"); @@ -1829,13 +1829,12 @@ package body Parse is | Iir_Kind_Array_Type_Definition | Iir_Kind_File_Type_Definition => Decl := Create_Iir (Iir_Kind_Type_Declaration); - Set_Type (Decl, Def); when Iir_Kind_Array_Subtype_Definition => Decl := Create_Iir (Iir_Kind_Anonymous_Type_Declaration); - Set_Type (Decl, Def); when others => Error_Kind ("parse_type_declaration", Def); end case; + Set_Type_Definition (Decl, Def); end if; Set_Identifier (Decl, Ident); Set_Location (Decl, Loc); @@ -611,7 +611,7 @@ package body Sem is -- must be analyzed prior to the analysis of the given design unit. Add_Dependence (Entity_Unit); - Sem_Scopes.Add_Name (Entity); + Sem_Scopes.Add_Name (Decl); Set_Visible_Flag (Decl, True); @@ -2189,7 +2189,7 @@ package body Sem is | Iir_Kind_Group_Declaration => null; when Iir_Kind_Type_Declaration => - Def := Get_Type (El); + Def := Get_Type_Definition (El); if Def /= Null_Iir and then Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration then diff --git a/sem_assocs.adb b/sem_assocs.adb index 77ffcd559..f393cfd0e 100644 --- a/sem_assocs.adb +++ b/sem_assocs.adb @@ -786,46 +786,46 @@ package body Sem_Assocs is end loop; end Is_Expanded_Name; - -- Return TRUE iff FUNC is valid as a conversion function/type. - function Is_Valid_Conversion (Func : Iir) return Boolean is - begin - case Get_Kind (Func) is - when Iir_Kinds_Function_Declaration => - if not Is_Chain_Length_One (Get_Interface_Declaration_Chain (Func)) - then - return False; - end if; - when Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration => - if Flags.Vhdl_Std = Vhdl_87 then - return False; - end if; - when others => - return False; - end case; - return True; - end Is_Valid_Conversion; - function Extract_Type_Of_Conversions (Convs : Iir) return Iir is + -- Return TRUE iff FUNC is valid as a conversion function/type. + function Extract_Type_Of_Conversion (Func : Iir) return Iir is + begin + case Get_Kind (Func) is + when Iir_Kinds_Function_Declaration => + if Is_Chain_Length_One (Get_Interface_Declaration_Chain (Func)) + then + return Get_Type (Func); + else + return Null_Iir; + end if; + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration => + if Flags.Vhdl_Std = Vhdl_87 then + return Null_Iir; + end if; + return Get_Type_Of_Type_Mark (Func); + when others => + return Null_Iir; + end case; + end Extract_Type_Of_Conversion; + Res_List : Iir_List; Ov_List : Iir_List; El : Iir; + Conv_Type : Iir; begin if not Is_Overload_List (Convs) then - if Is_Valid_Conversion (Convs) then - return Get_Type (Convs); - else - return Null_Iir; - end if; + return Extract_Type_Of_Conversion (Convs); else Ov_List := Get_Overload_List (Convs); Res_List := Create_Iir_List; for I in Natural loop El := Get_Nth_Element (Ov_List, I); exit when El = Null_Iir; - if Is_Valid_Conversion (El) then - Add_Element (Res_List, Get_Type (El)); + Conv_Type := Extract_Type_Of_Conversion (El); + if Conv_Type /= Null_Iir then + Add_Element (Res_List, Conv_Type); end if; end loop; return Simplify_Overload_List (Res_List); @@ -1053,7 +1053,7 @@ package body Sem_Assocs is end if; when Iir_Kind_Type_Declaration | Iir_Kind_Subtype_Declaration => - R_Type := Get_Type (Func); + R_Type := Get_Type_Of_Type_Mark (Func); if Get_Base_Type (R_Type) = Res_Base_Type and then Are_Types_Closely_Related (R_Type, Param_Base_Type) then @@ -1166,7 +1166,7 @@ package body Sem_Assocs is Res := Create_Iir (Iir_Kind_Type_Conversion); Location_Copy (Res, Conv); Set_Type_Mark (Res, Func); - Set_Type (Res, Get_Type (Func)); + Set_Type (Res, Get_Type_Of_Type_Mark (Func)); Set_Expression (Res, Null_Iir); Set_Expr_Staticness (Res, None); when others => diff --git a/sem_decls.adb b/sem_decls.adb index a878cbe8b..afdcdaafd 100644 --- a/sem_decls.adb +++ b/sem_decls.adb @@ -513,6 +513,28 @@ package body Sem_Decls is -- Add it to the list. Insert_Incr (Last, Proc); + -- Create the implicit procedure flush declaration + if Flags.Vhdl_Std >= Vhdl_08 then + Proc := Create_Iir (Iir_Kind_Implicit_Procedure_Declaration); + Set_Identifier (Proc, Std_Names.Name_Flush); + Set_Location (Proc, Loc); + Set_Parent (Proc, Get_Parent (Decl)); + Set_Type_Reference (Proc, Decl); + Set_Visible_Flag (Proc, True); + Build_Init (Last_Interface); + Inter := Create_Iir (File_Interface_Kind); + Set_Identifier (Inter, Std_Names.Name_F); + Set_Location (Inter, Loc); + Set_Type (Inter, Type_Definition); + Set_Base_Name (Inter, Inter); + Set_Name_Staticness (Inter, Locally); + Set_Expr_Staticness (Inter, None); + Append (Last_Interface, Proc, Inter); + Set_Implicit_Definition (Proc, Iir_Predefined_Flush); + Compute_Subprogram_Hash (Proc); + -- Add it to the list. + Insert_Incr (Last, Proc); + end if; -- Create the implicit function endfile declaration. Func := Create_Iir (Iir_Kind_Implicit_Function_Declaration); Set_Identifier (Func, Std_Names.Name_Endfile); @@ -596,6 +618,12 @@ package body Sem_Decls is Add_Operation (Name, Def, Unary_Chain, Type_Definition); end Add_Unary; + procedure Add_To_String (Def : Iir_Predefined_Functions) is + begin + Add_Operation (Name_To_String, Def, + Unary_Chain, String_Type_Definition); + end Add_To_String; + procedure Add_Min_Max (Name : Name_Id; Def : Iir_Predefined_Functions) is Left, Right : Iir; @@ -651,7 +679,7 @@ package body Sem_Decls is begin Last := Decl; - Type_Definition := Get_Base_Type (Get_Type (Decl)); + Type_Definition := Get_Base_Type (Get_Type_Definition (Decl)); if Get_Kind (Type_Definition) /= Iir_Kind_File_Type_Definition then Unary_Chain := Create_Anonymous_Interface (Type_Definition); Binary_Chain := Create_Anonymous_Interface (Type_Definition); @@ -671,8 +699,16 @@ package body Sem_Decls is (Name_Op_Less_Equal, Iir_Predefined_Enum_Less_Equal); if Flags.Vhdl_Std >= Vhdl_08 then + -- LRM08 5.2.6 Predefined operations on scalar types + -- Given a type declaration that declares a scalar type T, the + -- following operations are implicitely declared immediately + -- following the type declaration (except for the TO_STRING + -- operations in package STANDARD [...]) Add_Min_Max (Name_Minimum, Iir_Predefined_Enum_Minimum); Add_Min_Max (Name_Maximum, Iir_Predefined_Enum_Maximum); + if not Is_Std_Standard then + Add_To_String (Iir_Predefined_Enum_To_String); + end if; -- LRM08 9.2.3 Relational operators -- The matching relational operators are predefined for the @@ -934,7 +970,7 @@ package body Sem_Decls is and then Get_Only_Characters_Flag (Element_Type) then Add_Operation (Name_To_String, - Iir_Predefined_Array_To_String, + Iir_Predefined_Array_Char_To_String, Unary_Chain, String_Type_Definition); end if; @@ -1012,8 +1048,16 @@ package body Sem_Decls is end; if Vhdl_Std >= Vhdl_08 then + -- LRM08 5.2.6 Predefined operations on scalar types + -- Given a type declaration that declares a scalar type T, the + -- following operations are implicitely declared immediately + -- following the type declaration (except for the TO_STRING + -- operations in package STANDARD [...]) Add_Min_Max (Name_Minimum, Iir_Predefined_Integer_Minimum); Add_Min_Max (Name_Maximum, Iir_Predefined_Integer_Maximum); + if not Is_Std_Standard then + Add_To_String (Iir_Predefined_Integer_To_String); + end if; end if; when Iir_Kind_Floating_Type_Definition => @@ -1053,8 +1097,16 @@ package body Sem_Decls is end; if Vhdl_Std >= Vhdl_08 then + -- LRM08 5.2.6 Predefined operations on scalar types + -- Given a type declaration that declares a scalar type T, the + -- following operations are implicitely declared immediately + -- following the type declaration (except for the TO_STRING + -- operations in package STANDARD [...]) Add_Min_Max (Name_Minimum, Iir_Predefined_Floating_Minimum); Add_Min_Max (Name_Maximum, Iir_Predefined_Floating_Maximum); + if not Is_Std_Standard then + Add_To_String (Iir_Predefined_Floating_To_String); + end if; end if; when Iir_Kind_Physical_Type_Definition => @@ -1128,8 +1180,16 @@ package body Sem_Decls is Add_Unary (Name_Abs, Iir_Predefined_Physical_Absolute); if Vhdl_Std >= Vhdl_08 then + -- LRM08 5.2.6 Predefined operations on scalar types + -- Given a type declaration that declares a scalar type T, the + -- following operations are implicitely declared immediately + -- following the type declaration (except for the TO_STRING + -- operations in package STANDARD [...]) Add_Min_Max (Name_Minimum, Iir_Predefined_Physical_Minimum); Add_Min_Max (Name_Maximum, Iir_Predefined_Physical_Maximum); + if not Is_Std_Standard then + Add_To_String (Iir_Predefined_Physical_To_String); + end if; end if; when Iir_Kind_File_Type_Definition => @@ -1227,8 +1287,8 @@ package body Sem_Decls is then Old_Decl := Get_Declaration (Inter); if Get_Kind (Old_Decl) /= Iir_Kind_Type_Declaration - or else Get_Kind (Get_Type (Old_Decl)) /= - Iir_Kind_Incomplete_Type_Definition + or else (Get_Kind (Get_Type_Definition (Old_Decl)) /= + Iir_Kind_Incomplete_Type_Definition) then Old_Decl := Null_Iir; end if; @@ -1250,12 +1310,12 @@ package body Sem_Decls is end if; -- Check the definition of the type. - Def := Get_Type (Decl); + Def := Get_Type_Definition (Decl); if Def = Null_Iir then -- Incomplete type declaration Def := Create_Iir (Iir_Kind_Incomplete_Type_Definition); Location_Copy (Def, Decl); - Set_Type (Decl, Def); + Set_Type_Definition (Decl, Def); Set_Base_Type (Def, Def); Set_Signal_Type_Flag (Def, True); Set_Type_Declarator (Def, Decl); @@ -1286,7 +1346,7 @@ package body Sem_Decls is -- The type declaration declares the base type. Bt_Def := Get_Base_Type (Def); - Set_Type (Decl, Bt_Def); + Set_Type_Definition (Decl, Bt_Def); Set_Type_Declarator (Bt_Def, Decl); Set_Subtype_Definition (Decl, Def); @@ -1294,7 +1354,8 @@ package body Sem_Decls is Sem_Scopes.Add_Name (St_Decl); else Replace_Name (Get_Identifier (Decl), Old_Decl, St_Decl); - Set_Type_Declarator (Get_Type (Old_Decl), St_Decl); + Set_Type_Declarator + (Get_Type_Definition (Old_Decl), St_Decl); end if; Sem_Scopes.Name_Visible (St_Decl); @@ -1333,7 +1394,7 @@ package body Sem_Decls is El : Iir; Old_Def : Iir; begin - Old_Def := Get_Type (Old_Decl); + Old_Def := Get_Type_Definition (Old_Decl); Set_Signal_Type_Flag (Old_Def, Get_Signal_Type_Flag (Def)); List := Get_Incomplete_Type_List (Old_Def); for I in Natural loop @@ -1694,7 +1755,7 @@ package body Sem_Decls is when Iir_Kind_Variable_Declaration | Iir_Kind_Signal_Declaration => - -- LRM93 §3.2.1.1 + -- LRM93 3.2.1.1 / LRM08 5.3.2.2 -- For a variable or signal declared by an object declaration, the -- subtype indication of the corressponding object declaration -- must define a constrained array subtype. @@ -2080,7 +2141,7 @@ package body Sem_Decls is procedure Add_Aliases_For_Type_Alias (Alias : Iir) is N_Entity : constant Iir := Get_Name (Alias); - Def : constant Iir := Get_Base_Type (Get_Type (N_Entity)); + Def : constant Iir := Get_Base_Type (Get_Type_Of_Type_Mark (N_Entity)); Type_Decl : constant Iir := Get_Type_Declarator (Def); Last : Iir; El : Iir; @@ -2814,7 +2875,7 @@ package body Sem_Decls is declare Def : Iir; begin - Def := Get_Type (El); + Def := Get_Type_Definition (El); if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition and then Get_Type_Declarator (Def) = El then diff --git a/sem_expr.adb b/sem_expr.adb index aac561a90..2bf2fd51e 100644 --- a/sem_expr.adb +++ b/sem_expr.adb @@ -657,8 +657,10 @@ package body Sem_Expr is end if; case Get_Kind (Res) is - when Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration => + when Iir_Kind_Type_Declaration => + Res := Get_Type_Definition (Res); + Res_Type := Res; + when Iir_Kind_Subtype_Declaration => Res := Get_Type (Res); Res_Type := Res; when Iir_Kind_Range_Array_Attribute @@ -1160,6 +1162,8 @@ package body Sem_Expr is Inter: Iir; Match : Boolean; begin + -- Sem_Name has gathered all the possible names for the prefix of this + -- call. Reduce this list to only names that match the types. Nbr_Inter := 0; Imp_List := Get_Overload_List (Get_Implementation (Expr)); Assoc_Chain := Get_Parameter_Association_Chain (Expr); @@ -1168,28 +1172,25 @@ package body Sem_Expr is A_Func := Get_Nth_Element (Imp_List, I); exit when A_Func = Null_Iir; - -- The identifier of a function call must be a function or an - -- enumeration literal. - if Is_Func_Call and then not - (Get_Kind (A_Func) = Iir_Kind_Function_Declaration - or else Get_Kind (A_Func) = Iir_Kind_Implicit_Function_Declaration - or else Get_Kind (A_Func) = Iir_Kind_Enumeration_Literal) - then - goto Continue; - end if; - - -- The identifier of a procedure call must be a procedure. - if not Is_Func_Call and then not - (Get_Kind (A_Func) = Iir_Kind_Procedure_Declaration - or else - Get_Kind (A_Func) = Iir_Kind_Implicit_Procedure_Declaration) - then - goto Continue; - end if; + case Get_Kind (A_Func) is + when Iir_Kinds_Functions_And_Literals => + if not Is_Func_Call then + -- The identifier of a function call must be a function or + -- an enumeration literal. + goto Continue; + end if; + when Iir_Kinds_Procedure_Declaration => + if Is_Func_Call then + -- The identifier of a procedure call must be a procedure. + goto Continue; + end if; + when others => + Error_Kind ("sem_subprogram_call_stage1", A_Func); + end case; -- Keep this interpretation only if compatible. - if A_Type = Null_Iir or else - Compatibility_Nodes (A_Type, Get_Return_Type (A_Func)) + if A_Type = Null_Iir + or else Compatibility_Nodes (A_Type, Get_Return_Type (A_Func)) then Sem_Association_Chain (Get_Interface_Declaration_Chain (A_Func), @@ -1213,8 +1214,9 @@ package body Sem_Expr is Error_Msg_Sem ("cannot resolve overloading for subprogram call", Expr); return Null_Iir; + when 1 => - -- Very simple case: no overloading. + -- Simple case: no overloading. Inter := Get_First_Element (Imp_List); Free_Iir (Get_Implementation (Expr)); if Is_Func_Call then @@ -1231,6 +1233,7 @@ package body Sem_Expr is Check_Subprogram_Associations (Inter_Chain, Assoc_Chain); Sem_Subprogram_Call_Finish (Expr, Inter); return Expr; + when others => if Is_Func_Call then if A_Type /= Null_Iir then @@ -1240,12 +1243,15 @@ package body Sem_Expr is Disp_Overload_List (Imp_List, Expr); return Null_Iir; end if; + + -- Create the list of types for the result. Res_Type := Create_Iir_List; for I in 0 .. Nbr_Inter - 1 loop Add_Element (Res_Type, Get_Return_Type (Get_Nth_Element (Imp_List, I))); end loop; + if Get_Nbr_Elements (Res_Type) = 1 then -- several implementations but one profile. Error_Overload (Expr); @@ -1254,6 +1260,8 @@ package body Sem_Expr is end if; Set_Type (Expr, Create_Overload_List (Res_Type)); else + -- For a procedure call, the context does't help to resolve + -- overload. Error_Overload (Expr); Disp_Overload_List (Imp_List, Expr); end if; @@ -1265,7 +1273,7 @@ package body Sem_Expr is -- Associations must have already been semantized by sem_association_list. function Sem_Subprogram_Call (Expr: Iir; A_Type: Iir) return Iir is - Is_Func: Boolean; + Is_Func: constant Boolean := Get_Kind (Expr) = Iir_Kind_Function_Call; Res_Type: Iir; Res: Iir; Inter_List: Iir; @@ -1274,15 +1282,13 @@ package body Sem_Expr is Assoc_Chain : Iir; Match : Boolean; begin - Is_Func := Get_Kind (Expr) = Iir_Kind_Function_Call; - if Is_Func then Res_Type := Get_Type (Expr); end if; if not Is_Func or else Res_Type = Null_Iir then -- First call to sem_subprogram_call. - -- Create the list of possible implementation and possible + -- Create the list of possible implementations and possible -- return types, according to arguments and A_TYPE. -- Select possible interpretations among all interpretations. @@ -1292,25 +1298,25 @@ package body Sem_Expr is Inter_List := Get_Implementation (Expr); if Get_Kind (Inter_List) = Iir_Kind_Error then return Null_Iir; - end if; - if Is_Overload_List (Inter_List) then + elsif Is_Overload_List (Inter_List) then + -- Subprogram name is overloaded. return Sem_Subprogram_Call_Stage1 (Expr, A_Type, Is_Func); else + -- Only one interpretation for the subprogram name. if Is_Func then if Get_Kind (Inter_List) not in Iir_Kinds_Function_Declaration then - Error_Msg_Sem ("identifier is not a function", Expr); + Error_Msg_Sem ("name does not designate a function", Expr); return Null_Iir; end if; else if Get_Kind (Inter_List) not in Iir_Kinds_Procedure_Declaration - and then Get_Kind (Inter_List) /= - Iir_Kind_Implicit_Procedure_Declaration then Error_Msg_Sem ("name does not designate a procedure", Expr); return Null_Iir; end if; end if; + Assoc_Chain := Get_Parameter_Association_Chain (Expr); Param_Chain := Get_Interface_Declaration_Chain (Inter_List); Sem_Association_Chain @@ -1331,11 +1337,9 @@ package body Sem_Expr is end if; end if; - if Is_Func and then A_Type = Null_Iir then - -- Impossible case: second call to sem_function_call, without - -- A_TYPE set. - raise Internal_Error; - end if; + -- Second call to Sem_Function_Call (only for functions). + pragma Assert (Is_Func); + pragma Assert (A_Type /= Null_Iir); -- The implementation list was set. -- The return type was set. @@ -1345,51 +1349,40 @@ package body Sem_Expr is -- Find a single implementation. Res := Null_Iir; - if Is_Func then - if Is_Overload_List (Inter_List) then - -- INTER_LIST is a list of possible declaration to call. - -- Find one, based on the return type A_TYPE. - for I in Natural loop - Inter := Get_Nth_Element (Get_Overload_List (Inter_List), I); - exit when Inter = Null_Iir; - if Are_Basetypes_Compatible - (A_Type, Get_Base_Type (Get_Return_Type (Inter))) - then - if Res /= Null_Iir then - Error_Overload (Expr); - Disp_Overload_List (Get_Overload_List (Inter_List), Expr); - return Null_Iir; - else - Res := Inter; - end if; - end if; - end loop; - else + if Is_Overload_List (Inter_List) then + -- INTER_LIST is a list of possible declaration to call. + -- Find one, based on the return type A_TYPE. + for I in Natural loop + Inter := Get_Nth_Element (Get_Overload_List (Inter_List), I); + exit when Inter = Null_Iir; if Are_Basetypes_Compatible - (Get_Base_Type (Get_Return_Type (Inter_List)), A_Type) + (A_Type, Get_Base_Type (Get_Return_Type (Inter))) then - Res := Inter_List; + if Res /= Null_Iir then + Error_Overload (Expr); + Disp_Overload_List (Get_Overload_List (Inter_List), Expr); + return Null_Iir; + else + Res := Inter; + end if; end if; - end if; - if Res = Null_Iir then - Not_Match (Expr, A_Type); - return Null_Iir; - end if; - - -- Clean up. - if Res_Type /= Null_Iir and then Is_Overload_List (Res_Type) then - Free_Iir (Res_Type); - end if; + end loop; else - -- a procedure call. - if Is_Overload_List (Inter_List) then - Error_Overload (Expr); - Disp_Overload_List (Get_Overload_List (Inter_List), Expr); - return Null_Iir; - else + if Are_Basetypes_Compatible + (A_Type, Get_Base_Type (Get_Return_Type (Inter_List))) + then Res := Inter_List; end if; end if; + if Res = Null_Iir then + Not_Match (Expr, A_Type); + return Null_Iir; + end if; + + -- Clean up. + if Res_Type /= Null_Iir and then Is_Overload_List (Res_Type) then + Free_Iir (Res_Type); + end if; if Is_Overload_List (Inter_List) then Free_Iir (Inter_List); @@ -1403,9 +1396,7 @@ package body Sem_Expr is end if; -- Set types. - if Is_Func then - Set_Type (Expr, Get_Return_Type (Res)); - end if; + Set_Type (Expr, Get_Return_Type (Res)); Assoc_Chain := Get_Parameter_Association_Chain (Expr); Param_Chain := Get_Interface_Declaration_Chain (Res); Sem_Association_Chain @@ -1803,18 +1794,6 @@ package body Sem_Expr is -- The return type is known. -- Search for explicit subprogram. - -- LRM08 12.4 Use clause - -- b) If two potentially visible declarations are homograph - -- and one is explicitly declared and the other is - -- implicitly declared, then the implicit declaration is not - -- made directly visible. - if Flags.Flag_Explicit or else Flags.Vhdl_Std >= Vhdl_08 then - Decl := Get_Explicit_Subprogram (Overload_List); - if Decl /= Null_Iir then - return Set_Uniq_Interpretation (Decl); - end if; - end if; - -- It was impossible to find one solution. Error_Operator_Overload (Overload_List); @@ -1826,7 +1805,7 @@ package body Sem_Expr is Decl := Get_Explicit_Subprogram (Overload_List); if Decl /= Null_Iir then Error_Msg_Sem - ("(you may like to use the -fexplicit option)", Expr); + ("(you may want to use the -fexplicit option)", Expr); Explicit_Advice_Given := True; end if; end if; @@ -4016,7 +3995,9 @@ package body Sem_Expr is Res : Iir; begin Res := Sem_Expression_Ov (Expr, Null_Iir); - if Is_Overloaded (Res) then + if Res = Null_Iir or else Get_Type (Res) = Null_Iir then + return Res; + elsif Is_Overload_List (Get_Type (Res)) then declare List : constant Iir_List := Get_Overload_List (Get_Type (Res)); Res_Type : Iir; diff --git a/sem_names.adb b/sem_names.adb index 3b34ba5ce..ac62bef14 100644 --- a/sem_names.adb +++ b/sem_names.adb @@ -737,7 +737,12 @@ package body Sem_Names is end if; end if; Prefix := Get_Prefix (Attr); - Prefix_Type := Get_Type (Prefix); + -- FIXME: the prefix should be a name. + if Get_Kind (Prefix) = Iir_Kind_Type_Declaration then + Prefix_Type := Get_Type_Definition (Prefix); + else + Prefix_Type := Get_Type (Prefix); + end if; declare Dim : Iir_Int64; Indexes_List : Iir_List; @@ -812,6 +817,7 @@ package body Sem_Names is procedure Finish_Sem_Scalar_Type_Attribute (Attr : Iir; Param : Iir) is + Prefix : Iir; Prefix_Type : Iir; Prefix_Bt : Iir; Parameter : Iir; @@ -822,7 +828,8 @@ package body Sem_Names is return; end if; - Prefix_Type := Get_Type (Get_Prefix (Attr)); + Prefix := Get_Prefix (Attr); + Prefix_Type := Get_Type_Of_Type_Mark (Prefix); Prefix_Bt := Get_Base_Type (Prefix_Type); case Get_Kind (Attr) is @@ -1317,12 +1324,13 @@ package body Sem_Names is end case; end Finish_Sem_Name; - -- LRM93 §6.2 + -- LRM93 6.2 -- The evaluation of a simple name has no other effect than to determine -- the named entity denoted by the name. -- -- NAME may be a string literal too. - -- GHDL: set interpretation of NAME (possibly an overload list). + -- GHDL: set interpretation of NAME (possibly an overload list) or + -- error_mark for unknown names. -- If SOFT is TRUE, then no error message is reported in case of failure. procedure Sem_Simple_Name (Name : Iir; Keep_Alias : Boolean; Soft : Boolean) is @@ -1335,6 +1343,7 @@ package body Sem_Names is Interpretation := Get_Interpretation (Id); if not Valid_Interpretation (Interpretation) then + -- Unknown name. if not Soft then Error_Msg_Sem ("no declaration for """ & Image_Identifier (Name) & """", Name); @@ -1342,7 +1351,7 @@ package body Sem_Names is Res := Error_Mark; elsif not Valid_Interpretation (Get_Next_Interpretation (Interpretation)) then - -- not overloaded. + -- One simple interpretation. Res := Get_Declaration (Interpretation); -- For a design unit, return the library unit @@ -1353,6 +1362,7 @@ package body Sem_Names is Res := Get_Library_Unit (Res); end if; + -- Check visibility. if not Get_Visible_Flag (Res) then if Flag_Relaxed_Rules and then Get_Kind (Res) in Iir_Kinds_Object_Declaration @@ -1377,6 +1387,7 @@ package body Sem_Names is Res := Get_Name (Res); end if; else + -- Name is overloaded. Res_List := Create_Iir_List; N := 0; -- The SEEN_FLAG is used to get only one meaning which can be reached @@ -1395,12 +1406,16 @@ package body Sem_Names is end if; Interpretation := Get_Next_Interpretation (Interpretation); end loop; + + -- Clear SEEN_FLAG. for I in 0 .. N - 1 loop Res := Get_Nth_Element (Res_List, I); Set_Seen_Flag (Res, False); end loop; + Res := Create_Overload_List (Res_List); end if; + Set_Base_Name (Name, Res); Set_Named_Entity (Name, Res); end Sem_Simple_Name; @@ -1983,7 +1998,7 @@ package body Sem_Names is Res := Create_Iir (Iir_Kind_Type_Conversion); Location_Copy (Res, Name); Set_Type_Mark (Res, Prefix); - Set_Type (Res, Get_Type (Prefix)); + Set_Type (Res, Get_Type_Of_Type_Mark (Prefix)); Set_Expression (Res, Actual); else if Actual /= Null_Iir @@ -2209,16 +2224,23 @@ package body Sem_Names is function Sem_Base_Attribute (Attr : Iir_Attribute_Name) return Iir is + Prefix_Name : constant Iir := Get_Prefix (Attr); Prefix : Iir; Res : Iir; Base_Type : Iir; Type_Decl : Iir; begin - Prefix := Get_Named_Entity (Get_Prefix (Attr)); + Prefix := Get_Named_Entity (Prefix_Name); case Get_Kind (Prefix) is - when Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration => - null; + when Iir_Kind_Type_Declaration => + Base_Type := Get_Type_Definition (Prefix); + when Iir_Kind_Subtype_Declaration => + Base_Type := Get_Base_Type (Get_Type (Prefix)); + -- Get the first subtype. FIXME: ref? + Type_Decl := Get_Type_Declarator (Base_Type); + if Get_Kind (Type_Decl) = Iir_Kind_Anonymous_Type_Declaration then + Base_Type := Get_Subtype_Definition (Type_Decl); + end if; when others => Error_Msg_Sem ("prefix of 'base attribute must be a type or a subtype", Attr); @@ -2227,11 +2249,6 @@ package body Sem_Names is Res := Create_Iir (Iir_Kind_Base_Attribute); Location_Copy (Res, Attr); Set_Prefix (Res, Prefix); - Base_Type := Get_Base_Type (Get_Type (Prefix)); - Type_Decl := Get_Type_Declarator (Base_Type); - if Get_Kind (Type_Decl) = Iir_Kind_Anonymous_Type_Declaration then - Base_Type := Get_Subtype_Definition (Type_Decl); - end if; Set_Type (Res, Base_Type); return Res; end Sem_Base_Attribute; @@ -2313,30 +2330,32 @@ package body Sem_Names is end Sem_User_Attribute; function Sem_Scalar_Type_Attribute (Attr : Iir_Attribute_Name) - return Iir + return Iir is use Std_Names; - Prefix_Name : Iir; + Prefix_Name : constant Iir := Get_Prefix (Attr); + Id : constant Name_Id := Get_Attribute_Identifier (Attr); Prefix : Iir; Prefix_Type : Iir; Res : Iir; - Id : Name_Id; begin - Id := Get_Attribute_Identifier (Attr); - Prefix_Name := Get_Prefix (Attr); Prefix := Get_Named_Entity (Prefix_Name); + -- LRM93 14.1 -- Prefix: Any discrete or physical type of subtype T. case Get_Kind (Prefix) is - when Iir_Kinds_Type_Declaration - | Iir_Kind_Base_Attribute => - null; + when Iir_Kind_Type_Declaration => + Prefix_Type := Get_Type_Definition (Prefix); + when Iir_Kind_Subtype_Declaration => + Prefix_Type := Get_Type (Prefix); + when Iir_Kind_Base_Attribute => + Prefix_Type := Get_Type (Prefix); when others => Error_Msg_Sem ("prefix of '" & Name_Table.Image (Id) & " attribute must be a type", Attr); return Error_Mark; end case; - Prefix_Type := Get_Type (Prefix); + case Id is when Name_Image | Name_Value => @@ -2427,11 +2446,13 @@ package body Sem_Names is return Iir is use Std_Names; + Prefix_Name : constant Iir := Get_Prefix (Attr); + Id : constant Name_Id := Get_Attribute_Identifier (Attr); Res : Iir; Prefix : Iir; Prefix_Type : Iir; begin - case Get_Attribute_Identifier (Attr) is + case Id is when Name_Left => Res := Create_Iir (Iir_Kind_Left_Type_Attribute); when Name_Right => @@ -2449,17 +2470,25 @@ package body Sem_Names is Attr); return Error_Mark; when others => - Error_Msg_Sem ("Attribute '" - & Name_Table.Image(Get_Attribute_Identifier (Attr)) - & " not valid on this type", Attr); + Error_Msg_Sem ("Attribute '" & Name_Table.Image (Id) + & " not valid on this type", Attr); return Error_Mark; end case; Location_Copy (Res, Attr); - Prefix := Get_Named_Entity (Get_Prefix (Attr)); + Prefix := Get_Named_Entity (Prefix_Name); Set_Prefix (Res, Prefix); Set_Base_Name (Res, Res); - Prefix_Type := Get_Type (Prefix); + case Get_Kind (Prefix) is + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + Prefix_Type := Get_Type (Prefix); + Set_Expr_Staticness (Res, Get_Expr_Staticness (Prefix)); + when others => + Prefix_Type := Get_Type_Of_Type_Mark (Prefix); + Set_Expr_Staticness (Res, Get_Type_Staticness (Prefix_Type)); + end case; + case Get_Attribute_Identifier (Attr) is when Name_Ascending => -- LRM93 14.1 @@ -2470,13 +2499,6 @@ package body Sem_Names is -- Result Type: Same type as T. Set_Type (Res, Prefix_Type); end case; - case Get_Kind (Prefix) is - when Iir_Kind_Range_Array_Attribute - | Iir_Kind_Reverse_Range_Array_Attribute => - Set_Expr_Staticness (Res, Get_Expr_Staticness (Prefix)); - when others => - Set_Expr_Staticness (Res, Get_Type_Staticness (Prefix_Type)); - end case; return Res; end Sem_Predefined_Type_Attribute; @@ -2487,11 +2509,12 @@ package body Sem_Names is is use Std_Names; Prefix: Iir; + Prefix_Name : constant Iir := Get_Prefix (Attr); Prefix_Type : Iir; Res : Iir; Res_Type : Iir; begin - Prefix := Get_Named_Entity (Get_Prefix (Attr)); + Prefix := Get_Named_Entity (Prefix_Name); -- LRM93 14.1 -- Prefix: Any prefix A that is appropriate for an array object, or an @@ -2524,15 +2547,10 @@ package body Sem_Names is Error_Msg_Sem ("object prefix must be an array", Attr); return Error_Mark; end case; --- when Iir_Kind_Array_Subtype_Definition => --- Prefix_Type := Prefix; --- when Iir_Kind_Array_Type_Definition => --- Error_Type; --- return Null_Iir; when Iir_Kind_Subtype_Declaration | Iir_Kind_Type_Declaration | Iir_Kind_Base_Attribute => - Prefix_Type := Get_Type (Prefix); + Prefix_Type := Get_Type_Of_Type_Mark (Prefix); if not Is_Fully_Constrained_Type (Prefix_Type) then Error_Msg_Sem ("prefix type is not constrained", Attr); -- We continue using the unconstrained array type. @@ -2619,17 +2637,6 @@ package body Sem_Names is Set_Type (Res, Boolean_Type_Definition); end if; Set_Base_Name (Res, Res); --- Param := Get_Suffix (Attr); --- if Param /= Null_Iir then --- if Kind = Iir_Kind_Transaction_Attribute then --- Error_Msg_Sem ("'transaction does not allow a parameter", Attr); --- Param := Null_Iir; --- else --- Param := Sem_Expression --- (Param, Time_Subtype_Definition); --- Set_Parameter (Res, Param); --- end if; --- end if; if Get_Kind (Prefix) = Iir_Kind_Signal_Interface_Declaration then -- LRM93 2.1.1.2 / LRM08 4.2.2.3 @@ -2971,6 +2978,7 @@ package body Sem_Names is end if; if Get_Kind (Prefix) = Iir_Kind_Overload_List then + -- FIXME: this should be allowed. Error_Msg_Sem ("prefix of attribute is overloaded", Attr); Set_Named_Entity (Attr, Error_Mark); return; @@ -3050,8 +3058,7 @@ package body Sem_Names is end Sem_Attribute_Name; -- LRM93 §6 - procedure Sem_Name (Name : Iir; Keep_Alias : Boolean) - is + procedure Sem_Name (Name : Iir; Keep_Alias : Boolean) is begin -- Exit now if NAME was already semantized. if Get_Named_Entity (Name) /= Null_Iir then @@ -3482,9 +3489,8 @@ package body Sem_Names is when Decl_Type | Decl_Incomplete_Type => case Get_Kind (Res) is - when Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration => - Res := Get_Type (Res); + when Iir_Kind_Type_Declaration => + Res := Get_Type_Definition (Res); -- Note: RES cannot be NULL_IIR, this is just to be more -- bullet-proof. if Kind /= Decl_Incomplete_Type @@ -3495,6 +3501,8 @@ package body Sem_Names is Error_Msg_Sem ("invalid use of an incomplete type definition", Name); end if; + when Iir_Kind_Subtype_Declaration => + Res := Get_Type (Res); when others => Error_Msg_Sem ("type expected, found " & Disp_Node (Res), Name); diff --git a/sem_scopes.adb b/sem_scopes.adb index b81197de5..8028258d8 100644 --- a/sem_scopes.adb +++ b/sem_scopes.adb @@ -431,6 +431,11 @@ package body Sem_Scopes is Current_Inter: Name_Interpretation_Type; Current_Decl : Iir; + -- Before adding a new interpretation, the current interpretation + -- must be saved so that it could be restored when the current scope + -- is removed. That must be done only once per scope and per + -- interpretation. Note that the saved interpretation is not removed + -- from the chain of interpretations. procedure Save_Current_Interpretation is begin Scopes.Increment_Last; @@ -438,6 +443,7 @@ package body Sem_Scopes is (Kind => Save_Cell, Id => Ident, Inter => Current_Inter); end Save_Current_Interpretation; + -- Add DECL in the chain of interpretation for the identifier. procedure Add_New_Interpretation is begin Interpretations.Increment_Last; @@ -456,6 +462,9 @@ package body Sem_Scopes is -- (current interpretation is Conflict_Interpretation if there is -- only potentially visible declarations that are not made directly -- visible). + -- Note: in case of conflict interpretation, it may be unnecessary + -- to save the current interpretation (but it is simpler to always + -- save it). Save_Current_Interpretation; Add_New_Interpretation; return; @@ -468,7 +477,9 @@ package body Sem_Scopes is end if; -- Do not re-add a potential decl. This handles cases like: - -- 'use p.all; use p.all;' + -- 'use p.all; use p.all;'. + -- FIXME: add a flag (or reuse Visible_Flag) to avoid walking all + -- the interpretations. declare Inter: Name_Interpretation_Type := Current_Inter; begin @@ -507,6 +518,8 @@ package body Sem_Scopes is Homograph : Name_Interpretation_Type; Prev_Homograph : Name_Interpretation_Type; + -- Add DECL in the chain of interpretation, and save the current + -- one if necessary. procedure Maybe_Save_And_Add_New_Interpretation is begin if not Is_In_Current_Declarative_Region (Current_Inter) then @@ -515,6 +528,7 @@ package body Sem_Scopes is Add_New_Interpretation; end Maybe_Save_And_Add_New_Interpretation; + -- Hide HOMOGRAPH (ie unlink it from the chain of interpretation). procedure Hide_Homograph is S : Name_Interpretation_Type; @@ -541,37 +555,57 @@ package body Sem_Scopes is function Get_Hash_Non_Alias (D : Iir) return Iir_Int32 is begin - if Get_Kind (D) = Iir_Kind_Non_Object_Alias_Declaration then - return Get_Subprogram_Hash (Get_Name (D)); - else - return Get_Subprogram_Hash (D); - end if; + return Get_Subprogram_Hash (Strip_Non_Object_Alias (D)); end Get_Hash_Non_Alias; + -- Return True iff D is an implicit declaration (either a + -- subprogram or an implicit alias). + function Is_Implicit_Declaration (D : Iir) return Boolean is + begin + case Get_Kind (D) is + when Iir_Kinds_Implicit_Subprogram_Declaration => + return True; + when Iir_Kind_Non_Object_Alias_Declaration => + return Get_Implicit_Alias_Flag (D); + when Iir_Kind_Enumeration_Literal + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + return False; + when others => + Error_Kind ("is_implicit_declaration", D); + end case; + end Is_Implicit_Declaration; + -- Return TRUE iff D is an implicit alias of an implicit -- subprogram. function Is_Implicit_Alias (D : Iir) return Boolean is begin + -- FIXME: Is it possible to have an implicit alias of an + -- explicit subprogram ? Yes for enumeration literal and + -- physical units. return Get_Kind (D) = Iir_Kind_Non_Object_Alias_Declaration and then Get_Implicit_Alias_Flag (D) and then (Get_Kind (Get_Name (D)) in Iir_Kinds_Implicit_Subprogram_Declaration); end Is_Implicit_Alias; - procedure Replace_Current_Interpretation is + -- Replace the homograph of DECL by DECL. + procedure Replace_Homograph is begin - Interpretations.Table (Current_Inter).Decl := Decl; - end Replace_Current_Interpretation; + Interpretations.Table (Homograph).Decl := Decl; + end Replace_Homograph; Decl_Hash : Iir_Int32; Hash : Iir_Int32; begin Decl_Hash := Get_Hash_Non_Alias (Decl); if Decl_Hash = 0 then + -- The hash must have been computed. raise Internal_Error; end if; - -- Find an homograph of this declaration. + -- Find an homograph of this declaration (and also keep the + -- interpretation just before it in the chain), Homograph := Current_Inter; Prev_Homograph := No_Name_Interpretation; while Homograph /= No_Name_Interpretation loop @@ -591,51 +625,95 @@ package body Sem_Scopes is -- There is an homograph. if Potentially then - -- LRM 10.4 Use Clauses + -- Added DECL would be made potentially visible. + + -- LRM93 10.4 1) / LRM08 12.4 a) Use Clauses -- 1. A potentially visible declaration is not made - -- directly visible if the place considered is within the - -- immediate scope of a homograph of the declaration. + -- directly visible if the place considered is within the + -- immediate scope of a homograph of the declaration. if Is_In_Current_Declarative_Region (Homograph) then if not Is_Potentially_Visible (Homograph) then return; end if; + end if; - -- GHDL: if the homograph is in the same declarative - -- region than DECL, it must be an implicit declaration - -- to be hidden. - -- FIXME: this rule is not in the LRM. - if Get_Parent (Decl) = Get_Parent (Current_Decl) then - if Flags.Vhdl_Std >= Vhdl_08 - and then Is_Implicit_Alias (Decl) + -- LRM08 12.4 Use Clauses + -- b) If two potentially visible declarations are homograph + -- and one is explicitly declared and the other is + -- implicitly declared, then the implicit declaration is + -- not made directly visible. + if (Flags.Flag_Explicit or else Flags.Vhdl_Std >= Vhdl_08) + and then Is_Potentially_Visible (Homograph) + then + declare + Implicit_Current_Decl : constant Boolean := + Is_Implicit_Declaration (Current_Decl); + Implicit_Decl : constant Boolean := + Is_Implicit_Declaration (Decl); + begin + if Implicit_Current_Decl and then not Implicit_Decl then + if Is_In_Current_Declarative_Region (Homograph) then + Replace_Homograph; + else + -- Hide homoraph and insert decl. + Maybe_Save_And_Add_New_Interpretation; + Hide_Homograph; + end if; + return; + elsif not Implicit_Current_Decl and then Implicit_Decl + then + -- Discard decl. + return; + elsif Strip_Non_Object_Alias (Decl) + = Strip_Non_Object_Alias (Current_Decl) then - -- Re-declaration of an implicit subprogram via - -- an implicit alias is simply discarded. + -- This rule is not written clearly in the LRM, but + -- if two designators denote the same named entity, + -- no need to make both visible. return; end if; + end; + end if; - -- Note: no need to save previous interpretation, as it - -- is in the same declarative region. - Add_New_Interpretation; - Hide_Homograph; - return; - end if; - - -- The homograph is potentially visible and was declared - -- in a scope different from the DECL scope. - -- (ie, it was certainly made visible by another use - -- clause). - Add_New_Interpretation; - return; - else - -- The homograph was made visible in an outer declarative - -- region. Therefore, it must not be hidden. - Maybe_Save_And_Add_New_Interpretation; + -- GHDL: if the homograph is in the same declarative + -- region than DECL, it must be an implicit declaration + -- to be hidden. + -- FIXME: this rule is not in the LRM93, but it is necessary + -- so that explicit declaration hides the implicit one. + if Flags.Vhdl_Std < Vhdl_08 + and then not Flags.Flag_Explicit + and then Get_Parent (Decl) = Get_Parent (Current_Decl) + then + declare + Implicit_Current_Decl : constant Boolean := + (Get_Kind (Current_Decl) + in Iir_Kinds_Implicit_Subprogram_Declaration); + Implicit_Decl : constant Boolean := + (Get_Kind (Decl) + in Iir_Kinds_Implicit_Subprogram_Declaration); + begin + if Implicit_Current_Decl and not Implicit_Decl then + -- Note: no need to save previous interpretation, as + -- it is in the same declarative region. + -- Replace the previous homograph with DECL. + Replace_Homograph; + return; + elsif not Implicit_Current_Decl and Implicit_Decl then + -- As we have replaced the homograph, it is possible + -- than the implicit declaration is re-added (by + -- a new use clause). Discard it. + return; + end if; + end; end if; - return; + -- The homograph was made visible in an outer declarative + -- region. Therefore, it must not be hidden. + Maybe_Save_And_Add_New_Interpretation; + return; else - -- Added DECL was declared in the current declarative region. + -- Added DECL would be made directly visible. if not Is_Potentially_Visible (Homograph) then -- The homograph was also declared in that declarative @@ -694,7 +772,7 @@ package body Sem_Scopes is -- They aren't homograph but DECL is stronger -- (at it is not an implicit declaration) -- than CURRENT_DECL - Replace_Current_Interpretation; + Replace_Homograph; end if; return; @@ -757,7 +835,7 @@ package body Sem_Scopes is -- They are perhaps visible in the same declarative region. if Is_Potentially_Visible (Current_Inter) then if Potentially then - -- LRM93 §10.4, item #2 + -- LRM93 10.4 2) / LRM08 12.4 c) Use clauses -- Potentially visible declarations that have the same -- designator are not made directly visible unless each of -- them is either an enumeration literal specification or @@ -882,9 +960,7 @@ package body Sem_Scopes is end if; end Replace_Name; - procedure Name_Visible (Ident : Name_Id; Decl : Iir) - is - pragma Unreferenced (Ident); + procedure Name_Visible (Decl : Iir) is begin if Get_Visible_Flag (Decl) then -- A name can be made visible only once. @@ -893,11 +969,6 @@ package body Sem_Scopes is Set_Visible_Flag (Decl, True); end Name_Visible; - procedure Name_Visible (Decl : Iir) is - begin - Name_Visible (Get_Identifier (Decl), Decl); - end Name_Visible; - procedure Iterator_Decl (Decl : Iir; Arg : Arg_Type) is begin @@ -937,7 +1008,7 @@ package body Sem_Scopes is List : Iir_List; El : Iir; begin - Def := Get_Type (Decl); + Def := Get_Type_Definition (Decl); -- Handle incomplete type declaration. if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then @@ -962,7 +1033,7 @@ package body Sem_Scopes is Def : Iir; El : Iir; begin - Def := Get_Type (Decl); + Def := Get_Type_Definition (Decl); if Get_Kind (Def) = Iir_Kind_Physical_Type_Definition then El := Get_Unit_Chain (Def); @@ -1222,12 +1293,6 @@ package body Sem_Scopes is is use Ada.Text_IO; use Name_Table; - procedure Disp_Type (Str : String; Node : Iir) is - begin - Put (Str); - Put_Line - (Image (Get_Identifier (Get_Type_Declarator (Node)))); - end Disp_Type; Inter: Name_Interpretation_Type; Decl : Iir; @@ -1237,18 +1302,17 @@ package body Sem_Scopes is Inter := Get_Interpretation (Ident); while Valid_Interpretation (Inter) loop + Put (Name_Interpretation_Type'Image (Inter)); + if Is_Potentially_Visible (Inter) then + Put (" (use)"); + end if; + Put (": "); Decl := Get_Declaration (Inter); - Put (' '); Put (Iir_Kind'Image (Get_Kind (Decl))); Put_Line (", loc: " & Get_Location_Str (Get_Location (Decl))); - case Get_Kind (Decl) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Implicit_Function_Declaration => - Disp_Type (" return type: ", Get_Return_Type (Decl)); - null; - when others => - null; - end case; + if Get_Kind (Decl) in Iir_Kinds_Subprogram_Declaration then + Put_Line (" " & Disp_Subprg (Decl)); + end if; Inter := Get_Next_Interpretation (Inter); end loop; end Disp_Detailed_Interpretations; diff --git a/sem_scopes.ads b/sem_scopes.ads index bf495b353..76faaf191 100644 --- a/sem_scopes.ads +++ b/sem_scopes.ads @@ -39,14 +39,11 @@ package Sem_Scopes is procedure Open_Declarative_Region; procedure Close_Declarative_Region; - -- Add interpretation DECL for ID to the current declarative region. - -- ID is an identifier or a character literal. - -- Note: ID may be different from get_identifier (DECL), since for example - -- DECL may be a type definition. + -- Add meaning DECL for its identifier to the current declarative region. procedure Add_Name (Decl: Iir); pragma Inline (Add_Name); - -- Add interpretation DECL to the identifier of DECL. + -- Add meaning DECL to the identifier IDENT. -- POTENTIALLY is true if the identifier comes from a use clause. procedure Add_Name (Decl: Iir; Ident : Name_Id; Potentially: Boolean); @@ -63,6 +60,9 @@ package Sem_Scopes is procedure Replace_Name (Id: Name_Id; Old : Iir; Decl: Iir); -- Interpretation is a simply linked list of what an identifier means. + -- In LRM08 12.3 Visibility, the sentence is 'the declaration defines a + -- possible meaning of this occurrence'. + -- FIXME: replace Interpretation by Meaning. type Name_Interpretation_Type is private; -- Return true if INTER is a valid interpretation, ie has a corresponding diff --git a/sem_specs.adb b/sem_specs.adb index 3c09fb787..0e28161c3 100644 --- a/sem_specs.adb +++ b/sem_specs.adb @@ -413,7 +413,7 @@ package body Sem_Specs is Sem_Named_Entity (El); case Get_Kind (El) is when Iir_Kind_Type_Declaration => - Def := Get_Type (El); + Def := Get_Type_Definition (El); if Get_Kind (Def) = Iir_Kind_Enumeration_Type_Definition then declare List : Iir_List; @@ -428,7 +428,7 @@ package body Sem_Specs is end; end if; when Iir_Kind_Anonymous_Type_Declaration => - Def := Get_Type (El); + Def := Get_Type_Definition (El); if Get_Kind (Def) = Iir_Kind_Physical_Type_Definition then declare El1 : Iir; @@ -757,7 +757,8 @@ package body Sem_Specs is return; when Iir_Kind_Anonymous_Type_Declaration => -- A physical type definition declares units. - if Get_Kind (Get_Type (Decl)) = Iir_Kind_Physical_Type_Definition + if Get_Kind (Get_Type_Definition (Decl)) + = Iir_Kind_Physical_Type_Definition then Decl_Class := Tok_Units; else @@ -768,7 +769,7 @@ package body Sem_Specs is when Iir_Kind_Type_Declaration => Decl_Class := Tok_Type; -- An enumeration type declares literals. - if Get_Kind (Get_Type (Decl)) + if Get_Kind (Get_Type_Definition (Decl)) = Iir_Kind_Enumeration_Type_Definition then Decl_Class2 := Tok_Literal; diff --git a/sem_stmts.adb b/sem_stmts.adb index 8067abb8b..30ea99cae 100644 --- a/sem_stmts.adb +++ b/sem_stmts.adb @@ -711,6 +711,12 @@ package body Sem_Stmts is Set_Expression (Stmt, Expr); Target_Type := Get_Type (Expr); + -- An aggregate cannot be analyzed without a type. + -- FIXME: partially analyze the aggregate ? + if Target_Type = Null_Iir then + return; + end if; + -- FIXME: check elements are identified at most once. else Target_Type := Null_Iir; diff --git a/sem_types.adb b/sem_types.adb index 2bf032b78..e7f8c97b4 100644 --- a/sem_types.adb +++ b/sem_types.adb @@ -474,7 +474,7 @@ package body Sem_Types is Decl : Iir_Protected_Type_Declaration; El : Iir; begin - Decl := Get_Type (Type_Decl); + Decl := Get_Type_Definition (Type_Decl); Set_Base_Type (Decl, Decl); Set_Resolved_Flag (Decl, False); Set_Signal_Type_Flag (Decl, False); @@ -564,7 +564,7 @@ package body Sem_Types is then Type_Decl := Get_Declaration (Inter); if Get_Kind (Type_Decl) = Iir_Kind_Type_Declaration then - Decl := Get_Type (Type_Decl); + Decl := Get_Type_Definition (Type_Decl); else Decl := Null_Iir; end if; diff --git a/simulate/annotations.adb b/simulate/annotations.adb index e4e921aca..00c8f715b 100644 --- a/simulate/annotations.adb +++ b/simulate/annotations.adb @@ -604,8 +604,9 @@ package body Annotations is Add_Quantity_Info (Block_Info, Decl); when Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration | Iir_Kind_Anonymous_Type_Declaration => + Annotate_Type_Definition (Block_Info, Get_Type_Definition (Decl)); + when Iir_Kind_Subtype_Declaration => Annotate_Type_Definition (Block_Info, Get_Type (Decl)); when Iir_Kind_Protected_Type_Body => diff --git a/simulate/elaboration.adb b/simulate/elaboration.adb index 1b7b9cd3a..ec2442acd 100644 --- a/simulate/elaboration.adb +++ b/simulate/elaboration.adb @@ -346,6 +346,8 @@ package body Elaboration is end if; else -- Note: the body can elaborate some packages. + Elaborate_Dependence (Body_Design); + Elaborate_Package_Body (Get_Library_Unit (Body_Design)); end if; @@ -842,7 +844,7 @@ package body Elaboration is -- Elaboration of a type declaration generally consists of the -- elaboration of the definition of the type and the creation of that -- type. - Def := Get_Type (Decl); + Def := Get_Type_Definition (Decl); if Def = Null_Iir then -- FIXME: can this happen ? raise Program_Error; @@ -2177,7 +2179,7 @@ package body Elaboration is | Iir_Kind_Implicit_Procedure_Declaration => null; when Iir_Kind_Anonymous_Type_Declaration => - Elaborate_Type_Definition (Instance, Get_Type (Decl)); + Elaborate_Type_Definition (Instance, Get_Type_Definition (Decl)); when Iir_Kind_Type_Declaration => Elaborate_Type_Declaration (Instance, Decl); when Iir_Kind_Subtype_Declaration => diff --git a/simulate/execution.adb b/simulate/execution.adb index 3be904fd4..a3a29d485 100644 --- a/simulate/execution.adb +++ b/simulate/execution.adb @@ -40,6 +40,7 @@ with Grt.Vstrings; with Grt_Interface; with Grt.Values; with Grt.Errors; +with Grt.Std_Logic_1164; package body Execution is @@ -53,6 +54,11 @@ package body Execution is (Proc : Process_State_Acc; Complex_Stmt : Iir); procedure Update_Next_Statement (Proc : Process_State_Acc); + -- Display a message when an assertion has failed. + procedure Execute_Failed_Assertion (Report : String; + Severity : Natural; + Stmt: Iir); + function Get_Instance_By_Scope_Level (Instance: Block_Instance_Acc; Scope_Level: Scope_Level_Type) return Block_Instance_Acc @@ -150,6 +156,44 @@ package body Execution is return Res; end Create_Bounds_From_Length; + function Execute_High_Limit (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + if Bounds.Dir = Iir_To then + return Bounds.Right; + else + return Bounds.Left; + end if; + end Execute_High_Limit; + + function Execute_Low_Limit (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + if Bounds.Dir = Iir_To then + return Bounds.Left; + else + return Bounds.Right; + end if; + end Execute_Low_Limit; + + function Execute_Left_Limit (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Bounds.Left; + end Execute_Left_Limit; + + function Execute_Right_Limit (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Bounds.Right; + end Execute_Right_Limit; + + function Execute_Length (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Create_I64_Value (Ghdl_I64 (Bounds.Length)); + end Execute_Length; + function Create_Enum_Value (Pos : Natural; Etype : Iir) return Iir_Value_Literal_Acc is @@ -348,6 +392,48 @@ package body Execution is return Res; end Execute_Shift_Operator; + Hex_Chars : constant array (Natural range 0 .. 15) of Character := + "0123456789ABCDEF"; + + function Execute_Bit_Vector_To_String (Val : Iir_Value_Literal_Acc; + Log_Base : Natural) + return Iir_Value_Literal_Acc + is + Base : constant Natural := 2 ** Log_Base; + Blen : constant Natural := Natural (Val.Bounds.D (1).Length); + Str : String (1 .. (Blen + Log_Base - 1) / Log_Base); + Pos : Natural; + V : Natural; + N : Natural; + begin + V := 0; + N := 1; + Pos := Str'Last; + for I in reverse Val.Val_Array.V'Range loop + V := V + Ghdl_B2'Pos (Val.Val_Array.V (I).B2) * N; + N := N * 2; + if N = Base or else I = Val.Val_Array.V'First then + Str (Pos) := Hex_Chars (V); + Pos := Pos - 1; + N := 1; + V := 0; + end if; + end loop; + return String_To_Iir_Value (Str); + end Execute_Bit_Vector_To_String; + + procedure Check_Std_Ulogic_Dc + (Loc : Iir; V : Grt.Std_Logic_1164.Std_Ulogic) + is + use Grt.Std_Logic_1164; + begin + if V = '-' then + Execute_Failed_Assertion + ("STD_LOGIC_1164: '-' operand for matching ordering operator", + 2, Loc); + end if; + end Check_Std_Ulogic_Dc; + -- EXPR is the expression whose implementation is an implicit function. function Execute_Implicit_Function (Block : Block_Instance_Acc; Expr: Iir; @@ -385,12 +471,18 @@ package body Execution is begin Func := Get_Implicit_Definition (Get_Implementation (Expr)); - -- Eval left operand (only if the predefined function is not NOW). - if Func /= Iir_Predefined_Now_Function then - Left := Execute_Expression (Block, Left_Param); - else - Left := null; - end if; + -- Eval left operand. + case Func is + when Iir_Predefined_Now_Function => + Left := null; + when Iir_Predefined_Bit_Rising_Edge + | Iir_Predefined_Boolean_Rising_Edge + | Iir_Predefined_Bit_Falling_Edge + | Iir_Predefined_Boolean_Falling_Edge=> + Operand := Execute_Name (Block, Left_Param, True); + when others => + Left := Execute_Expression (Block, Left_Param); + end case; Right := null; case Func is @@ -521,6 +613,9 @@ package body Execution is | Iir_Predefined_Boolean_Not => Result := Boolean_To_Lit (Operand.B2 = Lit_Enum_0.B2); + when Iir_Predefined_Bit_Condition => + Result := Boolean_To_Lit (Operand.B2 = Lit_Enum_1.B2); + when Iir_Predefined_Array_Sll | Iir_Predefined_Array_Srl | Iir_Predefined_Array_Sla @@ -536,7 +631,9 @@ package body Execution is | Iir_Predefined_Access_Equality | Iir_Predefined_Physical_Equality | Iir_Predefined_Floating_Equality - | Iir_Predefined_Record_Equality => + | Iir_Predefined_Record_Equality + | Iir_Predefined_Bit_Match_Equality + | Iir_Predefined_Bit_Array_Match_Equality => Eval_Right; Result := Boolean_To_Lit (Is_Equal (Left, Right)); when Iir_Predefined_Enum_Inequality @@ -545,7 +642,9 @@ package body Execution is | Iir_Predefined_Access_Inequality | Iir_Predefined_Physical_Inequality | Iir_Predefined_Floating_Inequality - | Iir_Predefined_Record_Inequality => + | Iir_Predefined_Record_Inequality + | Iir_Predefined_Bit_Match_Inequality + | Iir_Predefined_Bit_Array_Match_Inequality => Eval_Right; Result := Boolean_To_Lit (not Is_Equal (Left, Right)); when Iir_Predefined_Integer_Less @@ -625,6 +724,23 @@ package body Execution is raise Internal_Error; end case; + when Iir_Predefined_Enum_Minimum + | Iir_Predefined_Physical_Minimum => + Eval_Right; + if Compare_Value (Left, Right) = Less then + Result := Left; + else + Result := Right; + end if; + when Iir_Predefined_Enum_Maximum + | Iir_Predefined_Physical_Maximum => + Eval_Right; + if Compare_Value (Left, Right) = Less then + Result := Right; + else + Result := Left; + end if; + when Iir_Predefined_Integer_Plus | Iir_Predefined_Physical_Plus => Eval_Right; @@ -834,6 +950,102 @@ package body Execution is Result.Val_Array.V (I).B2 := Result.Val_Array.V (I).B2 xor Right.Val_Array.V (I).B2; end loop; + when Iir_Predefined_TF_Array_Xnor => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B2 := + not (Result.Val_Array.V (I).B2 xor Right.Val_Array.V (I).B2); + end loop; + + when Iir_Predefined_TF_Array_Element_And => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B2 := + Result.Val_Array.V (I).B2 and Right.B2; + end loop; + when Iir_Predefined_TF_Element_Array_And => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B2 := + Result.Val_Array.V (I).B2 and Left.B2; + end loop; + + when Iir_Predefined_TF_Array_Element_Or => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B2 := + Result.Val_Array.V (I).B2 or Right.B2; + end loop; + when Iir_Predefined_TF_Element_Array_Or => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B2 := + Result.Val_Array.V (I).B2 or Left.B2; + end loop; + + when Iir_Predefined_TF_Array_Element_Xor => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B2 := + Result.Val_Array.V (I).B2 xor Right.B2; + end loop; + when Iir_Predefined_TF_Element_Array_Xor => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B2 := + Result.Val_Array.V (I).B2 xor Left.B2; + end loop; + + when Iir_Predefined_TF_Array_Element_Nand => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B2 := + not (Result.Val_Array.V (I).B2 and Right.B2); + end loop; + when Iir_Predefined_TF_Element_Array_Nand => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B2 := + not (Result.Val_Array.V (I).B2 and Left.B2); + end loop; + + when Iir_Predefined_TF_Array_Element_Nor => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B2 := + not (Result.Val_Array.V (I).B2 or Right.B2); + end loop; + when Iir_Predefined_TF_Element_Array_Nor => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B2 := + not (Result.Val_Array.V (I).B2 or Left.B2); + end loop; + + when Iir_Predefined_TF_Array_Element_Xnor => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B2 := + not (Result.Val_Array.V (I).B2 xor Right.B2); + end loop; + when Iir_Predefined_TF_Element_Array_Xnor => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B2 := + not (Result.Val_Array.V (I).B2 xor Left.B2); + end loop; when Iir_Predefined_TF_Array_Not => -- Need to copy as the result is modified. @@ -842,6 +1054,51 @@ package body Execution is Result.Val_Array.V (I).B2 := not Result.Val_Array.V (I).B2; end loop; + when Iir_Predefined_TF_Reduction_And => + Result := Create_B2_Value (True); + for I in Operand.Val_Array.V'Range loop + Result.B2 := Result.B2 and Operand.Val_Array.V (I).B2; + end loop; + when Iir_Predefined_TF_Reduction_Nand => + Result := Create_B2_Value (True); + for I in Operand.Val_Array.V'Range loop + Result.B2 := Result.B2 and Operand.Val_Array.V (I).B2; + end loop; + Result.B2 := not Result.B2; + when Iir_Predefined_TF_Reduction_Or => + Result := Create_B2_Value (False); + for I in Operand.Val_Array.V'Range loop + Result.B2 := Result.B2 or Operand.Val_Array.V (I).B2; + end loop; + when Iir_Predefined_TF_Reduction_Nor => + Result := Create_B2_Value (False); + for I in Operand.Val_Array.V'Range loop + Result.B2 := Result.B2 or Operand.Val_Array.V (I).B2; + end loop; + Result.B2 := not Result.B2; + when Iir_Predefined_TF_Reduction_Xor => + Result := Create_B2_Value (False); + for I in Operand.Val_Array.V'Range loop + Result.B2 := Result.B2 xor Operand.Val_Array.V (I).B2; + end loop; + when Iir_Predefined_TF_Reduction_Xnor => + Result := Create_B2_Value (False); + for I in Operand.Val_Array.V'Range loop + Result.B2 := Result.B2 xor Operand.Val_Array.V (I).B2; + end loop; + Result.B2 := not Result.B2; + + when Iir_Predefined_Bit_Rising_Edge + | Iir_Predefined_Boolean_Rising_Edge => + return Boolean_To_Lit + (Execute_Event_Attribute (Operand) + and then Execute_Signal_Value (Operand).B2 = True); + when Iir_Predefined_Bit_Falling_Edge + | Iir_Predefined_Boolean_Falling_Edge => + return Boolean_To_Lit + (Execute_Event_Attribute (Operand) + and then Execute_Signal_Value (Operand).B2 = False); + when Iir_Predefined_Array_Greater => Eval_Right; Result := Boolean_To_Lit (Compare_Value (Left, Right) = Greater); @@ -858,16 +1115,226 @@ package body Execution is Eval_Right; Result := Boolean_To_Lit (Compare_Value (Left, Right) <= Equal); + when Iir_Predefined_Array_Minimum => + Eval_Right; + if Compare_Value (Left, Right) = Less then + Result := Left; + else + Result := Right; + end if; + when Iir_Predefined_Array_Maximum => + Eval_Right; + if Compare_Value (Left, Right) = Less then + Result := Right; + else + Result := Left; + end if; + + when Iir_Predefined_Vector_Maximum => + declare + El_St : constant Iir := + Get_Return_Type (Get_Implementation (Expr)); + V : Iir_Value_Literal_Acc; + begin + Result := Execute_Low_Limit (Execute_Bounds (Block, El_St)); + for I in Left.Val_Array.V'Range loop + V := Left.Val_Array.V (I); + if Compare_Value (V, Result) = Greater then + Result := V; + end if; + end loop; + end; + when Iir_Predefined_Vector_Minimum => + declare + El_St : constant Iir := + Get_Return_Type (Get_Implementation (Expr)); + V : Iir_Value_Literal_Acc; + begin + Result := Execute_High_Limit (Execute_Bounds (Block, El_St)); + for I in Left.Val_Array.V'Range loop + V := Left.Val_Array.V (I); + if Compare_Value (V, Result) = Less then + Result := V; + end if; + end loop; + end; + when Iir_Predefined_Endfile => Result := Boolean_To_Lit (File_Operation.Endfile (Left, Null_Iir)); when Iir_Predefined_Now_Function => Result := Create_I64_Value (Ghdl_I64 (Grt.Types.Current_Time)); - when Iir_Predefined_Integer_To_String => + when Iir_Predefined_Integer_To_String + | Iir_Predefined_Floating_To_String + | Iir_Predefined_Physical_To_String => Result := String_To_Iir_Value (Execute_Image_Attribute (Left, Get_Type (Left_Param))); + when Iir_Predefined_Enum_To_String => + declare + use Name_Table; + Base_Type : constant Iir := + Get_Base_Type (Get_Type (Left_Param)); + Lits : constant Iir_List := + Get_Enumeration_Literal_List (Base_Type); + Pos : constant Natural := Get_Enum_Pos (Left); + Id : Name_Id; + begin + if Base_Type = Std_Package.Character_Type_Definition then + Result := String_To_Iir_Value ((1 => Character'Val (Pos))); + else + Id := Get_Identifier (Get_Nth_Element (Lits, Pos)); + if Is_Character (Id) then + Result := String_To_Iir_Value ((1 => Get_Character (Id))); + else + Result := String_To_Iir_Value (Image (Id)); + end if; + end if; + end; + + when Iir_Predefined_Array_Char_To_String => + declare + Str : String (1 .. Natural (Left.Bounds.D (1).Length)); + Lits : constant Iir_List := + Get_Enumeration_Literal_List + (Get_Base_Type + (Get_Element_Subtype (Get_Type (Left_Param)))); + Pos : Natural; + begin + for I in Left.Val_Array.V'Range loop + Pos := Get_Enum_Pos (Left.Val_Array.V (I)); + Str (Positive (I)) := Name_Table.Get_Character + (Get_Identifier (Get_Nth_Element (Lits, Pos))); + end loop; + Result := String_To_Iir_Value (Str); + end; + + when Iir_Predefined_Bit_Vector_To_Hstring => + return Execute_Bit_Vector_To_String (Left, 4); + + when Iir_Predefined_Bit_Vector_To_Ostring => + return Execute_Bit_Vector_To_String (Left, 3); + + when Iir_Predefined_Real_To_String_Digits => + Eval_Right; + declare + Str : Grt.Vstrings.String_Real_Digits; + Last : Natural; + begin + Grt.Vstrings.To_String + (Str, Last, Left.F64, Ghdl_I32 (Right.I64)); + Result := String_To_Iir_Value (Str (1 .. Last)); + end; + when Iir_Predefined_Real_To_String_Format => + Eval_Right; + declare + Format : String (1 .. Natural (Right.Val_Array.Len) + 1); + Str : Grt.Vstrings.String_Real_Format; + Last : Natural; + begin + for I in Right.Val_Array.V'Range loop + Format (Positive (I)) := + Character'Val (Right.Val_Array.V (I).E32); + end loop; + Format (Format'Last) := ASCII.NUL; + Grt.Vstrings.To_String + (Str, Last, Left.F64, To_Ghdl_C_String (Format'Address)); + Result := String_To_Iir_Value (Str (1 .. Last)); + end; + when Iir_Predefined_Time_To_String_Unit => + Eval_Right; + declare + Str : Grt.Vstrings.String_Time_Unit; + First : Natural; + Unit : Iir; + begin + Unit := Get_Unit_Chain (Std_Package.Time_Type_Definition); + while Unit /= Null_Iir loop + exit when Evaluation.Get_Physical_Value (Unit) + = Iir_Int64 (Right.I64); + Unit := Get_Chain (Unit); + end loop; + if Unit = Null_Iir then + Error_Msg_Exec + ("to_string for time called with wrong unit", Expr); + end if; + Grt.Vstrings.To_String (Str, First, Left.I64, Right.I64); + Result := String_To_Iir_Value + (Str (First .. Str'Last) & ' ' + & Name_Table.Image (Get_Identifier (Unit))); + end; + + when Iir_Predefined_Std_Ulogic_Match_Equality => + Eval_Right; + declare + use Grt.Std_Logic_1164; + begin + Result := Create_E32_Value + (Std_Ulogic'Pos + (Match_Eq_Table (Std_Ulogic'Val (Left.E32), + Std_Ulogic'Val (Right.E32)))); + end; + when Iir_Predefined_Std_Ulogic_Match_Inequality => + Eval_Right; + declare + use Grt.Std_Logic_1164; + begin + Result := Create_E32_Value + (Std_Ulogic'Pos + (Not_Table (Match_Eq_Table (Std_Ulogic'Val (Left.E32), + Std_Ulogic'Val (Right.E32))))); + end; + when Iir_Predefined_Std_Ulogic_Match_Ordering_Functions => + Eval_Right; + declare + use Grt.Std_Logic_1164; + L : constant Std_Ulogic := Std_Ulogic'Val (Left.E32); + R : constant Std_Ulogic := Std_Ulogic'Val (Right.E32); + Res : Std_Ulogic; + begin + Check_Std_Ulogic_Dc (Expr, L); + Check_Std_Ulogic_Dc (Expr, R); + case Iir_Predefined_Std_Ulogic_Match_Ordering_Functions (Func) + is + when Iir_Predefined_Std_Ulogic_Match_Less => + Res := Match_Lt_Table (L, R); + when Iir_Predefined_Std_Ulogic_Match_Less_Equal => + Res := Or_Table (Match_Lt_Table (L, R), + Match_Eq_Table (L, R)); + when Iir_Predefined_Std_Ulogic_Match_Greater => + Res := Not_Table (Or_Table (Match_Lt_Table (L, R), + Match_Eq_Table (L, R))); + when Iir_Predefined_Std_Ulogic_Match_Greater_Equal => + Res := Not_Table (Match_Lt_Table (L, R)); + end case; + Result := Create_E32_Value (Std_Ulogic'Pos (Res)); + end; + + when Iir_Predefined_Std_Ulogic_Array_Match_Equality + | Iir_Predefined_Std_Ulogic_Array_Match_Inequality => + Eval_Right; + if Left.Bounds.D (1).Length /= Right.Bounds.D (1).Length then + Error_Msg_Constraint (Expr); + end if; + declare + use Grt.Std_Logic_1164; + Res : Std_Ulogic := '1'; + begin + Result := Create_E32_Value (Std_Ulogic'Pos ('1')); + for I in Left.Val_Array.V'Range loop + Res := And_Table + (Res, + Match_Eq_Table + (Std_Ulogic'Val (Left.Val_Array.V (I).E32), + Std_Ulogic'Val (Right.Val_Array.V (I).E32))); + end loop; + if Func = Iir_Predefined_Std_Ulogic_Array_Match_Inequality then + Res := Not_Table (Res); + end if; + Result := Create_E32_Value (Std_Ulogic'Pos (Res)); + end; + when others => Error_Msg ("execute_implicit_function: unimplemented " & Iir_Predefined_Functions'Image (Func)); @@ -927,6 +1394,8 @@ package body Execution is end if; when Iir_Predefined_Read => File_Operation.Read_Binary (Args (0), Args (1)); + when Iir_Predefined_Flush => + File_Operation.Flush (Args (0)); when Iir_Predefined_File_Close => if Get_Text_File_Flag (Get_Type (Inter_Chain)) then File_Operation.File_Close_Text (Args (0), Stmt); @@ -961,6 +1430,9 @@ package body Execution is when Std_Names.Name_Untruncated_Text_Read => File_Operation.Untruncated_Text_Read (Args (0), Args (1), Args (2)); + when Std_Names.Name_Control_Simulation => + Put_Line (Standard_Error, "simulation finished"); + raise Simulation_Finished; when others => Error_Msg_Exec ("unsupported foreign procedure call", Stmt); end case; @@ -1727,44 +2199,6 @@ package body Execution is return Bound; end Execute_Bounds; - function Execute_High_Limit (Bounds : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - if Bounds.Dir = Iir_To then - return Bounds.Right; - else - return Bounds.Left; - end if; - end Execute_High_Limit; - - function Execute_Low_Limit (Bounds : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - if Bounds.Dir = Iir_To then - return Bounds.Left; - else - return Bounds.Right; - end if; - end Execute_Low_Limit; - - function Execute_Left_Limit (Bounds : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - return Bounds.Left; - end Execute_Left_Limit; - - function Execute_Right_Limit (Bounds : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - return Bounds.Right; - end Execute_Right_Limit; - - function Execute_Length (Bounds : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - return Create_I64_Value (Ghdl_I64 (Bounds.Length)); - end Execute_Length; - -- Perform type conversion as desribed in LRM93 7.3.5 function Execute_Type_Conversion (Block: Block_Instance_Acc; Conv : Iir_Type_Conversion; @@ -1996,8 +2430,13 @@ package body Execution is if Base /= null then Res := Base; else - Slot_Block := Get_Instance_For_Slot (Block, Expr); - Res := Slot_Block.Objects (Get_Info (Expr).Slot); + declare + Info : constant Sim_Info_Acc := Get_Info (Expr); + begin + Slot_Block := + Get_Instance_By_Scope_Level (Block, Info.Scope_Level); + Res := Slot_Block.Objects (Info.Slot); + end; end if; when Iir_Kind_Indexed_Name => @@ -2145,7 +2584,7 @@ package body Execution is return Iir_Value_Literal_Acc is Val : Iir_Value_Literal_Acc; - Attr_Type : constant Iir := Get_Type (Get_Prefix (Expr)); + Attr_Type : constant Iir := Get_Type_Of_Type_Mark (Get_Prefix (Expr)); begin Val := Execute_Expression (Block, Get_Parameter (Expr)); return String_To_Iir_Value @@ -2612,7 +3051,8 @@ package body Execution is when Iir_Kind_Val_Attribute => declare - Prefix_Type: constant Iir := Get_Type (Get_Prefix (Expr)); + Prefix_Type: constant Iir := + Get_Type_Of_Type_Mark (Get_Prefix (Expr)); Base_Type : constant Iir := Get_Base_Type (Prefix_Type); Mode : constant Iir_Value_Kind := Get_Info (Base_Type).Scalar_Mode; @@ -2636,7 +3076,8 @@ package body Execution is when Iir_Kind_Pos_Attribute => declare N_Res: Iir_Value_Literal_Acc; - Prefix_Type: constant Iir := Get_Type (Get_Prefix (Expr)); + Prefix_Type: constant Iir := + Get_Type_Of_Type_Mark (Get_Prefix (Expr)); Base_Type : constant Iir := Get_Base_Type (Prefix_Type); Mode : constant Iir_Value_Kind := Get_Info (Base_Type).Scalar_Mode; @@ -2676,7 +3117,8 @@ package body Execution is Bound : Iir_Value_Literal_Acc; begin Res := Execute_Expression (Block, Get_Parameter (Expr)); - Bound := Execute_Bounds (Block, Get_Type (Get_Prefix (Expr))); + Bound := Execute_Bounds + (Block, Get_Type_Of_Type_Mark (Get_Prefix (Expr))); case Bound.Dir is when Iir_To => Res := Execute_Dec (Res, Expr); @@ -2692,7 +3134,8 @@ package body Execution is Bound : Iir_Value_Literal_Acc; begin Res := Execute_Expression (Block, Get_Parameter (Expr)); - Bound := Execute_Bounds (Block, Get_Type (Get_Prefix (Expr))); + Bound := Execute_Bounds + (Block, Get_Type_Of_Type_Mark (Get_Prefix (Expr))); case Bound.Dir is when Iir_Downto => Res := Execute_Dec (Res, Expr); @@ -3638,7 +4081,7 @@ package body Execution is -- REPORT is the value (string) to display, or null to use default message. -- SEVERITY is the severity or null to use default (error). -- STMT is used to display location. - procedure Execute_Failed_Assertion (Report : Iir_Value_Literal_Acc; + procedure Execute_Failed_Assertion (Report : String; Severity : Natural; Stmt: Iir) is begin @@ -3671,17 +4114,7 @@ package body Execution is Put (Standard_Error, "): "); -- 3: the value of the message string. - if Report /= null then - for I in Report.Val_Array.V'Range loop - Put (Standard_Error, Character'Val (Report.Val_Array.V (I).E32)); - end loop; - New_Line (Standard_Error); - else - -- The default value for the message string is: - -- "Assertion violation.". - -- Does the message string include quotes ? - Put_Line (Standard_Error, "Assertion violation."); - end if; + Put_Line (Standard_Error, Report); -- Stop execution if the severity is too high. if Severity >= Grt.Options.Severity_Level then @@ -3690,6 +4123,28 @@ package body Execution is end if; end Execute_Failed_Assertion; + procedure Execute_Failed_Assertion (Report : Iir_Value_Literal_Acc; + Severity : Natural; + Stmt: Iir) is + begin + if Report /= null then + declare + Msg : String (1 .. Natural (Report.Val_Array.Len)); + begin + for I in Report.Val_Array.V'Range loop + Msg (Positive (I)) := + Character'Val (Report.Val_Array.V (I).E32); + end loop; + Execute_Failed_Assertion (Msg, Severity, Stmt); + end; + else + -- The default value for the message string is: + -- "Assertion violation.". + -- Does the message string include quotes ? + Execute_Failed_Assertion ("Assertion violation.", Severity, Stmt); + end if; + end Execute_Failed_Assertion; + procedure Execute_Report_Statement (Instance: Block_Instance_Acc; Stmt: Iir; Default_Severity : Natural) is diff --git a/simulate/execution.ads b/simulate/execution.ads index e6ccd1eb6..faed1111d 100644 --- a/simulate/execution.ads +++ b/simulate/execution.ads @@ -44,6 +44,8 @@ package Execution is end record; type Process_State_Acc is access all Process_State_Type; + Simulation_Finished : exception; + -- Current process being executed. This is only for the debugger. Current_Process : Process_State_Acc; diff --git a/simulate/file_operation.adb b/simulate/file_operation.adb index 03b346908..2404c4066 100644 --- a/simulate/file_operation.adb +++ b/simulate/file_operation.adb @@ -333,4 +333,9 @@ package body File_Operation is end loop; Length.I64 := Ghdl_I64 (Len); end Read_Length_Binary; + + procedure Flush (File : Iir_Value_Literal_Acc) is + begin + Ghdl_File_Flush (File.File); + end Flush; end File_Operation; diff --git a/simulate/file_operation.ads b/simulate/file_operation.ads index 39cbbb486..b66a06756 100644 --- a/simulate/file_operation.ads +++ b/simulate/file_operation.ads @@ -73,6 +73,8 @@ package File_Operation is Str : Iir_Value_Literal_Acc; Length : Iir_Value_Literal_Acc); + procedure Flush (File : Iir_Value_Literal_Acc); + -- Test end of FILE is reached. function Endfile (File : Iir_Value_Literal_Acc; Stmt : Iir) return Boolean; diff --git a/simulate/iir_values.adb b/simulate/iir_values.adb index 1de8b8803..67784df58 100644 --- a/simulate/iir_values.adb +++ b/simulate/iir_values.adb @@ -743,6 +743,18 @@ package body Iir_Values is end case; end Get_Nbr_Of_Scalars; + function Get_Enum_Pos (Val : Iir_Value_Literal_Acc) return Natural is + begin + case Val.Kind is + when Iir_Value_E32 => + return Ghdl_E32'Pos (Val.E32); + when Iir_Value_B2 => + return Ghdl_B2'Pos (Val.B2); + when others => + raise Internal_Error; + end case; + end Get_Enum_Pos; + procedure Disp_Value_Tab (Value: Iir_Value_Literal_Acc; Tab: Ada.Text_IO.Count) is @@ -897,7 +909,7 @@ package body Iir_Values is Last_Enum: Last_Enum_Type; El_Type: Iir; Enum_List: Iir_List; - El: Name_Id; + El_Id : Name_Id; El_Pos : Natural; begin if Dim = Value.Bounds.Nbr_Dims then @@ -911,10 +923,10 @@ package body Iir_Values is Last_Enum := None; Enum_List := Get_Enumeration_Literal_List (El_Type); for I in 1 .. Value.Bounds.D (Dim).Length loop - El_Pos := Ghdl_E32'Pos (Value.Val_Array.V (Off).E32); + El_Pos := Get_Enum_Pos (Value.Val_Array.V (Off)); Off := Off + 1; - El := Get_Identifier (Get_Nth_Element (Enum_List, El_Pos)); - if Name_Table.Is_Character (El) then + El_Id := Get_Identifier (Get_Nth_Element (Enum_List, El_Pos)); + if Name_Table.Is_Character (El_Id) then case Last_Enum is when None => Put (""""); @@ -923,7 +935,7 @@ package body Iir_Values is when Char => null; end case; - Put (Name_Table.Get_Character (El)); + Put (Name_Table.Get_Character (El_Id)); Last_Enum := Char; else case Last_Enum is @@ -934,7 +946,7 @@ package body Iir_Values is when Char => Put (""" & "); end case; - Put (Name_Table.Image (El)); + Put (Name_Table.Image (El_Id)); Last_Enum := Identifier; end if; end loop; diff --git a/simulate/iir_values.ads b/simulate/iir_values.ads index 7cbc892fa..54f9dfb4d 100644 --- a/simulate/iir_values.ads +++ b/simulate/iir_values.ads @@ -319,6 +319,9 @@ package Iir_Values is -- Return the number of scalars elements in VALS. function Get_Nbr_Of_Scalars (Val : Iir_Value_Literal_Acc) return Natural; + -- Return the position of an enumerated type value. + function Get_Enum_Pos (Val : Iir_Value_Literal_Acc) return Natural; + -- Well known values. -- Boolean_to_lit can be used to convert a boolean value from Ada to a -- boolean value for vhdl. diff --git a/simulate/simulation.adb b/simulate/simulation.adb index 304faa9b2..6a725ee9d 100644 --- a/simulate/simulation.adb +++ b/simulate/simulation.adb @@ -1661,6 +1661,8 @@ package body Simulation is exception when Debugger_Quit => null; + when Simulation_Finished => + null; end Simulation_Entity; end Simulation; diff --git a/std_package.adb b/std_package.adb index 4345637df..7932ad3fe 100644 --- a/std_package.adb +++ b/std_package.adb @@ -185,6 +185,18 @@ package body Std_Package is end loop; end Add_Implicit_Operations; + procedure Create_Std_Type (Decl : out Iir; + Def : Iir; + Name : Name_Id) + is + begin + Decl := Create_Std_Decl (Iir_Kind_Type_Declaration); + Set_Std_Identifier (Decl, Name); + Set_Type_Definition (Decl, Def); + Add_Decl (Decl); + Set_Type_Declarator (Def, Decl); + end Create_Std_Type; + procedure Create_Integer_Type (Type_Definition : Iir; Type_Decl : out Iir; Type_Name : Name_Id) @@ -199,7 +211,7 @@ package body Std_Package is Type_Decl := Create_Std_Decl (Iir_Kind_Anonymous_Type_Declaration); Set_Identifier (Type_Decl, Type_Name); - Set_Type (Type_Decl, Type_Definition); + Set_Type_Definition (Type_Decl, Type_Definition); Set_Type_Declarator (Type_Definition, Type_Decl); end Create_Integer_Type; @@ -249,11 +261,7 @@ package body Std_Package is Set_Signal_Type_Flag (Def, True); Set_Has_Signal_Flag (Def, not Flags.Flag_Whole_Analyze); - Decl := Create_Std_Decl (Iir_Kind_Type_Declaration); - Set_Std_Identifier (Decl, Name); - Set_Type (Decl, Def); - Add_Decl (Decl); - Set_Type_Declarator (Def, Decl); + Create_Std_Type (Decl, Def, Name); Add_Implicit_Operations (Decl); end Create_Array_Type; @@ -378,11 +386,7 @@ package body Std_Package is not Flags.Flag_Whole_Analyze); -- type boolean is - Boolean_Type := Create_Std_Decl (Iir_Kind_Type_Declaration); - Set_Std_Identifier (Boolean_Type, Name_Boolean); - Set_Type (Boolean_Type, Boolean_Type_Definition); - Add_Decl (Boolean_Type); - Set_Type_Declarator (Boolean_Type_Definition, Boolean_Type); + Create_Std_Type (Boolean_Type, Boolean_Type_Definition, Name_Boolean); Iirs_Utils.Create_Range_Constraint_For_Enumeration_Type (Boolean_Type_Definition); @@ -418,11 +422,7 @@ package body Std_Package is Set_Only_Characters_Flag (Bit_Type_Definition, True); -- type bit is - Bit_Type := Create_Std_Decl (Iir_Kind_Type_Declaration); - Set_Std_Identifier (Bit_Type, Name_Bit); - Set_Type (Bit_Type, Bit_Type_Definition); - Add_Decl (Bit_Type); - Set_Type_Declarator (Bit_Type_Definition, Bit_Type); + Create_Std_Type (Bit_Type, Bit_Type_Definition, Name_Bit); Iirs_Utils.Create_Range_Constraint_For_Enumeration_Type (Bit_Type_Definition); @@ -473,12 +473,8 @@ package body Std_Package is not Flags.Flag_Whole_Analyze); -- type character is - Character_Type := Create_Std_Decl (Iir_Kind_Type_Declaration); - Set_Std_Identifier (Character_Type, Name_Character); - Set_Type (Character_Type, Character_Type_Definition); - Add_Decl (Character_Type); - Set_Type_Declarator (Character_Type_Definition, - Character_Type); + Create_Std_Type (Character_Type, Character_Type_Definition, + Name_Character); Iirs_Utils.Create_Range_Constraint_For_Enumeration_Type (Character_Type_Definition); @@ -509,12 +505,8 @@ package body Std_Package is not Flags.Flag_Whole_Analyze); -- type severity_level is - Severity_Level_Type := Create_Std_Decl (Iir_Kind_Type_Declaration); - Set_Std_Identifier (Severity_Level_Type, Name_Severity_Level); - Set_Type (Severity_Level_Type, Severity_Level_Type_Definition); - Add_Decl (Severity_Level_Type); - Set_Type_Declarator (Severity_Level_Type_Definition, - Severity_Level_Type); + Create_Std_Type (Severity_Level_Type, Severity_Level_Type_Definition, + Name_Severity_Level); Iirs_Utils.Create_Range_Constraint_For_Enumeration_Type (Severity_Level_Type_Definition); @@ -558,7 +550,8 @@ package body Std_Package is Universal_Real_Type := Create_Std_Decl (Iir_Kind_Anonymous_Type_Declaration); Set_Identifier (Universal_Real_Type, Name_Universal_Real); - Set_Type (Universal_Real_Type, Universal_Real_Type_Definition); + Set_Type_Definition (Universal_Real_Type, + Universal_Real_Type_Definition); Set_Type_Declarator (Universal_Real_Type_Definition, Universal_Real_Type); Add_Decl (Universal_Real_Type); @@ -580,7 +573,8 @@ package body Std_Package is Universal_Real_Subtype := Create_Std_Decl (Iir_Kind_Subtype_Declaration); Set_Identifier (Universal_Real_Subtype, Name_Universal_Real); - Set_Type (Universal_Real_Subtype, Universal_Real_Subtype_Definition); + Set_Type (Universal_Real_Subtype, + Universal_Real_Subtype_Definition); Set_Type_Declarator (Universal_Real_Subtype_Definition, Universal_Real_Subtype); Set_Subtype_Definition (Universal_Real_Type, @@ -615,7 +609,8 @@ package body Std_Package is Convertible_Real_Type := Create_Std_Decl (Iir_Kind_Anonymous_Type_Declaration); Set_Identifier (Convertible_Real_Type, Name_Convertible_Real); - Set_Type (Convertible_Real_Type, Convertible_Real_Type_Definition); + Set_Type_Definition (Convertible_Real_Type, + Convertible_Real_Type_Definition); Set_Type_Declarator (Convertible_Real_Type_Definition, Convertible_Real_Type); end; @@ -654,7 +649,7 @@ package body Std_Package is Real_Type := Create_Std_Decl (Iir_Kind_Anonymous_Type_Declaration); Set_Identifier (Real_Type, Name_Real); - Set_Type (Real_Type, Real_Type_Definition); + Set_Type_Definition (Real_Type, Real_Type_Definition); Set_Type_Declarator (Real_Type_Definition, Real_Type); Add_Decl (Real_Type); @@ -770,7 +765,7 @@ package body Std_Package is -- type is Time_Type := Create_Std_Decl (Iir_Kind_Anonymous_Type_Declaration); Set_Identifier (Time_Type, Name_Time); - Set_Type (Time_Type, Time_Type_Definition); + Set_Type_Definition (Time_Type, Time_Type_Definition); Set_Type_Declarator (Time_Type_Definition, Time_Type); Add_Decl (Time_Type); @@ -948,11 +943,7 @@ package body Std_Package is Set_Has_Signal_Flag (String_Type_Definition, not Flags.Flag_Whole_Analyze); - String_Type := Create_Std_Decl (Iir_Kind_Type_Declaration); - Set_Std_Identifier (String_Type, Name_String); - Set_Type (String_Type, String_Type_Definition); - Add_Decl (String_Type); - Set_Type_Declarator (String_Type_Definition, String_Type); + Create_Std_Type (String_Type, String_Type_Definition, Name_String); Add_Implicit_Operations (String_Type); end; @@ -1023,12 +1014,9 @@ package body Std_Package is not Flags.Flag_Whole_Analyze); -- type file_open_kind is - File_Open_Kind_Type := Create_Std_Decl (Iir_Kind_Type_Declaration); - Set_Std_Identifier (File_Open_Kind_Type, Name_File_Open_Kind); - Set_Type (File_Open_Kind_Type, File_Open_Kind_Type_Definition); - Add_Decl (File_Open_Kind_Type); - Set_Type_Declarator (File_Open_Kind_Type_Definition, - File_Open_Kind_Type); + Create_Std_Type (File_Open_Kind_Type, File_Open_Kind_Type_Definition, + Name_File_Open_Kind); + Iirs_Utils.Create_Range_Constraint_For_Enumeration_Type (File_Open_Kind_Type_Definition); Add_Implicit_Operations (File_Open_Kind_Type); @@ -1065,12 +1053,9 @@ package body Std_Package is not Flags.Flag_Whole_Analyze); -- type file_open_kind is - File_Open_Status_Type := Create_Std_Decl (Iir_Kind_Type_Declaration); - Set_Std_Identifier (File_Open_Status_Type, Name_File_Open_Status); - Set_Type (File_Open_Status_Type, File_Open_Status_Type_Definition); - Add_Decl (File_Open_Status_Type); - Set_Type_Declarator (File_Open_Status_Type_Definition, - File_Open_Status_Type); + Create_Std_Type (File_Open_Status_Type, + File_Open_Status_Type_Definition, + Name_File_Open_Status); Iirs_Utils.Create_Range_Constraint_For_Enumeration_Type (File_Open_Status_Type_Definition); Add_Implicit_Operations (File_Open_Status_Type); diff --git a/translate/grt/grt-cbinding.c b/translate/grt/grt-cbinding.c index a913a4453..4da06c594 100644 --- a/translate/grt/grt-cbinding.c +++ b/translate/grt/grt-cbinding.c @@ -46,6 +46,19 @@ __ghdl_snprintf_g (char *buf, unsigned int len, double val) } void +__ghdl_snprintf_nf (char *buf, unsigned int len, int ndigits, double val) +{ + snprintf (buf, len, "%.*f", ndigits, val); +} + +void +__ghdl_snprintf_fmtf (const char *buf, unsigned int len, + const char *format, double v) +{ + snprintf (buf, len, format, v); +} + +void __ghdl_fprintf_g (FILE *stream, double val) { fprintf (stream, "%g", val); diff --git a/translate/grt/grt-files.adb b/translate/grt/grt-files.adb index 1688a269b..30d51cf43 100644 --- a/translate/grt/grt-files.adb +++ b/translate/grt/grt-files.adb @@ -32,6 +32,8 @@ pragma Elaborate_All (Grt.Table); package body Grt.Files is subtype C_Files is Grt.Stdio.FILEs; + Auto_Flush : constant Boolean := False; + type File_Entry_Type is record Stream : C_Files; Signature : Ghdl_C_String; @@ -307,7 +309,9 @@ package body Grt.Files is -- FIXME: check r -- Write '\n'. R1 := fputc (Character'Pos (Nl), Res); - R1 := fflush (Res); + if Auto_Flush then + fflush (Res); + end if; end Ghdl_Text_Write; procedure Ghdl_Write_Scalar (File : Ghdl_File_Index; @@ -316,8 +320,6 @@ package body Grt.Files is is Res : C_Files; R : size_t; - R1 : int; - pragma Unreferenced (R1); begin Res := Get_File (File); Check_File_Mode (File, False); @@ -329,7 +331,9 @@ package body Grt.Files is if R /= 1 then Error ("write_scalar failed"); end if; - R1 := fflush (Res); + if Auto_Flush then + fflush (Res); + end if; end Ghdl_Write_Scalar; procedure Ghdl_Read_Scalar (File : Ghdl_File_Index; @@ -433,5 +437,16 @@ package body Grt.Files is begin File_Close (File, False); end Ghdl_File_Close; + + procedure Ghdl_File_Flush (File : Ghdl_File_Index) + is + Stream : C_Files; + begin + Stream := Get_File (File); + if Stream = NULL_Stream then + return; + end if; + fflush (Stream); + end Ghdl_File_Flush; end Grt.Files; diff --git a/translate/grt/grt-files.ads b/translate/grt/grt-files.ads index 2d4b10567..14f998468 100644 --- a/translate/grt/grt-files.ads +++ b/translate/grt/grt-files.ads @@ -89,6 +89,8 @@ package Grt.Files is procedure Ghdl_Text_File_Close (File : Ghdl_File_Index); procedure Ghdl_File_Close (File : Ghdl_File_Index); + + procedure Ghdl_File_Flush (File : Ghdl_File_Index); private pragma Export (Ada, Ghdl_File_Endfile, "__ghdl_file_endfile"); @@ -116,4 +118,6 @@ private pragma Export (C, Ghdl_Text_File_Close, "__ghdl_text_file_close"); pragma Export (C, Ghdl_File_Close, "__ghdl_file_close"); + + pragma Export (C, Ghdl_File_Flush, "__ghdl_file_flush"); end Grt.Files; diff --git a/translate/grt/grt-vstrings.adb b/translate/grt/grt-vstrings.adb index 005bc89e2..30c58ab41 100644 --- a/translate/grt/grt-vstrings.adb +++ b/translate/grt/grt-vstrings.adb @@ -338,4 +338,85 @@ package body Grt.Vstrings is Last := P - 1; end To_String; + procedure To_String (Str : out String_Real_Digits; + Last : out Natural; + N : Ghdl_F64; + Nbr_Digits : Ghdl_I32) + is + procedure Snprintf_Nf (Str : in out String; + Len : Natural; + Ndigits : Ghdl_I32; + V : Ghdl_F64); + pragma Import (C, Snprintf_Nf, "__ghdl_snprintf_nf"); + begin + Snprintf_Nf (Str, Str'Length, Nbr_Digits, N); + Last := strlen (To_Ghdl_C_String (Str'Address)); + end To_String; + + procedure To_String (Str : out String_Real_Digits; + Last : out Natural; + N : Ghdl_F64; + Format : Ghdl_C_String) + is + procedure Snprintf_Fmtf (Str : in out String; + Len : Natural; + Format : Ghdl_C_String; + V : Ghdl_F64); + pragma Import (C, Snprintf_Fmtf, "__ghdl_snprintf_fmtf"); + begin + -- FIXME: check format ('%', f/g/e/a) + Snprintf_Fmtf (Str, Str'Length, Format, N); + Last := strlen (To_Ghdl_C_String (Str'Address)); + end To_String; + + procedure To_String (Str : out String_Time_Unit; + First : out Natural; + Value : Ghdl_I64; + Unit : Ghdl_I64) + is + V, U : Ghdl_I64; + D : Natural; + P : Natural := Str'Last; + Has_Digits : Boolean; + begin + -- Always work on negative values. + if Value > 0 then + V := -Value; + else + V := Value; + end if; + + Has_Digits := False; + U := Unit; + loop + if U = 1 then + if Has_Digits then + Str (P) := '.'; + P := P - 1; + else + Has_Digits := True; + end if; + end if; + + D := Natural (-(V rem 10)); + if D /= 0 or else Has_Digits then + Str (P) := Character'Val (48 + D); + P := P - 1; + Has_Digits := True; + end if; + U := U / 10; + V := V / 10; + exit when V = 0 and then U = 0; + end loop; + if not Has_Digits then + Str (P) := '0'; + else + P := P + 1; + end if; + if Value < 0 then + P := P - 1; + Str (P) := '-'; + end if; + First := P; + end To_String; end Grt.Vstrings; diff --git a/translate/grt/grt-vstrings.ads b/translate/grt/grt-vstrings.ads index 0f5938edc..94967bb0f 100644 --- a/translate/grt/grt-vstrings.ads +++ b/translate/grt/grt-vstrings.ads @@ -77,18 +77,49 @@ package Grt.Vstrings is -- Copy RSTR to STR, and return length of the string to LEN. procedure Copy (Rstr : Rstring; Str : in out String; Len : out Natural); - -- FIRST is the index of the first character. + -- Write the image of N into STR padded to the right. FIRST is the index + -- of the first character, so the result is in STR (FIRST .. STR'last). -- Requires at least 11 characters. procedure To_String (Str : out String; First : out Natural; N : Ghdl_I32); + -- Write the image of N into STR padded to the right. FIRST is the index + -- of the first character, so the result is in STR (FIRST .. STR'last). -- Requires at least 21 characters. procedure To_String (Str : out String; First : out Natural; N : Ghdl_I64); + -- Write the image of N into STR. LAST is the index of the last character, + -- so the result is in STR (STR'first .. LAST). -- Requires at least 24 characters. -- Sign (1) + digit (1) + dot (1) + digits (15) + exp (1) + sign (1) -- + exp_digits (4) -> 24. procedure To_String (Str : out String; Last : out Natural; N : Ghdl_F64); + subtype String_Real_Digits is String (1 .. 128); + + -- Write the image of N into STR using NBR_DIGITS digits after the decimal + -- point. + procedure To_String (Str : out String_Real_Digits; + Last : out Natural; + N : Ghdl_F64; + Nbr_Digits : Ghdl_I32); + + subtype String_Real_Format is String (1 .. 128); + + -- Write the image of N into STR using NBR_DIGITS digits after the decimal + -- point. + procedure To_String (Str : out String_Real_Digits; + Last : out Natural; + N : Ghdl_F64; + Format : Ghdl_C_String); + + -- Write the image of VALUE to STR using UNIT as unit. The output is in + -- STR (FIRST .. STR'last). + subtype String_Time_Unit is String (1 .. 22); + procedure To_String (Str : out String_Time_Unit; + First : out Natural; + Value : Ghdl_I64; + Unit : Ghdl_I64); + private subtype Fat_String is String (Positive); type Fat_String_Acc is access Fat_String; diff --git a/translate/trans_decls.ads b/translate/trans_decls.ads index f5aab5c58..9226c582c 100644 --- a/translate/trans_decls.ads +++ b/translate/trans_decls.ads @@ -26,8 +26,6 @@ package Trans_Decls is Ghdl_Psl_Cover_Failed : O_Dnode; -- Procedure for report statement. Ghdl_Report : O_Dnode; - -- Ortho node for default report message. - Ghdl_Assert_Default_Report : O_Dnode; -- Register a process. Ghdl_Process_Register : O_Dnode; diff --git a/translate/translation.adb b/translate/translation.adb index 38f4bdf4e..a80e40ea4 100644 --- a/translate/translation.adb +++ b/translate/translation.adb @@ -1978,7 +1978,13 @@ package body Translation is -- Generate an error if VALUE (computed from EXPR which may be NULL_IIR -- if not from a tree) is not in range specified by ATYPE. - procedure Check_Range (Value : O_Dnode; Expr : Iir; Atype : Iir); + procedure Check_Range + (Value : O_Dnode; Expr : Iir; Atype : Iir; Loc : Iir); + + -- Insert a scalar check for VALUE of type ATYPE. EXPR may be NULL_IIR. + function Insert_Scalar_Check + (Value : O_Enode; Expr : Iir; Atype : Iir; Loc : Iir) + return O_Enode; -- The base type of EXPR and the base type of ATYPE must be the same. -- If the type is a scalar type, and if a range check is needed, this @@ -5101,7 +5107,7 @@ package body Translation is raise Internal_Error; when Iir_Kind_Type_Declaration | Iir_Kind_Anonymous_Type_Declaration => - Atype := Get_Type (Decl); + Atype := Get_Type_Definition (Decl); case Iir_Kinds_Type_And_Subtype_Definition (Get_Kind (Atype)) is when Iir_Kinds_Scalar_Type_Definition => @@ -7156,7 +7162,7 @@ package body Translation is -- types not used before the full type declaration). return; end if; - Ctype := Get_Type (Get_Type_Declarator (Def)); + Ctype := Get_Type_Of_Type_Mark (Get_Type_Declarator (Def)); Info := Add_Info (Ctype, Kind_Incomplete_Type); Info.Incomplete_Type := Def; Info.Incomplete_Array := null; @@ -8050,7 +8056,7 @@ package body Translation is Tinfo : Type_Info_Acc; Id : Name_Id; begin - Def := Get_Type (Decl); + Def := Get_Type_Definition (Decl); if Get_Kind (Def) in Iir_Kinds_Subtype_Definition then -- Also elaborate the base type, iff DEF and its BASE_TYPE have @@ -8203,7 +8209,7 @@ package body Translation is procedure Elab_Type_Declaration (Decl : Iir) is begin - Elab_Type_Definition (Get_Type (Decl)); + Elab_Type_Definition (Get_Type_Definition (Decl)); end Elab_Type_Declaration; procedure Elab_Subtype_Declaration (Decl : Iir_Subtype_Declaration) @@ -8971,9 +8977,8 @@ package body Translation is function Need_Range_Check (Expr : Iir; Atype : Iir) return Boolean is - Info : Type_Info_Acc; + Info : constant Type_Info_Acc := Get_Info (Atype); begin - Info := Get_Info (Atype); if Info.T.Nocheck_Low and Info.T.Nocheck_Hi then return False; end if; @@ -8983,7 +8988,9 @@ package body Translation is return True; end Need_Range_Check; - procedure Check_Range (Value : O_Dnode; Expr : Iir; Atype : Iir) is + procedure Check_Range + (Value : O_Dnode; Expr : Iir; Atype : Iir; Loc : Iir) + is If_Blk : O_If_Block; begin if not Need_Range_Check (Expr, Atype) then @@ -8995,32 +9002,40 @@ package body Translation is and then Get_Type_Staticness (Atype) = Locally then if not Eval_Is_In_Bound (Eval_Static_Expr (Expr), Atype) then - Chap6.Gen_Bound_Error (Expr); + Chap6.Gen_Bound_Error (Loc); end if; else Open_Temp; Start_If_Stmt (If_Blk, Not_In_Range (Value, Atype)); - Chap6.Gen_Bound_Error (Expr); + Chap6.Gen_Bound_Error (Loc); Finish_If_Stmt (If_Blk); Close_Temp; end if; end Check_Range; + function Insert_Scalar_Check + (Value : O_Enode; Expr : Iir; Atype : Iir; Loc : Iir) + return O_Enode + is + Var : O_Dnode; + begin + Var := Create_Temp_Init + (Get_Ortho_Type (Get_Base_Type (Atype), Mode_Value), Value); + Check_Range (Var, Expr, Atype, Loc); + return New_Obj_Value (Var); + end Insert_Scalar_Check; + function Maybe_Insert_Scalar_Check (Value : O_Enode; Expr : Iir; Atype : Iir) return O_Enode is Expr_Type : constant Iir := Get_Type (Expr); - Var : O_Dnode; begin -- pragma Assert (Base_Type = Get_Base_Type (Atype)); if Get_Kind (Expr_Type) in Iir_Kinds_Scalar_Type_Definition and then Need_Range_Check (Expr, Atype) then - Var := Create_Temp_Init - (Get_Ortho_Type (Get_Base_Type (Atype), Mode_Value), Value); - Check_Range (Var, Expr, Atype); - return New_Obj_Value (Var); + return Insert_Scalar_Check (Value, Expr, Atype, Expr); else return Value; end if; @@ -9279,7 +9294,7 @@ package body Translation is New_Dyadic_Op (Op, Left_Bound, Diff)); -- Check the right bounds is inside the bounds of the index type. - Chap3.Check_Range (Var_Right, Null_Iir, Index_Type); + Chap3.Check_Range (Var_Right, Null_Iir, Index_Type, Null_Iir); New_Assign_Stmt (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Right), New_Obj_Value (Var_Right)); @@ -10614,7 +10629,7 @@ package body Translation is procedure Translate_Type_Declaration (Decl : Iir) is begin - Chap3.Translate_Named_Type_Definition (Get_Type (Decl), + Chap3.Translate_Named_Type_Definition (Get_Type_Definition (Decl), Get_Identifier (Decl)); end Translate_Type_Declaration; @@ -10625,7 +10640,7 @@ package body Translation is begin Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); Push_Identifier_Prefix (Mark1, "BT"); - Chap3.Translate_Type_Definition (Get_Type (Decl)); + Chap3.Translate_Type_Definition (Get_Type_Definition (Decl)); Pop_Identifier_Prefix (Mark1); Pop_Identifier_Prefix (Mark); end Translate_Anonymous_Type_Declaration; @@ -10642,7 +10657,7 @@ package body Translation is Mark : Id_Mark_Type; begin Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); - Chap3.Translate_Bool_Type_Definition (Get_Type (Decl)); + Chap3.Translate_Bool_Type_Definition (Get_Type_Definition (Decl)); Pop_Identifier_Prefix (Mark); end Translate_Bool_Type_Declaration; @@ -15378,25 +15393,13 @@ package body Translation is procedure Translate_Assign (Target : Mnode; Val : O_Enode; Expr : Iir; Target_Type : Iir) is - T_Info : Type_Info_Acc; + T_Info : constant Type_Info_Acc := Get_Info (Target_Type); begin - T_Info := Get_Info (Target_Type); case T_Info.Type_Mode is when Type_Mode_Scalar => - if not Chap3.Need_Range_Check (Expr, Target_Type) then - New_Assign_Stmt (M2Lv (Target), Val); - else - declare - V : O_Dnode; - begin - Open_Temp; - V := Create_Temp_Init (T_Info.Ortho_Type (Mode_Value), - Val); - Chap3.Check_Range (V, Expr, Target_Type); - New_Assign_Stmt (M2Lv (Target), New_Obj_Value (V)); - Close_Temp; - end; - end if; + New_Assign_Stmt + (M2Lv (Target), + Chap3.Maybe_Insert_Scalar_Check (Val, Expr, Target_Type)); when Type_Mode_Acc | Type_Mode_File => New_Assign_Stmt (M2Lv (Target), Val); @@ -16229,14 +16232,17 @@ package body Translation is (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) return O_Enode is - Res_Info : Type_Info_Acc; + Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); + Res : O_Enode; begin - Res_Info := Get_Info (Res_Type); case Get_Kind (Res_Type) is when Iir_Kinds_Scalar_Type_Definition => - -- If res_type = expr_type, do not convert. - -- FIXME: range check ? - return New_Convert_Ov (Expr, Res_Info.Ortho_Type (Mode_Value)); + Res := New_Convert_Ov (Expr, Res_Info.Ortho_Type (Mode_Value)); + if Chap3.Need_Range_Check (Null_Iir, Res_Type) then + Res := Chap3.Insert_Scalar_Check + (Res, Null_Iir, Res_Type, Loc); + end if; + return Res; when Iir_Kinds_Array_Type_Definition => if Get_Constraint_State (Res_Type) = Fully_Constrained then return Translate_Array_Subtype_Conversion @@ -17784,7 +17790,7 @@ package body Translation is Finish_If_Stmt (If_Blk); -- Check the right bounds is inside the bounds of the -- index type. - Chap3.Check_Range (Var_Right, Null_Iir, Index_Type); + Chap3.Check_Range (Var_Right, Null_Iir, Index_Type, Subprg); New_Assign_Stmt (M2Lv (Chap3.Range_To_Right (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))), @@ -18739,10 +18745,6 @@ package body Translation is when Iir_Predefined_Now_Function => null; - when Iir_Predefined_Array_To_String => - -- Not yet supported! - null; - when others => Error_Kind ("translate_implicit_subprogram (" & Iir_Predefined_Functions'Image (Kind) & ")", @@ -18809,7 +18811,7 @@ package body Translation is V := Create_Temp (Ret_Info.Ortho_Type (Mode_Value)); New_Assign_Stmt (New_Obj (V), R); Stack2_Release; - Chap3.Check_Range (V, Expr, Ret_Type); + Chap3.Check_Range (V, Expr, Ret_Type, Expr); Gen_Return_Value (New_Obj_Value (V)); else Gen_Return_Value (R); @@ -20379,7 +20381,9 @@ package body Translation is Last_Individual : Natural; Ptr : O_Lnode; In_Conv : Iir; + In_Expr : Iir; Out_Conv : Iir; + Out_Expr : Iir; Formal_Object_Kind : Object_Kind_Type; Bounds : O_Enode; Obj : Iir; @@ -20463,10 +20467,15 @@ package body Translation is Ptr := New_Selected_Element (New_Obj (Res), Formal_Info.Interface_Field); Param := Lv2M (Ptr, Ftype_Info, Mode_Value); + if In_Conv /= Null_Iir then + In_Expr := In_Conv; + else + In_Expr := Act; + end if; Chap7.Translate_Assign (Param, Do_Conversion (In_Conv, Act, Params (Pos)), - In_Conv, --FIXME: may be null. + In_Expr, Formal_Type); end if; elsif Ftype_Info.Type_Mode not in Type_Mode_By_Value then @@ -20635,13 +20644,18 @@ package body Translation is if Formal_Info.Interface_Field /= O_Fnode_Null then -- OUT parameters. Out_Conv := Get_Out_Conversion (El); + if Out_Conv = Null_Iir then + Out_Expr := Formal; + else + Out_Expr := Out_Conv; + end if; Ptr := New_Selected_Element (New_Obj (Res), Formal_Info.Interface_Field); Param := Lv2M (Ptr, Ftype_Info, Mode_Value); Chap7.Translate_Assign (Params (Pos), Do_Conversion (Out_Conv, Formal, Param), - Out_Conv, --FIXME: use real expr. + Out_Expr, Get_Type (Get_Actual (El))); elsif Base_Formal /= Formal then -- By individual. @@ -24484,7 +24498,7 @@ package body Translation is case Get_Kind (Prefix) is when Iir_Kind_Type_Declaration | Iir_Kind_Subtype_Declaration => - Arr := T2M (Get_Type (Prefix), Mode_Value); + Arr := T2M (Get_Type_Of_Type_Mark (Prefix), Mode_Value); when others => Arr := Chap6.Translate_Name (Prefix); end case; @@ -24702,7 +24716,8 @@ package body Translation is end case; New_Assign_Stmt (New_Obj (Res_Var), New_Convert_Ov (Val, Res_Type)); - Chap3.Check_Range (Res_Var, Attr, Get_Type (Get_Prefix (Attr))); + Chap3.Check_Range + (Res_Var, Attr, Get_Type_Of_Type_Mark (Get_Prefix (Attr)), Attr); return New_Obj_Value (Res_Var); end Translate_Val_Attribute; @@ -24718,7 +24733,7 @@ package body Translation is (New_Obj (T), New_Convert_Ov (Chap7.Translate_Expression (Get_Parameter (Attr)), Ttype)); - Chap3.Check_Range (T, Attr, Res_Type); + Chap3.Check_Range (T, Attr, Res_Type, Attr); return New_Obj_Value (T); end Translate_Pos_Attribute; @@ -25231,7 +25246,8 @@ package body Translation is Assoc : O_Assoc_List; Conv : O_Tnode; begin - Prefix_Type := Get_Base_Type (Get_Type (Get_Prefix (Attr))); + Prefix_Type := + Get_Base_Type (Get_Type_Of_Type_Mark (Get_Prefix (Attr))); Pinfo := Get_Info (Prefix_Type); Res := Create_Temp (Std_String_Node); Create_Temp_Stack2_Mark; @@ -25293,7 +25309,8 @@ package body Translation is Subprg : O_Dnode; Assoc : O_Assoc_List; begin - Prefix_Type := Get_Base_Type (Get_Type (Get_Prefix (Attr))); + Prefix_Type := + Get_Base_Type (Get_Type_Of_Type_Mark (Get_Prefix (Attr))); Pinfo := Get_Info (Prefix_Type); case Pinfo.Type_Mode is when Type_Mode_B2 => @@ -26986,7 +27003,7 @@ package body Translation is Info : Type_Info_Acc; Rti_Type : O_Tnode; begin - Ndef := Get_Type (Get_Type_Declarator (Def)); + Ndef := Get_Type_Of_Type_Mark (Get_Type_Declarator (Def)); Info := Get_Info (Ndef); case Get_Kind (Ndef) is when Iir_Kind_Integer_Type_Definition @@ -27027,7 +27044,7 @@ package body Translation is begin Id := Get_Identifier (Decl); Push_Identifier_Prefix (Mark, Id); - Def := Get_Type (Decl); + Def := Get_Type_Of_Type_Mark (Decl); if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then Rti := Generate_Incomplete_Type_Definition (Def); else @@ -27245,7 +27262,7 @@ package body Translation is null; when Iir_Kind_Type_Declaration => -- FIXME: physicals ? - if Get_Kind (Get_Type (Decl)) + if Get_Kind (Get_Type_Definition (Decl)) = Iir_Kind_Enumeration_Type_Definition then Add_Rti_Node (Generate_Type_Decl (Decl)); @@ -28690,11 +28707,6 @@ package body Translation is Create_Report_Subprg ("__ghdl_report", Ghdl_Report); end; - New_Var_Decl (Ghdl_Assert_Default_Report, - Get_Identifier ("__ghdl_assert_default_report"), - O_Storage_External, - Get_Info (String_Type_Definition).Ortho_Type (Mode_Value)); - -- procedure __ghdl_text_write (file : __ghdl_file_index; -- str : std_string_ptr); Start_Procedure_Decl |