-- Common operations on nodes. -- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold -- -- This program 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 of the License, or -- (at your option) any later version. -- -- This program 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 this program. If not, see . with Name_Table; with Str_Table; with Std_Names; use Std_Names; with Flags; with Files_Map; with Vhdl.Std_Package; with Vhdl.Errors; use Vhdl.Errors; with PSL.Nodes; package body Vhdl.Utils is 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 Strip_Literal_Origin (N : Iir) return Iir is Orig : Iir; begin if N = Null_Iir then return N; end if; case Get_Kind (N) is when Iir_Kind_String_Literal8 | Iir_Kind_Integer_Literal | Iir_Kind_Floating_Point_Literal | Iir_Kind_Physical_Int_Literal | Iir_Kind_Physical_Fp_Literal | Iir_Kind_Simple_Aggregate | Iir_Kind_Overflow_Literal | Iir_Kind_Enumeration_Literal | Iir_Kind_Aggregate => Orig := Get_Literal_Origin (N); if Orig /= Null_Iir then return Orig; else return N; end if; when others => return N; end case; end Strip_Literal_Origin; 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_Longest_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_longest_static_prefix", Adecl); end case; end loop; end Get_Longest_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_Kinds_Non_Alias_Object_Declaration | Iir_Kinds_Quantity_Declaration | Iir_Kind_Terminal_Declaration | Iir_Kind_Interface_Quantity_Declaration | Iir_Kind_Interface_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_Kinds_Simultaneous_Statement | Iir_Kind_Suspend_State_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_PSL_Inherit_Spec | Iir_Kind_Library_Declaration | Iir_Kinds_Library_Unit | Iir_Kind_Component_Declaration | Iir_Kind_Function_Declaration | Iir_Kind_Procedure_Declaration | Iir_Kind_Function_Instantiation_Declaration | Iir_Kind_Procedure_Instantiation_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_Foreign_Vector_Type_Definition | Iir_Kinds_Nature_Definition | Iir_Kinds_Subnature_Definition | Iir_Kind_Wildcard_Type_Definition | Iir_Kind_Subtype_Definition | Iir_Kind_Group_Template_Declaration | Iir_Kind_Group_Declaration | Iir_Kind_Attribute_Implicit_Declaration | Iir_Kind_Suspend_State_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_Kinds_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_Break_Element | Iir_Kind_Reference_Name | Iir_Kind_Package_Header | Iir_Kind_Block_Header | Iir_Kinds_Association_Element | Iir_Kinds_Choice | Iir_Kinds_Entity_Aspect | Iir_Kind_Psl_Hierarchical_Name | Iir_Kind_Psl_Prev | Iir_Kind_Psl_Stable | Iir_Kind_Psl_Rose | Iir_Kind_Psl_Fell | Iir_Kind_Psl_Onehot | Iir_Kind_Psl_Onehot0 | Iir_Kind_If_Generate_Else_Clause | Iir_Kind_Elsif | Iir_Kind_Simultaneous_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_Nature_Element_Declaration | Iir_Kind_Psl_Endpoint_Declaration | Iir_Kind_Psl_Boolean_Parameter | Iir_Kind_Psl_Declaration | Iir_Kind_Psl_Default_Clock | 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 | Iir_Kind_Free_Quantity_Declaration | Iir_Kind_Across_Quantity_Declaration | Iir_Kind_Through_Quantity_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 | Iir_Kind_Interface_Quantity_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 => if Name_To_Object (Get_Prefix (Name)) = Null_Iir then -- The prefix may not be an object. return Null_Iir; end if; 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; -- AMS-LRM17 6.4 Objects -- An implicit signal defined by any of the predefined attributes -- 'above, [...] when Iir_Kind_Above_Attribute => return Name; -- AMS-LRM17 6.4 Objects -- An implicit quantity defined by any of the predefined attributes -- 'DOT, 'INTEG, 'DELAYED, 'ZOH, 'LTF, 'ZTF, 'REFERENCE, -- 'CONTRIBUTION, 'RAMP, and 'SLEW. when Iir_Kind_Dot_Attribute | Iir_Kind_Integ_Attribute => 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 Iir_Kind_Indexed_Name | Iir_Kind_Selected_Element | Iir_Kind_Slice_Name => -- Already a value. return 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 Is_Quantity_Object (Name : Iir) return Boolean is Adecl: Iir; begin Adecl := Get_Object_Prefix (Name, True); case Get_Kind (Adecl) is when Iir_Kinds_Quantity_Declaration | Iir_Kind_Interface_Quantity_Declaration | Iir_Kind_Integ_Attribute | Iir_Kind_Dot_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_Quantity_Object; function Is_Quantity_Name (Expr : Iir) return Boolean is Obj : Iir; begin Obj := Name_To_Object (Expr); if Obj /= Null_Iir then return Is_Quantity_Object (Obj); else return False; end if; end Is_Quantity_Name; 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_Reference_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 : Iir; 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. Assoc := Get_Chain (Assoc); if Assoc = Null_Iir then -- End of the chain Inter := Null_Iir; return; end if; Formal := Get_Formal (Assoc); if Is_Valid (Formal) then Inter := Get_Interface_Of_Formal (Formal); else Inter := Get_Chain (Inter); end if; -- If INTER is null, this is an extra association. Should it be -- skipped here ? Or add a _Safe variant ? 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_Reference_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 Is_Copyback_Parameter (Inter : Iir) return Boolean is begin if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration and then Get_Mode (Inter) in Iir_Out_Mode .. Iir_Inout_Mode then -- For Vhdl-87, files are not copyback. return Get_Kind (Get_Type (Inter)) /= Iir_Kind_File_Type_Definition; else return False; end if; end Is_Copyback_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_Foreign_Module, 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 (Parent : Iir) is El : Iir; begin 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 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, Dir_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_Name (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 Get_Base_Type (Atype : Iir) return Iir is Res : Iir; begin Res := Atype; loop case Get_Kind (Res) is when Iir_Kind_Access_Type_Definition | Iir_Kind_Integer_Type_Definition | Iir_Kind_Floating_Type_Definition | Iir_Kind_Enumeration_Type_Definition | Iir_Kind_Physical_Type_Definition | Iir_Kind_Array_Type_Definition | Iir_Kind_Record_Type_Definition | Iir_Kind_Protected_Type_Declaration | Iir_Kind_File_Type_Definition | Iir_Kind_Incomplete_Type_Definition | Iir_Kind_Interface_Type_Definition | Iir_Kind_Wildcard_Type_Definition | Iir_Kind_Foreign_Vector_Type_Definition | Iir_Kind_Error => return Res; when Iir_Kind_Access_Subtype_Definition | Iir_Kind_File_Subtype_Definition | Iir_Kind_Integer_Subtype_Definition | Iir_Kind_Floating_Subtype_Definition | Iir_Kind_Enumeration_Subtype_Definition | Iir_Kind_Physical_Subtype_Definition | Iir_Kind_Array_Subtype_Definition | Iir_Kind_Record_Subtype_Definition => Res := Get_Parent_Type (Res); when others => Error_Kind ("get_base_type", Res); end case; end loop; end Get_Base_Type; 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_Anonymous_Nature_Definition (Def : Iir) return Boolean is begin return Get_Nature_Declarator (Def) = Null_Iir; end Is_Anonymous_Nature_Definition; function Is_Array_Type (Def : Iir) return Boolean is begin return Get_Kind (Def) in Iir_Kinds_Array_Type_Definition; end Is_Array_Type; 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 Is_Object_Fully_Constrained (Decl : Iir) return Boolean is begin -- That's true if the object type is constrained. if Is_Fully_Constrained_Type (Get_Type (Decl)) then return True; end if; -- That's also true if the object is declared with a subtype attribute. if Get_Kind (Get_Subtype_Indication (Decl)) = Iir_Kind_Subtype_Attribute then return True; end if; -- Otherwise this is false. return False; end Is_Object_Fully_Constrained; function Is_Object_Name_Fully_Constrained (Obj : Iir) return Boolean is Base : Iir; begin -- That's true if the object type is constrained. if Flags.Flag_Relaxed_Rules or else Is_Fully_Constrained_Type (Get_Type (Obj)) then return True; end if; -- That's also true if the object is declared with a subtype attribute. Base := Get_Base_Name (Obj); case Get_Kind (Base) is when Iir_Kind_Variable_Declaration | Iir_Kind_Signal_Declaration | Iir_Kind_Interface_Variable_Declaration | Iir_Kind_Interface_Signal_Declaration | Iir_Kind_Object_Alias_Declaration => declare Ind : constant Iir := Get_Subtype_Indication (Base); begin -- Note: an object alias may not have subtype indication. if Ind /= Null_Iir and then Get_Kind (Ind) = Iir_Kind_Subtype_Attribute then return True; end if; end; when Iir_Kind_Dereference | Iir_Kind_Implicit_Dereference => null; when others => Error_Kind ("is_object_name_fully_constrained", Base); end case; -- Otherwise this is false. return False; end Is_Object_Name_Fully_Constrained; 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 case Get_Kind (Name) is when Iir_Kinds_Denoting_Name | Iir_Kind_Attribute_Name => 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 | Iir_Kind_Subtype_Attribute | Iir_Kind_Element_Attribute => return Get_Type (Ent); when others => return Null_Iir; end case; when Iir_Kind_Subtype_Attribute => return Get_Type (Ent); when Iir_Kind_Element_Attribute => return Get_Type (Name); when others => return Null_Iir; end case; 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 | Iir_Kind_Element_Attribute | Iir_Kind_Across_Attribute | Iir_Kind_Through_Attribute => return Get_Type (Ind); when Iir_Kind_Interface_Type_Definition => return 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_Nature_Of_Subnature_Indication (Ind : Iir) return Iir is begin case Get_Kind (Ind) is when Iir_Kinds_Denoting_Name => -- Name of a nature. return Get_Nature (Get_Named_Entity (Ind)); when Iir_Kind_Array_Subnature_Definition => return Ind; when others => Error_Kind ("get_nature_of_subnature_indication", Ind); end case; end Get_Nature_Of_Subnature_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 Is_One_Dimensional_Array_Type (A_Type : Iir) return Boolean is Base_Type : constant Iir := Get_Base_Type (A_Type); begin return Get_Kind (Base_Type) = Iir_Kind_Array_Type_Definition and then Get_Nbr_Dimensions (Base_Type) = 1; end Is_One_Dimensional_Array_Type; 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_File_Subtype_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); pragma Assert (Get_Kind (Res) = Iir_Kind_Architecture_Body); 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 = Null_Iir or else Res = Vhdl.Std_Package.Error_Mark then return Null_Iir; end if; pragma Assert (Kind_In (Res, Iir_Kind_Entity_Declaration, Iir_Kind_Foreign_Module)); 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 Iir_Kind_Error => return Null_Identifier; 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 Dir_To => Low := Get_Left_Limit (Arange); High := Get_Right_Limit (Arange); when Dir_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 Dir_To => return Get_Left_Limit (Arange); when Dir_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 Dir_To => return Get_Right_Limit (Arange); when Dir_Downto => return Get_Left_Limit (Arange); end case; end Get_High_Limit; 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 Get_Range_From_Discrete_Range (Rng : Iir) return Iir is begin case Get_Kind (Rng) is when Iir_Kinds_Denoting_Name => return Get_Range_From_Discrete_Range (Get_Named_Entity (Rng)); when Iir_Kinds_Scalar_Subtype_Definition => return Get_Range_Constraint (Rng); when Iir_Kind_Range_Expression => return Rng; when Iir_Kinds_Range_Attribute => return Rng; when others => Error_Kind ("get_range_from_discrete_range", Rng); end case; end Get_Range_From_Discrete_Range; 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_Parent_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_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 Get_Entity_From_Configuration (Config : Iir) return Iir is Conf_Unit : constant Iir := Get_Library_Unit (Config); Arch : constant Iir := Get_Named_Entity (Get_Block_Specification (Get_Block_Configuration (Conf_Unit))); Entity : constant Iir := Vhdl.Utils.Get_Entity (Arch); begin return Entity; end Get_Entity_From_Configuration; 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; -- LRM08 4.2 Subprogram declarations -- If the subprogram header contains the reserved word GENERIC, a generic -- list, and no generic map aspect, the subprogram is called an -- uninstantiated subprogram. function Is_Uninstantiated_Subprogram (Subprg : Iir) return Boolean is begin return Get_Generic_Chain (Subprg) /= Null_Iir; end Is_Uninstantiated_Subprogram; 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 Kind_In (N : Iir; K1, K2, K3 : Iir_Kind) return Boolean is K : constant Iir_Kind := Get_Kind (N); begin return K = K1 or K = K2 or K = K3; end Kind_In; procedure Set_Attribute_Parameter (Attr : Iir; N : Parameter_Index; Param : Iir) is begin case N is when 1 => Set_Parameter (Attr, Param); when 2 => Set_Parameter_2 (Attr, Param); when 3 => Set_Parameter_3 (Attr, Param); when 4 => Set_Parameter_4 (Attr, Param); end case; end Set_Attribute_Parameter; function Get_Attribute_Parameter (Attr : Iir; N : Parameter_Index) return Iir is begin case N is when 1 => return Get_Parameter (Attr); when 2 => return Get_Parameter_2 (Attr); when 3 => return Get_Parameter_3 (Attr); when 4 => return Get_Parameter_4 (Attr); end case; end Get_Attribute_Parameter; function Get_File_Signature_Length (Def : Iir) return Natural is begin case Get_Kind (Def) is when Iir_Kinds_Scalar_Type_And_Subtype_Definition => return 1; when Iir_Kind_Array_Type_Definition | Iir_Kind_Array_Subtype_Definition => return 2 + Get_File_Signature_Length (Get_Element_Subtype (Def)); when Iir_Kind_Record_Type_Definition | Iir_Kind_Record_Subtype_Definition => declare List : constant Iir_Flist := Get_Elements_Declaration_List (Get_Base_Type (Def)); El : Iir; Res : Natural; begin Res := 2; for I in Flist_First .. Flist_Last (List) loop El := Get_Nth_Element (List, I); Res := Res + Get_File_Signature_Length (Get_Type (El)); end loop; return Res; end; when others => Error_Kind ("get_file_signature_length", Def); end case; end Get_File_Signature_Length; procedure Get_File_Signature (Def : Iir; Res : in out String; Off : in out Natural) is Base_Type : constant Iir := Get_Base_Type (Def); begin case Get_Kind (Base_Type) is when Iir_Kind_Integer_Type_Definition => case Get_Scalar_Size (Base_Type) is when Scalar_32 => Res (Off) := 'i'; when Scalar_64 => Res (Off) := 'I'; when others => raise Internal_Error; end case; Off := Off + 1; when Iir_Kind_Physical_Type_Definition => case Get_Scalar_Size (Base_Type) is when Scalar_32 => Res (Off) := 'p'; when Scalar_64 => Res (Off) := 'P'; when others => raise Internal_Error; end case; Off := Off + 1; when Iir_Kind_Floating_Type_Definition => Res (Off) := 'F'; Off := Off + 1; when Iir_Kind_Enumeration_Type_Definition => if Base_Type = Std_Package.Boolean_Type_Definition then Res (Off) := 'b'; else case Get_Scalar_Size (Base_Type) is when Scalar_8 => Res (Off) := 'e'; when Scalar_32 => Res (Off) := 'E'; when others => raise Internal_Error; end case; end if; Off := Off + 1; when Iir_Kind_Array_Type_Definition | Iir_Kind_Array_Subtype_Definition => Res (Off) := '['; Off := Off + 1; Get_File_Signature (Get_Element_Subtype (Def), Res, Off); Res (Off) := ']'; Off := Off + 1; when Iir_Kind_Record_Type_Definition | Iir_Kind_Record_Subtype_Definition => declare List : constant Iir_Flist := Get_Elements_Declaration_List (Get_Base_Type (Def)); El : Iir; begin Res (Off) := '<'; Off := Off + 1; for I in Flist_First .. Flist_Last (List) loop El := Get_Nth_Element (List, I); Get_File_Signature (Get_Type (El), Res, Off); end loop; Res (Off) := '>'; Off := Off + 1; end; when others => Error_Kind ("get_file_signature", Def); end case; end Get_File_Signature; function Get_Source_Identifier (Decl : Iir) return Name_Id is use Files_Map; use Name_Table; Loc : constant Location_Type := Get_Location (Decl); Len : constant Natural := Get_Name_Length (Get_Identifier (Decl)); subtype Ident_Str is String (1 .. Len); File : Source_File_Entry; Pos : Source_Ptr; Buf : File_Buffer_Acc; begin Location_To_File_Pos (Loc, File, Pos); Buf := Get_File_Source (File); return Get_Identifier (Ident_Str (Buf (Pos .. Pos + Source_Ptr (Len - 1)))); end Get_Source_Identifier; 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;