diff options
Diffstat (limited to 'src/vhdl/vhdl-utils.adb')
-rw-r--r-- | src/vhdl/vhdl-utils.adb | 1688 |
1 files changed, 1688 insertions, 0 deletions
diff --git a/src/vhdl/vhdl-utils.adb b/src/vhdl/vhdl-utils.adb new file mode 100644 index 000000000..e93becc60 --- /dev/null +++ b/src/vhdl/vhdl-utils.adb @@ -0,0 +1,1688 @@ +-- Common operations on nodes. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Vhdl.Scanner; use Vhdl.Scanner; +with Vhdl.Tokens; use Vhdl.Tokens; +with Errorout; use Errorout; +with Name_Table; +with Str_Table; +with Std_Names; use Std_Names; +with Vhdl.Std_Package; +with Flags; use Flags; +with PSL.Nodes; + +package body Vhdl.Utils is + -- Transform the current token into an iir literal. + -- The current token must be either a character or an identifier. + function Current_Text return Iir is + Res: Iir; + begin + case Current_Token is + when Tok_Identifier => + Res := Create_Iir (Iir_Kind_Simple_Name); + when Tok_Character => + Res := Create_Iir (Iir_Kind_Character_Literal); + when others => + raise Internal_Error; + end case; + Set_Identifier (Res, Current_Identifier); + Invalidate_Current_Identifier; + Invalidate_Current_Token; + Set_Location (Res, Get_Token_Location); + return Res; + end Current_Text; + + function Is_Error (N : Iir) return Boolean is + begin + return Get_Kind (N) = Iir_Kind_Error; + end Is_Error; + + function Is_Overflow_Literal (N : Iir) return Boolean is + begin + return Get_Kind (N) = Iir_Kind_Overflow_Literal; + end Is_Overflow_Literal; + + function List_To_Flist (L : Iir_List) return Iir_Flist + is + Len : constant Natural := Get_Nbr_Elements (L); + It : List_Iterator; + Temp_L : Iir_List; + Res : Iir_Flist; + begin + Res := Create_Iir_Flist (Len); + It := List_Iterate (L); + for I in 0 .. Len - 1 loop + pragma Assert (Is_Valid (It)); + Set_Nth_Element (Res, I, Get_Element (It)); + Next (It); + end loop; + pragma Assert (not Is_Valid (It)); + + Temp_L := L; + Destroy_Iir_List (Temp_L); + + return Res; + end List_To_Flist; + + function Truncate_Flist (L : Iir_Flist; Len : Natural) return Iir_Flist + is + Res : Iir_Flist; + Temp_L : Iir_Flist; + begin + Res := Create_Iir_Flist (Len); + for I in 0 .. Len - 1 loop + Set_Nth_Element (Res, I, Get_Nth_Element (L, I)); + end loop; + Temp_L := L; + Destroy_Iir_Flist (Temp_L); + return Res; + end Truncate_Flist; + + function Get_Operator_Name (Op : Iir) return Name_Id is + begin + case Get_Kind (Op) is + when Iir_Kind_And_Operator + | Iir_Kind_Reduction_And_Operator => + return Name_And; + when Iir_Kind_Or_Operator + | Iir_Kind_Reduction_Or_Operator => + return Name_Or; + when Iir_Kind_Nand_Operator + | Iir_Kind_Reduction_Nand_Operator => + return Name_Nand; + when Iir_Kind_Nor_Operator + | Iir_Kind_Reduction_Nor_Operator => + return Name_Nor; + when Iir_Kind_Xor_Operator + | Iir_Kind_Reduction_Xor_Operator => + return Name_Xor; + when Iir_Kind_Xnor_Operator + | Iir_Kind_Reduction_Xnor_Operator => + return Name_Xnor; + + when Iir_Kind_Equality_Operator => + return Name_Op_Equality; + when Iir_Kind_Inequality_Operator => + return Name_Op_Inequality; + when Iir_Kind_Less_Than_Operator => + return Name_Op_Less; + when Iir_Kind_Less_Than_Or_Equal_Operator => + return Name_Op_Less_Equal; + when Iir_Kind_Greater_Than_Operator => + return Name_Op_Greater; + when Iir_Kind_Greater_Than_Or_Equal_Operator => + return Name_Op_Greater_Equal; + + when Iir_Kind_Match_Equality_Operator => + return Name_Op_Match_Equality; + when Iir_Kind_Match_Inequality_Operator => + return Name_Op_Match_Inequality; + when Iir_Kind_Match_Less_Than_Operator => + return Name_Op_Match_Less; + when Iir_Kind_Match_Less_Than_Or_Equal_Operator => + return Name_Op_Match_Less_Equal; + when Iir_Kind_Match_Greater_Than_Operator => + return Name_Op_Match_Greater; + when Iir_Kind_Match_Greater_Than_Or_Equal_Operator => + return Name_Op_Match_Greater_Equal; + + when Iir_Kind_Sll_Operator => + return Name_Sll; + when Iir_Kind_Sla_Operator => + return Name_Sla; + when Iir_Kind_Srl_Operator => + return Name_Srl; + when Iir_Kind_Sra_Operator => + return Name_Sra; + when Iir_Kind_Rol_Operator => + return Name_Rol; + when Iir_Kind_Ror_Operator => + return Name_Ror; + when Iir_Kind_Addition_Operator => + return Name_Op_Plus; + when Iir_Kind_Substraction_Operator => + return Name_Op_Minus; + when Iir_Kind_Concatenation_Operator => + return Name_Op_Concatenation; + when Iir_Kind_Multiplication_Operator => + return Name_Op_Mul; + when Iir_Kind_Division_Operator => + return Name_Op_Div; + when Iir_Kind_Modulus_Operator => + return Name_Mod; + when Iir_Kind_Remainder_Operator => + return Name_Rem; + when Iir_Kind_Exponentiation_Operator => + return Name_Op_Exp; + when Iir_Kind_Not_Operator => + return Name_Not; + when Iir_Kind_Negation_Operator => + return Name_Op_Minus; + when Iir_Kind_Identity_Operator => + return Name_Op_Plus; + when Iir_Kind_Absolute_Operator => + return Name_Abs; + when Iir_Kind_Condition_Operator + | Iir_Kind_Implicit_Condition_Operator => + return Name_Op_Condition; + when others => + raise Internal_Error; + end case; + end Get_Operator_Name; + + function Get_Longuest_Static_Prefix (Expr: Iir) return Iir is + Adecl: Iir; + begin + Adecl := Expr; + loop + case Get_Kind (Adecl) is + when Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration => + return Adecl; + when Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Constant_Declaration => + return Adecl; + when Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + return Adecl; + when Iir_Kind_Object_Alias_Declaration => + -- LRM 4.3.3.1 Object Aliases + -- 2. The name must be a static name [...] + return Adecl; + when Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element => + if Get_Name_Staticness (Adecl) >= Globally then + return Adecl; + else + Adecl := Get_Prefix (Adecl); + end if; + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Adecl := Get_Named_Entity (Adecl); + when Iir_Kind_Type_Conversion => + return Null_Iir; + when others => + Error_Kind ("get_longuest_static_prefix", Adecl); + end case; + end loop; + end Get_Longuest_Static_Prefix; + + function Get_Object_Prefix (Name: Iir; With_Alias : Boolean := True) + return Iir + is + Adecl : Iir; + begin + Adecl := Name; + loop + case Get_Kind (Adecl) is + when Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Terminal_Declaration + | Iir_Kind_Interface_Type_Declaration + | Iir_Kind_Interface_Package_Declaration + | Iir_Kind_Interface_Function_Declaration + | Iir_Kind_Interface_Procedure_Declaration + | Iir_Kind_External_Signal_Name + | Iir_Kind_External_Constant_Name + | Iir_Kind_External_Variable_Name => + return Adecl; + when Iir_Kind_Object_Alias_Declaration => + if With_Alias then + Adecl := Get_Name (Adecl); + else + return Adecl; + end if; + when Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Selected_By_All_Name => + Adecl := Get_Base_Name (Adecl); + when Iir_Kinds_Literal + | Iir_Kind_Overflow_Literal + | Iir_Kind_Enumeration_Literal + | Iir_Kinds_Monadic_Operator + | Iir_Kinds_Dyadic_Operator + | Iir_Kind_Function_Call + | Iir_Kind_Qualified_Expression + | Iir_Kind_Type_Conversion + | Iir_Kind_Allocator_By_Expression + | Iir_Kind_Allocator_By_Subtype + | Iir_Kind_Parenthesis_Expression + | Iir_Kinds_Attribute + | Iir_Kind_Attribute_Value + | Iir_Kind_Aggregate + | Iir_Kind_Simple_Aggregate + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Unit_Declaration + | Iir_Kind_Psl_Expression + | Iir_Kinds_Concurrent_Statement + | Iir_Kinds_Sequential_Statement + | Iir_Kind_Simple_Simultaneous_Statement => + return Adecl; + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Adecl := Get_Named_Entity (Adecl); + when Iir_Kind_Attribute_Name => + return Get_Named_Entity (Adecl); + when Iir_Kind_Error + | Iir_Kind_Unused + | Iir_Kind_Parenthesis_Name + | Iir_Kind_Conditional_Expression + | Iir_Kind_Character_Literal + | Iir_Kind_Operator_Symbol + | Iir_Kind_Design_File + | Iir_Kind_Design_Unit + | Iir_Kind_Library_Clause + | Iir_Kind_Use_Clause + | Iir_Kind_Context_Reference + | Iir_Kind_Library_Declaration + | Iir_Kinds_Library_Unit + | Iir_Kind_Component_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Attribute_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration + | Iir_Kinds_Type_Declaration + | Iir_Kinds_Type_And_Subtype_Definition + | Iir_Kind_Wildcard_Type_Definition + | Iir_Kind_Subtype_Definition + | Iir_Kind_Scalar_Nature_Definition + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration + | Iir_Kind_Signal_Attribute_Declaration + | Iir_Kind_Unaffected_Waveform + | Iir_Kind_Waveform_Element + | Iir_Kind_Conditional_Waveform + | Iir_Kind_Binding_Indication + | Iir_Kind_Component_Configuration + | Iir_Kind_Block_Configuration + | Iir_Kind_Attribute_Specification + | Iir_Kind_Disconnection_Specification + | Iir_Kind_Configuration_Specification + | Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kinds_Subprogram_Body + | Iir_Kind_Protected_Type_Body + | Iir_Kind_Generate_Statement_Body + | Iir_Kind_Procedure_Call + | Iir_Kind_Aggregate_Info + | Iir_Kind_Entity_Class + | Iir_Kind_Signature + | Iir_Kind_Reference_Name + | Iir_Kind_Package_Header + | Iir_Kind_Block_Header + | Iir_Kinds_Association_Element + | Iir_Kind_Association_Element_Package + | Iir_Kind_Association_Element_Type + | Iir_Kind_Association_Element_Subprogram + | Iir_Kinds_Choice + | Iir_Kinds_Entity_Aspect + | Iir_Kind_If_Generate_Else_Clause + | Iir_Kind_Elsif + | Iir_Kind_Record_Element_Constraint + | Iir_Kind_Array_Element_Resolution + | Iir_Kind_Record_Resolution + | Iir_Kind_Record_Element_Resolution + | Iir_Kind_Element_Declaration + | Iir_Kind_Psl_Endpoint_Declaration + | Iir_Kind_Psl_Declaration + | Iir_Kind_Package_Pathname + | Iir_Kind_Absolute_Pathname + | Iir_Kind_Relative_Pathname + | Iir_Kind_Pathname_Element + | Iir_Kind_Range_Expression + | Iir_Kind_Overload_List => + return Adecl; + end case; + end loop; + end Get_Object_Prefix; + + function Is_Object_Name (Name : Iir) return Boolean + is + Obj : constant Iir := Name_To_Object (Name); + begin + return Obj /= Null_Iir; + end Is_Object_Name; + + function Name_To_Object (Name : Iir) return Iir is + begin + -- LRM08 6.4 Objects + -- An object is a named entity that contains (has) a value of a type. + -- An object is obe of the following: + case Get_Kind (Name) is + -- An object declared by an object declaration (see 6.4.2) + when Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Constant_Declaration => + return Name; + + -- A loop of generate parameter. + when Iir_Kind_Iterator_Declaration => + return Name; + + -- A formal parameter of a subprogram + -- A formal port + -- A formal generic constant + -- A local port + -- A local generic constant + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration => + return Name; + + -- An implicit signak GUARD defined by the guard expression of a + -- block statement + when Iir_Kind_Guard_Signal_Declaration => + return Name; + + -- In addition, the following are objects [ but are not named + -- entities]: + -- An implicit signal defined by any of the predefined attributes + -- 'DELAYED, 'STABLE, 'QUIET, and 'TRANSACTION + when Iir_Kinds_Signal_Attribute => + return Name; + + -- An element or a slice of another object + when Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element => + return Name; + + -- An object designated by a value of an access type + when Iir_Kind_Implicit_Dereference + | Iir_Kind_Dereference => + return Name; + + -- LRM08 6.6 Alias declarations + -- An object alias is an alias whose alias designatore denotes an + -- object. + when Iir_Kind_Object_Alias_Declaration => + return Name; + + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + -- LRM08 8 Names + -- Names can denote declared entities [...] + -- GHDL: in particular, names can denote objects. + return Name_To_Object (Get_Named_Entity (Name)); + + when Iir_Kinds_External_Name => + return Name; + + when others => + return Null_Iir; + end case; + end Name_To_Object; + + function Name_To_Value (Name : Iir) return Iir is + begin + case Get_Kind (Name) is + when Iir_Kind_Attribute_Value + | Iir_Kind_Function_Call + | Iir_Kinds_Expression_Attribute => + return Name; + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return Name_To_Value (Get_Named_Entity (Name)); + when others => + return Name_To_Object (Name); + end case; + end Name_To_Value; + + -- Return TRUE if EXPR is a signal name. + function Is_Signal_Name (Expr : Iir) return Boolean + is + Obj : Iir; + begin + Obj := Name_To_Object (Expr); + if Obj /= Null_Iir then + return Is_Signal_Object (Obj); + else + return False; + end if; + end Is_Signal_Name; + + function Is_Signal_Object (Name : Iir) return Boolean + is + Adecl: Iir; + begin + Adecl := Get_Object_Prefix (Name, True); + case Get_Kind (Adecl) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kinds_Signal_Attribute => + return True; + when Iir_Kind_Object_Alias_Declaration => + -- Must have been handled by Get_Object_Prefix. + raise Internal_Error; + when others => + return False; + end case; + end Is_Signal_Object; + + function Get_Interface_Of_Formal (Formal : Iir) return Iir + is + El : Iir; + begin + El := Formal; + loop + case Get_Kind (El) is + when Iir_Kind_Simple_Name + | Iir_Kind_Operator_Symbol => + -- Operator is for subprogram interfaces. + return Get_Named_Entity (El); + when Iir_Kinds_Interface_Declaration => + return El; + when Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element => + -- FIXME: use get_base_name ? + El := Get_Prefix (El); + when others => + Error_Kind ("get_interface_of_formal", El); + end case; + end loop; + end Get_Interface_Of_Formal; + + function Get_Association_Interface (Assoc : Iir; Inter : Iir) return Iir + is + Formal : constant Iir := Get_Formal (Assoc); + begin + if Formal /= Null_Iir then + return Get_Interface_Of_Formal (Formal); + else + return Inter; + end if; + end Get_Association_Interface; + + procedure Next_Association_Interface + (Assoc : in out Iir; Inter : in out Iir) + is + Formal : constant Iir := Get_Formal (Assoc); + begin + -- In canon, open association can be inserted after an association by + -- name. So do not assume there is no association by position after + -- association by name. + if Is_Valid (Formal) then + Inter := Get_Chain (Get_Interface_Of_Formal (Formal)); + else + Inter := Get_Chain (Inter); + end if; + Assoc := Get_Chain (Assoc); + end Next_Association_Interface; + + function Get_Association_Formal (Assoc : Iir; Inter : Iir) return Iir + is + Formal : constant Iir := Get_Formal (Assoc); + begin + if Formal /= Null_Iir then + -- Strip denoting name + case Get_Kind (Formal) is + when Iir_Kind_Simple_Name + | Iir_Kind_Operator_Symbol => + return Get_Named_Entity (Formal); + when Iir_Kinds_Interface_Declaration => + -- Shouldn't happen. + raise Internal_Error; + when Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element => + return Formal; + when others => + Error_Kind ("get_association_formal", Formal); + end case; + else + return Inter; + end if; + end Get_Association_Formal; + + function Find_First_Association_For_Interface + (Assoc_Chain : Iir; Inter_Chain : Iir; Inter : Iir) return Iir + is + Assoc_El : Iir; + Inter_El : Iir; + begin + Assoc_El := Assoc_Chain; + Inter_El := Inter_Chain; + while Is_Valid (Assoc_El) loop + if Get_Association_Interface (Assoc_El, Inter_El) = Inter then + return Assoc_El; + end if; + Next_Association_Interface (Assoc_El, Inter_El); + end loop; + return Null_Iir; + end Find_First_Association_For_Interface; + + function Is_Parameter (Inter : Iir) return Boolean is + begin + case Get_Kind (Get_Parent (Inter)) is + when Iir_Kinds_Subprogram_Declaration + | Iir_Kinds_Interface_Subprogram_Declaration => + return True; + when others => + -- Port + return False; + end case; + end Is_Parameter; + + function Find_Name_In_Flist (List : Iir_Flist; Lit : Name_Id) return Iir + is + El : Iir; + begin + for I in Flist_First .. Flist_Last (List) loop + El := Get_Nth_Element (List, I); + if Get_Identifier (El) = Lit then + return El; + end if; + end loop; + return Null_Iir; + end Find_Name_In_Flist; + + function Find_Name_In_Chain (Chain: Iir; Lit: Name_Id) return Iir + is + El: Iir := Chain; + begin + while El /= Null_Iir loop + if Get_Identifier (El) = Lit then + return El; + end if; + El := Get_Chain (El); + end loop; + return Null_Iir; + end Find_Name_In_Chain; + + function Is_In_Chain (Chain : Iir; El : Iir) return Boolean + is + Chain_El : Iir; + begin + Chain_El := Chain; + while Chain_El /= Null_Iir loop + if Chain_El = El then + return True; + end if; + Chain_El := Get_Chain (Chain_El); + end loop; + return False; + end Is_In_Chain; + + procedure Add_Dependence (Target: Iir_Design_Unit; Unit: Iir) is + begin + -- Do not add self-dependency + if Unit = Target then + return; + end if; + + pragma Assert (Kind_In (Unit, Iir_Kind_Design_Unit, + Iir_Kind_Entity_Aspect_Entity)); + + Add_Element (Get_Dependence_List (Target), Unit); + end Add_Dependence; + + function Get_Unit_From_Dependence (Dep : Iir) return Iir is + begin + case Get_Kind (Dep) is + when Iir_Kind_Design_Unit => + return Dep; + when Iir_Kind_Entity_Aspect_Entity => + return Get_Design_Unit (Get_Entity (Dep)); + when others => + Error_Kind ("get_unit_from_dependence", Dep); + end case; + end Get_Unit_From_Dependence; + + procedure Clear_Instantiation_Configuration_Vhdl87 + (Parent : Iir; In_Generate : Boolean; Full : Boolean) + is + El : Iir; + Prev : Iir; + begin + El := Get_Concurrent_Statement_Chain (Parent); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Component_Instantiation_Statement => + if In_Generate and not Full then + Prev := Get_Component_Configuration (El); + if Prev /= Null_Iir then + case Get_Kind (Prev) is + when Iir_Kind_Configuration_Specification => + -- Keep it. + null; + when Iir_Kind_Component_Configuration => + Set_Component_Configuration (El, Null_Iir); + when others => + Error_Kind + ("clear_instantiation_configuration_vhdl87", + Prev); + end case; + end if; + else + Set_Component_Configuration (El, Null_Iir); + end if; + when Iir_Kind_For_Generate_Statement => + Set_Generate_Block_Configuration (El, Null_Iir); + -- Clear inside a generate statement. + Clear_Instantiation_Configuration_Vhdl87 (El, True, Full); + when Iir_Kind_Block_Statement => + Set_Block_Block_Configuration (El, Null_Iir); + when others => + null; + end case; + El := Get_Chain (El); + end loop; + end Clear_Instantiation_Configuration_Vhdl87; + + procedure Clear_Instantiation_Configuration (Parent : Iir; Full : Boolean) + is + El : Iir; + begin + if False and then Flags.Vhdl_Std = Vhdl_87 then + Clear_Instantiation_Configuration_Vhdl87 + (Parent, Get_Kind (Parent) = Iir_Kind_For_Generate_Statement, Full); + else + El := Get_Concurrent_Statement_Chain (Parent); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Component_Instantiation_Statement => + Set_Component_Configuration (El, Null_Iir); + when Iir_Kind_For_Generate_Statement => + declare + Bod : constant Iir := Get_Generate_Statement_Body (El); + begin + Set_Generate_Block_Configuration (Bod, Null_Iir); + end; + when Iir_Kind_If_Generate_Statement => + declare + Clause : Iir; + Bod : Iir; + begin + Clause := El; + while Clause /= Null_Iir loop + Bod := Get_Generate_Statement_Body (Clause); + Set_Generate_Block_Configuration (Bod, Null_Iir); + Clause := Get_Generate_Else_Clause (Clause); + end loop; + end; + when Iir_Kind_Block_Statement => + Set_Block_Block_Configuration (El, Null_Iir); + when others => + null; + end case; + El := Get_Chain (El); + end loop; + end if; + end Clear_Instantiation_Configuration; + + -- Get identifier of NODE as a string. + function Image_Identifier (Node : Iir) return String is + begin + return Name_Table.Image (Vhdl.Nodes.Get_Identifier (Node)); + end Image_Identifier; + + function Image_String_Lit (Str : Iir) return String is + begin + return Str_Table.String_String8 + (Get_String8_Id (Str), Get_String_Length (Str)); + end Image_String_Lit; + + function Copy_Enumeration_Literal (Lit : Iir) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Enumeration_Literal); + Set_Identifier (Res, Get_Identifier (Lit)); + Location_Copy (Res, Lit); + Set_Parent (Res, Get_Parent (Lit)); + Set_Type (Res, Get_Type (Lit)); + Set_Enum_Pos (Res, Get_Enum_Pos (Lit)); + Set_Expr_Staticness (Res, Locally); + return Res; + end Copy_Enumeration_Literal; + + procedure Create_Range_Constraint_For_Enumeration_Type + (Def : Iir_Enumeration_Type_Definition) + is + Range_Expr : Iir_Range_Expression; + Literal_List : constant Iir_Flist := Get_Enumeration_Literal_List (Def); + List_Len : constant Natural := Get_Nbr_Elements (Literal_List); + begin + -- Create a constraint. + Range_Expr := Create_Iir (Iir_Kind_Range_Expression); + Location_Copy (Range_Expr, Def); + Set_Type (Range_Expr, Def); + Set_Direction (Range_Expr, Iir_To); + if List_Len >= 1 then + Set_Left_Limit + (Range_Expr, Get_Nth_Element (Literal_List, 0)); + Set_Right_Limit + (Range_Expr, Get_Nth_Element (Literal_List, List_Len - 1)); + end if; + Set_Expr_Staticness (Range_Expr, Locally); + Set_Range_Constraint (Def, Range_Expr); + end Create_Range_Constraint_For_Enumeration_Type; + + function Is_Static_Construct (Expr : Iir) return Boolean is + begin + case Get_Kind (Expr) is + when Iir_Kind_Aggregate => + return Get_Aggregate_Expand_Flag (Expr); + when Iir_Kinds_Literal => + return True; + when Iir_Kind_Simple_Aggregate + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Character_Literal => + return True; + when Iir_Kind_Overflow_Literal => + -- Needs to generate an error. + return False; + when others => + return False; + end case; + end Is_Static_Construct; + + procedure Free_Name (Node : Iir) + is + N : Iir; + N1 : Iir; + begin + if Node = Null_Iir then + return; + end if; + N := Node; + case Get_Kind (N) is + when Iir_Kind_Simple_Name + | Iir_Kind_Character_Literal + | Iir_Kind_String_Literal8 + | Iir_Kind_Subtype_Definition => + Free_Iir (N); + when Iir_Kind_Selected_Name + | Iir_Kind_Parenthesis_Name + | Iir_Kind_Selected_By_All_Name => + N1 := Get_Prefix (N); + Free_Iir (N); + Free_Name (N1); + when Iir_Kind_Library_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Design_Unit + | Iir_Kinds_Concurrent_Statement + | Iir_Kinds_Sequential_Statement => + return; + when others => + Error_Kind ("free_name", Node); + --Free_Iir (N); + end case; + end Free_Name; + + procedure Free_Recursive_List (List : Iir_List) + is + It : List_Iterator; + begin + It := List_Iterate (List); + while Is_Valid (It) loop + Free_Recursive (Get_Element (It)); + Next (It); + end loop; + end Free_Recursive_List; + + procedure Free_Recursive_Flist (List : Iir_Flist) + is + El : Iir; + begin + for I in Flist_First .. Flist_Last (List) loop + El := Get_Nth_Element (List, I); + Free_Recursive (El); + end loop; + end Free_Recursive_Flist; + + procedure Free_Recursive (Node : Iir; Free_List : Boolean := False) + is + N : Iir; + begin + if Node = Null_Iir then + return; + end if; + N := Node; + case Get_Kind (N) is + when Iir_Kind_Library_Declaration => + return; + when Iir_Kind_Simple_Name + | Iir_Kind_Parenthesis_Name + | Iir_Kind_Character_Literal => + null; + when Iir_Kind_Enumeration_Literal => + return; + when Iir_Kind_Selected_Name => + Free_Recursive (Get_Prefix (N)); + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration => + Free_Recursive (Get_Type (N)); + Free_Recursive (Get_Default_Value (N)); + when Iir_Kind_Range_Expression => + Free_Recursive (Get_Left_Limit (N)); + Free_Recursive (Get_Right_Limit (N)); + when Iir_Kind_Subtype_Definition => + Free_Recursive (Get_Base_Type (N)); + when Iir_Kind_Integer_Literal => + null; + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Entity_Declaration + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Context_Declaration => + null; + when Iir_Kind_File_Type_Definition + | Iir_Kind_Access_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + return; + when Iir_Kind_Architecture_Body => + Free_Recursive (Get_Entity_Name (N)); + when Iir_Kind_Overload_List => + Free_Recursive_List (Get_Overload_List (N)); + if not Free_List then + return; + end if; + when Iir_Kind_Array_Subtype_Definition => + Free_Recursive_Flist (Get_Index_List (N)); + Free_Recursive (Get_Base_Type (N)); + when Iir_Kind_Entity_Aspect_Entity => + Free_Recursive (Get_Entity (N)); + Free_Recursive (Get_Architecture (N)); + when others => + Error_Kind ("free_recursive", Node); + end case; + Free_Iir (N); + end Free_Recursive; + + function Get_Predefined_Function_Name (Func : Iir_Predefined_Functions) + return String + is + begin + return Iir_Predefined_Functions'Image (Func); + end Get_Predefined_Function_Name; + + function Get_Callees_List_Holder (Subprg : Iir) return Iir is + begin + case Get_Kind (Subprg) is + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + return Get_Subprogram_Body (Subprg); + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + return Subprg; + when others => + Error_Kind ("get_callees_list_holder", Subprg); + end case; + end Get_Callees_List_Holder; + + procedure Clear_Seen_Flag (Top : Iir) + is + Callees_List : Iir_Callees_List; + It : List_Iterator; + El: Iir; + begin + if Get_Seen_Flag (Top) then + Set_Seen_Flag (Top, False); + Callees_List := Get_Callees_List (Get_Callees_List_Holder (Top)); + if Callees_List /= Null_Iir_List then + It := List_Iterate (Callees_List); + while Is_Valid (It) loop + El := Get_Element (It); + if Get_Seen_Flag (El) = False then + Clear_Seen_Flag (El); + end if; + Next (It); + end loop; + end if; + end if; + end Clear_Seen_Flag; + + function Is_Anonymous_Type_Definition (Def : Iir) return Boolean is + begin + return Get_Type_Declarator (Def) = Null_Iir; + end Is_Anonymous_Type_Definition; + + function Is_Fully_Constrained_Type (Def : Iir) return Boolean is + begin + return Get_Kind (Def) not in Iir_Kinds_Composite_Type_Definition + or else Get_Constraint_State (Def) = Fully_Constrained; + end Is_Fully_Constrained_Type; + + function Strip_Denoting_Name (Name : Iir) return Iir is + begin + if Get_Kind (Name) in Iir_Kinds_Denoting_Name then + return Get_Named_Entity (Name); + else + return Name; + end if; + end Strip_Denoting_Name; + + function Build_Simple_Name (Ref : Iir; Loc : Location_Type) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Simple_Name); + Set_Location (Res, Loc); + Set_Identifier (Res, Get_Identifier (Ref)); + Set_Named_Entity (Res, Ref); + Set_Base_Name (Res, Res); + -- FIXME: set type and expr staticness ? + return Res; + end Build_Simple_Name; + + function Build_Simple_Name (Ref : Iir; Loc : Iir) return Iir is + begin + return Build_Simple_Name (Ref, Get_Location (Loc)); + end Build_Simple_Name; + + function Build_Reference_Name (Name : Iir) return Iir + is + Res : Iir; + begin + pragma Assert (Get_Kind (Name) in Iir_Kinds_Denoting_Name); + + Res := Create_Iir (Iir_Kind_Reference_Name); + Location_Copy (Res, Name); + Set_Referenced_Name (Res, Name); + Set_Is_Forward_Ref (Res, True); + Set_Named_Entity (Res, Get_Named_Entity (Name)); + return Res; + end Build_Reference_Name; + + function Strip_Reference_Name (N : Iir) return Iir is + begin + if Get_Kind (N) = Iir_Kind_Reference_Name then + return Get_Named_Entity (N); + else + return N; + end if; + end Strip_Reference_Name; + + function Has_Resolution_Function (Subtyp : Iir) return Iir + is + Ind : constant Iir := Get_Resolution_Indication (Subtyp); + begin + if Ind /= Null_Iir + and then Get_Kind (Ind) in Iir_Kinds_Denoting_Name + then + -- A resolution indication can be an array/record element resolution. + return Get_Named_Entity (Ind); + else + return Null_Iir; + end if; + end Has_Resolution_Function; + + function Is_Type_Name (Name : Iir) return Iir + is + Ent : Iir; + begin + if Get_Kind (Name) in Iir_Kinds_Denoting_Name then + Ent := Get_Named_Entity (Name); + case Get_Kind (Ent) is + when Iir_Kind_Type_Declaration => + return Get_Type_Definition (Ent); + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Base_Attribute => + return Get_Type (Ent); + when others => + return Null_Iir; + end case; + else + return Null_Iir; + end if; + end Is_Type_Name; + + function Get_Type_Of_Subtype_Indication (Ind : Iir) return Iir is + begin + case Get_Kind (Ind) is + when Iir_Kinds_Denoting_Name => + return Get_Type (Ind); + when Iir_Kinds_Subtype_Definition => + return Ind; + when Iir_Kind_Subtype_Attribute => + return Get_Type (Ind); + when Iir_Kind_Error => + return Ind; + when others => + Error_Kind ("get_type_of_subtype_indication", Ind); + end case; + end Get_Type_Of_Subtype_Indication; + + function Get_Index_Type (Indexes : Iir_Flist; Idx : Natural) return Iir + is + Index : constant Iir := Get_Nth_Element (Indexes, Idx); + begin + if Index = Null_Iir then + return Null_Iir; + else + return Get_Index_Type (Index); + end if; + end Get_Index_Type; + + function Get_Index_Type (Array_Type : Iir; Idx : Natural) return Iir is + begin + return Get_Index_Type (Get_Index_Subtype_List (Array_Type), Idx); + end Get_Index_Type; + + function Get_Nbr_Dimensions (Array_Type : Iir) return Natural is + begin + return Get_Nbr_Elements (Get_Index_Subtype_List (Array_Type)); + end Get_Nbr_Dimensions; + + function Are_Array_Indexes_Locally_Static (Array_Type : Iir) return Boolean + is + Indexes : constant Iir_Flist := Get_Index_Subtype_List (Array_Type); + Index : Iir; + begin + for I in Flist_First .. Flist_Last (Indexes) loop + Index := Get_Index_Type (Indexes, I); + if Get_Type_Staticness (Index) /= Locally then + return False; + end if; + end loop; + return True; + end Are_Array_Indexes_Locally_Static; + + function Are_Bounds_Locally_Static (Def : Iir) return Boolean is + begin + if Get_Type_Staticness (Def) = Locally then + return True; + end if; + + case Iir_Kinds_Type_And_Subtype_Definition (Get_Kind (Def)) is + when Iir_Kind_Array_Subtype_Definition => + pragma Assert (Get_Constraint_State (Def) = Fully_Constrained); + + -- Indexes. + if not Are_Array_Indexes_Locally_Static (Def) then + return False; + end if; + + -- Element. + return Are_Bounds_Locally_Static (Get_Element_Subtype (Def)); + when Iir_Kind_Array_Type_Definition => + return False; + when Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Record_Type_Definition => + pragma Assert (Get_Constraint_State (Def) = Fully_Constrained); + + declare + El_List : constant Iir_Flist := + Get_Elements_Declaration_List (Def); + El : Iir; + begin + for I in Flist_First .. Flist_Last (El_List) loop + El := Get_Nth_Element (El_List, I); + if not Are_Bounds_Locally_Static (Get_Type (El)) then + return False; + end if; + end loop; + return True; + end; + when Iir_Kinds_Scalar_Type_And_Subtype_Definition + | Iir_Kind_Protected_Type_Declaration + | Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + return True; + when Iir_Kind_Incomplete_Type_Definition + | Iir_Kind_File_Type_Definition + | Iir_Kind_Interface_Type_Definition => + Error_Kind ("are_bounds_locally_static", Def); + end case; + end Are_Bounds_Locally_Static; + + function Get_Denoted_Type_Mark (Subtyp : Iir) return Iir + is + Type_Mark_Name : constant Iir := Get_Subtype_Type_Mark (Subtyp); + begin + if Type_Mark_Name = Null_Iir then + -- No type_mark (for array subtype created by constrained array + -- definition. + return Null_Iir; + else + return Get_Type (Get_Named_Entity (Type_Mark_Name)); + end if; + end Get_Denoted_Type_Mark; + + function Get_Base_Element_Declaration (El : Iir) return Iir + is + Rec_Type : constant Iir := Get_Base_Type (Get_Parent (El)); + Els_List : constant Iir_Flist := + Get_Elements_Declaration_List (Rec_Type); + begin + return Get_Nth_Element + (Els_List, Natural (Get_Element_Position (El))); + end Get_Base_Element_Declaration; + + procedure Append_Owned_Element_Constraint (Rec_Type : Iir; El : Iir) is + begin + pragma Assert (Get_Parent (El) = Rec_Type); + Set_Chain (El, Get_Owned_Elements_Chain (Rec_Type)); + Set_Owned_Elements_Chain (Rec_Type, El); + end Append_Owned_Element_Constraint; + + + function Is_Second_Subprogram_Specification (Spec : Iir) return Boolean + is + Bod : constant Iir := Get_Chain (Spec); + begin + -- FIXME: don't directly use Subprogram_Body as it is not yet correctly + -- set during instantiation. + return Get_Has_Body (Spec) + and then Get_Subprogram_Specification (Bod) /= Spec; + end Is_Second_Subprogram_Specification; + + function Is_Implicit_Subprogram (Spec : Iir) return Boolean is + begin + return Get_Kind (Spec) in Iir_Kinds_Subprogram_Declaration + and then Get_Implicit_Definition (Spec) in Iir_Predefined_Implicit; + end Is_Implicit_Subprogram; + + function Is_Function_Declaration (N : Iir) return Boolean is + begin + return Kind_In (N, Iir_Kind_Function_Declaration, + Iir_Kind_Interface_Function_Declaration); + end Is_Function_Declaration; + + function Is_Procedure_Declaration (N : Iir) return Boolean is + begin + return Kind_In (N, Iir_Kind_Procedure_Declaration, + Iir_Kind_Interface_Procedure_Declaration); + end Is_Procedure_Declaration; + + function Is_Same_Profile (L, R: Iir) return Boolean + is + L1, R1 : Iir; + L_Kind, R_Kind : Iir_Kind; + El_L, El_R : Iir; + begin + L_Kind := Get_Kind (L); + if L_Kind = Iir_Kind_Non_Object_Alias_Declaration then + L1 := Get_Named_Entity (Get_Name (L)); + L_Kind := Get_Kind (L1); + else + L1 := L; + end if; + R_Kind := Get_Kind (R); + if R_Kind = Iir_Kind_Non_Object_Alias_Declaration then + R1 := Get_Named_Entity (Get_Name (R)); + R_Kind := Get_Kind (R1); + else + R1 := R; + end if; + + -- Check L and R are both of the same 'kind'. + -- Also the return profile for functions. + if L_Kind = Iir_Kind_Function_Declaration + and then R_Kind = Iir_Kind_Function_Declaration + then + if Get_Base_Type (Get_Return_Type (L1)) /= + Get_Base_Type (Get_Return_Type (R1)) + then + return False; + end if; + elsif L_Kind = Iir_Kind_Procedure_Declaration + and then R_Kind = Iir_Kind_Procedure_Declaration + then + null; + elsif L_Kind = Iir_Kind_Enumeration_Literal + and then R_Kind = Iir_Kind_Enumeration_Literal + then + return Get_Type (L1) = Get_Type (R1); + elsif L_Kind = Iir_Kind_Enumeration_Literal + and then R_Kind = Iir_Kind_Function_Declaration + then + return Get_Interface_Declaration_Chain (R1) = Null_Iir + and then Get_Base_Type (Get_Return_Type (R1)) = Get_Type (L1); + elsif L_Kind = Iir_Kind_Function_Declaration + and then R_Kind = Iir_Kind_Enumeration_Literal + then + return Get_Interface_Declaration_Chain (L1) = Null_Iir + and then Get_Base_Type (Get_Return_Type (L1)) = Get_Type (R1); + else + -- Kind mismatch. + return False; + end if; + + -- Check parameters profile. + El_L := Get_Interface_Declaration_Chain (L1); + El_R := Get_Interface_Declaration_Chain (R1); + loop + exit when El_L = Null_Iir and El_R = Null_Iir; + if El_L = Null_Iir or El_R = Null_Iir then + return False; + end if; + if Get_Base_Type (Get_Type (El_L)) /= Get_Base_Type (Get_Type (El_R)) + then + return False; + end if; + El_L := Get_Chain (El_L); + El_R := Get_Chain (El_R); + end loop; + + return True; + end Is_Same_Profile; + + function Is_Operation_For_Type (Subprg : Iir; Atype : Iir) return Boolean + is + pragma Assert (Get_Kind (Subprg) in Iir_Kinds_Subprogram_Declaration); + Base_Type : constant Iir := Get_Base_Type (Atype); + Inter : Iir; + begin + Inter := Get_Interface_Declaration_Chain (Subprg); + while Inter /= Null_Iir loop + if Get_Base_Type (Get_Type (Inter)) = Base_Type then + return True; + end if; + Inter := Get_Chain (Inter); + end loop; + if Get_Kind (Subprg) = Iir_Kind_Function_Declaration + and then Get_Base_Type (Get_Return_Type (Subprg)) = Base_Type + then + return True; + end if; + return False; + end Is_Operation_For_Type; + + -- From a block_specification, returns the block. + function Get_Block_From_Block_Specification (Block_Spec : Iir) + return Iir + is + Res : Iir; + begin + case Get_Kind (Block_Spec) is + when Iir_Kind_Design_Unit => + Res := Get_Library_Unit (Block_Spec); + if Get_Kind (Res) /= Iir_Kind_Architecture_Body then + raise Internal_Error; + end if; + return Res; + when Iir_Kind_Block_Statement + | Iir_Kind_Architecture_Body + | Iir_Kind_For_Generate_Statement + | Iir_Kind_If_Generate_Statement => + return Block_Spec; + when Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Slice_Name => + return Get_Named_Entity (Get_Prefix (Block_Spec)); + when Iir_Kind_Simple_Name => + return Get_Named_Entity (Block_Spec); + when Iir_Kind_Parenthesis_Name => + -- An alternative label. + return Get_Named_Entity (Block_Spec); + when others => + Error_Kind ("get_block_from_block_specification", Block_Spec); + return Null_Iir; + end case; + end Get_Block_From_Block_Specification; + + function Get_Entity (Decl : Iir) return Iir + is + Name : constant Iir := Get_Entity_Name (Decl); + Res : constant Iir := Get_Named_Entity (Name); + begin + if Res = Vhdl.Std_Package.Error_Mark then + return Null_Iir; + end if; + + pragma Assert (Res = Null_Iir + or else Get_Kind (Res) = Iir_Kind_Entity_Declaration); + return Res; + end Get_Entity; + + function Get_Configuration (Aspect : Iir) return Iir + is + Name : constant Iir := Get_Configuration_Name (Aspect); + Res : constant Iir := Get_Named_Entity (Name); + begin + pragma Assert (Get_Kind (Res) = Iir_Kind_Configuration_Declaration); + return Res; + end Get_Configuration; + + function Get_Entity_Identifier_Of_Architecture (Arch : Iir) return Name_Id + is + Name : constant Iir := Get_Entity_Name (Arch); + begin + case Get_Kind (Name) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return Get_Identifier (Name); + when others => + Error_Kind ("get_entity_identifier_of_architecture", Name); + end case; + end Get_Entity_Identifier_Of_Architecture; + + function Is_Component_Instantiation + (Inst : Iir_Component_Instantiation_Statement) + return Boolean is + begin + case Get_Kind (Get_Instantiated_Unit (Inst)) is + when Iir_Kinds_Denoting_Name => + return True; + when Iir_Kind_Entity_Aspect_Entity + | Iir_Kind_Entity_Aspect_Configuration => + return False; + when others => + Error_Kind ("is_component_instantiation", Inst); + end case; + end Is_Component_Instantiation; + + function Is_Entity_Instantiation + (Inst : Iir_Component_Instantiation_Statement) + return Boolean is + begin + case Get_Kind (Get_Instantiated_Unit (Inst)) is + when Iir_Kinds_Denoting_Name => + return False; + when Iir_Kind_Entity_Aspect_Entity + | Iir_Kind_Entity_Aspect_Configuration => + return True; + when others => + Error_Kind ("is_entity_instantiation", Inst); + end case; + end Is_Entity_Instantiation; + + function Get_Attribute_Name_Expression (Name : Iir) return Iir + is + Attr_Val : constant Iir := Get_Named_Entity (Name); + Attr_Spec : constant Iir := Get_Attribute_Specification (Attr_Val); + Attr_Expr : constant Iir := Get_Expression (Attr_Spec); + begin + return Attr_Expr; + end Get_Attribute_Name_Expression; + + function Get_String_Type_Bound_Type (Sub_Type : Iir) return Iir is + begin + if Get_Kind (Sub_Type) /= Iir_Kind_Array_Subtype_Definition then + Error_Kind ("get_string_type_bound_type", Sub_Type); + end if; + return Get_Nth_Element (Get_Index_Subtype_List (Sub_Type), 0); + end Get_String_Type_Bound_Type; + + procedure Get_Low_High_Limit (Arange : Iir_Range_Expression; + Low, High : out Iir) + is + begin + case Get_Direction (Arange) is + when Iir_To => + Low := Get_Left_Limit (Arange); + High := Get_Right_Limit (Arange); + when Iir_Downto => + High := Get_Left_Limit (Arange); + Low := Get_Right_Limit (Arange); + end case; + end Get_Low_High_Limit; + + function Get_Low_Limit (Arange : Iir_Range_Expression) return Iir is + begin + case Get_Direction (Arange) is + when Iir_To => + return Get_Left_Limit (Arange); + when Iir_Downto => + return Get_Right_Limit (Arange); + end case; + end Get_Low_Limit; + + function Get_High_Limit (Arange : Iir_Range_Expression) return Iir is + begin + case Get_Direction (Arange) is + when Iir_To => + return Get_Right_Limit (Arange); + when Iir_Downto => + return Get_Left_Limit (Arange); + end case; + end Get_High_Limit; + + function Is_One_Dimensional_Array_Type (A_Type : Iir) return Boolean + is + Base_Type : constant Iir := Get_Base_Type (A_Type); + begin + if Get_Kind (Base_Type) = Iir_Kind_Array_Type_Definition + and then Get_Nbr_Elements (Get_Index_Subtype_List (Base_Type)) = 1 + then + return True; + else + return False; + end if; + end Is_One_Dimensional_Array_Type; + + function Is_Range_Attribute_Name (Expr : Iir) return Boolean + is + Attr : Iir; + Id : Name_Id; + begin + if Get_Kind (Expr) = Iir_Kind_Parenthesis_Name then + Attr := Get_Prefix (Expr); + else + Attr := Expr; + end if; + if Get_Kind (Attr) /= Iir_Kind_Attribute_Name then + return False; + end if; + Id := Get_Identifier (Attr); + return Id = Name_Range or Id = Name_Reverse_Range; + end Is_Range_Attribute_Name; + + function Create_Array_Subtype (Arr_Type : Iir; Loc : Location_Type) + return Iir_Array_Subtype_Definition + is + Base_Type : constant Iir := Get_Base_Type (Arr_Type); + El_Type : constant Iir := Get_Element_Subtype (Base_Type); + Res : Iir_Array_Subtype_Definition; + List : Iir_Flist; + begin + Res := Create_Iir (Iir_Kind_Array_Subtype_Definition); + Set_Location (Res, Loc); + Set_Base_Type (Res, Base_Type); + Set_Element_Subtype (Res, El_Type); + if Get_Kind (Arr_Type) = Iir_Kind_Array_Subtype_Definition then + Set_Resolution_Indication (Res, Get_Resolution_Indication (Arr_Type)); + end if; + Set_Resolved_Flag (Res, Get_Resolved_Flag (Arr_Type)); + Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Arr_Type)); + Set_Type_Staticness (Res, Get_Type_Staticness (El_Type)); + List := Create_Iir_Flist (Get_Nbr_Dimensions (Base_Type)); + Set_Index_Subtype_List (Res, List); + Set_Index_Constraint_List (Res, List); + return Res; + end Create_Array_Subtype; + + function Is_Subprogram_Method (Spec : Iir) return Boolean is + begin + case Get_Kind (Get_Parent (Spec)) is + when Iir_Kind_Protected_Type_Declaration + | Iir_Kind_Protected_Type_Body => + return True; + when others => + return False; + end case; + end Is_Subprogram_Method; + + function Get_Method_Type (Spec : Iir) return Iir + is + Parent : Iir; + begin + Parent := Get_Parent (Spec); + case Get_Kind (Parent) is + when Iir_Kind_Protected_Type_Declaration => + return Parent; + when Iir_Kind_Protected_Type_Body => + return Get_Protected_Type_Declaration (Parent); + when others => + return Null_Iir; + end case; + end Get_Method_Type; + + function Get_Actual_Or_Default (Assoc : Iir; Inter : Iir) return Iir is + begin + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression => + return Get_Actual (Assoc); + when Iir_Kind_Association_Element_Open => + return Get_Default_Value (Inter); + when others => + Error_Kind ("get_actual_or_default", Assoc); + end case; + end Get_Actual_Or_Default; + + function Create_Error (Orig : Iir) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Error); + if Orig /= Null_Iir then + Set_Error_Origin (Res, Orig); + Location_Copy (Res, Orig); + end if; + return Res; + end Create_Error; + + function Create_Error_Expr (Orig : Iir; Atype : Iir) return Iir + is + Res : Iir; + begin + Res := Create_Error (Orig); + Set_Expr_Staticness (Res, None); + Set_Type (Res, Atype); + return Res; + end Create_Error_Expr; + + function Create_Error_Type (Orig : Iir) return Iir + is + Res : Iir; + begin + Res := Create_Error (Orig); + --Set_Expr_Staticness (Res, Locally); + Set_Base_Type (Res, Res); + Set_Type_Declarator (Res, Null_Iir); + Set_Resolved_Flag (Res, True); + Set_Signal_Type_Flag (Res, True); + return Res; + end Create_Error_Type; + + function Create_Error_Name (Orig : Iir) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Error); + Set_Expr_Staticness (Res, None); + Set_Error_Origin (Res, Orig); + Location_Copy (Res, Orig); + return Res; + end Create_Error_Name; + + -- Extract the entity from ASPECT. + -- Note: if ASPECT is a component declaration, returns ASPECT. + function Get_Entity_From_Entity_Aspect (Aspect : Iir) return Iir + is + Inst : Iir; + begin + case Get_Kind (Aspect) is + when Iir_Kinds_Denoting_Name => + -- A component declaration. + Inst := Get_Named_Entity (Aspect); + pragma Assert (Get_Kind (Inst) = Iir_Kind_Component_Declaration); + return Inst; + when Iir_Kind_Component_Declaration => + return Aspect; + when Iir_Kind_Entity_Aspect_Entity => + return Get_Entity (Aspect); + when Iir_Kind_Entity_Aspect_Configuration => + Inst := Get_Configuration (Aspect); + return Get_Entity (Inst); + when Iir_Kind_Entity_Aspect_Open => + return Null_Iir; + when others => + Error_Kind ("get_entity_from_entity_aspect", Aspect); + end case; + end Get_Entity_From_Entity_Aspect; + + function Is_Nested_Package (Pkg : Iir) return Boolean is + begin + return Get_Kind (Get_Parent (Pkg)) /= Iir_Kind_Design_Unit; + end Is_Nested_Package; + + -- LRM08 4.7 Package declarations + -- If the package header is empty, the package declared by a package + -- declaration is called a simple package. + function Is_Simple_Package (Pkg : Iir) return Boolean is + begin + return Get_Package_Header (Pkg) = Null_Iir; + end Is_Simple_Package; + + -- LRM08 4.7 Package declarations + -- If the package header contains a generic clause and no generic map + -- aspect, the package is called an uninstantiated package. + function Is_Uninstantiated_Package (Pkg : Iir) return Boolean + is + Header : constant Iir := Get_Package_Header (Pkg); + begin + return Header /= Null_Iir + and then Get_Generic_Map_Aspect_Chain (Header) = Null_Iir; + end Is_Uninstantiated_Package; + + -- LRM08 4.7 Package declarations + -- If the package header contains both a generic clause and a generic + -- map aspect, the package is declared a generic-mapped package. + function Is_Generic_Mapped_Package (Pkg : Iir) return Boolean + is + Header : constant Iir := Get_Package_Header (Pkg); + begin + return Header /= Null_Iir + and then Get_Generic_Map_Aspect_Chain (Header) /= Null_Iir; + end Is_Generic_Mapped_Package; + + function Kind_In (N : Iir; K1, K2 : Iir_Kind) return Boolean + is + K : constant Iir_Kind := Get_Kind (N); + begin + return K = K1 or K = K2; + end Kind_In; + + function Get_HDL_Node (N : PSL_Node) return Iir is + begin + return Iir (PSL.Nodes.Get_HDL_Node (N)); + end Get_HDL_Node; + + procedure Set_HDL_Node (N : PSL_Node; Expr : Iir) is + begin + PSL.Nodes.Set_HDL_Node (N, PSL.Nodes.HDL_Node (Expr)); + end Set_HDL_Node; +end Vhdl.Utils; |