diff options
39 files changed, 2161 insertions, 553 deletions
@@ -1635,6 +1635,12 @@ package body Canon is end case; end; + when Iir_Kind_Simple_Simultaneous_Statement => + if Canon_Flag_Expressions then + Canon_Expression (Get_Simultaneous_Left (El)); + Canon_Expression (Get_Simultaneous_Right (El)); + end if; + when others => Error_Kind ("canon_concurrent_stmts", El); end case; @@ -2201,6 +2207,13 @@ package body Canon is when Iir_Kinds_Signal_Attribute => null; + + when Iir_Kind_Nature_Declaration => + null; + when Iir_Kind_Terminal_Declaration => + null; + when Iir_Kinds_Quantity_Declaration => + null; when others => Error_Kind ("canon_declaration", Decl); end case; @@ -2394,12 +2407,15 @@ package body Canon is end if; end if; end; + when Iir_Kind_Sensitized_Process_Statement | Iir_Kind_Process_Statement | Iir_Kind_Psl_Assert_Statement | Iir_Kind_Psl_Default_Clock - | Iir_Kind_Psl_Declaration => + | Iir_Kind_Psl_Declaration + | Iir_Kind_Simple_Simultaneous_Statement => null; + when others => Error_Kind ("canon_block_configuration(3)", El); end case; @@ -2430,16 +2446,17 @@ package body Canon is -- This code is not executed since context clauses are already -- canonicalized. El := Get_Context_Items (Unit); --- while El /= Null_Iir loop --- case Get_Kind (El) is --- when Iir_Kind_Use_Clause => --- null; --- when Iir_Kind_Library_Clause => --- null; --- when others => --- Error_Kind ("canonicalize1", El); --- end case; --- end loop; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Library_Clause => + null; + when others => + Error_Kind ("canonicalize1", El); + end case; + El := Get_Chain (El); + end loop; end if; El := Get_Library_Unit (Unit); diff --git a/configuration.adb b/configuration.adb index 678f8a47d..7fdcfb0b0 100644 --- a/configuration.adb +++ b/configuration.adb @@ -220,7 +220,8 @@ package body Configuration is | Iir_Kind_Sensitized_Process_Statement | Iir_Kind_Psl_Assert_Statement | Iir_Kind_Psl_Default_Clock - | Iir_Kind_Psl_Declaration => + | Iir_Kind_Psl_Declaration + | Iir_Kind_Simple_Simultaneous_Statement => null; when others => Error_Kind ("add_design_concurrent_stmts(2)", Stmt); diff --git a/disp_tree.adb b/disp_tree.adb index 12c91d3b3..0656aa9da 100644 --- a/disp_tree.adb +++ b/disp_tree.adb @@ -270,6 +270,23 @@ package body Disp_Tree is when Iir_Kind_Subtype_Declaration => Put ("subtype_declaration"); Disp_Identifier (Tree); + + when Iir_Kind_Nature_Declaration => + Put ("nature_declaration"); + Disp_Identifier (Tree); + when Iir_Kind_Subnature_Declaration => + Put ("subnature_declaration"); + Disp_Identifier (Tree); + when Iir_Kind_Terminal_Declaration => + Put ("terminal_declaration"); + Disp_Identifier (Tree); + when Iir_Kind_Through_Quantity_Declaration => + Put ("through_quantity_declaration"); + Disp_Identifier (Tree); + when Iir_Kind_Across_Quantity_Declaration => + Put ("across_quantity_declaration"); + Disp_Identifier (Tree); + when Iir_Kind_Component_Declaration => Put ("component_declaration"); Disp_Identifier (Tree); @@ -335,6 +352,10 @@ package body Disp_Tree is when Iir_Kind_Physical_Subtype_Definition => Put_Line ("physical_subtype_definition"); + when Iir_Kind_Scalar_Nature_Definition => + Put ("scalar_nature_definition"); + Disp_Identifier (Get_Nature_Declarator (Tree)); + when Iir_Kind_Simple_Name => Put ("simple_name "); Disp_Identifier (Tree); @@ -989,6 +1010,15 @@ package body Disp_Tree is end if; Header ("type (definition):"); Disp_Tree (Get_Type (Tree), Ntab); + when Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration => + if Flat_Decl then + return; + end if; + Header ("nature (definition):"); + Disp_Tree (Get_Nature (Tree), Ntab); + Header ("attribute_value_chain:"); + Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); when Iir_Kind_Component_Declaration => if Flat_Decl then return; @@ -1013,6 +1043,39 @@ package body Disp_Tree is end if; Header ("type:"); Disp_Tree (Get_Type (Tree), Ntab, True); + when Iir_Kind_Terminal_Declaration => + if Flat_Decl then + return; + end if; + Header ("nature:"); + Disp_Tree (Get_Nature (Tree), Ntab, True); + when Iir_Kind_Free_Quantity_Declaration => + if Flat_Decl then + return; + end if; + Header ("type:"); + Disp_Tree (Get_Type (Tree), Ntab, True); + Header ("default value:"); + Disp_Tree (Get_Default_Value (Tree), Ntab, True); + Header ("attribute_value_chain:"); + Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + when Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration => + if Flat_Decl then + return; + end if; + Header ("type:"); + Disp_Tree (Get_Type (Tree), Ntab, True); + Header ("default value:"); + Disp_Tree (Get_Default_Value (Tree), Ntab, True); + Header ("plus terminal:"); + Disp_Tree (Get_Plus_Terminal (Tree), Ntab, True); + Header ("minus terminal:"); + Disp_Tree (Get_Minus_Terminal (Tree), Ntab, True); + Header ("tolerance:"); + Disp_Tree (Get_Tolerance (Tree), Ntab, True); + Header ("attribute_value_chain:"); + Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); when Iir_Kind_Psl_Declaration => if Flat_Decl then return; @@ -1151,6 +1214,12 @@ package body Disp_Tree is Disp_Tree_Flat (Get_Resolution_Function (Tree), Ntab); Header ("range constraint:"); Disp_Tree (Get_Range_Constraint (Tree), Ntab); + if Kind = Iir_Kind_Floating_Subtype_Definition + or else Kind = Iir_Kind_Subtype_Definition + then + Header ("tolerance"); + Disp_Tree (Get_Tolerance (Tree), Ntab); + end if; when Iir_Kind_Range_Expression => Header ("staticness:", false); Disp_Expr_Staticness (Tree); @@ -1340,6 +1409,19 @@ package body Disp_Tree is Header ("declarative_part:"); Disp_Tree_Chain (Get_Declaration_Chain (Tree), Ntab); + when Iir_Kind_Scalar_Nature_Definition => + if Flat_Decl then + return; + end if; + Header ("across_type:"); + Disp_Tree_Flat (Get_Across_Type (Tree), Ntab); + Header ("through_type:"); + Disp_Tree_Flat (Get_Through_Type (Tree), Ntab); + Header ("reference: ", False); + Disp_Tree_Flat (Get_Reference (Tree), Ntab); + Header ("nature_declarator:"); + Disp_Tree_Flat (Get_Nature_Declarator (Tree), Ntab); + when Iir_Kind_Block_Statement => if Flat_Decl then return; @@ -1429,6 +1511,16 @@ package body Disp_Tree is when Iir_Kind_Psl_Default_Clock => null; + when Iir_Kind_Simple_Simultaneous_Statement => + Header ("left:"); + Disp_Tree (Get_Simultaneous_Left (Tree), Ntab); + Header ("right:"); + Disp_Tree (Get_Simultaneous_Right (Tree), Ntab); + Header ("tolerance:"); + Disp_Tree (Get_Tolerance (Tree), Ntab, True); + Header ("attribute_value_chain:"); + Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + when Iir_Kind_Sensitized_Process_Statement | Iir_Kind_Process_Statement => Disp_Label (Tree); diff --git a/disp_vhdl.adb b/disp_vhdl.adb index 98851aefa..0bfb4b01d 100644 --- a/disp_vhdl.adb +++ b/disp_vhdl.adb @@ -52,8 +52,8 @@ package body Disp_Vhdl is -- end Disp_Tab; procedure Disp_Type (A_Type: Iir); + procedure Disp_Nature (Nature : Iir); - procedure Disp_Expression (Expr: Iir); procedure Disp_Concurrent_Statement (Stmt: Iir); procedure Disp_Concurrent_Statement_Chain (Parent: Iir; Indent : Count); procedure Disp_Declaration_Chain (Parent : Iir; Indent: Count); @@ -145,7 +145,10 @@ package body Disp_Vhdl is | Iir_Kind_Non_Object_Alias_Declaration | Iir_Kind_Iterator_Declaration | Iir_Kind_Library_Declaration - | Iir_Kind_Unit_Declaration => + | Iir_Kind_Unit_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Terminal_Declaration + | Iir_Kinds_Quantity_Declaration => Disp_Identifier (Decl); when Iir_Kind_Anonymous_Type_Declaration => Put ('<'); @@ -212,7 +215,8 @@ package body Disp_Vhdl is | Iir_Kind_Implicit_Procedure_Declaration | Iir_Kind_Variable_Declaration | Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Terminal_Declaration => Disp_Name_Of (Name); when others => Error_Kind ("disp_name", Name); @@ -383,6 +387,15 @@ package body Disp_Vhdl is end case; end Disp_Element_Constraint; + procedure Disp_Tolerance_Opt (N : Iir) is + Tol : constant Iir := Get_Tolerance (N); + begin + if Tol /= Null_Iir then + Put ("tolerance "); + Disp_Expression (Tol); + end if; + end Disp_Tolerance_Opt; + procedure Disp_Subtype_Indication (Def : Iir; Full_Decl : Boolean := False) is Type_Mark : Iir; @@ -420,6 +433,9 @@ package body Disp_Vhdl is end if; Disp_Expression (Get_Range_Constraint (Def)); end if; + if Get_Kind (Base_Type) = Iir_Kind_Floating_Type_Definition then + Disp_Tolerance_Opt (Def); + end if; when Iir_Kind_Array_Type_Definition => Disp_Array_Element_Constraint (Def, Type_Mark); when Iir_Kind_Record_Type_Definition => @@ -729,6 +745,42 @@ package body Disp_Vhdl is end if; end Disp_Type; + procedure Disp_Nature_Definition (Def : Iir) is + begin + case Get_Kind (Def) is + when Iir_Kind_Scalar_Nature_Definition => + Disp_Subtype_Indication (Get_Across_Type (Def)); + Put (" across "); + Disp_Subtype_Indication (Get_Through_Type (Def)); + Put (" through "); + Disp_Name_Of (Get_Reference (Def)); + Put (" reference"); + when others => + Error_Kind ("disp_nature_definition", Def); + end case; + end Disp_Nature_Definition; + + procedure Disp_Nature_Declaration (Decl : Iir) is + begin + Put ("nature "); + Disp_Name_Of (Decl); + Put (" is "); + Disp_Nature_Definition (Get_Nature (Decl)); + Put_Line (";"); + end Disp_Nature_Declaration; + + procedure Disp_Nature (Nature : Iir) + is + Decl: Iir; + begin + Decl := Get_Nature_Declarator (Nature); + if Decl /= Null_Iir then + Disp_Name_Of (Decl); + else + Error_Kind ("disp_nature", Nature); + end if; + end Disp_Nature; + procedure Disp_Mode (Mode: Iir_Mode) is begin case Mode is @@ -948,6 +1000,56 @@ package body Disp_Vhdl is Put (';'); end Disp_File_Declaration; + procedure Disp_Quantity_Declaration (Decl: Iir) + is + Expr : Iir; + Term : Iir; + begin + Put ("quantity "); + Disp_Name_Of (Decl); + + case Get_Kind (Decl) is + when Iir_Kinds_Branch_Quantity_Declaration => + Disp_Tolerance_Opt (Decl); + Expr := Get_Default_Value (Decl); + if Expr /= Null_Iir then + Put (":= "); + Disp_Expression (Expr); + end if; + if Get_Kind (Decl) = Iir_Kind_Across_Quantity_Declaration then + Put (" across "); + else + Put (" through "); + end if; + Disp_Name_Of (Get_Plus_Terminal (Decl)); + Term := Get_Minus_Terminal (Decl); + if Term /= Null_Iir then + Put (" to "); + Disp_Name_Of (Term); + end if; + when Iir_Kind_Free_Quantity_Declaration => + Put (": "); + Disp_Type (Get_Type (Decl)); + Expr := Get_Default_Value (Decl); + if Expr /= Null_Iir then + Put (":= "); + Disp_Expression (Expr); + end if; + when others => + raise Program_Error; + end case; + Put (';'); + end Disp_Quantity_Declaration; + + procedure Disp_Terminal_Declaration (Decl: Iir) is + begin + Put ("terminal "); + Disp_Name_Of (Decl); + Put (": "); + Disp_Nature (Get_Nature (Decl)); + Put (';'); + end Disp_Terminal_Declaration; + procedure Disp_Object_Declaration (Decl: Iir) is begin case Get_Kind (Decl) is @@ -1159,6 +1261,12 @@ package body Disp_Vhdl is Disp_Component_Declaration (Decl); when Iir_Kinds_Object_Declaration => Disp_Object_Declaration (Decl); + when Iir_Kind_Terminal_Declaration => + Disp_Terminal_Declaration (Decl); + when Iir_Kinds_Quantity_Declaration => + Disp_Quantity_Declaration (Decl); + when Iir_Kind_Nature_Declaration => + Disp_Nature_Declaration (Decl); when Iir_Kind_Non_Object_Alias_Declaration => Disp_Non_Object_Alias_Declaration (Decl); when Iir_Kind_Implicit_Function_Declaration @@ -2201,6 +2309,16 @@ package body Disp_Vhdl is end if; end Disp_Psl_Assert_Statement; + procedure Disp_Simple_Simultaneous_Statement (Stmt : Iir) + is + begin + Disp_Label (Get_Label (Stmt)); + Disp_Expression (Get_Simultaneous_Left (Stmt)); + Put (" == "); + Disp_Expression (Get_Simultaneous_Right (Stmt)); + Put_Line (";"); + end Disp_Simple_Simultaneous_Statement; + procedure Disp_Concurrent_Statement (Stmt: Iir) is begin case Get_Kind (Stmt) is @@ -2225,6 +2343,8 @@ package body Disp_Vhdl is Disp_Psl_Default_Clock (Stmt); when Iir_Kind_Psl_Assert_Statement => Disp_Psl_Assert_Statement (Stmt); + when Iir_Kind_Simple_Simultaneous_Statement => + Disp_Simple_Simultaneous_Statement (Stmt); when others => Error_Kind ("disp_concurrent_statement", Stmt); end case; diff --git a/disp_vhdl.ads b/disp_vhdl.ads index 6bac04e70..880290efd 100644 --- a/disp_vhdl.ads +++ b/disp_vhdl.ads @@ -24,6 +24,9 @@ package Disp_Vhdl is -- the node. procedure Disp_Vhdl (An_Iir: Iir); + procedure Disp_Expression (Expr: Iir); + -- Display an expression. + -- Disp an iir_int64, without the leading blank. procedure Disp_Int64 (Val: Iir_Int64); @@ -33,4 +36,3 @@ package Disp_Vhdl is -- Disp an iir_Fp64, without the leading blank. procedure Disp_Fp64 (Val: Iir_Fp64); end Disp_Vhdl; - diff --git a/errorout.adb b/errorout.adb index 9b2e4a687..15309f853 100644 --- a/errorout.adb +++ b/errorout.adb @@ -463,6 +463,9 @@ package body Errorout is when Iir_Kind_Overload_List => return "overloaded name or expression"; + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Enumeration_Type_Definition => + return Iirs_Utils.Image_Identifier (Get_Type_Declarator (Node)); when Iir_Kind_Array_Type_Definition => return Disp_Type (Node, "array type"); when Iir_Kind_Array_Subtype_Definition => @@ -497,6 +500,9 @@ package body Errorout is when Iir_Kind_Subtype_Definition => return "subtype definition"; + when Iir_Kind_Scalar_Nature_Definition => + return Iirs_Utils.Image_Identifier (Get_Nature_Declarator (Node)); + when Iir_Kind_Choice_By_Expression => return "choice by expression"; when Iir_Kind_Choice_By_Range => @@ -508,9 +514,6 @@ package body Errorout is when Iir_Kind_Choice_By_None => return "positionnal choice"; - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Enumeration_Type_Definition => - return Iirs_Utils.Image_Identifier (Get_Type_Declarator (Node)); when Iir_Kind_Function_Call => return "function call"; when Iir_Kind_Procedure_Call_Statement => @@ -667,6 +670,11 @@ package body Errorout is when Iir_Kind_Subtype_Declaration => return Disp_Identifier (Node, "subtype"); + when Iir_Kind_Nature_Declaration => + return Disp_Identifier (Node, "nature"); + when Iir_Kind_Subnature_Declaration => + return Disp_Identifier (Node, "subnature"); + when Iir_Kind_Component_Instantiation_Statement => return Disp_Identifier (Node, "component instance"); when Iir_Kind_Configuration_Specification => @@ -689,9 +697,19 @@ package body Errorout is when Iir_Kind_Generate_Statement => return "generate statement"; + when Iir_Kind_Simple_Simultaneous_Statement => + return "simple simultaneous statement"; + when Iir_Kind_Psl_Declaration => return Disp_Identifier (Node, "PSL declaration"); + when Iir_Kind_Terminal_Declaration => + return Disp_Identifier (Node, "terminal declaration"); + when Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration => + return Disp_Identifier (Node, "quantity declaration"); + when Iir_Kind_Attribute_Declaration => return Disp_Identifier (Node, "attribute"); when Iir_Kind_Attribute_Specification => diff --git a/files_map.adb b/files_map.adb index 4aff442b3..ed2b3f208 100644 --- a/files_map.adb +++ b/files_map.adb @@ -754,6 +754,7 @@ package body Files_Map is return Res; end if; + -- Open the file (punt on non regular files). declare Filename : String := Get_Pathname (Directory, Name, True); begin @@ -28,9 +28,12 @@ package Flags is type Vhdl_Std_Type is (Vhdl_87, Vhdl_93c, Vhdl_93, Vhdl_00, Vhdl_02, Vhdl_08); - -- Standard accepted. + -- Standard accepted. Vhdl_Std: Vhdl_Std_Type := Vhdl_93c; + -- Enable AMS-VHDL extensions. + AMS_Vhdl : Boolean := False; + -- Some flags (such as vhdl version) must be the same for every design -- units of a hierarchy. -- The Flag_String is a signature of all these flags. @@ -152,7 +152,7 @@ package body Iirs is raise Internal_Error; else Error_Msg_Sem ("Aborting compilation due to previous errors.", - An_Iir); + An_Iir); raise Compilation_Error; end if; end if; @@ -375,10 +375,8 @@ package body Iirs is | Iir_Kind_File_Type_Definition | Iir_Kind_Protected_Type_Declaration | Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition | Iir_Kind_Access_Subtype_Definition | Iir_Kind_Physical_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition | Iir_Kind_Integer_Subtype_Definition | Iir_Kind_Enumeration_Subtype_Definition | Iir_Kind_Enumeration_Type_Definition @@ -387,11 +385,12 @@ package body Iirs is | Iir_Kind_Physical_Type_Definition | Iir_Kind_Range_Expression | Iir_Kind_Protected_Type_Body - | Iir_Kind_Subtype_Definition | Iir_Kind_Overload_List | Iir_Kind_Type_Declaration | Iir_Kind_Anonymous_Type_Declaration | Iir_Kind_Subtype_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration | Iir_Kind_Configuration_Declaration | Iir_Kind_Package_Declaration | Iir_Kind_Package_Body @@ -400,6 +399,7 @@ package body Iirs is | Iir_Kind_Group_Declaration | Iir_Kind_Element_Declaration | Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kind_Terminal_Declaration | Iir_Kind_Function_Body | Iir_Kind_Procedure_Body | Iir_Kind_Object_Alias_Declaration @@ -508,12 +508,19 @@ package body Iirs is | Iir_Kind_Attribute_Specification | Iir_Kind_Array_Type_Definition | Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Subtype_Definition + | Iir_Kind_Scalar_Nature_Definition | Iir_Kind_Entity_Declaration | Iir_Kind_Architecture_Declaration | Iir_Kind_Unit_Declaration | Iir_Kind_Library_Declaration | Iir_Kind_Component_Declaration | Iir_Kind_Psl_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration @@ -538,6 +545,7 @@ package body Iirs is | Iir_Kind_Block_Statement | Iir_Kind_Generate_Statement | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Simple_Simultaneous_Statement | Iir_Kind_Signal_Assignment_Statement | Iir_Kind_Assertion_Statement | Iir_Kind_Report_Statement @@ -1846,9 +1854,14 @@ package body Iirs is when Iir_Kind_Design_Unit | Iir_Kind_Type_Declaration | Iir_Kind_Subtype_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration | Iir_Kind_Unit_Declaration | Iir_Kind_Component_Declaration | Iir_Kind_Group_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration @@ -1874,6 +1887,7 @@ package body Iirs is | Iir_Kind_Block_Statement | Iir_Kind_Generate_Statement | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Simple_Simultaneous_Statement | Iir_Kind_Signal_Assignment_Statement | Iir_Kind_Null_Statement | Iir_Kind_Assertion_Statement @@ -2117,6 +2131,8 @@ package body Iirs is | Iir_Kind_Type_Declaration | Iir_Kind_Anonymous_Type_Declaration | Iir_Kind_Subtype_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration | Iir_Kind_Unit_Declaration | Iir_Kind_Library_Declaration | Iir_Kind_Component_Declaration @@ -2125,6 +2141,10 @@ package body Iirs is | Iir_Kind_Group_Declaration | Iir_Kind_Non_Object_Alias_Declaration | Iir_Kind_Psl_Declaration + | Iir_Kind_Terminal_Declaration + | 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 @@ -2152,6 +2172,7 @@ package body Iirs is | Iir_Kind_Block_Statement | Iir_Kind_Generate_Statement | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Simple_Simultaneous_Statement | Iir_Kind_Signal_Assignment_Statement | Iir_Kind_Null_Statement | Iir_Kind_Assertion_Statement @@ -2259,6 +2280,9 @@ package body Iirs is | Iir_Kind_Unit_Declaration | Iir_Kind_Attribute_Declaration | Iir_Kind_Element_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Enumeration_Literal @@ -2397,6 +2421,30 @@ package body Iirs is Set_Field4 (Target, Def); end Set_Subtype_Definition; + procedure Check_Kind_For_Nature (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration + | Iir_Kind_Terminal_Declaration => + null; + when others => + Failed ("Nature", Target); + end case; + end Check_Kind_For_Nature; + + function Get_Nature (Target : Iir) return Iir is + begin + Check_Kind_For_Nature (Target); + return Get_Field1 (Target); + end Get_Nature; + + procedure Set_Nature (Target : Iir; Nature : Iir) is + begin + Check_Kind_For_Nature (Target); + Set_Field1 (Target, Nature); + end Set_Nature; + procedure Check_Kind_For_Mode (Target : Iir) is begin case Get_Kind (Target) is @@ -2452,6 +2500,9 @@ package body Iirs is case Get_Kind (Target) is when Iir_Kind_Attribute_Value | Iir_Kind_Operator_Symbol + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration | Iir_Kind_Enumeration_Literal | Iir_Kind_Object_Alias_Declaration | Iir_Kind_File_Declaration @@ -2797,7 +2848,10 @@ package body Iirs is procedure Check_Kind_For_Default_Value (Target : Iir) is begin case Get_Kind (Target) is - when Iir_Kind_Signal_Declaration + when Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Signal_Declaration | Iir_Kind_Variable_Declaration | Iir_Kind_Constant_Declaration | Iir_Kind_Constant_Interface_Declaration @@ -3351,6 +3405,8 @@ package body Iirs is | Iir_Kind_Type_Declaration | Iir_Kind_Anonymous_Type_Declaration | Iir_Kind_Subtype_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration | Iir_Kind_Configuration_Declaration | Iir_Kind_Entity_Declaration | Iir_Kind_Package_Declaration @@ -3365,6 +3421,10 @@ package body Iirs is | Iir_Kind_Element_Declaration | Iir_Kind_Non_Object_Alias_Declaration | Iir_Kind_Psl_Declaration + | Iir_Kind_Terminal_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration @@ -3392,6 +3452,7 @@ package body Iirs is | Iir_Kind_Block_Statement | Iir_Kind_Generate_Statement | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Simple_Simultaneous_Statement | Iir_Kind_Signal_Assignment_Statement | Iir_Kind_Null_Statement | Iir_Kind_Assertion_Statement @@ -3439,6 +3500,7 @@ package body Iirs is | Iir_Kind_Block_Statement | Iir_Kind_Generate_Statement | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Simple_Simultaneous_Statement | Iir_Kind_Signal_Assignment_Statement | Iir_Kind_Null_Statement | Iir_Kind_Assertion_Statement @@ -3478,6 +3540,8 @@ package body Iirs is | Iir_Kind_Record_Element_Constraint | Iir_Kind_Type_Declaration | Iir_Kind_Subtype_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration | Iir_Kind_Unit_Declaration | Iir_Kind_Library_Declaration | Iir_Kind_Component_Declaration @@ -3487,6 +3551,10 @@ package body Iirs is | Iir_Kind_Element_Declaration | Iir_Kind_Non_Object_Alias_Declaration | Iir_Kind_Psl_Declaration + | Iir_Kind_Terminal_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration @@ -3513,6 +3581,7 @@ package body Iirs is | Iir_Kind_Block_Statement | Iir_Kind_Generate_Statement | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Simple_Simultaneous_Statement | Iir_Kind_Signal_Assignment_Statement | Iir_Kind_Null_Statement | Iir_Kind_Assertion_Statement @@ -3705,6 +3774,124 @@ package body Iirs is Set_Field5 (Decl, Func); end Set_Resolution_Function; + procedure Check_Kind_For_Tolerance (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Subtype_Definition + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Simple_Simultaneous_Statement => + null; + when others => + Failed ("Tolerance", Target); + end case; + end Check_Kind_For_Tolerance; + + function Get_Tolerance (Def : Iir) return Iir is + begin + Check_Kind_For_Tolerance (Def); + return Get_Field7 (Def); + end Get_Tolerance; + + procedure Set_Tolerance (Def : Iir; Tol : Iir) is + begin + Check_Kind_For_Tolerance (Def); + Set_Field7 (Def, Tol); + end Set_Tolerance; + + procedure Check_Kind_For_Plus_Terminal (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration => + null; + when others => + Failed ("Plus_Terminal", Target); + end case; + end Check_Kind_For_Plus_Terminal; + + function Get_Plus_Terminal (Def : Iir) return Iir is + begin + Check_Kind_For_Plus_Terminal (Def); + return Get_Field8 (Def); + end Get_Plus_Terminal; + + procedure Set_Plus_Terminal (Def : Iir; Terminal : Iir) is + begin + Check_Kind_For_Plus_Terminal (Def); + Set_Field8 (Def, Terminal); + end Set_Plus_Terminal; + + procedure Check_Kind_For_Minus_Terminal (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration => + null; + when others => + Failed ("Minus_Terminal", Target); + end case; + end Check_Kind_For_Minus_Terminal; + + function Get_Minus_Terminal (Def : Iir) return Iir is + begin + Check_Kind_For_Minus_Terminal (Def); + return Get_Field9 (Def); + end Get_Minus_Terminal; + + procedure Set_Minus_Terminal (Def : Iir; Terminal : Iir) is + begin + Check_Kind_For_Minus_Terminal (Def); + Set_Field9 (Def, Terminal); + end Set_Minus_Terminal; + + procedure Check_Kind_For_Simultaneous_Left (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Simple_Simultaneous_Statement => + null; + when others => + Failed ("Simultaneous_Left", Target); + end case; + end Check_Kind_For_Simultaneous_Left; + + function Get_Simultaneous_Left (Def : Iir) return Iir is + begin + Check_Kind_For_Simultaneous_Left (Def); + return Get_Field5 (Def); + end Get_Simultaneous_Left; + + procedure Set_Simultaneous_Left (Def : Iir; Expr : Iir) is + begin + Check_Kind_For_Simultaneous_Left (Def); + Set_Field5 (Def, Expr); + end Set_Simultaneous_Left; + + procedure Check_Kind_For_Simultaneous_Right (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Simple_Simultaneous_Statement => + null; + when others => + Failed ("Simultaneous_Right", Target); + end case; + end Check_Kind_For_Simultaneous_Right; + + function Get_Simultaneous_Right (Def : Iir) return Iir is + begin + Check_Kind_For_Simultaneous_Right (Def); + return Get_Field6 (Def); + end Get_Simultaneous_Right; + + procedure Set_Simultaneous_Right (Def : Iir; Expr : Iir) is + begin + Check_Kind_For_Simultaneous_Right (Def); + Set_Field6 (Def, Expr); + end Set_Simultaneous_Right; + procedure Check_Kind_For_Text_File_Flag (Target : Iir) is begin case Get_Kind (Target) is @@ -3926,6 +4113,94 @@ package body Iirs is Set_Field2 (Target, Dtype); end Set_Designated_Type; + procedure Check_Kind_For_Reference (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Scalar_Nature_Definition => + null; + when others => + Failed ("Reference", Target); + end case; + end Check_Kind_For_Reference; + + function Get_Reference (Def : Iir) return Iir is + begin + Check_Kind_For_Reference (Def); + return Get_Field2 (Def); + end Get_Reference; + + procedure Set_Reference (Def : Iir; Ref : Iir) is + begin + Check_Kind_For_Reference (Def); + Set_Field2 (Def, Ref); + end Set_Reference; + + procedure Check_Kind_For_Nature_Declarator (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Scalar_Nature_Definition => + null; + when others => + Failed ("Nature_Declarator", Target); + end case; + end Check_Kind_For_Nature_Declarator; + + function Get_Nature_Declarator (Def : Iir) return Iir is + begin + Check_Kind_For_Nature_Declarator (Def); + return Get_Field3 (Def); + end Get_Nature_Declarator; + + procedure Set_Nature_Declarator (Def : Iir; Decl : Iir) is + begin + Check_Kind_For_Nature_Declarator (Def); + Set_Field3 (Def, Decl); + end Set_Nature_Declarator; + + procedure Check_Kind_For_Across_Type (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Scalar_Nature_Definition => + null; + when others => + Failed ("Across_Type", Target); + end case; + end Check_Kind_For_Across_Type; + + function Get_Across_Type (Def : Iir) return Iir is + begin + Check_Kind_For_Across_Type (Def); + return Get_Field7 (Def); + end Get_Across_Type; + + procedure Set_Across_Type (Def : Iir; Atype : Iir) is + begin + Check_Kind_For_Across_Type (Def); + Set_Field7 (Def, Atype); + end Set_Across_Type; + + procedure Check_Kind_For_Through_Type (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Scalar_Nature_Definition => + null; + when others => + Failed ("Through_Type", Target); + end case; + end Check_Kind_For_Through_Type; + + function Get_Through_Type (Def : Iir) return Iir is + begin + Check_Kind_For_Through_Type (Def); + return Get_Field8 (Def); + end Get_Through_Type; + + procedure Set_Through_Type (Def : Iir; Atype : Iir) is + begin + Check_Kind_For_Through_Type (Def); + Set_Field8 (Def, Atype); + end Set_Through_Type; + procedure Check_Kind_For_Target (Target : Iir) is begin case Get_Kind (Target) is @@ -5100,6 +5375,8 @@ package body Iirs is | Iir_Kind_Type_Declaration | Iir_Kind_Anonymous_Type_Declaration | Iir_Kind_Subtype_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration | Iir_Kind_Configuration_Declaration | Iir_Kind_Entity_Declaration | Iir_Kind_Package_Declaration @@ -5111,6 +5388,10 @@ package body Iirs is | Iir_Kind_Group_Declaration | Iir_Kind_Non_Object_Alias_Declaration | Iir_Kind_Psl_Declaration + | Iir_Kind_Terminal_Declaration + | 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 @@ -5140,6 +5421,7 @@ package body Iirs is | Iir_Kind_Block_Statement | Iir_Kind_Generate_Statement | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Simple_Simultaneous_Statement | Iir_Kind_Signal_Assignment_Statement | Iir_Kind_Null_Statement | Iir_Kind_Assertion_Statement @@ -5397,6 +5679,9 @@ package body Iirs is | Iir_Kind_Attribute_Value | Iir_Kind_Range_Expression | Iir_Kind_Unit_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration | Iir_Kind_Enumeration_Literal | Iir_Kind_Object_Alias_Declaration | Iir_Kind_File_Declaration @@ -5722,6 +6007,9 @@ package body Iirs is begin case Get_Kind (Target) is when Iir_Kind_Attribute_Value + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration | Iir_Kind_Enumeration_Literal | Iir_Kind_Object_Alias_Declaration | Iir_Kind_File_Declaration @@ -6757,12 +7045,18 @@ package body Iirs is case Get_Kind (Target) is when Iir_Kind_Type_Declaration | Iir_Kind_Subtype_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration | Iir_Kind_Component_Declaration | Iir_Kind_Attribute_Declaration | Iir_Kind_Group_Template_Declaration | Iir_Kind_Group_Declaration | Iir_Kind_Non_Object_Alias_Declaration | Iir_Kind_Psl_Declaration + | Iir_Kind_Terminal_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration @@ -809,6 +809,38 @@ package Iirs is -- -- Get/Set_Use_Flag (Flag6) + -- Iir_Kind_Nature_Declaration (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Nature (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + + -- Iir_Kind_Subnature_Declaration (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Nature (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + -- Iir_Kind_Signal_Interface_Declaration (Medium) -- Iir_Kind_Constant_Interface_Declaration (Medium) -- Iir_Kind_Variable_Interface_Declaration (Medium) @@ -1262,6 +1294,75 @@ package Iirs is -- -- Get/Set_Use_Flag (Flag6) + -- Iir_Kind_Terminal_Declaration (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Nature (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + + -- Iir_Kind_Free_Quantity_Declaration (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Default_Value (Field6) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + + -- Iir_Kind_Across_Quantity_Declaration (Medium) + -- Iir_Kind_Through_Quantity_Declaration (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Base_Name (Field5) + -- + -- Get/Set_Default_Value (Field6) + -- + -- Get/Set_Tolerance (Field7) + -- + -- Get/Set_Plus_Terminal (Field8) + -- + -- Get/Set_Minus_Terminal (Field9) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + -- + -- Get/Set_Expr_Staticness (State1) + -- + -- Get/Set_Name_Staticness (State2) + -- Iir_Kind_Use_Clause (Short) -- -- Get/Set_Parent (Field0) @@ -1550,7 +1651,6 @@ package Iirs is -- Iir_Kind_Enumeration_Subtype_Definition (Short) -- Iir_Kind_Integer_Subtype_Definition (Short) - -- Iir_Kind_Floating_Subtype_Definition (Short) -- Iir_Kind_Physical_Subtype_Definition (Short) -- -- Get/Set_Range_Constraint (Field1) @@ -1571,6 +1671,28 @@ package Iirs is -- -- Get/Set_Type_Staticness (State1) + -- Iir_Kind_Floating_Subtype_Definition (Medium) + -- + -- Get/Set_Range_Constraint (Field1) + -- + -- Get/Set_Type_Mark (Field2) + -- + -- Get/Set_Type_Declarator (Field3) + -- + -- Get/Set_Base_Type (Field4) + -- + -- Get/Set_Resolution_Function (Field5) + -- + -- Get/Set_Tolerance (Field7) + -- + -- Get/Set_Resolved_Flag (Flag1) + -- + -- Get/Set_Signal_Type_Flag (Flag2) + -- + -- Get/Set_Has_Signal_Flag (Flag3) + -- + -- Get/Set_Type_Staticness (State1) + -- Iir_Kind_Access_Subtype_Definition (Short) -- -- Get/Set_Type_Staticness (State1) @@ -1587,7 +1709,7 @@ package Iirs is -- -- Get/Set_Signal_Type_Flag (Flag2) - -- Iir_Kind_Record_Subtype_Definition (Short) + -- Iir_Kind_Record_Subtype_Definition (Medium) -- -- Get/Set_Elements_Declaration_List (Field1) -- @@ -1599,6 +1721,8 @@ package Iirs is -- -- Get/Set_Resolution_Function (Field5) -- + -- Get/Set_Tolerance (Field7) + -- -- Get/Set_Resolved_Flag (Flag1) -- -- Get/Set_Signal_Type_Flag (Flag2) @@ -1623,6 +1747,8 @@ package Iirs is -- -- Get/Set_Index_Subtype_List (Field6) -- + -- Get/Set_Tolerance (Field7) + -- -- Get/Set_Type_Staticness (State1) -- -- Get/Set_Constraint_State (State2) @@ -1647,7 +1773,7 @@ package Iirs is -- -- Get/Set_Direction (State2) - -- Iir_Kind_Subtype_Definition (Short) + -- Iir_Kind_Subtype_Definition (Medium) -- Such a node is only created by parse and transformed into the correct -- kind (enumeration_subtype, integer_subtype...) by sem. -- @@ -1656,6 +1782,28 @@ package Iirs is -- Get/Set_Type_Mark (Field2) -- -- Get/Set_Resolution_Function (Field5) + -- + -- Get/Set_Tolerance (Field7) + + ------------------------ + -- Nature definitions -- + ------------------------ + + -- Iir_Kind_Scalar_Nature_Definition (Medium) + -- + -- Get/Set_Reference (Field2) + -- + -- Get/Set the declarator that has created this nature type. + -- Get/Set_Nature_Declarator (Field3) + -- + -- C-- Get/Set_Base_Type (Field4) + -- + -- Type staticness is always locally. + -- C-- Get/Set_Type_Staticness (State1) + -- + -- Get/Set_Across_Type (Field7) + -- + -- Get/Set_Through_Type (Field8) --------------------------- -- concurrent statements -- @@ -1880,6 +2028,25 @@ package Iirs is -- -- Get/Set_Visible_Flag (Flag4) + -- Iir_Kind_Simple_Simultaneous_Statement (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Simultaneous_Left (Field5) + -- + -- Get/Set_Simultaneous_Right (Field6) + -- + -- Get/Set_Tolerance (Field7) + -- + -- Get/Set_Visible_Flag (Flag4) + --------------------------- -- sequential statements -- --------------------------- @@ -2599,6 +2766,9 @@ package Iirs is Iir_Kind_Protected_Type_Body, Iir_Kind_Subtype_Definition, -- temporary (must not appear after sem). + -- Nature definition + Iir_Kind_Scalar_Nature_Definition, + -- Lists. Iir_Kind_Overload_List, -- used internally by sem_expr. @@ -2606,6 +2776,8 @@ package Iirs is Iir_Kind_Type_Declaration, Iir_Kind_Anonymous_Type_Declaration, Iir_Kind_Subtype_Declaration, + Iir_Kind_Nature_Declaration, + Iir_Kind_Subnature_Declaration, Iir_Kind_Configuration_Declaration, Iir_Kind_Entity_Declaration, Iir_Kind_Package_Declaration, @@ -2621,6 +2793,10 @@ package Iirs is Iir_Kind_Non_Object_Alias_Declaration, Iir_Kind_Psl_Declaration, + Iir_Kind_Terminal_Declaration, + Iir_Kind_Free_Quantity_Declaration, + Iir_Kind_Across_Quantity_Declaration, + Iir_Kind_Through_Quantity_Declaration, Iir_Kind_Function_Body, Iir_Kind_Function_Declaration, @@ -2697,6 +2873,8 @@ package Iirs is Iir_Kind_Generate_Statement, Iir_Kind_Component_Instantiation_Statement, + Iir_Kind_Simple_Simultaneous_Statement, + -- Iir_Kind_Sequential_Statement Iir_Kind_Signal_Assignment_Statement, Iir_Kind_Null_Statement, @@ -3266,6 +3444,15 @@ package Iirs is --Iir_Kind_Signal_Interface_Declaration Iir_Kind_File_Interface_Declaration; + subtype Iir_Kinds_Branch_Quantity_Declaration is Iir_Kind range + Iir_Kind_Across_Quantity_Declaration .. + Iir_Kind_Through_Quantity_Declaration; + + subtype Iir_Kinds_Quantity_Declaration is Iir_Kind range + Iir_Kind_Free_Quantity_Declaration .. + --Iir_Kind_Across_Quantity_Declaration + Iir_Kind_Through_Quantity_Declaration; + subtype Iir_Kinds_Non_Alias_Object_Declaration is Iir_Kind range Iir_Kind_File_Declaration .. --Iir_Kind_Guard_Signal_Declaration @@ -3440,6 +3627,8 @@ package Iirs is Iir_Kind_Type_Declaration .. --Iir_Kind_Anonymous_Type_Declaration --Iir_Kind_Subtype_Declaration + --Iir_Kind_Nature_Declaration + --Iir_Kind_Subnature_Declaration --Iir_Kind_Configuration_Declaration --Iir_Kind_Entity_Declaration --Iir_Kind_Package_Declaration @@ -3454,6 +3643,10 @@ package Iirs is --Iir_Kind_Element_Declaration --Iir_Kind_Non_Object_Alias_Declaration --Iir_Kind_Psl_Declaration + --Iir_Kind_Terminal_Declaration + --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 @@ -4257,6 +4450,10 @@ package Iirs is function Get_Subtype_Definition (Target : Iir) return Iir; procedure Set_Subtype_Definition (Target : Iir; Def : Iir); + -- Field: Field1 + function Get_Nature (Target : Iir) return Iir; + procedure Set_Nature (Target : Iir; Nature : Iir); + -- Mode of interfaces or file (v87). -- Field: Odigit1 (pos) function Get_Mode (Target : Iir) return Iir_Mode; @@ -4506,6 +4703,26 @@ package Iirs is function Get_Resolution_Function (Decl : Iir) return Iir; procedure Set_Resolution_Function (Decl : Iir; Func : Iir); + -- Field: Field7 + function Get_Tolerance (Def : Iir) return Iir; + procedure Set_Tolerance (Def : Iir; Tol : Iir); + + -- Field: Field8 + function Get_Plus_Terminal (Def : Iir) return Iir; + procedure Set_Plus_Terminal (Def : Iir; Terminal : Iir); + + -- Field: Field9 + function Get_Minus_Terminal (Def : Iir) return Iir; + procedure Set_Minus_Terminal (Def : Iir; Terminal : Iir); + + -- Field: Field5 + function Get_Simultaneous_Left (Def : Iir) return Iir; + procedure Set_Simultaneous_Left (Def : Iir; Expr : Iir); + + -- Field: Field6 + function Get_Simultaneous_Right (Def : Iir) return Iir; + procedure Set_Simultaneous_Right (Def : Iir; Expr : Iir); + -- True if ATYPE defines std.textio.text file type. -- Field: Flag4 function Get_Text_File_Flag (Atype : Iir) return Boolean; @@ -4545,6 +4762,23 @@ package Iirs is function Get_Designated_Type (Target : Iir) return Iir; procedure Set_Designated_Type (Target : Iir; Dtype : Iir); + -- The terminal declaration for the reference (ground) of a nature + -- Field: Field2 + function Get_Reference (Def : Iir) return Iir; + procedure Set_Reference (Def : Iir; Ref : Iir); + + -- Field: Field3 + function Get_Nature_Declarator (Def : Iir) return Iir; + procedure Set_Nature_Declarator (Def : Iir; Decl : Iir); + + -- Field: Field7 + function Get_Across_Type (Def : Iir) return Iir; + procedure Set_Across_Type (Def : Iir; Atype : Iir); + + -- Field: Field8 + function Get_Through_Type (Def : Iir) return Iir; + procedure Set_Through_Type (Def : Iir; Atype : Iir); + -- Field: Field1 function Get_Target (Target : Iir) return Iir; procedure Set_Target (Target : Iir; Atarget : Iir); diff --git a/options.adb b/options.adb index e95456f9c..a62b76da1 100644 --- a/options.adb +++ b/options.adb @@ -89,6 +89,8 @@ package body Options is else return False; end if; + elsif Opt'Length = 5 and then Opt (Beg .. Beg + 4) = "--ams" then + AMS_Vhdl := True; elsif Opt'Length > 2 and then Opt (Beg .. Beg + 1) = "-P" then Libraries.Add_Library_Path (Opt (Beg + 2 .. Opt'Last)); elsif Opt'Length > 10 and then Opt (Beg .. Beg + 9) = "--workdir=" then diff --git a/ortho/debug/ortho_debug.adb b/ortho/debug/ortho_debug.adb index 633fe7012..e2307b9e4 100644 --- a/ortho/debug/ortho_debug.adb +++ b/ortho/debug/ortho_debug.adb @@ -1307,11 +1307,13 @@ package body Ortho_Debug is Add_Decl (Res); end New_Const_Decl; + -- Const is not modified + pragma Warnings (Off, "*is not modified"); + procedure Start_Const_Value (Const : in out O_Dnode) is subtype O_Dnode_Const_Value is O_Dnode_Type (ON_Const_Value); N : O_Dnode; - Temp : constant O_Dnode := Const; begin if Const.Const_Value /= O_Dnode_Null then -- Constant already has a value. @@ -1334,16 +1336,13 @@ package body Ortho_Debug is Lineno => 0, Const_Decl => Const, Value => O_Cnode_Null); - Temp.Const_Value := N; - Const := Temp; + Const.Const_Value := N; Add_Decl (N, False); end Start_Const_Value; procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode) is - Temp : constant O_Dnode := Const; begin - if Const.Const_Value = O_Dnode_Null then -- Start_Const_Value not called. raise Syntax_Error; @@ -1357,10 +1356,11 @@ package body Ortho_Debug is raise Type_Error; end if; Check_Type (Val.Ctype, Const.Dtype); - Temp.Const_Value.Value := Val; - Const := Temp; + Const.Const_Value.Value := Val; end Finish_Const_Value; + pragma Warnings (On, "*is not modified"); + procedure New_Var_Decl (Res : out O_Dnode; Ident : O_Ident; diff --git a/ortho/gcc/ortho-lang.c b/ortho/gcc/ortho-lang.c index f5cb2bd15..370bdd633 100644 --- a/ortho/gcc/ortho-lang.c +++ b/ortho/gcc/ortho-lang.c @@ -643,20 +643,21 @@ type_for_size (unsigned int precision, int unsignedp) && signed_and_unsigned_types[precision][unsignedp] != NULL_TREE) return signed_and_unsigned_types[precision][unsignedp]; - if (unsignedp) + if (unsignedp) t = make_unsigned_type (precision); else t = make_signed_type (precision); if (precision <= MAX_BITS_PER_WORD) signed_and_unsigned_types[precision][unsignedp] = t; - else - // Handle larger requests by returning a NULL tree and letting + else + // Handle larger requests by returning a NULL tree and letting // the back end default to another approach. - // the exact test is unknown : distinguishing between 32 and 64 bits may be enough - // for all likely platforms - if (MAX_BITS_PER_WORD >= 64) t = NULL_TREE; - + // the exact test is unknown : distinguishing between 32 and 64 bits + // may be enough for all likely platforms + if (MAX_BITS_PER_WORD >= 64) + t = NULL_TREE; + return t; } diff --git a/ortho/gcc/ortho_gcc.ads b/ortho/gcc/ortho_gcc.ads index 9ec38cdd4..9b5356863 100644 --- a/ortho/gcc/ortho_gcc.ads +++ b/ortho/gcc/ortho_gcc.ads @@ -422,7 +422,6 @@ package Ortho_Gcc is procedure New_Default_Choice (Block : in out O_Case_Block); procedure Finish_Choice (Block : in out O_Case_Block); procedure Finish_Case_Stmt (Block : in out O_Case_Block); - procedure Debug_Tree_C(Expr : O_Cnode); private subtype Tree is System.Address; @@ -658,7 +657,4 @@ private pragma Import (C, New_Default_Choice); pragma Import (C, Finish_Choice); pragma Import (C, Finish_Case_Stmt); - - pragma Import (C, Debug_Tree_C); - end Ortho_Gcc; @@ -51,7 +51,8 @@ package body Parse is -- current_token must be valid. -- Leaves a token. - function Parse_Simple_Expression return Iir_Expression; + function Parse_Simple_Expression (Primary : Iir := Null_Iir) + return Iir_Expression; function Parse_Primary return Iir_Expression; function Parse_Use_Clause return Iir_Use_Clause; @@ -1939,6 +1940,24 @@ package body Parse is return Def; end Parse_Element_Constraint; + -- precond : tolerance + -- postcond: next token + -- + -- [ LRM93 4.2 ] + -- tolerance_aspect ::= TOLERANCE string_expression + function Parse_Tolerance_Aspect_Opt return Iir + is + begin + if AMS_Vhdl + and then Current_Token = Tok_Tolerance + then + Scan.Scan; + return Parse_Expression; + else + return Null_Iir; + end if; + end Parse_Tolerance_Aspect_Opt; + -- precond : identifier or '(' -- postcond: next token -- @@ -1960,6 +1979,7 @@ package body Parse is Type_Mark : Iir; Def: Iir; Resolution_Function: Iir; + Tolerance : Iir; begin -- FIXME: location. Resolution_Function := Null_Iir; @@ -1996,6 +2016,7 @@ package body Parse is Def := Parse_Element_Constraint; Set_Type_Mark (Def, Type_Mark); Set_Resolution_Function (Def, Resolution_Function); + Set_Tolerance (Def, Parse_Tolerance_Aspect_Opt); when Tok_Range => -- range_constraint. @@ -2004,13 +2025,18 @@ package body Parse is Set_Type_Mark (Def, Type_Mark); Set_Range_Constraint (Def, Parse_Range_Constraint); Set_Resolution_Function (Def, Resolution_Function); + Set_Tolerance (Def, Parse_Tolerance_Aspect_Opt); when others => - if Resolution_Function /= Null_Iir then + Tolerance := Parse_Tolerance_Aspect_Opt; + if Resolution_Function /= Null_Iir + or else Tolerance /= Null_Iir + then Def := Create_Iir (Iir_Kind_Subtype_Definition); Location_Copy (Def, Type_Mark); Set_Type_Mark (Def, Type_Mark); Set_Resolution_Function (Def, Resolution_Function); + Set_Tolerance (Def, Tolerance); else Def := Type_Mark; end if; @@ -2042,6 +2068,417 @@ package body Parse is return Decl; end Parse_Subtype_Declaration; + -- precond : NATURE + -- postcond: a token + -- + -- [ §4.8 ] + -- nature_definition ::= scalar_nature_definition + -- | composite_nature_definition + -- + -- [ §3.5.1 ] + -- scalar_nature_definition ::= type_mark ACROSS + -- type_mark THROUGH + -- identifier REFERENCE + -- + -- [ §3.5.2 ] + -- composite_nature_definition ::= array_nature_definition + -- | record_nature_definition + function Parse_Nature_Declaration return Iir + is + Def : Iir; + Ref : Iir; + Loc : Location_Type; + Ident : Name_Id; + Decl : Iir; + begin + -- The current token must be type. + if Current_Token /= Tok_Nature then + raise Program_Error; + end if; + + -- Get the identifier + Scan_Expect (Tok_Identifier, + "an identifier is expected after 'nature'"); + Loc := Get_Token_Location; + Ident := Current_Identifier; + + Scan.Scan; + + if Current_Token /= Tok_Is then + Error_Msg_Parse ("'is' expected here"); + -- Act as if IS token was forgotten. + else + -- Eat IS token. + Scan.Scan; + end if; + + case Current_Token is + when Tok_Array => + -- TODO + Error_Msg_Parse ("array nature definition not supported"); + Def := Null_Iir; + Eat_Tokens_Until_Semi_Colon; + when Tok_Record => + -- TODO + Error_Msg_Parse ("record nature definition not supported"); + Def := Null_Iir; + Eat_Tokens_Until_Semi_Colon; + when Tok_Identifier => + Def := Create_Iir (Iir_Kind_Scalar_Nature_Definition); + Set_Location (Def, Loc); + Set_Across_Type (Def, Parse_Type_Mark); + if Current_Token = Tok_Across then + Scan.Scan; + else + Expect (Tok_Across, "'across' expected after type mark"); + end if; + Set_Through_Type (Def, Parse_Type_Mark); + if Current_Token = Tok_Through then + Scan.Scan; + else + Expect (Tok_Across, "'through' expected after type mark"); + end if; + if Current_Token = Tok_Identifier then + Ref := Create_Iir (Iir_Kind_Terminal_Declaration); + Set_Identifier (Ref, Current_Identifier); + Set_Location (Ref); + Set_Reference (Def, Ref); + Scan.Scan; + if Current_Token = Tok_Reference then + Scan.Scan; + else + Expect (Tok_Reference, "'reference' expected"); + Eat_Tokens_Until_Semi_Colon; + end if; + else + Error_Msg_Parse ("reference identifier expected"); + Eat_Tokens_Until_Semi_Colon; + end if; + when others => + Error_Msg_Parse ("nature definition expected here"); + Eat_Tokens_Until_Semi_Colon; + end case; + + Decl := Create_Iir (Iir_Kind_Nature_Declaration); + Set_Nature (Decl, Def); + Set_Identifier (Decl, Ident); + Set_Location (Decl, Loc); + + -- ';' is expected after end of type declaration + Expect (Tok_Semi_Colon); + Invalidate_Current_Token; + return Decl; + end Parse_Nature_Declaration; + + -- precond : identifier + -- postcond: next token + -- + -- LRM 4.8 Nature declaration + -- + -- subnature_indication ::= + -- nature_mark [ index_constraint ] + -- [ TOLERANCE string_expression ACROSS string_expression THROUGH ] + -- + -- nature_mark ::= + -- nature_name | subnature_name + function Parse_Subnature_Indication return Iir is + Nature_Mark : Iir; + begin + if Current_Token /= Tok_Identifier then + Error_Msg_Parse ("nature mark expected in a subnature indication"); + raise Parse_Error; + end if; + Nature_Mark := Parse_Name (Allow_Indexes => False); + + if Current_Token = Tok_Left_Paren then + -- TODO + Error_Msg_Parse + ("index constraint not supported for subnature indication"); + raise Parse_Error; + end if; + + if Current_Token = Tok_Tolerance then + Error_Msg_Parse + ("tolerance not supported for subnature indication"); + raise Parse_Error; + end if; + return Nature_Mark; + end Parse_Subnature_Indication; + + -- precond : TERMINAL + -- postcond: ; + -- + -- [ 4.3.1.5 Terminal declarations ] + -- terminal_declaration ::= + -- TERMINAL identifier_list : subnature_indication + function Parse_Terminal_Declaration (Parent : Iir) return Iir + is + -- First and last element of the chain to be returned. + First, Last : Iir; + Terminal : Iir; + Subnature : Iir; + Proxy : Iir_Proxy; + begin + Sub_Chain_Init (First, Last); + + loop + -- 'terminal' or "," was just scanned. + Terminal := Create_Iir (Iir_Kind_Terminal_Declaration); + Scan_Expect (Tok_Identifier); + Set_Identifier (Terminal, Current_Identifier); + Set_Location (Terminal); + Set_Parent (Terminal, Parent); + + Sub_Chain_Append (First, Last, Terminal); + + Scan.Scan; + exit when Current_Token = Tok_Colon; + if Current_Token /= Tok_Comma then + Error_Msg_Parse + ("',' or ':' is expected after " + & "identifier in terminal declaration"); + raise Expect_Error; + end if; + end loop; + + -- The colon was parsed. + Scan.Scan; + Subnature := Parse_Subnature_Indication; + + Proxy := Null_Iir; + Terminal := First; + while Terminal /= Null_Iir loop + -- Type definitions are factorized. This is OK, but not done by + -- sem. + if Terminal = First then + Set_Nature (Terminal, Subnature); + else + -- FIXME: could avoid to create many proxies, by adding + -- a reference counter. + Proxy := Create_Iir (Iir_Kind_Proxy); + Set_Proxy (Proxy, First); + Set_Nature (Terminal, Proxy); + end if; + Terminal := Get_Chain (Terminal); + end loop; + Expect (Tok_Semi_Colon); + return First; + end Parse_Terminal_Declaration; + + -- precond : QUANTITY + -- postcond: ; + -- + -- [ 4.3.1.6 Quantity declarations ] + -- quantity_declaration ::= + -- free_quantity_declaration + -- | branch_quantity_declaration + -- | source_quantity_declaration + -- + -- free_quantity_declaration ::= + -- QUANTITY identifier_list : subtype_indication [ := expression ] ; + -- + -- branch_quantity_declaration ::= + -- QUANTITY [ across_aspect ] [ through_aspect ] terminal_aspect ; + -- + -- source_quantity_declaration ::= + -- QUANTITY identifier_list : subtype_indication source_aspect ; + -- + -- across_aspect ::= + -- identifier_list [ tolerance_aspect ] [ := expression ] ACROSS + -- + -- through_aspect ::= + -- identifier_list [ tolerance_aspect ] [ := expression ] THROUGH + -- + -- terminal_aspect ::= + -- plus_terminal_name [ TO minus_terminal_name ] + function Parse_Quantity_Declaration (Parent : Iir) return Iir + is + -- First and last element of the chain to be returned. + First, Last : Iir; + Object : Iir; + New_Object : Iir; + Tolerance : Iir; + Default_Value : Iir; + Kind : Iir_Kind; + Plus_Terminal : Iir; + Proxy : Iir; + First_Through : Iir; + begin + Sub_Chain_Init (First, Last); + + -- Eat 'quantity' + Scan.Scan; + + loop + -- Quantity or "," was just scanned. We assume a free quantity + -- declaration and will change to branch or source quantity if + -- necessary. + Object := Create_Iir (Iir_Kind_Free_Quantity_Declaration); + Expect (Tok_Identifier); + Set_Identifier (Object, Current_Identifier); + Set_Location (Object); + Set_Parent (Object, Parent); + + Sub_Chain_Append (First, Last, Object); + + -- Eat identifier + Scan.Scan; + exit when Current_Token /= Tok_Comma; + + -- Eat ',' + Scan.Scan; + end loop; + + case Current_Token is + when Tok_Colon => + -- Either a free quantity (or a source quantity) + -- TODO + raise Program_Error; + when Tok_Tolerance + | Tok_Assign + | Tok_Across + | Tok_Through => + -- A branch quantity + + -- Parse tolerance aspect + Tolerance := Parse_Tolerance_Aspect_Opt; + + -- Parse default value + if Current_Token = Tok_Assign then + Scan.Scan; + Default_Value := Parse_Expression; + else + Default_Value := Null_Iir; + end if; + + case Current_Token is + when Tok_Across => + Kind := Iir_Kind_Across_Quantity_Declaration; + when Tok_Through => + Kind := Iir_Kind_Through_Quantity_Declaration; + when others => + Error_Msg_Parse ("'across' or 'through' expected here"); + Eat_Tokens_Until_Semi_Colon; + raise Expect_Error; + end case; + + -- Eat across/through + Scan.Scan; + + -- Change declarations + Object := First; + Sub_Chain_Init (First, Last); + while Object /= Null_Iir loop + New_Object := Create_Iir (Kind); + Location_Copy (New_Object, Object); + Set_Identifier (New_Object, Get_Identifier (Object)); + Set_Parent (New_Object, Parent); + Set_Tolerance (New_Object, Tolerance); + Set_Default_Value (New_Object, Default_Value); + + Sub_Chain_Append (First, Last, New_Object); + + if Object /= First then + Proxy := Create_Iir (Iir_Kind_Proxy); + Set_Proxy (Proxy, First); + Set_Plus_Terminal (New_Object, Proxy); + end if; + New_Object := Get_Chain (Object); + Free_Iir (Object); + Object := New_Object; + end loop; + + -- Parse terminal (or first identifier of through declarations) + Plus_Terminal := Parse_Name; + + case Current_Token is + when Tok_Comma + | Tok_Tolerance + | Tok_Assign + | Tok_Through + | Tok_Across => + -- Through quantity declaration. Convert the Plus_Terminal + -- to a declaration. + Object := Create_Iir (Iir_Kind_Through_Quantity_Declaration); + New_Object := Object; + Location_Copy (Object, Plus_Terminal); + if Get_Kind (Plus_Terminal) /= Iir_Kind_Simple_Name then + Error_Msg_Parse + ("identifier for quantity declaration expected"); + else + Set_Identifier (Object, Get_Identifier (Plus_Terminal)); + end if; + Proxy := Create_Iir (Iir_Kind_Proxy); + Set_Proxy (Proxy, First); + Set_Plus_Terminal (Object, Proxy); + First_Through := Object; + Free_Iir (Plus_Terminal); + + loop + Set_Parent (Object, Parent); + Sub_Chain_Append (First, Last, Object); + exit when Current_Token /= Tok_Comma; + Scan.Scan; + + Object := Create_Iir + (Iir_Kind_Through_Quantity_Declaration); + Set_Location (Object); + if Current_Token /= Tok_Identifier then + Error_Msg_Parse + ("identifier for quantity declaration expected"); + else + Set_Identifier (Object, Current_Identifier); + Scan.Scan; + end if; + Proxy := Create_Iir (Iir_Kind_Proxy); + Set_Proxy (Proxy, First_Through); + Set_Plus_Terminal (Object, Proxy); + + end loop; + + -- Parse tolerance aspect + Set_Tolerance (Object, Parse_Tolerance_Aspect_Opt); + + -- Parse default value + if Current_Token = Tok_Assign then + Scan.Scan; + Set_Default_Value (Object, Parse_Expression); + end if; + + -- Scan 'through' + if Current_Token = Tok_Through then + Scan.Scan; + elsif Current_Token = Tok_Across then + Error_Msg_Parse ("across quantity declaration must appear" + & " before though declaration"); + Scan.Scan; + else + Error_Msg_Parse ("'through' expected"); + end if; + + -- Parse plus terminal + Plus_Terminal := Parse_Name; + when others => + null; + end case; + + Set_Plus_Terminal (First, Plus_Terminal); + + -- Parse minus terminal (if present) + if Current_Token = Tok_To then + Scan.Scan; + Set_Minus_Terminal (First, Parse_Name); + end if; + when others => + Error_Msg_Parse ("missign type or across/throught aspect " + & "in quantity declaration"); + Eat_Tokens_Until_Semi_Colon; + raise Expect_Error; + end case; + Expect (Tok_Semi_Colon); + return First; + end Parse_Quantity_Declaration; + -- precond : token (CONSTANT, SIGNAL, VARIABLE, FILE) -- postcond: ; -- @@ -2762,6 +3199,12 @@ package body Parse is end if; when Tok_Subtype => Decl := Parse_Subtype_Declaration; + when Tok_Nature => + Decl := Parse_Nature_Declaration; + when Tok_Terminal => + Decl := Parse_Terminal_Declaration (Parent); + when Tok_Quantity => + Decl := Parse_Quantity_Declaration (Parent); when Tok_Signal => case Get_Kind (Parent) is when Iir_Kind_Function_Body @@ -3254,24 +3697,34 @@ package body Parse is -- factor ::= primary [ ** primary ] -- | ABS primary -- | NOT primary - function Parse_Factor return Iir_Expression is + function Parse_Factor (Primary : Iir := Null_Iir) return Iir_Expression is Res, Tmp: Iir_Expression; begin case Current_Token is when Tok_Abs => + if Primary /= Null_Iir then + return Primary; + end if; Scan.Scan; Res := Create_Iir (Iir_Kind_Absolute_Operator); Set_Location (Res); Set_Operand (Res, Parse_Primary); return Res; when Tok_Not => + if Primary /= Null_Iir then + return Primary; + end if; Res := Create_Iir (Iir_Kind_Not_Operator); Set_Location (Res); Scan.Scan; Set_Operand (Res, Parse_Primary); return Res; when others => - Tmp := Parse_Primary; + if Primary /= Null_Iir then + Tmp := Primary; + else + Tmp := Parse_Primary; + end if; if Current_Token = Tok_Double_Star then Res := Create_Iir (Iir_Kind_Exponentiation_Operator); Set_Location (Res); @@ -3293,10 +3746,10 @@ package body Parse is -- -- [ §7.2 ] -- multiplying_operator ::= * | / | MOD | REM - function Parse_Term return Iir_Expression is + function Parse_Term (Primary : Iir) return Iir_Expression is Res, Tmp: Iir_Expression; begin - Res := Parse_Factor; + Res := Parse_Factor (Primary); while Current_Token in Token_Multiplying_Operator_Type loop case Current_Token is when Tok_Star => @@ -3330,10 +3783,14 @@ package body Parse is -- -- [ §7.2 ] -- adding_operator ::= + | - | & - function Parse_Simple_Expression return Iir_Expression is + function Parse_Simple_Expression (Primary : Iir := Null_Iir) + return Iir_Expression + is Res, Tmp: Iir_Expression; begin - if Current_Token in Token_Sign_Type then + if Current_Token in Token_Sign_Type + and then Primary = Null_Iir + then case Current_Token is when Tok_Plus => Res := Create_Iir (Iir_Kind_Identity_Operator); @@ -3344,9 +3801,9 @@ package body Parse is end case; Set_Location (Res); Scan.Scan; - Set_Operand (Res, Parse_Term); + Set_Operand (Res, Parse_Term (Null_Iir)); else - Res := Parse_Term; + Res := Parse_Term (Primary); end if; while Current_Token in Token_Adding_Operator_Type loop case Current_Token is @@ -3362,7 +3819,7 @@ package body Parse is Set_Location (Tmp); Scan.Scan; Set_Left (Tmp, Res); - Set_Right (Tmp, Parse_Term); + Set_Right (Tmp, Parse_Term (Null_Iir)); Res := Tmp; end loop; return Res; @@ -3984,12 +4441,10 @@ package body Parse is when Iir_Kind_Simple_Name | Iir_Kind_Selected_Name => Set_Implementation (Call, Name); - when Iir_Kind_Attribute_Name => -- Support issue 3060 - Error_Msg_Parse ("Attribute cannot be applied to procedure call"); + when Iir_Kind_Attribute_Name => + Error_Msg_Parse ("attribute cannot be used as procedure call"); when others => - -- Support issue 2686 : no testcase, but improve the error message - Error_Kind("parenthesis_name_to_procedure_call", Name); - -- raise Internal_Error; + Error_Kind ("parenthesis_name_to_procedure_call", Name); end case; return Res; end Parenthesis_Name_To_Procedure_Call; @@ -5024,6 +5479,7 @@ package body Parse is -- | [ label : ] [ POSTPONED ] selected_signal_assignment function Parse_Concurrent_Assignment (Target : Iir) return Iir is + Res : Iir; begin case Current_Token is when Tok_Less_Equal @@ -5038,9 +5494,28 @@ package body Parse is Expect (Tok_Semi_Colon); return Parenthesis_Name_To_Procedure_Call (Target, Iir_Kind_Concurrent_Procedure_Call_Statement); - when others => + when Tok_Generic | Tok_Port => -- or a component instantiation. return Parse_Component_Instantiation (Target); + when others => + -- or a simple simultaneous statement + if AMS_Vhdl then + Res := Create_Iir (Iir_Kind_Simple_Simultaneous_Statement); + Set_Simultaneous_Left (Res, Parse_Simple_Expression (Target)); + if Current_Token /= Tok_Equal_Equal then + Error_Msg_Parse ("'==' expected after expression"); + else + Set_Location (Res); + Scan.Scan; + end if; + Set_Simultaneous_Right (Res, Parse_Simple_Expression); + Set_Tolerance (Res, Parse_Tolerance_Aspect_Opt); + Expect (Tok_Semi_Colon); + return Res; + else + return Parse_Conditional_Signal_Assignment + (Parse_Simple_Expression (Target)); + end if; end case; end Parse_Concurrent_Assignment; @@ -642,31 +642,44 @@ package body Scan is -- The identifiers listed below are called reserved words and are -- reserved for signifiances in the language. -- IN: this is also achieved in packages std_names and tokens. - if Current_Identifier > Std_Names.Name_Last_Vhdl87 - and then Vhdl_Std = Vhdl_87 - then - if Flags.Warn_Reserved_Word then - Warning_Msg_Scan - ("using """ & Name_Buffer (1 .. Name_Length) - & """ vhdl93 reserved word as a vhdl87 identifier"); - Warning_Msg_Scan - ("(use option --std=93 to compile as vhdl93)"); - end if; - Current_Token := Tok_Identifier; - elsif Current_Identifier > Std_Names.Name_Last_Vhdl93 - and then Vhdl_Std < Vhdl_00 - then - if Flags.Warn_Reserved_Word then - Warning_Msg_Scan - ("using """ & Name_Buffer (1 .. Name_Length) - & """ vhdl00 reserved word as an identifier"); - end if; - Current_Token := Tok_Identifier; - else - Current_Token := Token_Type'Val - (Token_Type'Pos (Tok_First_Keyword) - + Current_Identifier - Std_Names.Name_First_Keyword); - end if; + Current_Token := Token_Type'Val + (Token_Type'Pos (Tok_First_Keyword) + + Current_Identifier - Std_Names.Name_First_Keyword); + case Current_Identifier is + when Std_Names.Name_Id_AMS_Reserved_Words => + if not AMS_Vhdl then + if Flags.Warn_Reserved_Word then + Warning_Msg_Scan + ("using """ & Name_Buffer (1 .. Name_Length) + & """ AMS-VHDL reserved word as an identifier"); + end if; + Current_Token := Tok_Identifier; + end if; + when Std_Names.Name_Id_Vhdl00_Reserved_Words => + if Vhdl_Std < Vhdl_00 then + if Flags.Warn_Reserved_Word then + Warning_Msg_Scan + ("using """ & Name_Buffer (1 .. Name_Length) + & """ vhdl00 reserved word as an identifier"); + end if; + Current_Token := Tok_Identifier; + end if; + when Std_Names.Name_Id_Vhdl93_Reserved_Words => + if Vhdl_Std = Vhdl_87 then + if Flags.Warn_Reserved_Word then + Warning_Msg_Scan + ("using """ & Name_Buffer (1 .. Name_Length) + & """ vhdl93 reserved word as a vhdl87 identifier"); + Warning_Msg_Scan + ("(use option --std=93 to compile as vhdl93)"); + end if; + Current_Token := Tok_Identifier; + end if; + when Std_Names.Name_Id_Vhdl87_Reserved_Words => + null; + when others => + raise Program_Error; + end case; elsif Flag_Psl then case Current_Identifier is when Std_Names.Name_Clock => @@ -1217,7 +1230,16 @@ package body Scan is end if; return; when '=' => - if Source (Pos + 1) = '>' then + if Source (Pos + 1) = '=' then + if AMS_Vhdl then + Current_Token := Tok_Equal_Equal; + else + Error_Msg_Scan + ("'==' is not the vhdl equality, replaced by '='"); + Current_Token := Tok_Equal; + end if; + Pos := Pos + 2; + elsif Source (Pos + 1) = '>' then Current_Token := Tok_Double_Arrow; Pos := Pos + 2; else @@ -2150,6 +2150,11 @@ package body Sem is null; when Iir_Kind_Protected_Type_Body => null; + when Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration => + null; + when Iir_Kind_Terminal_Declaration => + null; when others => Error_Kind ("package_need_body_p", El); end case; diff --git a/sem_decls.adb b/sem_decls.adb index cb3a0c418..1209960e4 100644 --- a/sem_decls.adb +++ b/sem_decls.adb @@ -2001,6 +2001,8 @@ package body Sem_Decls is when Iir_Kind_Subtype_Declaration | Iir_Kind_Attribute_Declaration => null; + when Iir_Kind_Terminal_Declaration => + null; when others => Error_Kind ("sem_non_object_alias_declaration", N_Entity); end case; @@ -2128,6 +2130,152 @@ package body Sem_Decls is Set_Visible_Flag (Group, True); end Sem_Group_Declaration; + function Sem_Scalar_Nature_Definition (Def : Iir; Decl : Iir) return Iir + is + function Sem_Scalar_Nature_Typemark (T : Iir; Name : String) return Iir + is + Res : Iir; + begin + Res := Find_Declaration (T, Decl_Type); + if Res = Null_Iir then + return Real_Type_Definition; + end if; + -- LRM93 3.5.1 + -- The type marks must denote floating point types + case Get_Kind (Res) is + when Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Floating_Type_Definition => + return Res; + when others => + Error_Msg_Sem (Name & "type must be a floating point type", T); + return Real_Type_Definition; + end case; + end Sem_Scalar_Nature_Typemark; + + Tm : Iir; + Ref : Iir; + begin + Tm := Get_Across_Type (Def); + Tm := Sem_Scalar_Nature_Typemark (Tm, "across"); + Set_Across_Type (Def, Tm); + + Tm := Get_Through_Type (Def); + Tm := Sem_Scalar_Nature_Typemark (Tm, "through"); + Set_Through_Type (Def, Tm); + + -- Declare the reference + Ref := Get_Reference (Def); + Set_Nature (Ref, Def); + Set_Chain (Ref, Get_Chain (Decl)); + Set_Chain (Decl, Ref); + + return Def; + end Sem_Scalar_Nature_Definition; + + function Sem_Nature_Definition (Def : Iir; Decl : Iir) return Iir + is + begin + case Get_Kind (Def) is + when Iir_Kind_Scalar_Nature_Definition => + return Sem_Scalar_Nature_Definition (Def, Decl); + when others => + Error_Kind ("sem_nature_definition", Def); + return Null_Iir; + end case; + end Sem_Nature_Definition; + + procedure Sem_Nature_Declaration (Decl : Iir) + is + Def : Iir; + begin + Def := Get_Nature (Decl); + if Def /= Null_Iir then + Sem_Scopes.Add_Name (Decl); + Xref_Decl (Decl); + + Def := Sem_Nature_Definition (Def, Decl); + if Def /= Null_Iir then + Set_Nature_Declarator (Def, Decl); + Sem_Scopes.Name_Visible (Decl); + end if; + end if; + end Sem_Nature_Declaration; + + procedure Sem_Terminal_Declaration (Decl : Iir) + is + Def, Nature : Iir; + begin + Def := Get_Nature (Decl); + if Def /= Null_Iir then + Sem_Scopes.Add_Name (Decl); + Xref_Decl (Decl); + + if Get_Kind (Def) = Iir_Kind_Proxy then + Nature := Get_Nature (Get_Proxy (Def)); + Free_Iir (Def); + else + Nature := Sem_Subnature_Indication (Def); + end if; + if Nature /= Null_Iir then + Set_Nature (Decl, Nature); + Sem_Scopes.Name_Visible (Decl); + end if; + end if; + end Sem_Terminal_Declaration; + + procedure Sem_Branch_Quantity_Declaration (Decl : Iir) + is + Plus : Iir; + Minus : Iir; + Branch_Type : Iir; + Value : Iir; + Proxy : Iir; + begin + Plus := Get_Plus_Terminal (Decl); + if Get_Kind (Plus) = Iir_Kind_Proxy then + Proxy := Get_Proxy (Plus); + Free_Iir (Plus); + Plus := Get_Plus_Terminal (Proxy); + Minus := Get_Minus_Terminal (Proxy); + Value := Get_Default_Value (Proxy); + else + Plus := Find_Declaration (Plus, Decl_Terminal); + Minus := Get_Minus_Terminal (Decl); + if Minus /= Null_Iir then + Minus := Find_Declaration (Minus, Decl_Terminal); + end if; + Proxy := Null_Iir; + end if; + Set_Plus_Terminal (Decl, Plus); + Set_Minus_Terminal (Decl, Minus); + case Get_Kind (Decl) is + when Iir_Kind_Across_Quantity_Declaration => + Branch_Type := Get_Across_Type (Get_Nature (Plus)); + when Iir_Kind_Through_Quantity_Declaration => + Branch_Type := Get_Through_Type (Get_Nature (Plus)); + when others => + raise Program_Error; + end case; + Set_Type (Decl, Branch_Type); + Set_Base_Name (Decl, Decl); + + if Proxy = Null_Iir then + Value := Get_Default_Value (Decl); + if Value /= Null_Iir then + Value := Sem_Expression (Value, Branch_Type); + end if; + else + Value := Get_Default_Value (Proxy); + end if; + Set_Default_Value (Decl, Value); + + -- TODO: tolerance + + Sem_Scopes.Add_Name (Decl); + Xref_Decl (Decl); + Sem_Scopes.Name_Visible (Decl); + end Sem_Branch_Quantity_Declaration; + -- Semantize every declaration of DECLS_PARENT. -- STMTS is the concurrent statement list associated with DECLS_PARENT -- if any, or null_iir. This is used for specification. @@ -2231,6 +2379,13 @@ package body Sem_Decls is null; when Iir_Kind_Protected_Type_Body => Sem_Protected_Type_Body (Decl); + when Iir_Kind_Nature_Declaration => + Sem_Nature_Declaration (Decl); + when Iir_Kind_Terminal_Declaration => + Sem_Terminal_Declaration (Decl); + when Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration => + Sem_Branch_Quantity_Declaration (Decl); when others => Error_Kind ("sem_declaration_chain", Decl); end case; diff --git a/sem_expr.adb b/sem_expr.adb index 2293e0a38..f008a7bbc 100644 --- a/sem_expr.adb +++ b/sem_expr.adb @@ -189,6 +189,8 @@ package body Sem_Expr is | Iir_Kind_Allocator_By_Subtype | Iir_Kind_Qualified_Expression => return Expr; + when Iir_Kinds_Quantity_Declaration => + return Expr; when Iir_Kinds_Dyadic_Operator | Iir_Kinds_Monadic_Operator => return Expr; @@ -683,7 +685,6 @@ package body Sem_Expr is end if; end Get_Discrete_Range_Staticness; - procedure Set_Function_Call_Staticness (Expr : Iir; Imp : Iir) is Staticness : Iir_Staticness; @@ -3479,6 +3480,8 @@ package body Sem_Expr is | Iir_Kind_Iterator_Declaration | Iir_Kind_Guard_Signal_Declaration => return; + when Iir_Kinds_Quantity_Declaration => + return; when Iir_Kind_File_Declaration | Iir_Kind_File_Interface_Declaration => -- LRM 4.3.2 Interface declarations diff --git a/sem_names.adb b/sem_names.adb index 65624a709..da6c749eb 100644 --- a/sem_names.adb +++ b/sem_names.adb @@ -1453,29 +1453,16 @@ package body Sem_Names is begin Prot_Type := Get_Type (Sub_Name); --- bld 26 apr 2013 : the following returned the FIRST method matching name --- rather than the full overload list. --- Method := Find_Name_In_Chain --- (Get_Declaration_Chain (Prot_Type), Suffix); --- if Method = Null_Iir then --- Error_Msg_Sem --- ("no method " & Name_Table.Image (Suffix) & " in " --- & Disp_Node (Prot_Type), Name); --- return; --- else --- Add_Result (Res, Method); --- end if; - - -- build overload list from all declarations in chain, matching name, + -- Build overload list from all declarations in chain, matching name, -- which are actually functions or procedures. -- TODO: error here if there's a variable with matching name? -- currently we warn... - -- rather than add a "Find_nth_name_in chain" to iirs_utils I have + -- Rather than add a "Find_nth_name_in chain" to iirs_utils I have -- expanded the chain walk here. Method := Get_Declaration_Chain (Prot_Type); while Method /= Null_Iir loop if Get_Identifier (Method) = Suffix then -- found the name - -- check it's a method! + -- Check it's a method. case Get_Kind (Method) is when Iir_Kind_Function_Declaration | Iir_Kind_Procedure_Declaration => @@ -1493,22 +1480,6 @@ package body Sem_Names is & Disp_Node (Prot_Type), Name); return; end if; - --- following is handled by later stages --- case Get_Kind (Method) is --- when Iir_Kind_Function_Declaration => --- Call := Create_Iir (Iir_Kind_Function_Call); --- Set_Type (Call, Get_Return_Type (Method)); --- Set_Base_Name (Call, Call); --- when Iir_Kind_Procedure_Declaration => --- Call := Create_Iir (Iir_Kind_Procedure_Call); --- when others => --- Error_Kind ("sem_as_method_call", Method); --- end case; --- Location_Copy (Call, Sub_Name); --- Set_Implementation (Call, Method); --- --Set_Parameter_Association_Chain (Call, Xx); --- Add_Result (Res, Call); end Sem_As_Method_Call; begin @@ -1992,7 +1963,7 @@ package body Sem_Names is if Res = Null_Iir then Error_Msg_Sem ("No overloaded subprogram found matching " - & Disp_Node(Prefix_Name), Name); + & Disp_Node (Prefix_Name), Name); end if; when Iir_Kinds_Function_Declaration => Add_Result (Res, Sem_As_Function_Call (Prefix_Name, @@ -2119,14 +2090,9 @@ package body Sem_Names is | Iir_Kind_Selected_Element | Iir_Kind_Dereference | Iir_Kind_Indexed_Name - -- Iir_Kind_Function_Call added to resolve testcase 2 in - -- https://gna.org/bugs/?18351 | Iir_Kind_Function_Call => Sem_As_Selected_By_All_Name (Prefix); - -- when clause added to resolve testcases 3-6 in - -- https://gna.org/bugs/?18351 when Iir_Kinds_Function_Declaration => - -- or Iir_Kind_Function_Declaration to exclude implicit functions Prefix := Sem_As_Function_Call (Name => Prefix_Name, Spec => Prefix, Assoc_Chain => Null_Iir); @@ -3005,7 +2971,8 @@ package body Sem_Names is case Get_Kind (Expr) is when Iir_Kind_Error => null; - when Iir_Kinds_Object_Declaration => + when Iir_Kinds_Object_Declaration + | Iir_Kinds_Quantity_Declaration => Set_Base_Name (Name, Expr); Sem_Check_Pure (Name, Expr); Sem_Check_All_Sensitized (Expr); @@ -3438,6 +3405,17 @@ package body Sem_Names is ("type expected, found " & Disp_Node (Res), Name); return Null_Iir; end case; + when Decl_Nature => + case Get_Kind (Res) is + when Iir_Kind_Nature_Declaration => + Res := Get_Nature (Res); + when others => + Error_Msg_Sem + ("nature expected, found " & Disp_Node (Res), Name); + return Null_Iir; + end case; + when Decl_Terminal => + Res := Check_Kind (Res, Iir_Kind_Terminal_Declaration, "terminal"); when Decl_Component => Res := Check_Kind (Res, Iir_Kind_Component_Declaration, "component"); diff --git a/sem_names.ads b/sem_names.ads index ce7573d45..b48cd7b6a 100644 --- a/sem_names.ads +++ b/sem_names.ads @@ -98,7 +98,8 @@ package Sem_Names is type Decl_Kind_Type is (Decl_Type, Decl_Incomplete_Type, Decl_Component, Decl_Unit, Decl_Label, - Decl_Group_Template, Decl_Entity, Decl_Configuration, Decl_Attribute); + Decl_Group_Template, Decl_Entity, Decl_Configuration, Decl_Attribute, + Decl_Nature, Decl_Terminal); -- Find a uniq declaration for name NAME, which can be a simple_name, -- an identifier or a selected_name. diff --git a/sem_scopes.adb b/sem_scopes.adb index b3d345ce2..7737ed881 100644 --- a/sem_scopes.adb +++ b/sem_scopes.adb @@ -878,6 +878,11 @@ package body Sem_Scopes is | Iir_Kind_Attribute_Declaration | Iir_Kind_Group_Template_Declaration | Iir_Kind_Group_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Terminal_Declaration | Iir_Kind_Entity_Declaration | Iir_Kind_Package_Declaration | Iir_Kinds_Concurrent_Statement diff --git a/sem_stmts.adb b/sem_stmts.adb index b5a8f17e6..373ea7d68 100644 --- a/sem_stmts.adb +++ b/sem_stmts.adb @@ -1702,6 +1702,31 @@ package body Sem_Stmts is Sem_Guard (Stmt); end Sem_Concurrent_Selected_Signal_Assignment; + procedure Simple_Simultaneous_Statement (Stmt : Iir) is + Left, Right : Iir; + Res_Type : Iir; + begin + Left := Get_Simultaneous_Left (Stmt); + Right := Get_Simultaneous_Right (Stmt); + + Left := Sem_Expression_Ov (Left, Null_Iir); + Right := Sem_Expression_Ov (Right, Null_Iir); + + -- Give up in case of error + if Left = Null_Iir or else Right = Null_Iir then + return; + end if; + + Res_Type := Search_Compatible_Type (Get_Type (Left), Get_Type (Right)); + if Res_Type = Null_Iir then + Error_Msg_Sem ("types of left and right expressions are incompatible", + Stmt); + return; + end if; + + -- FIXME: check for nature type... + end Simple_Simultaneous_Statement; + procedure Sem_Concurrent_Statement_Chain (Parent : Iir; Is_Passive : Boolean) is @@ -1776,6 +1801,8 @@ package body Sem_Stmts is Sem_Psl.Sem_Psl_Assert_Statement (El); when Iir_Kind_Psl_Default_Clock => Sem_Psl.Sem_Psl_Default_Clock (El); + when Iir_Kind_Simple_Simultaneous_Statement => + Simple_Simultaneous_Statement (El); when others => Error_Kind ("sem_concurrent_statement_chain", El); end case; diff --git a/sem_types.adb b/sem_types.adb index cef8234c8..c57c151c5 100644 --- a/sem_types.adb +++ b/sem_types.adb @@ -1731,6 +1731,7 @@ package body Sem_Types is is Res : Iir; A_Range : Iir; + Tolerance : Iir; begin if Def = Null_Iir then Res := Copy_Subtype_Indication (Type_Mark); @@ -1747,8 +1748,11 @@ package body Sem_Types is return Type_Mark; end if; + Tolerance := Get_Tolerance (Def); + if Get_Range_Constraint (Def) = Null_Iir and then Resolution = Null_Iir + and then Tolerance = Null_Iir then -- This defines an alias, and must have been handled just -- before the case statment. @@ -1780,6 +1784,29 @@ package body Sem_Types is Set_Type_Staticness (Res, Get_Expr_Staticness (A_Range)); Free_Name (Def); Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark)); + if Tolerance /= Null_Iir then + -- LRM93 4.2 Subtype declarations + -- It is an error in this case the subtype is not a nature + -- type + -- + -- FIXME: should be moved into sem_subtype_indication + if Get_Kind (Res) /= Iir_Kind_Floating_Subtype_Definition then + Error_Msg_Sem ("tolerance allowed only for floating subtype", + Tolerance); + else + -- LRM93 4.2 Subtype declarations + -- If the subtype indication includes a tolerance aspect, then + -- the string expression must be a static expression + Tolerance := Sem_Expression (Tolerance, String_Type_Definition); + if Tolerance /= Null_Iir + and then Get_Expr_Staticness (Tolerance) /= Locally + then + Error_Msg_Sem ("tolerance must be a static string", + Tolerance); + end if; + Set_Tolerance (Res, Tolerance); + end if; + end if; end if; if Resolution /= Null_Iir then @@ -2005,4 +2032,30 @@ package body Sem_Types is Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Def)); return Res; end Copy_Subtype_Indication; + + function Sem_Subnature_Indication (Def: Iir) return Iir + is + Nature_Mark: Iir; + begin + -- LRM 4.8 Nature declatation + -- + -- If the subnature indication does not include a constraint, the + -- subnature is the same as that denoted by the type mark. + case Get_Kind (Def) is + when Iir_Kind_Scalar_Nature_Definition => + -- Used for reference declared by a nature + return Def; + when Iir_Kinds_Name => + Nature_Mark := Find_Declaration (Def, Decl_Nature); + if Nature_Mark = Null_Iir then + -- return Create_Error_Type (Def); + raise Program_Error; -- TODO + else + return Nature_Mark; + end if; + when others => + raise Program_Error; -- TODO + end case; + end Sem_Subnature_Indication; + end Sem_Types; diff --git a/sem_types.ads b/sem_types.ads index dc36640ad..16548b007 100644 --- a/sem_types.ads +++ b/sem_types.ads @@ -54,4 +54,6 @@ package Sem_Types is -- This is used when an alias of DEF is required (eg: subtype a is b). function Copy_Subtype_Indication (Def : Iir) return Iir; + function Sem_Subnature_Indication (Def: Iir) return Iir; + -- Also a nature is not a type, it is patterned like a type. end Sem_Types; diff --git a/std_names.adb b/std_names.adb index 8ad854b53..82f883530 100644 --- a/std_names.adb +++ b/std_names.adb @@ -17,394 +17,371 @@ -- 02111-1307, USA. with Name_Table; with Tokens; use Tokens; +with Ada.Exceptions; package body Std_Names is procedure Std_Names_Initialize is - function GI (S : String) return Name_Id - renames Name_Table.Get_Identifier; - --- function GI (S : String) return Name_Id is --- begin --- Ada.Text_IO.Put_Line ("add " & S); --- return Name_Table.Get_Identifier (S); --- end GI; - + procedure Def (S : String; Id : Name_Id) is + begin + if Name_Table.Get_Identifier (S) /= Id then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "wrong name_id for " & S); + end if; + end Def; begin Name_Table.Initialize; - -- Create keywords. - for I in Tok_Mod .. Tok_Protected loop - if GI (Image (I)) /= - Name_First_Keyword + - Token_Type'Pos (I) - Token_Type'Pos (Tok_First_Keyword) - then - raise Program_Error; - end if; + -- Create reserved words. + for I in Tok_Mod .. Tok_Tolerance loop + Def (Image (I), + Name_First_Keyword + + Token_Type'Pos (I) - Token_Type'Pos (Tok_First_Keyword)); end loop; -- Create operators. - if GI ("=") /= Name_Op_Equality - or GI ("/=") /= Name_Op_Inequality - or GI ("<") /= Name_Op_Less - or GI ("<=") /= Name_Op_Less_Equal - or GI (">") /= Name_Op_Greater - or GI (">=") /= Name_Op_Greater_Equal - or GI ("+") /= Name_Op_Plus - or GI ("-") /= Name_Op_Minus - or GI ("*") /= Name_Op_Mul - or GI ("/") /= Name_Op_Div - or GI ("**") /= Name_Op_Exp - or GI ("&") /= Name_Op_Concatenation - or GI ("??") /= Name_Op_Condition - then - raise Program_Error; - end if; + Def ("=", Name_Op_Equality); + Def ("/=", Name_Op_Inequality); + Def ("<", Name_Op_Less); + Def ("<=", Name_Op_Less_Equal); + Def (">", Name_Op_Greater); + Def (">=", Name_Op_Greater_Equal); + Def ("+", Name_Op_Plus); + Def ("-", Name_Op_Minus); + Def ("*", Name_Op_Mul); + Def ("/", Name_Op_Div); + Def ("**", Name_Op_Exp); + Def ("&", Name_Op_Concatenation); + Def ("??", Name_Op_Condition); -- Create Attributes. - if GI ("base") /= Name_Base - or GI ("left") /= Name_Left - or GI ("right") /= Name_Right - or GI ("high") /= Name_High - or GI ("low") /= Name_Low - or GI ("pos") /= Name_Pos - or GI ("val") /= Name_Val - or GI ("succ") /= Name_Succ - or GI ("pred") /= Name_Pred - or GI ("leftof") /= Name_Leftof - or GI ("rightof") /= Name_Rightof - or GI ("reverse_range") /= Name_Reverse_Range - or GI ("length") /= Name_Length - or GI ("delayed") /= Name_Delayed - or GI ("stable") /= Name_Stable - or GI ("quiet") /= Name_Quiet - or GI ("transaction") /= Name_Transaction - or GI ("event") /= Name_Event - or GI ("active") /= Name_Active - or GI ("last_event") /= Name_Last_Event - or GI ("last_active") /= Name_Last_Active - or GI ("last_value") /= Name_Last_Value + Def ("base", Name_Base); + Def ("left", Name_Left); + Def ("right", Name_Right); + Def ("high", Name_High); + Def ("low", Name_Low); + Def ("pos", Name_Pos); + Def ("val", Name_Val); + Def ("succ", Name_Succ); + Def ("pred", Name_Pred); + Def ("leftof", Name_Leftof); + Def ("rightof", Name_Rightof); + Def ("reverse_range", Name_Reverse_Range); + Def ("length", Name_Length); + Def ("delayed", Name_Delayed); + Def ("stable", Name_Stable); + Def ("quiet", Name_Quiet); + Def ("transaction", Name_Transaction); + Def ("event", Name_Event); + Def ("active", Name_Active); + Def ("last_event", Name_Last_Event); + Def ("last_active", Name_Last_Active); + Def ("last_value", Name_Last_Value); + + Def ("behavior", Name_Behavior); + Def ("structure", Name_Structure); - or GI ("behavior") /= Name_Behavior - or GI ("structure") /= Name_Structure + Def ("ascending", Name_Ascending); + Def ("image", Name_Image); + Def ("value", Name_Value); + Def ("driving", Name_Driving); + Def ("driving_value", Name_Driving_Value); + Def ("simple_name", Name_Simple_Name); + Def ("instance_name", Name_Instance_Name); + Def ("path_name", Name_Path_Name); - or GI ("ascending") /= Name_Ascending - or GI ("image") /= Name_Image - or GI ("value") /= Name_Value - or GI ("driving") /= Name_Driving - or GI ("driving_value") /= Name_Driving_Value - or GI ("simple_name") /= Name_Simple_Name - or GI ("instance_name") /= Name_Instance_Name - or GI ("path_name") /= Name_Path_Name - then - raise Program_Error; - end if; + Def ("contribution", Name_Contribution); + Def ("dot", Name_Dot); + Def ("integ", Name_Integ); + Def ("above", Name_Above); + Def ("zoh", Name_ZOH); + Def ("ltf", Name_LTF); + Def ("ztf", Name_ZTF); + Def ("ramp", Name_Ramp); + Def ("slew", Name_Slew); -- Create standard. - if GI ("std") /= Name_Std - or GI ("standard") /= Name_Standard - or GI ("boolean") /= Name_Boolean - or GI ("false") /= Name_False - or GI ("true") /= Name_True - or GI ("bit") /= Name_Bit - or GI ("character") /= Name_Character - or GI ("severity_level") /= Name_Severity_Level - or GI ("note") /= Name_Note - or GI ("warning") /= Name_Warning - or GI ("error") /= Name_Error - or GI ("failure") /= Name_Failure - or GI ("UNIVERSAL_INTEGER") /= Name_Universal_Integer - or GI ("UNIVERSAL_REAL") /= Name_Universal_Real - or GI ("CONVERTIBLE_INTEGER") /= Name_Convertible_Integer - or GI ("CONVERTIBLE_REAL") /= Name_Convertible_Real - or GI ("integer") /= Name_Integer - or GI ("real") /= Name_Real - or GI ("time") /= Name_Time - or GI ("fs") /= Name_Fs - or GI ("ps") /= Name_Ps - or GI ("ns") /= Name_Ns - or GI ("us") /= Name_Us - or GI ("ms") /= Name_Ms - or GI ("sec") /= Name_Sec - or GI ("min") /= Name_Min - or GI ("hr") /= Name_Hr - or GI ("delay_length") /= Name_Delay_Length - or GI ("now") /= Name_Now - or GI ("natural") /= Name_Natural - or GI ("positive") /= Name_Positive - or GI ("string") /= Name_String - or GI ("bit_vector") /= Name_Bit_Vector - or GI ("file_open_kind") /= Name_File_Open_Kind - or GI ("read_mode") /= Name_Read_Mode - or GI ("write_mode") /= Name_Write_Mode - or GI ("append_mode") /= Name_Append_Mode - or GI ("file_open_status") /= Name_File_Open_Status - or GI ("open_ok") /= Name_Open_Ok - or GI ("status_error") /= Name_Status_Error - or GI ("name_error") /= Name_Name_Error - or GI ("mode_error") /= Name_Mode_Error - or GI ("foreign") /= Name_Foreign - then - raise Program_Error; - end if; + Def ("std", Name_Std); + Def ("standard", Name_Standard); + Def ("boolean", Name_Boolean); + Def ("false", Name_False); + Def ("true", Name_True); + Def ("bit", Name_Bit); + Def ("character", Name_Character); + Def ("severity_level", Name_Severity_Level); + Def ("note", Name_Note); + Def ("warning", Name_Warning); + Def ("error", Name_Error); + Def ("failure", Name_Failure); + Def ("UNIVERSAL_INTEGER", Name_Universal_Integer); + Def ("UNIVERSAL_REAL", Name_Universal_Real); + Def ("CONVERTIBLE_INTEGER", Name_Convertible_Integer); + Def ("CONVERTIBLE_REAL", Name_Convertible_Real); + Def ("integer", Name_Integer); + Def ("real", Name_Real); + Def ("time", Name_Time); + Def ("fs", Name_Fs); + Def ("ps", Name_Ps); + Def ("ns", Name_Ns); + Def ("us", Name_Us); + Def ("ms", Name_Ms); + Def ("sec", Name_Sec); + Def ("min", Name_Min); + Def ("hr", Name_Hr); + Def ("delay_length", Name_Delay_Length); + Def ("now", Name_Now); + Def ("natural", Name_Natural); + Def ("positive", Name_Positive); + Def ("string", Name_String); + Def ("bit_vector", Name_Bit_Vector); + Def ("file_open_kind", Name_File_Open_Kind); + Def ("read_mode", Name_Read_Mode); + Def ("write_mode", Name_Write_Mode); + Def ("append_mode", Name_Append_Mode); + Def ("file_open_status", Name_File_Open_Status); + Def ("open_ok", Name_Open_Ok); + Def ("status_error", Name_Status_Error); + Def ("name_error", Name_Name_Error); + Def ("mode_error", Name_Mode_Error); + Def ("foreign", Name_Foreign); + Def ("domain_type", Name_Domain_Type); + Def ("quiescent_domain", Name_Quiescent_Domain); + Def ("time_domain", Name_Time_Domain); + Def ("frequency_domain", Name_Frequency_Domain); + Def ("domain", Name_Domain); + Def ("frequency", Name_Frequency); + Def ("real_vector", Name_Real_Vector); - if GI ("nul") /= Name_Nul - or GI ("soh") /= Name_Soh - or GI ("stx") /= Name_Stx - or GI ("etx") /= Name_Etx - or GI ("eot") /= Name_Eot - or GI ("enq") /= Name_Enq - or GI ("ack") /= Name_Ack - or GI ("bel") /= Name_Bel - or GI ("bs") /= Name_Bs - or GI ("ht") /= Name_Ht - or GI ("lf") /= Name_Lf - or GI ("vt") /= Name_Vt - or GI ("ff") /= Name_Ff - or GI ("cr") /= Name_Cr - or GI ("so") /= Name_So - or GI ("si") /= Name_Si - or GI ("dle") /= Name_Dle - or GI ("dc1") /= Name_Dc1 - or GI ("dc2") /= Name_Dc2 - or GI ("dc3") /= Name_Dc3 - or GI ("dc4") /= Name_Dc4 - or GI ("nak") /= Name_Nak - or GI ("syn") /= Name_Syn - or GI ("etb") /= Name_Etb - or GI ("can") /= Name_Can - or GI ("em") /= Name_Em - or GI ("sub") /= Name_Sub - or GI ("esc") /= Name_Esc - or GI ("fsp") /= Name_Fsp - or GI ("gsp") /= Name_Gsp - or GI ("rsp") /= Name_Rsp - or GI ("usp") /= Name_Usp - or GI ("del") /= Name_Del - then - raise Program_Error; - end if; + Def ("nul", Name_Nul); + Def ("soh", Name_Soh); + Def ("stx", Name_Stx); + Def ("etx", Name_Etx); + Def ("eot", Name_Eot); + Def ("enq", Name_Enq); + Def ("ack", Name_Ack); + Def ("bel", Name_Bel); + Def ("bs", Name_Bs); + Def ("ht", Name_Ht); + Def ("lf", Name_Lf); + Def ("vt", Name_Vt); + Def ("ff", Name_Ff); + Def ("cr", Name_Cr); + Def ("so", Name_So); + Def ("si", Name_Si); + Def ("dle", Name_Dle); + Def ("dc1", Name_Dc1); + Def ("dc2", Name_Dc2); + Def ("dc3", Name_Dc3); + Def ("dc4", Name_Dc4); + Def ("nak", Name_Nak); + Def ("syn", Name_Syn); + Def ("etb", Name_Etb); + Def ("can", Name_Can); + Def ("em", Name_Em); + Def ("sub", Name_Sub); + Def ("esc", Name_Esc); + Def ("fsp", Name_Fsp); + Def ("gsp", Name_Gsp); + Def ("rsp", Name_Rsp); + Def ("usp", Name_Usp); + Def ("del", Name_Del); - if GI ("c128") /= Name_C128 - or GI ("c129") /= Name_C129 - or GI ("c130") /= Name_C130 - or GI ("c131") /= Name_C131 - or GI ("c132") /= Name_C132 - or GI ("c133") /= Name_C133 - or GI ("c134") /= Name_C134 - or GI ("c135") /= Name_C135 - or GI ("c136") /= Name_C136 - or GI ("c137") /= Name_C137 - or GI ("c138") /= Name_C138 - or GI ("c139") /= Name_C139 - or GI ("c140") /= Name_C140 - or GI ("c141") /= Name_C141 - or GI ("c142") /= Name_C142 - or GI ("c143") /= Name_C143 - or GI ("c144") /= Name_C144 - or GI ("c145") /= Name_C145 - or GI ("c146") /= Name_C146 - or GI ("c147") /= Name_C147 - or GI ("c148") /= Name_C148 - or GI ("c149") /= Name_C149 - or GI ("c150") /= Name_C150 - or GI ("c151") /= Name_C151 - or GI ("c152") /= Name_C152 - or GI ("c153") /= Name_C153 - or GI ("c154") /= Name_C154 - or GI ("c155") /= Name_C155 - or GI ("c156") /= Name_C156 - or GI ("c157") /= Name_C157 - or GI ("c158") /= Name_C158 - or GI ("c159") /= Name_C159 - then - raise Program_Error; - end if; + Def ("c128", Name_C128); + Def ("c129", Name_C129); + Def ("c130", Name_C130); + Def ("c131", Name_C131); + Def ("c132", Name_C132); + Def ("c133", Name_C133); + Def ("c134", Name_C134); + Def ("c135", Name_C135); + Def ("c136", Name_C136); + Def ("c137", Name_C137); + Def ("c138", Name_C138); + Def ("c139", Name_C139); + Def ("c140", Name_C140); + Def ("c141", Name_C141); + Def ("c142", Name_C142); + Def ("c143", Name_C143); + Def ("c144", Name_C144); + Def ("c145", Name_C145); + Def ("c146", Name_C146); + Def ("c147", Name_C147); + Def ("c148", Name_C148); + Def ("c149", Name_C149); + Def ("c150", Name_C150); + Def ("c151", Name_C151); + Def ("c152", Name_C152); + Def ("c153", Name_C153); + Def ("c154", Name_C154); + Def ("c155", Name_C155); + Def ("c156", Name_C156); + Def ("c157", Name_C157); + Def ("c158", Name_C158); + Def ("c159", Name_C159); -- Create misc. - if GI ("guard") /= Name_Guard - or GI ("deallocate") /= Name_Deallocate - or GI ("file_open") /= Name_File_Open - or GI ("file_close") /= Name_File_Close - or GI ("read") /= Name_Read - or GI ("write") /= Name_Write - or GI ("flush") /= Name_Flush - or GI ("endfile") /= Name_Endfile - or GI ("p") /= Name_P - or GI ("f") /= Name_F - or GI ("external_name") /= Name_External_Name - or GI ("open_kind") /= Name_Open_Kind - or GI ("status") /= Name_Status - or GI ("first") /= Name_First - or GI ("last") /= Name_Last - or GI ("textio") /= Name_Textio - or GI ("work") /= Name_Work - or GI ("text") /= Name_Text - or GI ("to_string") /= Name_To_String - or GI ("untruncated_text_read") /= Name_Untruncated_Text_Read - then - raise Program_Error; - end if; + Def ("guard", Name_Guard); + Def ("deallocate", Name_Deallocate); + Def ("file_open", Name_File_Open); + Def ("file_close", Name_File_Close); + Def ("read", Name_Read); + Def ("write", Name_Write); + Def ("flush", Name_Flush); + Def ("endfile", Name_Endfile); + Def ("p", Name_P); + Def ("f", Name_F); + Def ("external_name", Name_External_Name); + Def ("open_kind", Name_Open_Kind); + Def ("status", Name_Status); + Def ("first", Name_First); + Def ("last", Name_Last); + Def ("textio", Name_Textio); + Def ("work", Name_Work); + Def ("text", Name_Text); + Def ("to_string", Name_To_String); + Def ("untruncated_text_read", Name_Untruncated_Text_Read); - if GI ("ieee") /= Name_Ieee - or GI ("std_logic_1164") /= Name_Std_Logic_1164 - or GI ("std_ulogic") /= Name_Std_Ulogic - or GI ("std_ulogic_vector") /= Name_Std_Ulogic_Vector - or GI ("std_logic") /= Name_Std_Logic - or GI ("std_logic_vector") /= Name_Std_Logic_Vector - or GI ("rising_edge") /= Name_Rising_Edge - or GI ("falling_edge") /= Name_Falling_Edge - or GI ("vital_timing") /= Name_VITAL_Timing - or GI ("vital_level0") /= Name_VITAL_Level0 - or GI ("vital_level1") /= Name_VITAL_Level1 - then - raise Program_Error; - end if; + Def ("ieee", Name_Ieee); + Def ("std_logic_1164", Name_Std_Logic_1164); + Def ("std_ulogic", Name_Std_Ulogic); + Def ("std_ulogic_vector", Name_Std_Ulogic_Vector); + Def ("std_logic", Name_Std_Logic); + Def ("std_logic_vector", Name_Std_Logic_Vector); + Def ("rising_edge", Name_Rising_Edge); + Def ("falling_edge", Name_Falling_Edge); + Def ("vital_timing", Name_VITAL_Timing); + Def ("vital_level0", Name_VITAL_Level0); + Def ("vital_level1", Name_VITAL_Level1); -- Verilog keywords - if GI ("always") /= Name_Always - or GI ("assign") /= Name_Assign - or GI ("buf") /= Name_Buf - or GI ("bufif0") /= Name_Bufif0 - or GI ("bufif1") /= Name_Bufif1 - or GI ("casex") /= Name_Casex - or GI ("casez") /= Name_Casez - or GI ("cmos") /= Name_Cmos - or GI ("deassign") /= Name_Deassign - or GI ("default") /= Name_Default - or GI ("defparam") /= Name_Defparam - or GI ("disable") /= Name_Disable - or GI ("endcase") /= Name_Endcase - or GI ("endfunction") /= Name_Endfunction - or GI ("endmodule") /= Name_Endmodule - or GI ("endprimitive") /= Name_Endprimitive - or GI ("endspecify") /= Name_Endspecify - or GI ("endtable") /= Name_Endtable - or GI ("endtask") /= Name_Endtask - or GI ("forever") /= Name_Forever - or GI ("fork") /= Name_Fork - or GI ("highz0") /= Name_Highz0 - or GI ("highz1") /= Name_Highz1 - or GI ("initial") /= Name_Initial - or GI ("input") /= Name_Input - or GI ("join") /= Name_Join - or GI ("large") /= Name_Large - or GI ("medium") /= Name_Medium - or GI ("module") /= Name_Module - or GI ("negedge") /= Name_Negedge - or GI ("nmos") /= Name_Nmos - or GI ("notif0") /= Name_Notif0 - or GI ("notif1") /= Name_Notif1 - or GI ("output") /= Name_Output - or GI ("parameter") /= Name_Parameter - or GI ("pmos") /= Name_Pmos - or GI ("posedge") /= Name_Posedge - or GI ("primitive") /= Name_Primitive - or GI ("pull0") /= Name_Pull0 - or GI ("pull1") /= Name_Pull1 - or GI ("pulldown") /= Name_Pulldown - or GI ("pullup") /= Name_Pullup - or GI ("reg") /= Name_Reg - or GI ("repeat") /= Name_Repeat - or GI ("rcmos") /= Name_Rcmos - or GI ("rnmos") /= Name_Rnmos - or GI ("rpmos") /= Name_Rpmos - or GI ("rtran") /= Name_Rtran - or GI ("rtranif0") /= Name_Rtranif0 - or GI ("rtranif1") /= Name_Rtranif1 - or GI ("small") /= Name_Small - or GI ("specify") /= Name_Specify - or GI ("specparam") /= Name_Specparam - or GI ("strong0") /= Name_Strong0 - or GI ("strong1") /= Name_Strong1 - or GI ("supply0") /= Name_Supply0 - or GI ("supply1") /= Name_Supply1 - or GI ("table") /= Name_Tablex - or GI ("task") /= Name_Task - or GI ("tran") /= Name_Tran - or GI ("tranif0") /= Name_Tranif0 - or GI ("tranif1") /= Name_Tranif1 - or GI ("tri") /= Name_Tri - or GI ("tri0") /= Name_Tri0 - or GI ("tri1") /= Name_Tri1 - or GI ("trireg") /= Name_Trireg - or GI ("wand") /= Name_Wand - or GI ("weak0") /= Name_Weak0 - or GI ("weak1") /= Name_Weak1 - or GI ("wire") /= Name_Wire - or GI ("wor") /= Name_Wor - then - raise Program_Error; - end if; + Def ("always", Name_Always); + Def ("assign", Name_Assign); + Def ("buf", Name_Buf); + Def ("bufif0", Name_Bufif0); + Def ("bufif1", Name_Bufif1); + Def ("casex", Name_Casex); + Def ("casez", Name_Casez); + Def ("cmos", Name_Cmos); + Def ("deassign", Name_Deassign); + Def ("default", Name_Default); + Def ("defparam", Name_Defparam); + Def ("disable", Name_Disable); + Def ("endcase", Name_Endcase); + Def ("endfunction", Name_Endfunction); + Def ("endmodule", Name_Endmodule); + Def ("endprimitive", Name_Endprimitive); + Def ("endspecify", Name_Endspecify); + Def ("endtable", Name_Endtable); + Def ("endtask", Name_Endtask); + Def ("forever", Name_Forever); + Def ("fork", Name_Fork); + Def ("highz0", Name_Highz0); + Def ("highz1", Name_Highz1); + Def ("initial", Name_Initial); + Def ("input", Name_Input); + Def ("join", Name_Join); + Def ("large", Name_Large); + Def ("medium", Name_Medium); + Def ("module", Name_Module); + Def ("negedge", Name_Negedge); + Def ("nmos", Name_Nmos); + Def ("notif0", Name_Notif0); + Def ("notif1", Name_Notif1); + Def ("output", Name_Output); + Def ("parameter", Name_Parameter); + Def ("pmos", Name_Pmos); + Def ("posedge", Name_Posedge); + Def ("primitive", Name_Primitive); + Def ("pull0", Name_Pull0); + Def ("pull1", Name_Pull1); + Def ("pulldown", Name_Pulldown); + Def ("pullup", Name_Pullup); + Def ("reg", Name_Reg); + Def ("repeat", Name_Repeat); + Def ("rcmos", Name_Rcmos); + Def ("rnmos", Name_Rnmos); + Def ("rpmos", Name_Rpmos); + Def ("rtran", Name_Rtran); + Def ("rtranif0", Name_Rtranif0); + Def ("rtranif1", Name_Rtranif1); + Def ("small", Name_Small); + Def ("specify", Name_Specify); + Def ("specparam", Name_Specparam); + Def ("strong0", Name_Strong0); + Def ("strong1", Name_Strong1); + Def ("supply0", Name_Supply0); + Def ("supply1", Name_Supply1); + Def ("table", Name_Tablex); + Def ("task", Name_Task); + Def ("tran", Name_Tran); + Def ("tranif0", Name_Tranif0); + Def ("tranif1", Name_Tranif1); + Def ("tri", Name_Tri); + Def ("tri0", Name_Tri0); + Def ("tri1", Name_Tri1); + Def ("trireg", Name_Trireg); + Def ("wand", Name_Wand); + Def ("weak0", Name_Weak0); + Def ("weak1", Name_Weak1); + Def ("wire", Name_Wire); + Def ("wor", Name_Wor); - if GI ("define") /= Name_Define - or GI ("endif") /= Name_Endif - or GI ("ifdef") /= Name_Ifdef - or GI ("include") /= Name_Include - or GI ("timescale") /= Name_Timescale - or GI ("undef") /= Name_Undef - then - raise Program_Error; - end if; + Def ("define", Name_Define); + Def ("endif", Name_Endif); + Def ("ifdef", Name_Ifdef); + Def ("include", Name_Include); + Def ("timescale", Name_Timescale); + Def ("undef", Name_Undef); - if GI ("display") /= Name_Display - or GI ("finish") /= Name_Finish - then - raise Program_Error; - end if; + Def ("display", Name_Display); + Def ("finish", Name_Finish); - if GI ("psl") /= Name_Psl - or GI ("pragma") /= Name_Pragma - then - raise Program_Error; - end if; + Def ("psl", Name_Psl); + Def ("pragma", Name_Pragma); -- PSL keywords - if GI ("a") /= Name_A - or GI ("af") /= Name_Af - or GI ("ag") /= Name_Ag - or GI ("ax") /= Name_Ax - or GI ("abort") /= Name_Abort - or GI ("assume") /= Name_Assume - or GI ("assume_guarantee") /= Name_Assume_Guarantee - or GI ("before") /= Name_Before - or GI ("clock") /= Name_Clock - or GI ("const") /= Name_Const - or GI ("cover") /= Name_Cover - or GI ("e") /= Name_E - or GI ("ef") /= Name_Ef - or GI ("eg") /= Name_Eg - or GI ("ex") /= Name_Ex - or GI ("endpoint") /= Name_Endpoint - or GI ("eventually") /= Name_Eventually - or GI ("fairness") /= Name_Fairness - or GI ("fell ") /= Name_Fell - or GI ("forall") /= Name_forall - or GI ("g") /= Name_G - or GI ("inf") /= Name_Inf - or GI ("inherit") /= Name_Inherit - or GI ("never") /= Name_Never - or GI ("next_a") /= Name_Next_A - or GI ("next_e") /= Name_Next_E - or GI ("next_event") /= Name_Next_Event - or GI ("next_event_a") /= Name_Next_Event_A - or GI ("next_event_e") /= Name_Next_Event_E - or GI ("property") /= Name_Property - or GI ("prev") /= Name_Prev - or GI ("restrict") /= Name_Restrict - or GI ("restrict_guarantee") /= Name_Restrict_Guarantee - or GI ("rose") /= Name_Rose - or GI ("sequence") /= Name_Sequence - or GI ("strong") /= Name_Strong - or GI ("union") /= Name_Union - or GI ("vmode") /= Name_Vmode - or GI ("vprop") /= Name_Vprop - or GI ("vunit") /= Name_Vunit - or GI ("w") /= Name_W - or GI ("whilenot") /= Name_Whilenot - or GI ("within") /= Name_Within - or GI ("x") /= Name_X - then - raise Program_Error; - end if; + Def ("a", Name_A); + Def ("af", Name_Af); + Def ("ag", Name_Ag); + Def ("ax", Name_Ax); + Def ("abort", Name_Abort); + Def ("assume", Name_Assume); + Def ("assume_guarantee", Name_Assume_Guarantee); + Def ("before", Name_Before); + Def ("clock", Name_Clock); + Def ("const", Name_Const); + Def ("cover", Name_Cover); + Def ("e", Name_E); + Def ("ef", Name_Ef); + Def ("eg", Name_Eg); + Def ("ex", Name_Ex); + Def ("endpoint", Name_Endpoint); + Def ("eventually", Name_Eventually); + Def ("fairness", Name_Fairness); + Def ("fell ", Name_Fell); + Def ("forall", Name_Forall); + Def ("g", Name_G); + Def ("inf", Name_Inf); + Def ("inherit", Name_Inherit); + Def ("never", Name_Never); + Def ("next_a", Name_Next_A); + Def ("next_e", Name_Next_E); + Def ("next_event", Name_Next_Event); + Def ("next_event_a", Name_Next_Event_A); + Def ("next_event_e", Name_Next_Event_E); + Def ("property", Name_Property); + Def ("prev", Name_Prev); + Def ("restrict", Name_Restrict); + Def ("restrict_guarantee", Name_Restrict_Guarantee); + Def ("rose", Name_Rose); + Def ("sequence", Name_Sequence); + Def ("strong", Name_Strong); + Def ("union", Name_Union); + Def ("vmode", Name_Vmode); + Def ("vprop", Name_Vprop); + Def ("vunit", Name_Vunit); + Def ("w", Name_W); + Def ("whilenot", Name_Whilenot); + Def ("within", Name_Within); + Def ("x", Name_X); end Std_Names_Initialize; end Std_Names; diff --git a/std_names.ads b/std_names.ads index b4455e05e..e6ba625bf 100644 --- a/std_names.ads +++ b/std_names.ads @@ -139,8 +139,10 @@ package Std_Names is Name_With : constant Name_Id := Name_First_Keyword + 080; Name_Last_Vhdl87 : constant Name_Id := Name_With; + subtype Name_Id_Vhdl87_Reserved_Words is + Name_Id range Name_First_Keyword .. Name_With; - -- VHDL93 keywords. + -- VHDL93 reserved words. Name_Xnor : constant Name_Id := Name_First_Keyword + 081; Name_Group : constant Name_Id := Name_First_Keyword + 082; Name_Impure : constant Name_Id := Name_First_Keyword + 083; @@ -161,10 +163,35 @@ package Std_Names is subtype Name_Shift_Operators is Name_Id range Name_Sll .. Name_Ror; Name_Last_Vhdl93 : constant Name_Id := Name_Ror; + subtype Name_Id_Vhdl93_Reserved_Words is + Name_Id range Name_Xnor .. Name_Ror; Name_Protected : constant Name_Id := Name_First_Keyword + 097; - Name_Last_Keyword : constant Name_Id := Name_Protected; + Name_Last_Vhdl00 : constant Name_Id := Name_Protected; + subtype Name_Id_Vhdl00_Reserved_Words is + Name_Id range Name_Protected .. Name_Protected; + + Name_Across : constant Name_Id := Name_First_Keyword + 098; + Name_Break : constant Name_Id := Name_First_Keyword + 099; + Name_Limit : constant Name_Id := Name_First_Keyword + 100; + Name_Nature : constant Name_Id := Name_First_Keyword + 101; + Name_Noise : constant Name_Id := Name_First_Keyword + 102; + Name_Procedural : constant Name_Id := Name_First_Keyword + 103; + Name_Quantity : constant Name_Id := Name_First_Keyword + 104; + Name_Reference : constant Name_Id := Name_First_Keyword + 105; + Name_Spectrum : constant Name_Id := Name_First_Keyword + 106; + Name_Subnature : constant Name_Id := Name_First_Keyword + 107; + Name_Terminal : constant Name_Id := Name_First_Keyword + 108; + Name_Through : constant Name_Id := Name_First_Keyword + 109; + Name_Tolerance : constant Name_Id := Name_First_Keyword + 110; + + Name_Last_AMS_Vhdl : constant Name_Id := Name_Tolerance; + + subtype Name_Id_AMS_Reserved_Words is + Name_Id range Name_Across .. Name_Tolerance; + + Name_Last_Keyword : constant Name_Id := Name_Tolerance; subtype Name_Id_Keywords is Name_Id range Name_First_Keyword .. Name_Last_Keyword; @@ -241,11 +268,25 @@ package Std_Names is subtype Name_Id_Vhdl93_Attributes is Name_Id range Name_First_Vhdl93_Attribute ..Name_Last_Vhdl93_Attribute; + + Name_First_AMS_Attribute : constant Name_Id := + Name_Last_Vhdl93_Attribute + 1; + Name_Contribution : constant Name_Id := Name_First_AMS_Attribute + 000; + Name_Dot : constant Name_Id := Name_First_AMS_Attribute + 001; + Name_Integ : constant Name_Id := Name_First_AMS_Attribute + 002; + Name_Above : constant Name_Id := Name_First_AMS_Attribute + 003; + Name_ZOH : constant Name_Id := Name_First_AMS_Attribute + 004; + Name_LTF : constant Name_Id := Name_First_AMS_Attribute + 005; + Name_ZTF : constant Name_Id := Name_First_AMS_Attribute + 006; + Name_Ramp : constant Name_Id := Name_First_AMS_Attribute + 007; + Name_Slew : constant Name_Id := Name_First_AMS_Attribute + 008; + Name_Last_AMS_Attribute : constant Name_Id := Name_Slew; + subtype Name_Id_Name_Attributes is Name_Id range Name_Simple_Name .. Name_Path_Name; -- Names used in std.standard package. - Name_First_Standard : constant Name_Id := Name_Last_Vhdl93_Attribute + 1; + Name_First_Standard : constant Name_Id := Name_Last_AMS_Attribute + 1; Name_Std : constant Name_Id := Name_First_Standard + 000; Name_Standard : constant Name_Id := Name_First_Standard + 001; Name_Boolean : constant Name_Id := Name_First_Standard + 002; @@ -289,7 +330,17 @@ package Std_Names is Name_Name_Error : constant Name_Id := Name_First_Standard + 040; Name_Mode_Error : constant Name_Id := Name_First_Standard + 041; Name_Foreign : constant Name_Id := Name_First_Standard + 042; - Name_Last_Standard : constant Name_Id := Name_Foreign; + + -- Added by AMS vhdl. + Name_Domain_Type : constant Name_Id := Name_First_Standard + 043; + Name_Quiescent_Domain : constant Name_Id := Name_First_Standard + 044; + Name_Time_Domain : constant Name_Id := Name_First_Standard + 045; + Name_Frequency_Domain : constant Name_Id := Name_First_Standard + 046; + Name_Domain : constant Name_Id := Name_First_Standard + 047; + Name_Frequency : constant Name_Id := Name_First_Standard + 048; + Name_Real_Vector : constant Name_Id := Name_First_Standard + 049; + + Name_Last_Standard : constant Name_Id := Name_Real_Vector; Name_First_Charname : constant Name_Id := Name_Last_Standard + 1; Name_Nul : constant Name_Id := Name_First_Charname + 00; @@ -519,7 +570,7 @@ package Std_Names is Name_Eventually : constant Name_Id := Name_First_PSL + 16; Name_Fairness : constant Name_Id := Name_First_PSL + 17; Name_Fell : constant Name_Id := Name_First_PSL + 18; - Name_forall : constant Name_Id := Name_First_PSL + 19; + Name_Forall : constant Name_Id := Name_First_PSL + 19; Name_G : constant Name_Id := Name_First_PSL + 20; -- Name_In Name_Inf : constant Name_Id := Name_First_PSL + 21; diff --git a/tokens.adb b/tokens.adb index 2022ecc4b..07dd1ac7a 100644 --- a/tokens.adb +++ b/tokens.adb @@ -70,6 +70,9 @@ package body Tokens is when Tok_Bit_String => return "<bit string>"; + when Tok_Equal_Equal => + return "=="; + -- relational_operator: when Tok_Equal => return "="; @@ -317,9 +320,38 @@ package body Tokens is when Tok_Ror => return "ror"; + -- VHDL 00 when Tok_Protected => return "protected"; + -- AMS-VHDL + when Tok_Across => + return "across"; + when Tok_Break => + return "break"; + when Tok_Limit => + return "limit"; + when Tok_Nature => + return "nature"; + when Tok_Noise => + return "noise"; + when Tok_Procedural => + return "procedural"; + when Tok_Quantity => + return "quantity"; + when Tok_Reference => + return "reference"; + when Tok_Spectrum => + return "spectrum"; + when Tok_Subnature => + return "subnature"; + when Tok_Terminal => + return "terminal"; + when Tok_Through => + return "through"; + when Tok_Tolerance => + return "tolerance"; + when Tok_And_And => return "&&"; when Tok_Bar_Bar => diff --git a/tokens.ads b/tokens.ads index c3fd68345..c331c099e 100644 --- a/tokens.ads +++ b/tokens.ads @@ -37,6 +37,8 @@ package Tokens is Tok_Box, -- <> Tok_Dot, -- . + Tok_Equal_Equal, -- == (AMS Vhdl) + Tok_Eof, -- End of file. Tok_Newline, Tok_Comment, @@ -208,6 +210,21 @@ package Tokens is -- Added by Vhdl 2000: Tok_Protected, + -- AMS reserved words + Tok_Across, + Tok_Break, + Tok_Limit, + Tok_Nature, + Tok_Noise, + Tok_Procedural, + Tok_Quantity, + Tok_Reference, + Tok_Spectrum, + Tok_Subnature, + Tok_Terminal, + Tok_Through, + Tok_Tolerance, + -- PSL words Tok_Psl_Default, Tok_Psl_Clock, diff --git a/translate/gcc/Make-lang.in b/translate/gcc/Make-lang.in index 5a0b2a580..5eab2db24 100644 --- a/translate/gcc/Make-lang.in +++ b/translate/gcc/Make-lang.in @@ -92,7 +92,7 @@ ghdllib: ghdl$(exeext) $(GCC_PASSES) force # Build hooks: -vhdl.all.build: +vhdl.all.build: vhdl.all.cross: @echo "No support for building vhdl cross-compiler" diff --git a/translate/ghdldrv/Makefile b/translate/ghdldrv/Makefile index b4199a990..47f6e0f23 100644 --- a/translate/ghdldrv/Makefile +++ b/translate/ghdldrv/Makefile @@ -61,7 +61,7 @@ ortho_code-x86-flags.ads: echo "package Ortho_Code.X86.Flags renames Ortho_Code.X86.$(ORTHO_X86_FLAGS);" >> $@ ghdl_mcode: GRT_FLAGS+=-DWITH_GNAT_RUN_TIME -ghdl_mcode: default_pathes.ads $(GRT_ADD_OBJS) $(ORTHO_DEPS) memsegs_c.o chkstk.o force +ghdl_mcode: default_pathes.ads $(GRT_ADD_OBJS) $(ORTHO_DEPS) memsegs_c.o chkstk.o force $(GNATMAKE) -aI../../ortho/mcode -aI../../ortho $(GNATFLAGS) ghdl_mcode $(GNAT_BARGS) -largs memsegs_c.o chkstk.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) ghdl_llvm_jit: GRT_FLAGS+=-DWITH_GNAT_RUN_TIME @@ -158,7 +158,7 @@ install.simul: $(MAKE) GHDL=ghdl_simul install.v87 install.v93 clean: force - $(RM) -f *.o *.ali ghdl_gcc ghdl_mcode + $(RM) -f *.o *.ali ghdl_gcc ghdl_mcode $(RM) -f b~*.ad? *~ default_pathes.ads $(RM) -rf ../lib diff --git a/translate/ghdldrv/ghdlprint.adb b/translate/ghdldrv/ghdlprint.adb index 9eaba5ce0..dedc1eb0a 100644 --- a/translate/ghdldrv/ghdlprint.adb +++ b/translate/ghdldrv/ghdlprint.adb @@ -374,17 +374,11 @@ package body Ghdlprint is Disp_Spaces; Disp_Text; when Tok_Xnor .. Tok_Ror => - if Flags.Vhdl_Std > Vhdl_87 then - Disp_Reserved; - else - Disp_Identifier; - end if; + Disp_Reserved; when Tok_Protected => - if Flags.Vhdl_Std >= Vhdl_00 then - Disp_Reserved; - else - Disp_Identifier; - end if; + Disp_Reserved; + when Tok_Across .. Tok_Tolerance => + Disp_Reserved; when Tok_Psl_Default | Tok_Psl_Clock | Tok_Psl_Property @@ -429,6 +423,7 @@ package body Ghdlprint is end if; when Tok_Left_Paren .. Tok_Colon | Tok_Comma .. Tok_Dot + | Tok_Equal_Equal | Tok_Integer | Tok_Real | Tok_Equal .. Tok_Slash diff --git a/translate/grt/Makefile.inc b/translate/grt/Makefile.inc index f0bdf61c6..2cd6722cd 100644 --- a/translate/grt/Makefile.inc +++ b/translate/grt/Makefile.inc @@ -62,7 +62,7 @@ ifeq ($(filter-out i%86 darwin%,$(arch) $(osys)),) GRT_TARGET_OBJS=i386.o linux.o times.o GRT_EXTRA_LIB= endif -ifeq ($(filter-out x84_64 darwin%,$(arch) $(osys)),) +ifeq ($(filter-out x86_64 darwin%,$(arch) $(osys)),) GRT_TARGET_OBJS=amd64.o linux.o times.o GRT_EXTRA_LIB= endif diff --git a/translate/grt/config/amd64.S b/translate/grt/config/amd64.S index 76475acdb..aa9a8c2ae 100644 --- a/translate/grt/config/amd64.S +++ b/translate/grt/config/amd64.S @@ -18,26 +18,34 @@ */ .file "amd64.S" .version "01.01" - + +#ifdef __ELF__ +#define ENTRY(func) .align 4; .globl func; .type func,@function; func: +#define END(func) .size func, . - func +#define NAME(name) name +#elif __APPLE__ +#define ENTRY(func) .align 4; .globl _##func; _##func: +#define END(func) +#define NAME(name) _##name +#else +#define ENTRY(func) .align 4; func: +#define END(func) +#define NAME(name) name +#endif .text - /* Function called to loop on the process. */ - .align 4 - .type grt_stack_loop,@function -grt_stack_loop: + /* Function called to loop on the process. */ +ENTRY(grt_stack_loop) mov 0(%rsp),%rdi call *8(%rsp) - jmp grt_stack_loop - .size grt_stack_loop, . - grt_stack_loop + jmp NAME(grt_stack_loop) +END(grt_stack_loop) /* function Stack_Create (Func : Address; Arg : Address) return Stack_Type; Args: FUNC (RDI), ARG (RSI) */ - .align 4 - .globl grt_stack_create - .type grt_stack_create,@function -grt_stack_create: +ENTRY(grt_stack_create) /* Standard prologue. */ pushq %rbp movq %rsp,%rbp @@ -45,15 +53,15 @@ grt_stack_create: sub $0x10,%rsp mov %rdi,-8(%rbp) mov %rsi,-16(%rbp) - + /* Allocate the stack, and exit in case of failure */ - callq grt_stack_allocate + callq NAME(grt_stack_allocate) test %rax,%rax je .Ldone /* Note: %RAX contains the address of the stack_context. This is also the top of the stack. */ - + /* Prepare stack. */ /* The function to be executed. */ mov -8(%rbp), %rdi @@ -62,7 +70,12 @@ grt_stack_create: mov -16(%rbp), %rsi mov %rsi, -16(%rax) /* The return function. Must be 8 mod 16. */ +#if __APPLE__ + movq _grt_stack_loop@GOTPCREL(%rip), %rsi + movq %rsi, -24(%rax) +#else movq $grt_stack_loop, -24(%rax) +#endif /* The context. */ mov %rbp, -32(%rax) mov %rbx, -40(%rax) @@ -78,16 +91,13 @@ grt_stack_create: .Ldone: leave ret - .size grt_stack_create,. - grt_stack_create +END(grt_stack_create) - .align 4 - .globl grt_stack_switch /* Arguments: TO (RDI), FROM (RSI) [VAL (RDX)] Both are pointers to a stack_context. */ - .type grt_stack_switch,@function -grt_stack_switch: +ENTRY(grt_stack_switch) /* Save call-used registers. */ pushq %rbp pushq %rbx @@ -110,7 +120,6 @@ grt_stack_switch: movq %rdx, %rax /* Run. */ ret - .size grt_stack_switch, . - grt_stack_switch +END(grt_stack_switch) - .ident "Written by T.Gingold" diff --git a/translate/grt/config/clock.c b/translate/grt/config/clock.c index 038ce2210..038ce2210 100644..100755 --- a/translate/grt/config/clock.c +++ b/translate/grt/config/clock.c diff --git a/translate/grt/config/i386.S b/translate/grt/config/i386.S index 2490ea1dd..5c8aa0d3a 100644 --- a/translate/grt/config/i386.S +++ b/translate/grt/config/i386.S @@ -18,7 +18,7 @@ */ .file "i386.S" .version "01.01" - + .text #ifdef __ELF__ @@ -34,7 +34,7 @@ #define END(func) #define NAME(name) name #endif - + /* Function called to loop on the process. */ ENTRY(grt_stack_loop) call *4(%esp) @@ -50,7 +50,7 @@ ENTRY(grt_stack_create) movl %esp,%ebp /* Keep aligned (call + pushl + 8 = 16 bytes). */ subl $8,%esp - + /* Allocate the stack, and exit in case of failure */ call NAME(grt_stack_allocate) testl %eax,%eax @@ -58,7 +58,7 @@ ENTRY(grt_stack_create) /* Note: %EAX contains the address of the stack_context. This is also the top of the stack. */ - + /* Prepare stack. */ /* The function to be executed. */ movl 8(%ebp), %ecx @@ -67,7 +67,13 @@ ENTRY(grt_stack_create) movl 12(%ebp), %ecx movl %ecx, -8(%eax) /* The return function. */ +#if __APPLE__ + call ___x86.get_pc_thunk.cx +L1$pb: + movl L_grt_stack_loop$non_lazy_ptr-L1$pb(%ecx), %eax +#else movl $NAME(grt_stack_loop), -12(%eax) +#endif /* The context. */ movl %ebx, -16(%eax) movl %esi, -20(%eax) @@ -109,5 +115,19 @@ ENTRY(grt_stack_switch) ret END(grt_stack_switch) - + +#if __APPLE__ + .section __TEXT,__textcoal_nt,coalesced,pure_instructions + .weak_definition ___x86.get_pc_thunk.cx + .private_extern ___x86.get_pc_thunk.cx +___x86.get_pc_thunk.cx: + movl (%esp), %ecx + ret + + .section __IMPORT,__pointers,non_lazy_symbol_pointers +L_grt_stack_loop$non_lazy_ptr: + .indirect_symbol _grt_stack_loop + .long 0 +#endif + .ident "Written by T.Gingold" diff --git a/translate/grt/grt-values.adb b/translate/grt/grt-values.adb index 336cf4e0a..97a36ae17 100644 --- a/translate/grt/grt-values.adb +++ b/translate/grt/grt-values.adb @@ -350,7 +350,7 @@ package body Grt.Values is S.Bounds := To_Std_String_Boundp(Bound'Address); -- find characters at the end... - Finish := Ghdl_Index_Type(Bound.Dim_1.Length)-1; + Finish := Bound.Dim_1.Length - 1; while White(S.Base.all(Finish)) loop Finish := Finish - 1; end loop; @@ -389,7 +389,7 @@ package body Grt.Values is end; if Rti.Kind = Ghdl_Rtik_Type_P64 then - Mult := Ghdl_I64(Multiple.Unit_64); + Mult := Multiple.Unit_64; else Mult := Ghdl_I64(Multiple.Unit_32); end if; diff --git a/translate/grt/grt-vcd.adb b/translate/grt/grt-vcd.adb index b262560c6..aa7f352ea 100644 --- a/translate/grt/grt-vcd.adb +++ b/translate/grt/grt-vcd.adb @@ -604,7 +604,9 @@ package body Grt.Vcd is Fact := 0.1; Delta_Exp := 1; end if; - while 1 = 1 loop -- Seek the first digit + + -- Seek the first digit + loop Digit := Digit_Floor(Val_tmp); if Digit > 0 then exit; diff --git a/translate/translation.adb b/translate/translation.adb index 71c05971f..8c46561fc 100644 --- a/translate/translation.adb +++ b/translate/translation.adb @@ -10278,7 +10278,6 @@ package body Translation is Atype := Tinfo.Ortho_Ptr_Type (Mode_Value); end case; when Type_Mode_Record => - -- part 1 of fix for https://gna.org/bugs/?19195 -- Create an object pointer. -- At elaboration: copy base from name. Atype := Tinfo.Ortho_Ptr_Type (Info.Alias_Kind); @@ -10342,7 +10341,6 @@ package body Translation is M2E (Name_Node)); end case; when Type_Mode_Record => - -- part 2 of fix for https://gna.org/bugs/?19195 Open_Temp; Stabilize (Name_Node); New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var), @@ -13220,7 +13218,6 @@ package body Translation is return Lp2M (R, Type_Info, Name_Info.Alias_Kind); end if; when Type_Mode_Record => - -- part 3 of fix for https://gna.org/bugs/?19195 R := Get_Var (Name_Info.Alias_Var); return Lp2M (R, Type_Info, Name_Info.Alias_Kind); when others => @@ -27746,16 +27743,17 @@ package body Translation is if False then El := Get_Context_Items (Unit); --- while El /= Null_Iir loop --- case Get_Kind (El) is --- when Iir_Kind_Use_Clause => --- null; --- when Iir_Kind_Library_Clause => --- null; --- when others => --- Error_Kind ("translate1", El); --- end case; --- end loop; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Library_Clause => + null; + when others => + Error_Kind ("translate1", El); + end case; + El := Get_Chain (El); + end loop; end if; El := Get_Library_Unit (Unit); |