aboutsummaryrefslogtreecommitdiffstats
path: root/src/vhdl/vhdl-utils.adb
diff options
context:
space:
mode:
authorTristan Gingold <tgingold@free.fr>2019-05-06 08:05:20 +0200
committerTristan Gingold <tgingold@free.fr>2019-05-06 08:05:20 +0200
commitf325fa6fc787f23239d8de2a41a6d9c37d23b991 (patch)
tree0e4a1f95060e2c84cf929f954fdb612a1bf1c340 /src/vhdl/vhdl-utils.adb
parent5c10bacd0cd58926839b8904e10ef0693930bddc (diff)
downloadghdl-f325fa6fc787f23239d8de2a41a6d9c37d23b991.tar.gz
ghdl-f325fa6fc787f23239d8de2a41a6d9c37d23b991.tar.bz2
ghdl-f325fa6fc787f23239d8de2a41a6d9c37d23b991.zip
vhdl: move iirs_utils to vhdl.utils
Diffstat (limited to 'src/vhdl/vhdl-utils.adb')
-rw-r--r--src/vhdl/vhdl-utils.adb1688
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;