From 53fcf00d88d1a3b34c7833aa4c421ea52f3e03dd Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Sun, 5 May 2019 07:18:49 +0200 Subject: vhdl: move sem* packages to vhdl children. --- src/vhdl/configuration.adb | 16 +- src/vhdl/ieee-vital_timing.adb | 16 +- src/vhdl/post_sems.adb | 4 +- src/vhdl/sem.adb | 3314 -------------------- src/vhdl/sem.ads | 94 - src/vhdl/sem_assocs.adb | 2571 --------------- src/vhdl/sem_assocs.ads | 68 - src/vhdl/sem_decls.adb | 2342 -------------- src/vhdl/sem_decls.ads | 105 - src/vhdl/sem_expr.adb | 5229 ------------------------------- src/vhdl/sem_expr.ads | 270 -- src/vhdl/sem_inst.adb | 1217 ------- src/vhdl/sem_inst.ads | 36 - src/vhdl/sem_lib.adb | 411 --- src/vhdl/sem_lib.ads | 58 - src/vhdl/sem_names.adb | 4313 ------------------------- src/vhdl/sem_names.ads | 159 - src/vhdl/sem_psl.adb | 808 ----- src/vhdl/sem_psl.ads | 31 - src/vhdl/sem_scopes.adb | 1672 ---------- src/vhdl/sem_scopes.ads | 220 -- src/vhdl/sem_specs.adb | 1928 ------------ src/vhdl/sem_specs.ads | 99 - src/vhdl/sem_stmts.adb | 2183 ------------- src/vhdl/sem_stmts.ads | 58 - src/vhdl/sem_types.adb | 2382 -------------- src/vhdl/sem_types.ads | 68 - src/vhdl/sem_utils.adb | 1039 ------ src/vhdl/sem_utils.ads | 30 - src/vhdl/simulate/simul-debugger.adb | 14 +- src/vhdl/simulate/simul-elaboration.adb | 2 +- src/vhdl/simulate/simul-execution.adb | 6 +- src/vhdl/std_package.adb | 12 +- src/vhdl/translate/ortho_front.adb | 6 +- src/vhdl/translate/trans-chap12.adb | 6 +- src/vhdl/translate/trans-chap2.adb | 6 +- src/vhdl/translate/translation.adb | 4 +- src/vhdl/vhdl-canon.adb | 6 +- src/vhdl/vhdl-sem.adb | 3314 ++++++++++++++++++++ src/vhdl/vhdl-sem.ads | 94 + src/vhdl/vhdl-sem_assocs.adb | 2571 +++++++++++++++ src/vhdl/vhdl-sem_assocs.ads | 68 + src/vhdl/vhdl-sem_decls.adb | 2342 ++++++++++++++ src/vhdl/vhdl-sem_decls.ads | 105 + src/vhdl/vhdl-sem_expr.adb | 5229 +++++++++++++++++++++++++++++++ src/vhdl/vhdl-sem_expr.ads | 270 ++ src/vhdl/vhdl-sem_inst.adb | 1217 +++++++ src/vhdl/vhdl-sem_inst.ads | 36 + src/vhdl/vhdl-sem_lib.adb | 411 +++ src/vhdl/vhdl-sem_lib.ads | 58 + src/vhdl/vhdl-sem_names.adb | 4313 +++++++++++++++++++++++++ src/vhdl/vhdl-sem_names.ads | 159 + src/vhdl/vhdl-sem_psl.adb | 808 +++++ src/vhdl/vhdl-sem_psl.ads | 31 + src/vhdl/vhdl-sem_scopes.adb | 1672 ++++++++++ src/vhdl/vhdl-sem_scopes.ads | 220 ++ src/vhdl/vhdl-sem_specs.adb | 1928 ++++++++++++ src/vhdl/vhdl-sem_specs.ads | 99 + src/vhdl/vhdl-sem_stmts.adb | 2183 +++++++++++++ src/vhdl/vhdl-sem_stmts.ads | 58 + src/vhdl/vhdl-sem_types.adb | 2382 ++++++++++++++ src/vhdl/vhdl-sem_types.ads | 68 + src/vhdl/vhdl-sem_utils.adb | 1039 ++++++ src/vhdl/vhdl-sem_utils.ads | 30 + 64 files changed, 30754 insertions(+), 30754 deletions(-) delete mode 100644 src/vhdl/sem.adb delete mode 100644 src/vhdl/sem.ads delete mode 100644 src/vhdl/sem_assocs.adb delete mode 100644 src/vhdl/sem_assocs.ads delete mode 100644 src/vhdl/sem_decls.adb delete mode 100644 src/vhdl/sem_decls.ads delete mode 100644 src/vhdl/sem_expr.adb delete mode 100644 src/vhdl/sem_expr.ads delete mode 100644 src/vhdl/sem_inst.adb delete mode 100644 src/vhdl/sem_inst.ads delete mode 100644 src/vhdl/sem_lib.adb delete mode 100644 src/vhdl/sem_lib.ads delete mode 100644 src/vhdl/sem_names.adb delete mode 100644 src/vhdl/sem_names.ads delete mode 100644 src/vhdl/sem_psl.adb delete mode 100644 src/vhdl/sem_psl.ads delete mode 100644 src/vhdl/sem_scopes.adb delete mode 100644 src/vhdl/sem_scopes.ads delete mode 100644 src/vhdl/sem_specs.adb delete mode 100644 src/vhdl/sem_specs.ads delete mode 100644 src/vhdl/sem_stmts.adb delete mode 100644 src/vhdl/sem_stmts.ads delete mode 100644 src/vhdl/sem_types.adb delete mode 100644 src/vhdl/sem_types.ads delete mode 100644 src/vhdl/sem_utils.adb delete mode 100644 src/vhdl/sem_utils.ads create mode 100644 src/vhdl/vhdl-sem.adb create mode 100644 src/vhdl/vhdl-sem.ads create mode 100644 src/vhdl/vhdl-sem_assocs.adb create mode 100644 src/vhdl/vhdl-sem_assocs.ads create mode 100644 src/vhdl/vhdl-sem_decls.adb create mode 100644 src/vhdl/vhdl-sem_decls.ads create mode 100644 src/vhdl/vhdl-sem_expr.adb create mode 100644 src/vhdl/vhdl-sem_expr.ads create mode 100644 src/vhdl/vhdl-sem_inst.adb create mode 100644 src/vhdl/vhdl-sem_inst.ads create mode 100644 src/vhdl/vhdl-sem_lib.adb create mode 100644 src/vhdl/vhdl-sem_lib.ads create mode 100644 src/vhdl/vhdl-sem_names.adb create mode 100644 src/vhdl/vhdl-sem_names.ads create mode 100644 src/vhdl/vhdl-sem_psl.adb create mode 100644 src/vhdl/vhdl-sem_psl.ads create mode 100644 src/vhdl/vhdl-sem_scopes.adb create mode 100644 src/vhdl/vhdl-sem_scopes.ads create mode 100644 src/vhdl/vhdl-sem_specs.adb create mode 100644 src/vhdl/vhdl-sem_specs.ads create mode 100644 src/vhdl/vhdl-sem_stmts.adb create mode 100644 src/vhdl/vhdl-sem_stmts.ads create mode 100644 src/vhdl/vhdl-sem_types.adb create mode 100644 src/vhdl/vhdl-sem_types.ads create mode 100644 src/vhdl/vhdl-sem_utils.adb create mode 100644 src/vhdl/vhdl-sem_utils.ads (limited to 'src/vhdl') diff --git a/src/vhdl/configuration.adb b/src/vhdl/configuration.adb index fd8a72605..d047da43d 100644 --- a/src/vhdl/configuration.adb +++ b/src/vhdl/configuration.adb @@ -23,8 +23,8 @@ with Name_Table; use Name_Table; with Flags; with Iirs_Utils; use Iirs_Utils; with Iirs_Walk; -with Sem_Scopes; -with Sem_Lib; use Sem_Lib; +with Vhdl.Sem_Scopes; +with Vhdl.Sem_Lib; use Vhdl.Sem_Lib; with Vhdl.Canon; package body Configuration is @@ -803,7 +803,7 @@ package body Configuration is Load_Design_Unit (Design, Null_Iir); when Iir_Kind_Entity_Declaration => Load_Design_Unit (Design, Null_Iir); - Sem_Scopes.Add_Name (Get_Library_Unit (Design)); + Vhdl.Sem_Scopes.Add_Name (Get_Library_Unit (Design)); when Iir_Kind_Package_Declaration | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Package_Body @@ -851,7 +851,7 @@ package body Configuration is end if; end; declare - use Sem_Scopes; + use Vhdl.Sem_Scopes; Comp : constant Iir := Get_Named_Entity (Inst); Interp : constant Name_Interpretation_Type := Get_Interpretation (Get_Identifier (Comp)); @@ -913,8 +913,8 @@ package body Configuration is Status : Walk_Status; begin -- Name table is used to map names to entities. - Sem_Scopes.Push_Interpretations; - Sem_Scopes.Open_Declarative_Region; + Vhdl.Sem_Scopes.Push_Interpretations; + Vhdl.Sem_Scopes.Open_Declarative_Region; -- 1. Add all design entities in the name table. Status := Walk_Design_Units (Lib, Add_Entity_Cb'Access); @@ -925,8 +925,8 @@ package body Configuration is Status := Walk_Design_Units (Lib, Mark_Units_Cb'Access); pragma Assert (Status = Walk_Continue); - Sem_Scopes.Close_Declarative_Region; - Sem_Scopes.Pop_Interpretations; + Vhdl.Sem_Scopes.Close_Declarative_Region; + Vhdl.Sem_Scopes.Pop_Interpretations; end Mark_Instantiated_Units; function Extract_Entity_Cb (Design : Iir) return Walk_Status diff --git a/src/vhdl/ieee-vital_timing.adb b/src/vhdl/ieee-vital_timing.adb index ee60bbd15..a1413285e 100644 --- a/src/vhdl/ieee-vital_timing.adb +++ b/src/vhdl/ieee-vital_timing.adb @@ -22,10 +22,10 @@ with Std_Package; use Std_Package; with Vhdl.Tokens; use Vhdl.Tokens; with Name_Table; with Ieee.Std_Logic_1164; use Ieee.Std_Logic_1164; -with Sem_Scopes; -with Sem_Specs; +with Vhdl.Sem_Scopes; +with Vhdl.Sem_Specs; with Evaluation; -with Sem; +with Vhdl.Sem; with Iirs_Utils; package body Ieee.Vital_Timing is @@ -317,7 +317,7 @@ package body Ieee.Vital_Timing is -- Returns the port. function Check_Port return Iir is - use Sem_Scopes; + use Vhdl.Sem_Scopes; use Name_Table; C : Character; @@ -1052,8 +1052,8 @@ package body Ieee.Vital_Timing is -- Furthermore, the type of the biased propagation generic -- shall be the same as the type of the corresponding delay -- generic. - if not Sem.Are_Trees_Equal (Get_Type (Decl), - Get_Type (Tpd_Decl)) + if not Vhdl.Sem.Are_Trees_Equal (Get_Type (Decl), + Get_Type (Tpd_Decl)) then Error_Vital (+Decl, "type of VITAL 'tbpd' generic mismatch type of " @@ -1241,7 +1241,7 @@ package body Ieee.Vital_Timing is -- Checks rules for a VITAL level 0 entity. procedure Check_Vital_Level0_Entity (Ent : Iir_Entity_Declaration) is - use Sem_Scopes; + use Vhdl.Sem_Scopes; Decl : Iir; Gen_Chain : Iir; begin @@ -1295,7 +1295,7 @@ package body Ieee.Vital_Timing is Value : Iir_Attribute_Value; Spec : Iir_Attribute_Specification; begin - Value := Sem_Specs.Find_Attribute_Value + Value := Vhdl.Sem_Specs.Find_Attribute_Value (Unit, Std_Names.Name_VITAL_Level0); if Value = Null_Iir then return False; diff --git a/src/vhdl/post_sems.adb b/src/vhdl/post_sems.adb index 43e8ec76f..d00a808c0 100644 --- a/src/vhdl/post_sems.adb +++ b/src/vhdl/post_sems.adb @@ -17,7 +17,7 @@ -- 02111-1307, USA. with Types; use Types; with Std_Names; use Std_Names; -with Sem_Specs; +with Vhdl.Sem_Specs; with Ieee.Std_Logic_1164; with Ieee.Vital_Timing; with Ieee.Numeric; @@ -65,7 +65,7 @@ package body Post_Sems is -- Look for VITAL attributes. if Flag_Vital_Checks then Value := Get_Attribute_Value_Chain - (Sem_Specs.Get_Attribute_Value_Chain_Parent (Lib_Unit)); + (Vhdl.Sem_Specs.Get_Attribute_Value_Chain_Parent (Lib_Unit)); while Value /= Null_Iir loop Spec := Get_Attribute_Specification (Value); Attr_Decl := Get_Named_Entity (Get_Attribute_Designator (Spec)); diff --git a/src/vhdl/sem.adb b/src/vhdl/sem.adb deleted file mode 100644 index c5d9761ac..000000000 --- a/src/vhdl/sem.adb +++ /dev/null @@ -1,3314 +0,0 @@ --- Semantic analysis pass. --- 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 Errorout; use Errorout; -with Std_Package; use Std_Package; -with Ieee.Std_Logic_1164; -with Libraries; -with Std_Names; -with Sem_Scopes; use Sem_Scopes; -with Sem_Expr; use Sem_Expr; -with Sem_Names; use Sem_Names; -with Sem_Specs; use Sem_Specs; -with Sem_Decls; use Sem_Decls; -with Sem_Assocs; use Sem_Assocs; -with Sem_Inst; -with Sem_Lib; use Sem_Lib; -with Iirs_Utils; use Iirs_Utils; -with Flags; use Flags; -with Str_Table; -with Sem_Utils; -with Sem_Stmts; use Sem_Stmts; -with Iir_Chains; -with Xrefs; use Xrefs; - -package body Sem is - -- Forward declarations. - procedure Sem_Context_Clauses (Unit: Iir); - procedure Sem_Block_Configuration - (Block_Conf : Iir_Block_Configuration; Father: Iir); - procedure Sem_Component_Configuration - (Conf : Iir_Component_Configuration; Father : Iir); - - procedure Add_Dependence (Unit : Iir) - is - Targ : constant Iir := Get_Current_Design_Unit; - begin - -- During normal analysis, there is a current design unit. But not - -- during debugging outside of any context. - if Targ = Null_Iir then - return; - end if; - - Add_Dependence (Targ, Unit); - end Add_Dependence; - - -- LRM 1.1 Entity declaration. - procedure Sem_Entity_Declaration (Entity : Iir_Entity_Declaration) is - begin - Xrefs.Xref_Decl (Entity); - Sem_Scopes.Add_Name (Entity); - Set_Visible_Flag (Entity, True); - - Set_Is_Within_Flag (Entity, True); - - -- LRM 10.1 - -- 1. An entity declaration, together with a corresponding architecture - -- body. - Open_Declarative_Region; - - -- Sem generics. - Sem_Interface_Chain (Get_Generic_Chain (Entity), Generic_Interface_List); - - -- Sem ports. - Sem_Interface_Chain (Get_Port_Chain (Entity), Port_Interface_List); - - -- Entity declarative part and concurrent statements. - Sem_Block (Entity); - - Close_Declarative_Region; - Set_Is_Within_Flag (Entity, False); - end Sem_Entity_Declaration; - - -- Get the entity unit for LIBRARY_UNIT (an architecture or a - -- configuration declaration). - -- Return NULL_IIR in case of error (not found, bad library). - function Sem_Entity_Name (Library_Unit : Iir) return Iir - is - Name : Iir; - Library : Iir_Library_Declaration; - Entity : Iir; - begin - -- Get the library of architecture/configuration. - Library := Get_Library - (Get_Design_File (Get_Design_Unit (Library_Unit))); - - -- Resolve the name. - - Name := Get_Entity_Name (Library_Unit); - if Is_Error (Name) then - pragma Assert (Flags.Flag_Force_Analysis); - return Null_Iir; - end if; - - if Get_Kind (Name) = Iir_Kind_Simple_Name then - -- LRM93 10.1 Declarative Region - -- LRM08 12.1 Declarative Region - -- a) An entity declaration, tohether with a corresponding - -- architecture body. - -- - -- GHDL: simple name needs to be handled specially. Because - -- architecture body is in the declarative region of its entity, - -- the entity name is directly visible. But we cannot really use - -- that rule as is, as we don't know which is the entity. - Entity := Load_Primary_Unit - (Library, Get_Identifier (Name), Library_Unit); - if Entity = Null_Iir then - Error_Msg_Sem (+Library_Unit, "entity %n was not analysed", +Name); - return Null_Iir; - end if; - Entity := Get_Library_Unit (Entity); - Set_Named_Entity (Name, Entity); - Xrefs.Xref_Ref (Name, Entity); - else - -- Certainly an expanded name. Use the standard name analysis. - Name := Sem_Denoting_Name (Name); - Set_Entity_Name (Library_Unit, Name); - Entity := Get_Named_Entity (Name); - end if; - - if Get_Kind (Entity) /= Iir_Kind_Entity_Declaration then - Error_Class_Match (Name, "entity"); - return Null_Iir; - end if; - - -- LRM 1.2 Architecture bodies - -- For a given design entity, both the entity declaration and the - -- associated architecture body must reside in the same library. - - -- LRM 1.3 Configuration Declarations - -- For a configuration of a given design entity, both the - -- configuration declaration and the corresponding entity - -- declaration must reside in the same library. - if Get_Library (Get_Design_File (Get_Design_Unit (Entity))) /= Library - then - Error_Msg_Sem - (+Library_Unit, "%n does not reside in %n", (+Entity, +Library)); - return Null_Iir; - end if; - - return Entity; - end Sem_Entity_Name; - - -- LRM 1.2 Architecture bodies. - procedure Sem_Architecture_Body (Arch: Iir_Architecture_Body) - is - Entity_Unit : Iir_Design_Unit; - Entity_Library : Iir_Entity_Declaration; - begin - Xrefs.Xref_Decl (Arch); - -- First, find the entity. - Entity_Library := Sem_Entity_Name (Arch); - if Entity_Library = Null_Iir then - return; - end if; - Entity_Unit := Get_Design_Unit (Entity_Library); - - -- LRM93 11.4 - -- In each case, the second unit depends on the first unit. - -- GHDL: an architecture depends on its entity. - Add_Dependence (Entity_Unit); - - Add_Context_Clauses (Entity_Unit); - - Set_Is_Within_Flag (Arch, True); - Set_Is_Within_Flag (Entity_Library, True); - - -- Makes the entity name visible. - -- FIXME: quote LRM. - Sem_Scopes.Add_Name - (Entity_Library, Get_Identifier (Entity_Library), False); - - -- LRM 10.1 Declarative Region - -- 1. An entity declaration, together with a corresponding architecture - -- body. - Open_Declarative_Region; - Sem_Scopes.Add_Entity_Declarations (Entity_Library); - - -- LRM02 1.2 Architecture bodies - -- For the purpose of interpreting the scope and visibility of the - -- identifier (see 10.2 and 10.3), the declaration of the identifier is - -- considered to occur after the final declarative item of the entity - -- declarative part of the corresponding entity declaration. - -- - -- FIXME: before VHDL-02, an architecture is not a declaration. - Sem_Scopes.Add_Name (Arch, Get_Identifier (Arch), True); - Set_Visible_Flag (Arch, True); - - -- LRM02 10.1 Declarative region - -- The declarative region associated with an architecture body is - -- considered to occur immediatly within the declarative region - -- associated with the entity declaration corresponding to the given - -- architecture body. - -- - -- GHDL: this is only in vhdl-2002. - if Vhdl_Std = Vhdl_02 then - Open_Declarative_Region; - end if; - - Current_Psl_Default_Clock := Null_Iir; - Sem_Block (Arch); - - if Vhdl_Std = Vhdl_02 then - Close_Declarative_Region; - end if; - - Close_Declarative_Region; - Set_Is_Within_Flag (Arch, False); - Set_Is_Within_Flag (Entity_Library, False); - end Sem_Architecture_Body; - - -- Return the real resolver used for (sub) object OBJ. - -- Return NULL_IIR if none. - function Get_Resolver (Obj : Iir) return Iir - is - Obj_Type : Iir; - Res : Iir; - begin - case Get_Kind (Obj) is - when Iir_Kind_Indexed_Name - | Iir_Kind_Slice_Name - | Iir_Kind_Selected_Element => - Res := Get_Resolver (Get_Prefix (Obj)); - if Res /= Null_Iir then - return Res; - end if; - when Iir_Kind_Signal_Declaration - | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Guard_Signal_Declaration => - null; - when Iir_Kind_Object_Alias_Declaration => - return Get_Resolver (Get_Name (Obj)); - when Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name => - return Get_Resolver (Get_Named_Entity (Obj)); - when others => - Error_Kind ("get_resolved", Obj); - end case; - - Obj_Type := Get_Type (Obj); - if Get_Kind (Obj_Type) in Iir_Kinds_Subtype_Definition then - return Get_Resolution_Indication (Obj_Type); - else - return Null_Iir; - end if; - end Get_Resolver; - - -- Return TRUE iff the actual of ASSOC can be the formal. - -- ASSOC must be an association_element_by_expression. - function Can_Collapse_Signals (Assoc : Iir; Formal : Iir) return Boolean - is - Actual : Iir; - Actual_Res : Iir; - Formal_Res : Iir; - Formal_Base : Iir; - Actual_Base : Iir; - begin - -- If there is a conversion, signals types are not necessarily - -- the same, and sharing is not possible. - -- FIXME: optimize type conversions - -- (unsigned <-> signed <-> std_ulogic_vector <-> ...) - if Get_Actual_Conversion (Assoc) /= Null_Iir - or else Get_Formal_Conversion (Assoc) /= Null_Iir - then - return False; - end if; - - -- Here we may assume formal and actual have the same type and the - -- same lengths. This is caught at elaboration time. - - Actual := Name_To_Object (Get_Actual (Assoc)); - if Actual = Null_Iir then - -- This is an expression. - return False; - end if; - - Formal_Base := Get_Object_Prefix (Formal); - Actual_Base := Get_Object_Prefix (Actual); - - -- If the formal is of mode IN, then it has no driving value, and its - -- effective value is the effective value of the actual. - -- Always collapse in this case. - if Get_Mode (Formal_Base) = Iir_In_Mode then - return True; - end if; - - -- Otherwise, these rules are applied: - -- - -- In this table, E means element, S means signal. - -- Er means the element is resolved, - -- Sr means the signal is resolved (at the signal level). - -- - -- Actual - -- | E,S | Er,S | E,Sr | Er,Sr | - -- ------+-------+-------+-------+-------+ - -- E,S |collap | no(3) | no(3) | no(3) | - -- ------+-------+-------+-------+-------+ - -- Er,S | no(1) |if same| no(2) | no(2) | - -- Formal ------+-------+-------+-------+-------+ - -- E,Sr | no(1) | no(2) |if same| no(4) | - -- ------+-------+-------+-------+-------+ - -- Er,Sr | no(1) | no(2) | no(4) |if same| - -- ------+-------+-------+-------+-------+ - -- - -- Notes: (1): formal may have several sources. - -- (2): resolver is not the same. - -- (3): this prevents to catch several sources error in instance. - -- (4): resolver is not the same, because the types are not the - -- same. - -- - -- Furthermore, signals cannot be collapsed if the kind (none, bus or - -- register) is not the same. - -- - -- Default value: default value is the effective value. - - -- Resolution function. - Actual_Res := Get_Resolver (Actual); - Formal_Res := Get_Resolver (Formal); - - -- If the resolutions are not the same, signals cannot be collapsed. - if Actual_Res /= Formal_Res then - return False; - end if; - - -- If neither the actual nor the formal is resolved, then collapsing is - -- possible. - -- (this is case ES/ES). - if Actual_Res = Null_Iir and Formal_Res = Null_Iir then - return True; - end if; - - -- If the formal can have sources and is guarded, but the actual is - -- not guarded (or has not the same kind of guard), signals cannot - -- be collapsed. - if (Get_Guarded_Signal_Flag (Formal_Base) - /= Get_Guarded_Signal_Flag (Actual_Base)) - or else (Get_Signal_Kind (Formal_Base) - /= Get_Signal_Kind (Actual_Base)) - then - return False; - end if; - - return True; - end Can_Collapse_Signals; - - -- INTER_PARENT contains generics interfaces; - -- ASSOC_PARENT constains generic aspects. - function Sem_Generic_Association_Chain - (Inter_Parent : Iir; Assoc_Parent : Iir) return Boolean - is - El : Iir; - Match : Compatibility_Level; - Assoc_Chain : Iir; - Inter_Chain : Iir; - Miss : Missing_Type; - begin - -- LRM08 6.5.6.2 Generic clauses - -- If no such actual is specified for a given formal generic constant - -- (either because the formal generic is unassociated or because the - -- actual is open), and if a default expression is specified for that - -- generic, the value of this expression is the value of the generic. - -- It is an error if no actual is specified for a given formal generic - -- constant and no default expression is present in the corresponding - -- interface element. - - -- Note: CHECK_MATCH argument of sem_subprogram_arguments must be - -- true if parent is a component instantiation. - case Get_Kind (Assoc_Parent) is - when Iir_Kind_Component_Instantiation_Statement => - -- LRM 9.6 Component Instantiation Statement - -- Each local generic (or subelement or slice thereof) must be - -- associated {VHDL87: exactly}{VHDL93: at most} once. - -- ... - -- Each local port (or subelement or slice therof) must be - -- associated {VHDL87: exactly}{VHDL93: at most} once. - - -- GHDL: for a direct instantiation, follow rules of - -- LRM 1.1.1.1 Generic and LRM 1.1.1.2 Ports. - -- The difference between 87 and 93 is simply a clarification: - -- missing association are left open, but need a default - -- expression in the formal declaration. - Miss := Missing_Generic; - when Iir_Kind_Binding_Indication => - -- LRM 5.2.1.2 Generic map and port map aspects - Miss := Missing_Allowed; - when Iir_Kind_Block_Header => - Miss := Missing_Generic; - when Iir_Kind_Package_Instantiation_Declaration - | Iir_Kind_Interface_Package_Declaration - | Iir_Kind_Package_Header => - -- LRM08 4.9 - -- Each formal generic (or member thereof) shall be associated - -- at most once. - Miss := Missing_Generic; - when others => - Error_Kind ("sem_generic_association_list", Assoc_Parent); - end case; - - -- The generics - Inter_Chain := Get_Generic_Chain (Inter_Parent); - Assoc_Chain := Get_Generic_Map_Aspect_Chain (Assoc_Parent); - - -- Extract non-object associations, as the actual cannot be analyzed - -- as an expression. - Assoc_Chain := Extract_Non_Object_Association (Assoc_Chain, Inter_Chain); - Set_Generic_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain); - - if not Sem_Actual_Of_Association_Chain (Assoc_Chain) then - return False; - end if; - - Sem_Association_Chain - (Inter_Chain, Assoc_Chain, True, Miss, Assoc_Parent, Match); - Set_Generic_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain); - if Match = Not_Compatible then - return False; - end if; - - -- LRM 5.2.1.2 Generic map and port map aspects - -- An actual associated with a formal generic map aspect must be an - -- expression or the reserved word open; - El := Assoc_Chain; - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Association_Element_By_Expression => - Check_Read (Get_Actual (El)); - when Iir_Kind_Association_Element_Open - | Iir_Kind_Association_Element_By_Individual - | Iir_Kind_Association_Element_Package - | Iir_Kind_Association_Element_Type - | Iir_Kind_Association_Element_Subprogram => - null; - when others => - Error_Kind ("sem_generic_association_chain(1)", El); - end case; - El := Get_Chain (El); - end loop; - - return True; - end Sem_Generic_Association_Chain; - - procedure Sem_Generic_Association_Chain - (Inter_Parent : Iir; Assoc_Parent : Iir) - is - Res : Boolean; - pragma Unreferenced (Res); - begin - Res := Sem_Generic_Association_Chain (Inter_Parent, Assoc_Parent); - end Sem_Generic_Association_Chain; - - -- INTER_PARENT contains ports interfaces; - -- ASSOC_PARENT constains ports map aspects. - procedure Sem_Port_Association_Chain - (Inter_Parent : Iir; Assoc_Parent : Iir) - is - Assoc : Iir; - Actual : Iir; - Prefix : Iir; - Object : Iir; - Match : Compatibility_Level; - Assoc_Chain : Iir; - Miss : Missing_Type; - Inter : Iir; - Formal : Iir; - Formal_Base : Iir; - begin - -- Note: CHECK_MATCH argument of sem_subprogram_arguments must be - -- true if parent is a component instantiation. - case Get_Kind (Assoc_Parent) is - when Iir_Kind_Component_Instantiation_Statement => - -- LRM 9.6 Component Instantiation Statement - -- Each local generic (or subelement or slice thereof) must be - -- associated {VHDL87: exactly}{VHDL93: at most} once. - -- ... - -- Each local port (or subelement or slice therof) must be - -- associated {VHDL87: exactly}{VHDL93: at most} once. - - -- GHDL: for a direct instantiation, follow rules of - -- LRM 1.1.1.1 Generic and LRM 1.1.1.2 Ports. - Miss := Missing_Port; - when Iir_Kind_Binding_Indication => - -- LRM 5.2.1.2 Generic map and port map aspects - Miss := Missing_Allowed; - when Iir_Kind_Block_Header => - -- FIXME: it is possible to have port unassociated ? - Miss := Missing_Port; - when others => - Error_Kind ("sem_port_association_list", Assoc_Parent); - end case; - - -- The ports - Assoc_Chain := Get_Port_Map_Aspect_Chain (Assoc_Parent); - if not Sem_Actual_Of_Association_Chain (Assoc_Chain) then - return; - end if; - Sem_Association_Chain (Get_Port_Chain (Inter_Parent), Assoc_Chain, - True, Miss, Assoc_Parent, Match); - Set_Port_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain); - if Match = Not_Compatible then - return; - end if; - - -- LRM 5.2.1.2 Generic map and port map aspects - -- [...]; an actual associated with a formal port in a port map aspect - -- must be a signal, an expression, or the reserved word open. - -- - -- Certain restriction apply to the actual associated with a formal in - -- a port map aspect; these restrictions are described in 1.1.1.2 - - -- LRM93 1.1.1.2 - -- The actual, if a port or signal, must be denoted by a static name. - -- The actual, if an expression, must be a globally static expression. - Assoc := Assoc_Chain; - Inter := Get_Port_Chain (Inter_Parent); - while Assoc /= Null_Iir loop - Formal := Get_Association_Formal (Assoc, Inter); - Formal_Base := Get_Interface_Of_Formal (Formal); - - if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression then - Actual := Get_Actual (Assoc); - -- There has been an error, exit from the loop. - exit when Actual = Null_Iir; - Object := Name_To_Object (Actual); - if Is_Valid (Object) and then Is_Signal_Object (Object) then - -- Port or signal. - Set_Collapse_Signal_Flag - (Assoc, Can_Collapse_Signals (Assoc, Formal)); - if Get_Name_Staticness (Object) < Globally then - Error_Msg_Sem (+Actual, "actual must be a static name"); - end if; - Check_Port_Association_Bounds_Restrictions - (Formal, Actual, Assoc); - Prefix := Get_Object_Prefix (Object); - if Get_Kind (Prefix) = Iir_Kind_Interface_Signal_Declaration - then - declare - P : Boolean; - pragma Unreferenced (P); - begin - P := Check_Port_Association_Mode_Restrictions - (Formal_Base, Prefix, Assoc); - end; - end if; - else - -- Expression. - Set_Collapse_Signal_Flag (Assoc, False); - - pragma Assert (Is_Null (Get_Actual_Conversion (Assoc))); - if Flags.Vhdl_Std >= Vhdl_93c then - -- LRM93 1.1.1.2 Ports - -- Moreover, the ports of a block may be associated - -- with an expression, in order to provide these ports - -- with constant driving values; such ports must be - -- of mode in. - if Get_Mode (Formal_Base) /= Iir_In_Mode then - Error_Msg_Sem - (+Assoc, "only 'in' ports may be associated with " - & "expression"); - end if; - - -- LRM93 1.1.1.2 Ports - -- The actual, if an expression, must be a globally - -- static expression. - if Get_Expr_Staticness (Actual) < Globally then - Error_Msg_Sem - (+Actual, - "actual expression must be globally static"); - end if; - else - Error_Msg_Sem - (+Assoc, - "cannot associate ports with expression in vhdl87"); - end if; - end if; - end if; - Next_Association_Interface (Assoc, Inter); - end loop; - end Sem_Port_Association_Chain; - - -- INTER_PARENT contains generics and ports interfaces; - -- ASSOC_PARENT constains generics and ports map aspects. - procedure Sem_Generic_Port_Association_Chain - (Inter_Parent : Iir; Assoc_Parent : Iir) - is - Res : Boolean; - pragma Unreferenced (Res); - begin - Sem_Generic_Association_Chain (Inter_Parent, Assoc_Parent); - Sem_Port_Association_Chain (Inter_Parent, Assoc_Parent); - end Sem_Generic_Port_Association_Chain; - - -- LRM 1.3 Configuration Declarations. - procedure Sem_Configuration_Declaration (Decl: Iir) - is - Entity: Iir_Entity_Declaration; - Entity_Unit : Iir_Design_Unit; - begin - Xref_Decl (Decl); - - -- LRM 1.3 - -- The entity name identifies the name of the entity declaration that - -- defines the design entity at the apex of the design hierarchy. - Entity := Sem_Entity_Name (Decl); - if Entity = Null_Iir then - return; - end if; - Entity_Unit := Get_Design_Unit (Entity); - - -- LRM 11.4 - -- A primary unit whose name is referenced within a given design unit - -- must be analyzed prior to the analysis of the given design unit. - Add_Dependence (Entity_Unit); - - Sem_Scopes.Add_Name (Decl); - - Set_Visible_Flag (Decl, True); - - -- LRM 10.1 Declarative Region - -- 2. A configuration declaration. - Open_Declarative_Region; - - -- LRM93 10.2 - -- In addition to the above rules, the scope of any declaration that - -- includes the end of the declarative part of a given block (whether - -- it be an external block defined by a design entity or an internal - -- block defined by a block statement) extends into a configuration - -- declaration that configures the given block. - Add_Context_Clauses (Entity_Unit); - Sem_Scopes.Add_Entity_Declarations (Entity); - - Sem_Declaration_Chain (Decl); - -- GHDL: no need to check for missing subprogram bodies, since they are - -- not allowed in configuration declarations. - - Sem_Block_Configuration (Get_Block_Configuration (Decl), Decl); - Close_Declarative_Region; - end Sem_Configuration_Declaration; - - -- Analyze the block specification of a block statement or of a generate - -- statement. Return the corresponding block statement, generate - -- statement body, or Null_Iir in case of error. - function Sem_Block_Specification_Of_Statement - (Block_Conf : Iir_Block_Configuration; Father : Iir) return Iir - is - Block_Spec : Iir; - Block_Name : Iir; - Block_Stmts : Iir; - Prev : Iir_Block_Configuration; - Block : Iir; - Res : Iir; - Assoc : Iir; - Clause : Iir; - Gen_Spec : Iir; - begin - Block_Spec := Get_Block_Specification (Block_Conf); - case Get_Kind (Block_Spec) is - when Iir_Kind_Simple_Name => - Block_Name := Block_Spec; - when Iir_Kind_Parenthesis_Name - | Iir_Kind_Slice_Name => - Block_Name := Get_Prefix (Block_Spec); - when others => - Error_Msg_Sem (+Block_Spec, "label expected"); - return Null_Iir; - end case; - - -- Analyze the label and generate specification. - Block_Name := Sem_Denoting_Name (Block_Name); - Block := Get_Named_Entity (Block_Name); - case Get_Kind (Block) is - when Iir_Kind_Block_Statement => - if Get_Kind (Block_Spec) /= Iir_Kind_Simple_Name then - Error_Msg_Sem (+Block_Spec, - "label does not denote a generate statement"); - end if; - Set_Block_Specification (Block_Conf, Block_Name); - Prev := Get_Block_Block_Configuration (Block); - Res := Block; - - when Iir_Kind_For_Generate_Statement => - Res := Get_Generate_Statement_Body (Block); - Set_Named_Entity (Block_Name, Res); - Prev := Get_Generate_Block_Configuration (Res); - - case Get_Kind (Block_Spec) is - when Iir_Kind_Simple_Name => - Set_Block_Specification (Block_Conf, Block_Name); - when Iir_Kind_Parenthesis_Name => - Block_Spec := Sem_Index_Specification - (Block_Spec, - Get_Type (Get_Parameter_Specification (Block))); - if Block_Spec /= Null_Iir then - Set_Prefix (Block_Spec, Block_Name); - Set_Block_Specification (Block_Conf, Block_Spec); - end if; - when others => - raise Internal_Error; - end case; - - when Iir_Kind_If_Generate_Statement => - case Get_Kind (Block_Spec) is - when Iir_Kind_Simple_Name => - -- LRM08 3.4.2 Block configuration - -- If no generate specification appears in such a block - -- configuration, then it applies to exactly one of the - -- following sets of blocks: - -- [...] - -- - The implicit block generated by the corresponding - -- generate statement, if and only if the corresponding - -- generate is an if generate statement and if the first - -- condition after IF evaluates to TRUE. - Res := Get_Generate_Statement_Body (Block); - - -- LRM08 3.4.2 Block configuration - -- If the block specification of a block configuration - -- contains a generate statement label that denotes an if - -- generate statement, and if the first condition after IF - -- has an alternative label, then it is an error if the - -- generate statement label does not contain a generate - -- specification that is an alternative label. - if Get_Has_Label (Res) then - Error_Msg_Sem - (+Block_Spec, - "alternative label required in block specification"); - end if; - - Set_Block_Specification (Block_Conf, Block_Name); - - when Iir_Kind_Parenthesis_Name => - if Vhdl_Std < Vhdl_08 then - Error_Msg_Sem - (+Block_Spec, - "alternative label only allowed by vhdl08"); - return Null_Iir; - end if; - Assoc := Get_Association_Chain (Block_Spec); - pragma Assert - (Get_Kind (Assoc) - = Iir_Kind_Association_Element_By_Expression); - Gen_Spec := Get_Actual (Assoc); - if Get_Kind (Gen_Spec) /= Iir_Kind_Simple_Name then - Error_Msg_Sem - (+Gen_Spec, - "alternative label expected for if-generate"); - return Null_Iir; - end if; - -- Search label. - Clause := Block; - while Clause /= Null_Iir loop - Res := Get_Generate_Statement_Body (Clause); - exit when Get_Alternative_Label (Res) - = Get_Identifier (Gen_Spec); - Clause := Get_Generate_Else_Clause (Clause); - end loop; - if Clause = Null_Iir then - Error_Msg_Sem - (+Gen_Spec, - "alternative label %i not found for if-generate", - +Gen_Spec); - return Null_Iir; - end if; - Set_Named_Entity (Block_Spec, Res); - Xref_Ref (Gen_Spec, Res); - Set_Prefix (Block_Spec, Block_Name); - Set_Block_Specification (Block_Conf, Block_Spec); - - when others => - raise Internal_Error; - end case; - - Set_Named_Entity (Block_Name, Res); - Prev := Get_Generate_Block_Configuration (Res); - - when Iir_Kind_Case_Generate_Statement => - case Get_Kind (Block_Spec) is - when Iir_Kind_Simple_Name => - -- LRM08 3.4.2 Block configuration - -- If no generate specification appears in such a block - -- configuration, [...] - -- GHDL: doesn't apply to case generate statement - Error_Msg_Sem - (+Block_Spec, - "missing alternative label for a case-generate"); - return Null_Iir; - when Iir_Kind_Parenthesis_Name => - Assoc := Get_Association_Chain (Block_Spec); - pragma Assert - (Get_Kind (Assoc) - = Iir_Kind_Association_Element_By_Expression); - Gen_Spec := Get_Actual (Assoc); - if Get_Kind (Gen_Spec) /= Iir_Kind_Simple_Name then - Error_Msg_Sem - (+Gen_Spec, - "alternative label expected for case-generate"); - return Null_Iir; - end if; - -- Search label. - Clause := Get_Case_Statement_Alternative_Chain (Block); - while Clause /= Null_Iir loop - Res := Get_Associated_Block (Clause); - exit when Get_Alternative_Label (Res) - = Get_Identifier (Gen_Spec); - Clause := Get_Chain (Clause); - end loop; - if Clause = Null_Iir then - Error_Msg_Sem - (+Gen_Spec, - "alternative label %i not found for case-generate", - +Gen_Spec); - return Null_Iir; - end if; - Set_Named_Entity (Block_Spec, Res); - Xref_Ref (Gen_Spec, Res); - Set_Prefix (Block_Spec, Block_Name); - Set_Block_Specification (Block_Conf, Block_Spec); - - when others => - raise Internal_Error; - end case; - - Set_Named_Entity (Block_Name, Res); - Prev := Get_Generate_Block_Configuration (Res); - - when others => - Error_Msg_Sem (+Block_Conf, - "block or generate statement label expected"); - return Null_Iir; - end case; - - -- LRM93 1.3.1 / LRM08 3.4.2 Block configuration - -- [...], and the label must denote a block statement or generate - -- statement that is contained immediatly within the block denoted by - -- the block specification of the containing block configuration. - Block_Stmts := Get_Concurrent_Statement_Chain - (Get_Block_From_Block_Specification - (Get_Block_Specification (Father))); - if not Is_In_Chain (Block_Stmts, Block) then - Error_Msg_Sem (+Block_Conf, - "label does not denotes an inner block statement"); - return Null_Iir; - end if; - - case Get_Kind (Block) is - when Iir_Kind_Block_Statement => - -- LRM93 1.3 - -- It is an error if, in a given block configuration, more than - -- one configuration item is defined for the same block [or - -- component instance]. - if Prev /= Null_Iir then - Error_Msg_Sem - (+Block_Conf, - "%n was already configured at %l", (+Block, +Prev)); - return Null_Iir; - end if; - Set_Block_Block_Configuration (Res, Block_Conf); - - when Iir_Kind_If_Generate_Statement - | Iir_Kind_Case_Generate_Statement => - -- LRM93 1.3 - -- It is an error if, in a given block configuration, more than - -- one configuration item is defined for the same block [or - -- component instance]. - if Prev /= Null_Iir then - Error_Msg_Sem - (+Block_Conf, - "%n was already configured at %l", (+Block, +Prev)); - return Null_Iir; - end if; - Set_Generate_Block_Configuration (Res, Block_Conf); - - when Iir_Kind_For_Generate_Statement => - -- LRM93 1.3 - -- For any name that is the label of a generate statement - -- immediately wihin a given block, one or more corresponding - -- block configuration may appear as configuration items - -- immediately within a block configuration corresponding to the - -- given block. - -- GHDL: keep them in a linked list, but don't try to detect - -- duplicate as values may not be static. FIXME: try for - -- static values only ? - Set_Prev_Block_Configuration (Block_Conf, Prev); - Set_Generate_Block_Configuration (Res, Block_Conf); - when others => - raise Internal_Error; - end case; - return Res; - end Sem_Block_Specification_Of_Statement; - - -- LRM 1.3.1 Block Configuration. - -- FATHER is the block_configuration, configuration_declaration, - -- component_configuration containing the block_configuration BLOCK_CONF. - procedure Sem_Block_Configuration - (Block_Conf : Iir_Block_Configuration; Father: Iir) - is - El : Iir; - Block : Iir; - begin - case Get_Kind (Father) is - when Iir_Kind_Configuration_Declaration => - -- LRM93 1.3.1 - -- If a block configuration appears immediately within a - -- configuration declaration, then the block specification of that - -- block configuration must be an architecture name, and that - -- architecture name must denote a design entity body whose - -- interface is defined by the entity declaration denoted by the - -- entity name of the enclosing configuration declaration. - declare - Block_Spec : Iir; - Arch : Iir_Architecture_Body; - Design: Iir_Design_Unit; - begin - Block_Spec := Get_Block_Specification (Block_Conf); - -- FIXME: handle selected name. - if Get_Kind (Block_Spec) /= Iir_Kind_Simple_Name then - Error_Msg_Sem (+Block_Spec, "architecture name expected"); - return; - end if; - -- LRM 10.3 rule b) - -- For an architecture body associated with a given entity - -- declaration: at the place of the block specification in a - -- block configuration for an external block whose interface - -- is defined by that entity declaration. - Design := Load_Secondary_Unit - (Get_Design_Unit (Get_Entity (Father)), - Get_Identifier (Block_Spec), - Block_Conf); - if Design = Null_Iir then - Error_Msg_Sem - (+Block_Conf, "no architecture %i", +Block_Spec); - return; - end if; - Arch := Get_Library_Unit (Design); - Set_Named_Entity (Block_Spec, Arch); - Xref_Ref (Block_Spec, Arch); - Block := Arch; - Add_Dependence (Design); - end; - - when Iir_Kind_Component_Configuration => - -- LRM93 1.3.1 - -- If a block configuration appears immediately within a component - -- configuration, then the corresponding components must be - -- fully bound, the block specification of that block - -- configuration must be an architecture name, and that - -- architecture name must denote the same architecture body as - -- that to which the corresponding components are bound. - declare - Block_Spec : Iir; - Arch : Iir_Architecture_Body; - Design: Iir_Design_Unit; - Entity_Aspect : Iir; - Entity : Iir; - Comp_Arch : Iir; - begin - Entity_Aspect := - Get_Entity_Aspect (Get_Binding_Indication (Father)); - if Entity_Aspect = Null_Iir or else - Get_Kind (Entity_Aspect) /= Iir_Kind_Entity_Aspect_Entity - then - Error_Msg_Sem - (+Block_Conf, "corresponding component not fully bound"); - end if; - - Block_Spec := Get_Block_Specification (Block_Conf); - -- FIXME: handle selected name. - if Get_Kind (Block_Spec) /= Iir_Kind_Simple_Name then - Error_Msg_Sem (+Block_Spec, "architecture name expected"); - return; - end if; - - Comp_Arch := Get_Architecture (Entity_Aspect); - if Comp_Arch /= Null_Iir then - pragma Assert (Get_Kind (Comp_Arch) = Iir_Kind_Simple_Name); - if Get_Identifier (Comp_Arch) /= Get_Identifier (Block_Spec) - then - Error_Msg_Sem - (+Block_Spec, "block specification name is different " - & "from component architecture name"); - return; - end if; - end if; - - Entity := Get_Entity (Entity_Aspect); - if Entity = Null_Iir then - return; - end if; - - Design := Load_Secondary_Unit (Get_Design_Unit (Entity), - Get_Identifier (Block_Spec), - Block_Conf); - if Design = Null_Iir then - Error_Msg_Sem - (+Block_Conf, "no architecture %i", +Block_Spec); - return; - end if; - Add_Dependence (Design); - Arch := Get_Library_Unit (Design); - Set_Named_Entity (Block_Spec, Arch); - Xref_Ref (Block_Spec, Arch); - Block := Arch; - end; - - when Iir_Kind_Block_Configuration => - -- LRM93 1.3.1 / LRM08 3.4.2 Block configuration - -- If a block configuration appears immediately within another - -- block configuration, then the block specification of the - -- contained block configuration must be a block statement or - -- generate statement label, and the label must denote a block - -- statement or generate statement that is contained immediatly - -- within the block denoted by the block specification of the - -- containing block configuration. - Block := Sem_Block_Specification_Of_Statement (Block_Conf, Father); - if Block = Null_Iir then - return; - end if; - - when others => - Error_Kind ("sem_block_configuration", Father); - end case; - - -- LRM93 §10.1 - -- 10. A block configuration - Sem_Scopes.Open_Scope_Extension; - - -- LRM 10.3 - -- In addition, any declaration that is directly visible at the end of - -- the declarative part of a given block is directly visible in a block - -- configuration that configure the given block. This rule holds unless - -- a use clause that makes a homograph of the declaration potentially - -- visible (see 10.4) appears in the corresponding configuration - -- declaration, and if the scope of that use clause encompasses all or - -- part of those configuration items. If such a use clase appears, then - -- the declaration will be directly visible within the corresponding - -- configuration items, except at hose places that fall within the scope - -- of the additional use clause. At such places, neither name will be - -- directly visible. - -- FIXME: handle use clauses. - Sem_Scopes.Extend_Scope_Of_Block_Declarations (Block); - - declare - El : Iir; - begin - El := Get_Declaration_Chain (Block_Conf); - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Use_Clause => - Sem_Use_Clause (El); - when others => - -- Parse checks there are only use clauses. - raise Internal_Error; - end case; - El := Get_Chain (El); - end loop; - end; - - -- VHDL 87: do not remove configuration specification in generate stmts. - Clear_Instantiation_Configuration (Block, False); - - El := Get_Configuration_Item_Chain (Block_Conf); - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Block_Configuration => - Sem_Block_Configuration (El, Block_Conf); - when Iir_Kind_Component_Configuration => - Sem_Component_Configuration (El, Block_Conf); - when others => - Error_Kind ("sem_block_configuration(2)", El); - end case; - El := Get_Chain (El); - end loop; - Sem_Scopes.Close_Scope_Extension; - end Sem_Block_Configuration; - - -- Check that incremental binding of the component configuration CONF only - -- rebinds non associated ports of each instantiations of CONFIGURED_BLOCK - -- which CONF applies to. - procedure Check_Incremental_Binding (Configured_Block : Iir; Conf : Iir) - is - Comp : constant Iir := Get_Named_Entity (Get_Component_Name (Conf)); - Inter_Chain : constant Iir := Get_Port_Chain (Comp); - Binding : constant Iir := Get_Binding_Indication (Conf); - Inst : Iir; - begin - -- Check each component instantiation of the block configured by CONF. - Inst := Get_Concurrent_Statement_Chain (Configured_Block); - while Inst /= Null_Iir loop - if Get_Kind (Inst) = Iir_Kind_Component_Instantiation_Statement - and then Get_Component_Configuration (Inst) = Conf - then - -- Check this instantiation. - declare - Primary_Binding : constant Iir := Get_Binding_Indication - (Get_Configuration_Specification (Inst)); - F_Chain : constant Iir := - Get_Port_Map_Aspect_Chain (Primary_Binding); - S_El : Iir; - S_Inter : Iir; - F_El : Iir; - Formal : Iir; - begin - S_El := Get_Port_Map_Aspect_Chain (Binding); - S_Inter := Inter_Chain; - while S_El /= Null_Iir loop - -- Find S_EL formal in F_CHAIN. - Formal := Get_Association_Interface (S_El, S_Inter); - F_El := Find_First_Association_For_Interface - (F_Chain, Inter_Chain, Formal); - if F_El /= Null_Iir - and then - Get_Kind (F_El) /= Iir_Kind_Association_Element_Open - then - Error_Msg_Sem - (+S_El, - "%n already associated in primary binding", +Formal); - end if; - Next_Association_Interface (S_El, S_Inter); - end loop; - end; - end if; - Inst := Get_Chain (Inst); - end loop; - end Check_Incremental_Binding; - - -- LRM 1.3.2 - procedure Sem_Component_Configuration - (Conf : Iir_Component_Configuration; Father : Iir) - is - Block : Iir; - Configured_Block : Iir; - Binding : Iir; - Entity : Iir_Design_Unit; - Comp : Iir_Component_Declaration; - Primary_Entity_Aspect : Iir; - begin - -- LRM 10.1 Declarative Region - -- 11. A component configuration. - Open_Declarative_Region; - - -- LRM93 10.2 - -- If a component configuration appears as a configuration item - -- immediatly within a block configuration that configures a given - -- block, and the scope of a given declaration includes the end of the - -- declarative part of that block, then the scope of the given - -- declaration extends from the beginning to the end of the - -- declarative region associated with the given component configuration. - -- GHDL: this is for labels of component instantiation statements, and - -- for local ports and generics of the component. - if Get_Kind (Father) = Iir_Kind_Block_Configuration then - Configured_Block := Get_Block_Specification (Father); - pragma Assert (Get_Kind (Configured_Block) /= Iir_Kind_Design_Unit); - Configured_Block := - Get_Block_From_Block_Specification (Configured_Block); - Sem_Scopes.Extend_Scope_Of_Block_Declarations (Configured_Block); - else - -- Can a component configuration not be just inside a block - -- configuration ? - raise Internal_Error; - end if; - -- FIXME: this is wrong (all declarations should be considered). - Sem_Component_Specification - (Configured_Block, Conf, Primary_Entity_Aspect); - - Comp := Get_Named_Entity (Get_Component_Name (Conf)); - if Get_Kind (Comp) /= Iir_Kind_Component_Declaration then - -- There has been an error in sem_component_specification. - -- Leave here. - Close_Declarative_Region; - return; - end if; - - -- FIXME: (todo) - -- If a given component instance is unbound in the corresponding block, - -- then any explicit component configuration for that instance that does - -- not contain an explicit binding indication will contain an implicit, - -- default binding indication (see 5.2.2). Similarly, if a given - -- component instance is unbound in the corresponding block, then any - -- implicit component configuration for that instance will contain an - -- implicit, default binding indication. - Open_Declarative_Region; - Sem_Scopes.Add_Component_Declarations (Comp); - Binding := Get_Binding_Indication (Conf); - if Binding /= Null_Iir then - Sem_Binding_Indication (Binding, Conf, Primary_Entity_Aspect); - - if Primary_Entity_Aspect /= Null_Iir then - -- LRM93 5.2.1 Binding Indication - -- It is an error if a formal port appears in the port map aspect - -- of the incremental binding indication and it is a formal - -- port that is associated with an actual other than OPEN in one - -- of the primary binding indications. - Check_Incremental_Binding (Configured_Block, Conf); - end if; - elsif Primary_Entity_Aspect = Null_Iir then - -- LRM93 5.2.1 - -- If the generic map aspect or port map aspect of a primary binding - -- indication is not present, then the default rules as described - -- in 5.2.2 apply. - - -- Create a default binding indication. - Entity := Get_Visible_Entity_Declaration (Comp); - Binding := Sem_Create_Default_Binding_Indication - (Comp, Entity, Conf, False, False); - - if Binding /= Null_Iir then - -- Remap to defaults. - Set_Default_Entity_Aspect (Binding, Get_Entity_Aspect (Binding)); - Set_Entity_Aspect (Binding, Null_Iir); - - Set_Binding_Indication (Conf, Binding); - end if; - end if; - Close_Declarative_Region; - - -- External block. - Block := Get_Block_Configuration (Conf); - if Block /= Null_Iir and then Binding /= Null_Iir then - Sem_Block_Configuration (Block, Conf); - end if; - Close_Declarative_Region; - end Sem_Component_Configuration; - - function Are_Trees_Chain_Equal (Left, Right : Iir) return Boolean - is - El_Left, El_Right : Iir; - begin - if Left = Right then - return True; - end if; - El_Left := Left; - El_Right := Right; - loop - if El_Left = Null_Iir and El_Right = Null_Iir then - return True; - end if; - if El_Left = Null_Iir or El_Right = Null_Iir then - return False; - end if; - if not Are_Trees_Equal (El_Left, El_Right) then - return False; - end if; - El_Left := Get_Chain (El_Left); - El_Right := Get_Chain (El_Right); - end loop; - end Are_Trees_Chain_Equal; - - -- Return TRUE iff LEFT and RIGHT are (in depth) equal. - -- This corresponds to conformance rules, LRM93 2.7 - function Are_Trees_Equal (Left, Right : Iir) return Boolean - is - El_Left, El_Right : Iir; - begin - -- Short-cut to speed up. - if Left = Right then - return True; - end if; - - -- Handle null_iir. - if Left = Null_Iir or Right = Null_Iir then - -- Note: LEFT *xor* RIGHT is null_iir. - return False; - end if; - - -- LRM 2.7 Conformance Rules - -- A simple name can be replaced by an expanded name in which this - -- simple name is the selector, if and only if at both places the - -- meaning of the simple name is given by the same declaration. - case Get_Kind (Left) is - when Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name => - case Get_Kind (Right) is - when Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name => - return Are_Trees_Equal (Get_Named_Entity (Left), - Get_Named_Entity (Right)); - when others => - return False; - end case; - when others => - null; - end case; - - -- If nodes are not of the same kind, then they are not equals! - if Get_Kind (Left) /= Get_Kind (Right) then - return False; - end if; - - case Get_Kind (Left) is - when Iir_Kind_Procedure_Declaration => - return Are_Trees_Chain_Equal - (Get_Interface_Declaration_Chain (Left), - Get_Interface_Declaration_Chain (Right)); - when Iir_Kind_Function_Declaration => - if not Are_Trees_Equal (Get_Return_Type (Left), - Get_Return_Type (Right)) - then - return False; - end if; - if Get_Pure_Flag (Left) /= Get_Pure_Flag (Right) then - return False; - end if; - if not Are_Trees_Chain_Equal - (Get_Interface_Declaration_Chain (Left), - Get_Interface_Declaration_Chain (Right)) - then - return False; - end if; - return True; - when Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Interface_File_Declaration => - if Get_Identifier (Left) /= Get_Identifier (Right) then - return False; - end if; - if Get_Has_Mode (Left) /= Get_Has_Mode (Right) - or else Get_Has_Class (Left) /= Get_Has_Class (Right) - or else (Get_Has_Identifier_List (Left) - /= Get_Has_Identifier_List (Right)) - or else Get_Mode (Left) /= Get_Mode (Right) - then - return False; - end if; - if not Are_Trees_Equal (Get_Type (Left), Get_Type (Right)) then - return False; - end if; - El_Left := Get_Default_Value (Left); - El_Right := Get_Default_Value (Right); - if (El_Left = Null_Iir) xor (El_Right = Null_Iir) then - return False; - end if; - if El_Left /= Null_Iir - and then Are_Trees_Equal (El_Left, El_Right) = False - then - return False; - end if; - return True; - - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition => - if Get_Base_Type (Left) /= Get_Base_Type (Right) then - return False; - end if; - if Get_Type_Declarator (Left) /= Get_Type_Declarator (Right) then - return False; - end if; - if not Are_Trees_Equal (Get_Resolution_Indication (Left), - Get_Resolution_Indication (Right)) - then - return False; - end if; - if Are_Trees_Equal (Get_Range_Constraint (Left), - Get_Range_Constraint (Right)) = False - then - return False; - end if; - return True; - when Iir_Kind_Array_Subtype_Definition => - if Get_Base_Type (Left) /= Get_Base_Type (Right) then - return False; - end if; - if not Are_Trees_Equal (Get_Resolution_Indication (Left), - Get_Resolution_Indication (Right)) - then - return False; - end if; - declare - L_Left : constant Iir_Flist := Get_Index_Subtype_List (Left); - L_Right : constant Iir_Flist := Get_Index_Subtype_List (Right); - begin - if Get_Nbr_Elements (L_Left) /= Get_Nbr_Elements (L_Right) then - return False; - end if; - for I in Flist_First .. Flist_Last (L_Left) loop - El_Left := Get_Nth_Element (L_Left, I); - El_Right := Get_Nth_Element (L_Right, I); - if not Are_Trees_Equal (El_Left, El_Right) then - return False; - end if; - end loop; - end; - return True; - when Iir_Kind_Record_Subtype_Definition => - if Get_Base_Type (Left) /= Get_Base_Type (Right) then - return False; - end if; - if not Are_Trees_Equal (Get_Resolution_Indication (Left), - Get_Resolution_Indication (Right)) - then - return False; - end if; - declare - L_Left : constant Iir_Flist := - Get_Elements_Declaration_List (Left); - L_Right : constant Iir_Flist := - Get_Elements_Declaration_List (Right); - begin - for I in Flist_First .. Flist_Last (L_Left) loop - El_Left := Get_Nth_Element (L_Left, I); - El_Right := Get_Nth_Element (L_Right, I); - if not Are_Trees_Equal (El_Left, El_Right) then - return False; - end if; - end loop; - end; - return True; - - when Iir_Kind_Integer_Literal => - if Get_Value (Left) /= Get_Value (Right) then - return False; - end if; - return Are_Trees_Equal (Get_Literal_Origin (Left), - Get_Literal_Origin (Right)); - when Iir_Kind_Enumeration_Literal => - if Get_Enum_Pos (Left) /= Get_Enum_Pos (Right) then - return False; - end if; - return Are_Trees_Equal (Get_Literal_Origin (Left), - Get_Literal_Origin (Right)); - when Iir_Kind_Physical_Int_Literal => - if Get_Value (Left) /= Get_Value (Right) - or else not Are_Trees_Equal (Get_Unit_Name (Left), - Get_Unit_Name (Right)) - then - return False; - end if; - return Are_Trees_Equal (Get_Literal_Origin (Left), - Get_Literal_Origin (Right)); - when Iir_Kind_Physical_Fp_Literal => - if Get_Fp_Value (Left) /= Get_Fp_Value (Right) - or else not Are_Trees_Equal (Get_Unit_Name (Left), - Get_Unit_Name (Right)) - then - return False; - end if; - return Are_Trees_Equal (Get_Literal_Origin (Left), - Get_Literal_Origin (Right)); - when Iir_Kind_Unit_Declaration => - return Left = Right; - when Iir_Kind_Floating_Point_Literal => - if Get_Fp_Value (Left) /= Get_Fp_Value (Right) then - return False; - end if; - return Are_Trees_Equal (Get_Literal_Origin (Left), - Get_Literal_Origin (Right)); - - when Iir_Kinds_Dyadic_Operator => - return Are_Trees_Equal (Get_Left (Left), Get_Left (Right)) - and then Are_Trees_Equal (Get_Right (Left), Get_Right (Right)); - when Iir_Kinds_Monadic_Operator => - return Are_Trees_Equal (Get_Operand (Left), Get_Operand (Right)); - - when Iir_Kind_Function_Call => - return Are_Trees_Equal (Get_Prefix (Left), Get_Prefix (Right)) - and then - Are_Trees_Chain_Equal (Get_Parameter_Association_Chain (Left), - Get_Parameter_Association_Chain (Right)); - - when Iir_Kind_Association_Element_By_Expression => - return Are_Trees_Equal (Get_Actual (Left), Get_Actual (Right)) - and then Are_Trees_Equal (Get_Formal (Left), Get_Formal (Right)) - and then Are_Trees_Equal (Get_Actual_Conversion (Left), - Get_Actual_Conversion (Right)) - and then Are_Trees_Equal (Get_Formal_Conversion (Left), - Get_Formal_Conversion (Right)); - - when Iir_Kind_Type_Conversion => - return Are_Trees_Equal (Get_Type_Mark (Left), - Get_Type_Mark (Right)) - and then - Are_Trees_Equal (Get_Expression (Left), - Get_Expression (Right)); - - when Iir_Kind_Access_Type_Definition - | Iir_Kind_Record_Type_Definition - | Iir_Kind_Array_Type_Definition - | Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_File_Type_Definition => - return Left = Right; - - when Iir_Kind_Range_Expression => - if Get_Type (Left) /= Get_Type (Right) - or else Get_Direction (Left) /= Get_Direction (Right) - then - return False; - end if; - if not Are_Trees_Equal (Get_Left_Limit (Left), - Get_Left_Limit (Right)) - or else not Are_Trees_Equal (Get_Right_Limit (Left), - Get_Right_Limit (Right)) - then - return False; - end if; - return True; - - when Iir_Kind_High_Type_Attribute - | Iir_Kind_Low_Type_Attribute - | Iir_Kind_Left_Type_Attribute - | Iir_Kind_Right_Type_Attribute - | Iir_Kind_Ascending_Type_Attribute => - return Are_Trees_Equal (Get_Prefix (Left), Get_Prefix (Right)); - - when Iir_Kind_String_Literal8 => - if Get_Bit_String_Base (Left) /= Get_Bit_String_Base (Right) then - return False; - end if; - declare - use Str_Table; - Len : constant Nat32 := Get_String_Length (Left); - L_Id : constant String8_Id := Get_String8_Id (Left); - R_Id : constant String8_Id := Get_String8_Id (Right); - begin - if Get_String_Length (Right) /= Len then - return False; - end if; - for I in 1 .. Len loop - if Element_String8 (L_Id, I) /= Element_String8 (R_Id, I) - then - return False; - end if; - end loop; - return True; - end; - - when Iir_Kind_Aggregate => - if not Are_Trees_Equal (Get_Type (Left), Get_Type (Right)) then - return False; - end if; - declare - El_L, El_R : Iir; - begin - El_L := Get_Association_Choices_Chain (Left); - El_R := Get_Association_Choices_Chain (Right); - loop - exit when El_L = Null_Iir and El_R = Null_Iir; - if not Are_Trees_Equal (El_L, El_R) then - return False; - end if; - El_L := Get_Chain (El_L); - El_R := Get_Chain (El_R); - end loop; - return True; - end; - - when Iir_Kind_Choice_By_None - | Iir_Kind_Choice_By_Others => - return Are_Trees_Equal (Get_Associated_Expr (Left), - Get_Associated_Expr (Right)); - when Iir_Kind_Choice_By_Name => - if not Are_Trees_Equal (Get_Choice_Name (Left), - Get_Choice_Name (Right)) - then - return False; - end if; - return Are_Trees_Equal (Get_Associated_Expr (Left), - Get_Associated_Expr (Right)); - when Iir_Kind_Choice_By_Expression => - if not Are_Trees_Equal (Get_Choice_Expression (Left), - Get_Choice_Expression (Right)) then - return False; - end if; - return Are_Trees_Equal (Get_Associated_Expr (Left), - Get_Associated_Expr (Right)); - when Iir_Kind_Choice_By_Range => - if not Are_Trees_Equal (Get_Choice_Range (Left), - Get_Choice_Range (Right)) then - return False; - end if; - return Are_Trees_Equal (Get_Associated_Expr (Left), - Get_Associated_Expr (Right)); - when Iir_Kind_Character_Literal => - return Are_Trees_Equal (Get_Named_Entity (Left), - Get_Named_Entity (Right)); - when Iir_Kind_Allocator_By_Subtype => - return Are_Trees_Equal (Get_Subtype_Indication (Left), - Get_Subtype_Indication (Right)); - when Iir_Kind_Allocator_By_Expression => - return Are_Trees_Equal (Get_Expression (Left), - Get_Expression (Right)); - when others => - Error_Kind ("are_trees_equal", Left); - end case; - end Are_Trees_Equal; - - -- LRM 2.7 Conformance Rules. - procedure Check_Conformance_Rules (Subprg, Spec: Iir) is - begin - if not Are_Trees_Equal (Subprg, Spec) then - -- FIXME: should explain why it does not conform ? - Error_Msg_Sem - (+Subprg, "body of %n does not conform with specification at %l", - (+Subprg, +Spec)); - end if; - end Check_Conformance_Rules; - - -- Return the specification corresponding to a declaration DECL, or - -- null_Iir if none. - -- FIXME: respect rules of LRM93 2.7 - function Find_Subprogram_Specification (Decl: Iir) return Iir - is - Interpretation : Name_Interpretation_Type; - Decl1: Iir; - Hash : Iir_Int32; - begin - Hash := Get_Subprogram_Hash (Decl); - Interpretation := Get_Interpretation (Get_Identifier (Decl)); - while Valid_Interpretation (Interpretation) loop - if not Is_In_Current_Declarative_Region (Interpretation) then - -- The declaration does not belong to the current declarative - -- region, neither will the following one. So, we do not found - -- it. - return Null_Iir; - end if; - Decl1 := Get_Declaration (Interpretation); - -- Should be sure DECL1 and DECL belongs to the same declarative - -- region, ie DECL1 was not made visible via a USE clause. - -- - -- Also, only check for explicitly subprograms (and not - -- implicit one). - if not Is_Implicit_Subprogram (Decl1) - and then Get_Kind (Decl1) in Iir_Kinds_Subprogram_Declaration - and then not Is_Potentially_Visible (Interpretation) - and then Get_Subprogram_Hash (Decl1) = Hash - and then Is_Same_Profile (Decl, Decl1) - then - return Decl1; - end if; - Interpretation := Get_Next_Interpretation (Interpretation); - end loop; - return Null_Iir; - end Find_Subprogram_Specification; - - procedure Set_Subprogram_Overload_Number (Decl : Iir) - is - Id : constant Name_Id := Get_Identifier (Decl); - Inter : Name_Interpretation_Type; - Prev : Iir; - Num : Iir_Int32; - begin - Inter := Get_Interpretation (Id); - while Valid_Interpretation (Inter) - and then Is_In_Current_Declarative_Region (Inter) - loop - -- There is a previous declaration with the same name in the - -- current declarative region. - Prev := Get_Declaration (Inter); - case Get_Kind (Prev) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - if Is_Implicit_Subprogram (Prev) then - -- Implicit declarations aren't taken into account (as they - -- are mangled differently). - Inter := Get_Next_Interpretation (Inter); - else - -- The previous declaration is a user subprogram. - Num := Get_Overload_Number (Prev) + 1; - if Num = 1 - and then Get_Parent (Prev) = Get_Parent (Decl) - then - -- The previous was not (yet) overloaded. Mark it as - -- overloaded. - -- Do not mark it if it is not in the same declarative - -- part (ie, do not change a subprogram declaration in - -- the package while analyzing the body). - Set_Overload_Number (Prev, 1); - Num := 2; - end if; - Set_Overload_Number (Decl, Num); - return; - end if; - when Iir_Kind_Enumeration_Literal => - -- Enumeration literal are ignored for overload number. - Inter := Get_Next_Interpretation (Inter); - when Iir_Kind_Non_Object_Alias_Declaration => - -- Subprogram aliases aren't considered, just skip them. - -- (No subprogram is created by an alias). - Inter := Get_Next_Interpretation (Inter); - when others => - -- Case of user error: redefinition of an identifier. - -- Error message is generated by sem_scope. - Set_Overload_Number (Decl, 0); - return; - end case; - end loop; - -- No previous declaration in the current declarative region. - Set_Overload_Number (Decl, 0); - end Set_Subprogram_Overload_Number; - - -- Check requirements on number of interfaces for subprogram specification - -- SUBPRG. Requirements only concern operators, and are defined in - -- LRM 2.3.1 - procedure Check_Operator_Requirements (Id : Name_Id; Subprg : Iir) - is - use Std_Names; - - Nbr_Interfaces : Natural; - Is_Method : Boolean; - begin - Nbr_Interfaces := Iir_Chains.Get_Chain_Length - (Get_Interface_Declaration_Chain (Subprg)); - - -- For vhdl-02, the protected variable is an implicit parameter. - if Flags.Vhdl_Std >= Vhdl_02 - and then Is_Subprogram_Method (Subprg) - then - Nbr_Interfaces := Nbr_Interfaces + 1; - else - Is_Method := False; - end if; - - case Id is - when Name_Abs - | Name_Not => - -- LRM93 2.3.1 - -- The subprogram specification of a unary operator must have a - -- single parameter. - - -- LRM02 2.3.1 - -- ..., unless the subprogram specification is a method (see - -- 3.5.1) of a protected type. In this latter case, the - -- subprogram specification must have no parameters. - if Nbr_Interfaces = 1 then - return; - end if; - Error_Msg_Sem - (+Subprg, "unary operator must have a single parameter"); - when Name_Mod - | Name_Rem - | Name_Op_Mul - | Name_Op_Div - | Name_Relational_Operators - | Name_Op_Concatenation - | Name_Shift_Operators - | Name_Op_Exp => - -- LRM93 2.3.1 - -- The subprogram specification of a binary operator must have - -- two parameters. - - -- LRM02 2.3.1 - -- ..., unless the subprogram specification is a method of a - -- protected type, in which case, the subprogram specification - -- must have a single parameter. - if Nbr_Interfaces = 2 then - return; - end if; - Error_Msg_Sem - (+Subprg, "binary operators must have two parameters"); - when Name_Logical_Operators - | Name_Xnor => - -- LRM08 4.5.2 Operator overloading - -- For each of the "+", "-", "and", "or", "xor", "nand", "nor" - -- and "xnor", overloading is allowed both as a unary operator - -- and as a binary operator. - if Nbr_Interfaces = 2 then - return; - end if; - if Nbr_Interfaces = 1 then - if Vhdl_Std >= Vhdl_08 then - return; - end if; - Error_Msg_Sem - (+Subprg, - "logical operators must have two parameters before vhdl08"); - else - Error_Msg_Sem - (+Subprg, "logical operators must have two parameters"); - end if; - when Name_Op_Plus - | Name_Op_Minus => - -- LRM93 2.3.1 - -- For each of the operators "+" and "-", overloading is allowed - -- both as a unary operator and as a binary operator. - if Nbr_Interfaces in 1 .. 2 then - return; - end if; - Error_Msg_Sem - (+Subprg, - """+"" and ""-"" operators must have 1 or 2 parameters"); - when others => - return; - end case; - if Is_Method then - Error_Msg_Sem - (+Subprg, - " (the protected object is an implicit parameter of methods)"); - end if; - end Check_Operator_Requirements; - - procedure Sem_Subprogram_Specification (Subprg: Iir) - is - Interface_Chain : Iir; - Return_Type : Iir; - begin - -- LRM 10.1 Declarative Region - -- 3. A subprogram declaration, together with the corresponding - -- subprogram body. - Open_Declarative_Region; - - -- Sem interfaces. - Interface_Chain := Get_Interface_Declaration_Chain (Subprg); - case Get_Kind (Subprg) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Interface_Function_Declaration => - Sem_Interface_Chain - (Interface_Chain, Function_Parameter_Interface_List); - Return_Type := Get_Return_Type_Mark (Subprg); - Return_Type := Sem_Type_Mark (Return_Type); - Set_Return_Type_Mark (Subprg, Return_Type); - Return_Type := Get_Type (Return_Type); - Set_Return_Type (Subprg, Return_Type); - Set_All_Sensitized_State (Subprg, Unknown); - - -- LRM08 4.2 Subprogram declarations - -- It is an error if the result subtype of a function denotes - -- either a file type or a protected type. Moreover, it is an - -- error if the result subtype of a pure function denotes an - -- access type or a subtype that has a subelement of an access - -- type. - - -- GHDL: this was added by VHDL 2008, but vital packages don't - -- follow that rule. So, it is not retroactive. - case Get_Kind (Return_Type) is - when Iir_Kind_File_Type_Definition => - Error_Msg_Sem - (+Subprg, "result subtype cannot denote a file type"); - when Iir_Kind_Protected_Type_Declaration => - Error_Msg_Sem - (+Subprg, "result subtype cannot denote a protected type"); - when Iir_Kind_Access_Type_Definition - | Iir_Kind_Access_Subtype_Definition => - if Vhdl_Std >= Vhdl_08 - and then Get_Pure_Flag (Subprg) - then - Error_Msg_Sem_Relaxed - (Subprg, Warnid_Pure, - "result subtype of a pure function cannot denote an" - & " access type"); - end if; - when others => - if Vhdl_Std >= Vhdl_08 - and then not Get_Signal_Type_Flag (Return_Type) - and then Get_Pure_Flag (Subprg) - then - Error_Msg_Sem_Relaxed - (Subprg, Warnid_Pure, - "result subtype of a pure function cannot have" - & " access subelements"); - end if; - end case; - - when Iir_Kind_Interface_Procedure_Declaration => - Sem_Interface_Chain - (Interface_Chain, Procedure_Parameter_Interface_List); - - when Iir_Kind_Procedure_Declaration => - Sem_Interface_Chain - (Interface_Chain, Procedure_Parameter_Interface_List); - - -- Unless the body is analyzed, the procedure purity is unknown. - Set_Purity_State (Subprg, Unknown); - -- Check if the procedure is passive. - Set_Passive_Flag (Subprg, True); - Set_All_Sensitized_State (Subprg, Unknown); - declare - Inter : Iir; - begin - Inter := Interface_Chain; - while Inter /= Null_Iir loop - if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration - and then Get_Mode (Inter) /= Iir_In_Mode - then - -- There is a driver for this signal interface. - Set_Passive_Flag (Subprg, False); - exit; - end if; - Inter := Get_Chain (Inter); - end loop; - end; - - -- Mark the procedure as suspendable, unless in a std packages. - -- This is a minor optimization. - if Get_Library (Get_Design_File (Get_Current_Design_Unit)) - /= Libraries.Std_Library - then - Set_Suspend_Flag (Subprg, True); - end if; - when others => - Error_Kind ("sem_subprogram_declaration", Subprg); - end case; - - Check_Operator_Requirements (Get_Identifier (Subprg), Subprg); - - Sem_Utils.Compute_Subprogram_Hash (Subprg); - - -- The specification has been analyzed, close the declarative region - -- now. - Close_Declarative_Region; - end Sem_Subprogram_Specification; - - -- LRM 2.1 Subprogram Declarations. - procedure Sem_Subprogram_Declaration (Subprg: Iir) - is - Parent : constant Iir := Get_Parent (Subprg); - Spec: Iir; - Subprg_Body : Iir; - begin - -- Set depth. - case Get_Kind (Parent) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - raise Internal_Error; - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body => - Set_Subprogram_Depth - (Subprg, - Get_Subprogram_Depth - (Get_Subprogram_Specification (Parent)) + 1); - when others => - -- FIXME: protected type ? - Set_Subprogram_Depth (Subprg, 0); - end case; - - Sem_Subprogram_Specification (Subprg); - - -- Look if there is an associated body (the next node). - Subprg_Body := Get_Chain (Subprg); - if Subprg_Body /= Null_Iir - and then Get_Kind (Subprg_Body) in Iir_Kinds_Subprogram_Body - then - Spec := Find_Subprogram_Specification (Subprg); - else - Spec := Null_Iir; - end if; - - if Spec /= Null_Iir then - -- SUBPRG is the body of the specification SPEC. - if Get_Subprogram_Body (Spec) /= Null_Iir then - Error_Msg_Sem (+Subprg, "%n body already defined at %l", - (+Spec, +Get_Subprogram_Body (Spec))); - -- Kill warning. - Set_Use_Flag (Subprg, True); - else - Check_Conformance_Rules (Subprg, Spec); - Xref_Body (Subprg, Spec); - Set_Subprogram_Body (Subprg, Subprg_Body); - Set_Subprogram_Specification (Subprg_Body, Spec); - Set_Subprogram_Body (Spec, Subprg_Body); - end if; - else - -- Forward declaration or specification followed by body. - Set_Subprogram_Overload_Number (Subprg); - Sem_Scopes.Add_Name (Subprg); - Name_Visible (Subprg); - Xref_Decl (Subprg); - end if; - end Sem_Subprogram_Declaration; - - procedure Add_Analysis_Checks_List (El : Iir) - is - Design : constant Iir := Get_Current_Design_Unit; - List : Iir_List; - begin - List := Get_Analysis_Checks_List (Design); - if List = Null_Iir_List then - List := Create_Iir_List; - Set_Analysis_Checks_List (Design, List); - end if; - Add_Element (List, El); - end Add_Analysis_Checks_List; - - procedure Sem_Subprogram_Body (Subprg : Iir) - is - Spec : constant Iir := Get_Subprogram_Specification (Subprg); - Warn_Hide_Enabled : constant Boolean := Is_Warning_Enabled (Warnid_Hide); - El : Iir; - begin - Set_Impure_Depth (Subprg, Iir_Depth_Pure); - - -- LRM 10.1 Declarative regions - -- 3. A subprogram declaration, together with the corresponding - -- subprogram body. - Open_Declarative_Region; - Set_Is_Within_Flag (Spec, True); - - -- Add the interface names into the current declarative region. - -- (Do not emit warnings for hiding, they were already emitted during - -- analysis of the subprogram spec). - Enable_Warning (Warnid_Hide, False); - El := Get_Interface_Declaration_Chain (Spec); - while El /= Null_Iir loop - Add_Name (El, Get_Identifier (El), False); - if Get_Kind (El) = Iir_Kind_Interface_Signal_Declaration then - Set_Has_Active_Flag (El, False); - end if; - El := Get_Chain (El); - end loop; - Enable_Warning (Warnid_Hide, Warn_Hide_Enabled); - - Sem_Sequential_Statements (Spec, Subprg); - - Set_Is_Within_Flag (Spec, False); - Close_Declarative_Region; - - case Get_Kind (Spec) is - when Iir_Kind_Procedure_Declaration => - if Get_Suspend_Flag (Subprg) - and then not Get_Suspend_Flag (Spec) - then - -- Incoherence: procedures declared in std library are not - -- expected to suspend. This is an internal check. - Error_Msg_Sem (+Subprg, "unexpected suspendable procedure"); - end if; - - -- Update purity state of procedure if there are no callees. - case Get_Purity_State (Spec) is - when Pure - | Maybe_Impure => - -- We can't know this yet. - raise Internal_Error; - when Impure => - null; - when Unknown => - if Get_Callees_List (Subprg) = Null_Iir_List then - -- Since there are no callees, purity state can - -- be updated. - if Get_Impure_Depth (Subprg) = Iir_Depth_Pure then - Set_Purity_State (Spec, Pure); - else - Set_Purity_State (Spec, Maybe_Impure); - end if; - end if; - end case; - - -- Update wait state if the state of all callees is known. - if Get_Wait_State (Spec) = Unknown then - declare - Callees : constant Iir_List := Get_Callees_List (Subprg); - Callees_It : List_Iterator; - Callee : Iir; - State : Tri_State_Type; - begin - -- Per default, has no wait. - Set_Wait_State (Spec, False); - Callees_It := List_Iterate_Safe (Callees); - while Is_Valid (Callees_It) loop - Callee := Get_Element (Callees_It); - case Get_Kind (Callee) is - when Iir_Kind_Function_Declaration => - null; - when Iir_Kind_Procedure_Declaration => - State := Get_Wait_State (Callee); - case State is - when False => - null; - when Unknown => - -- Yet unknown, but can be TRUE. - Set_Wait_State (Spec, Unknown); - when True => - -- Can this happen ? - raise Internal_Error; - --Set_Wait_State (Spec, True); - --exit; - end case; - when others => - Error_Kind ("sem_subprogram_body(2)", Callee); - end case; - Next (Callees_It); - end loop; - end; - end if; - - -- Do not add to Analysis_Checks_List as procedures can't - -- generate purity/wait/all-sensitized errors by themselves. - - when Iir_Kind_Function_Declaration => - if Get_Callees_List (Subprg) /= Null_Iir_List then - -- Purity calls to be checked later. - -- No wait statements in procedures called. - Add_Analysis_Checks_List (Spec); - end if; - when others => - Error_Kind ("sem_subprogram_body", Spec); - end case; - - -- Set All_Sensitized_State in trivial cases. - if Get_All_Sensitized_State (Spec) = Unknown - and then Get_Callees_List (Subprg) = Null_Iir_List - then - Set_All_Sensitized_State (Spec, No_Signal); - end if; - end Sem_Subprogram_Body; - - -- Return the subprogram body of SPEC. If there is no body, and if SPEC - -- is an instance, returns the body of the generic specification but only - -- if known. - function Get_Subprogram_Body_Or_Generic (Spec : Iir) return Iir - is - Bod : Iir; - Orig : Iir; - begin - Bod := Get_Subprogram_Body (Spec); - - if Bod /= Null_Iir then - return Bod; - end if; - - Orig := Sem_Inst.Get_Origin (Spec); - if Orig = Null_Iir then - return Null_Iir; - end if; - - return Get_Subprogram_Body (Orig); - end Get_Subprogram_Body_Or_Generic; - - -- Status of Update_And_Check_Pure_Wait. - type Update_Pure_Status is - ( - -- The purity/wait/all-sensitized are computed and known. - Update_Pure_Done, - -- A missing body prevents from computing the purity/wait/all-sensitized - Update_Pure_Missing, - -- Purity/wait/all-sensitized is unknown (recursion). - Update_Pure_Unknown - ); - - function Update_And_Check_Pure_Wait (Subprg : Iir) return Update_Pure_Status - is - procedure Error_Wait (Caller : Iir; Callee : Iir) is - begin - Error_Msg_Sem - (+Caller, "%n must not contain wait statement, but calls", - (1 => +Caller), Cont => True); - Error_Msg_Sem - (+Callee, "%n which has (indirectly) a wait statement", +Callee); - end Error_Wait; - - -- Kind of subprg. - type Caller_Kind is (K_Function, K_Process, K_Procedure); - Kind : Caller_Kind; - - Callees_List : Iir_List; - Callees_List_Holder : Iir; - Callees_It : List_Iterator; - Callee : Iir; - Callee_Bod : Iir; - Subprg_Depth : Iir_Int32; - Subprg_Bod : Iir; - -- Current purity depth of SUBPRG. - Depth : Iir_Int32; - Depth_Callee : Iir_Int32; - Has_Wait_Errors : Boolean := False; - New_List : Iir_List; - Res, Res1 : Update_Pure_Status; - begin - case Get_Kind (Subprg) is - when Iir_Kind_Function_Declaration => - Kind := K_Function; - Subprg_Bod := Get_Subprogram_Body_Or_Generic (Subprg); - if Subprg_Bod = Null_Iir then - return Update_Pure_Missing; - end if; - Subprg_Depth := Get_Subprogram_Depth (Subprg); - Callees_List_Holder := Subprg_Bod; - if Get_Pure_Flag (Subprg) then - Depth := Iir_Depth_Pure; - else - Depth := Iir_Depth_Impure; - end if; - - when Iir_Kind_Procedure_Declaration => - Kind := K_Procedure; - Subprg_Bod := Get_Subprogram_Body_Or_Generic (Subprg); - if Subprg_Bod = Null_Iir then - return Update_Pure_Missing; - end if; - if Get_Purity_State (Subprg) = Impure - and then Get_Wait_State (Subprg) /= Unknown - and then Get_All_Sensitized_State (Subprg) /= Unknown - then - -- No need to go further. - if Get_All_Sensitized_State (Subprg) = No_Signal - or else Vhdl_Std < Vhdl_08 - then - Callees_List := Get_Callees_List (Subprg_Bod); - Destroy_Iir_List (Callees_List); - Set_Callees_List (Subprg_Bod, Null_Iir_List); - end if; - return Update_Pure_Done; - end if; - Subprg_Depth := Get_Subprogram_Depth (Subprg); - Depth := Get_Impure_Depth (Subprg_Bod); - Callees_List_Holder := Subprg_Bod; - - when Iir_Kind_Sensitized_Process_Statement => - Kind := K_Process; - Subprg_Bod := Null_Iir; - Subprg_Depth := Iir_Depth_Top; - Depth := Iir_Depth_Impure; - Callees_List_Holder := Subprg; - - when others => - Error_Kind ("update_and_check_pure_wait(1)", Subprg); - end case; - - -- If the subprogram has no callee list, there is nothing to do. - Callees_List := Get_Callees_List (Callees_List_Holder); - if Callees_List = Null_Iir_List then - -- There are two reasons why a callees_list is null: - -- * either because SUBPRG does not call any procedure - -- in this case, the status are already known and we should have - -- returned in the above case. - -- * or because of a recursion - -- in this case the status are still unknown here. - return Update_Pure_Unknown; - end if; - - -- By default we don't know the status. - Res := Update_Pure_Unknown; - - -- This subprogram is being considered. - -- To avoid infinite loop, suppress its callees list. - Set_Callees_List (Callees_List_Holder, Null_Iir_List); - - -- First loop: check without recursion. - -- Second loop: recurse if necessary. - for J in 0 .. 1 loop - New_List := Create_Iir_List; - Callees_It := List_Iterate (Callees_List); - while Is_Valid (Callees_It) loop - Callee := Get_Element (Callees_It); - - -- Note: - -- Pure functions should not be in the list. - -- Impure functions must have directly set Purity_State. - - -- The body of subprograms may not be set for instances. - -- Use the body from the generic (if any). - -- This is meaningful for non macro-expanded package interface, - -- because there is no associated body and because the call - -- tree is known (if there were an interface subprogram, it - -- would have been macro-expanded). - -- Do not set the body, as it would trigger an assert during - -- macro-expansion (maybe this shouldn't be called for macro - -- expanded packages). - Callee_Bod := Get_Subprogram_Body_Or_Generic (Callee); - - -- Check pure. - if Callee_Bod = Null_Iir then - -- No body yet for the subprogram called. - -- Nothing can be extracted from it, postpone the checks until - -- elaboration. - Res := Update_Pure_Missing; - else - -- Second loop: recurse if a state is not known. - if J = 1 - and then - ((Get_Kind (Callee) = Iir_Kind_Procedure_Declaration - and then Get_Purity_State (Callee) = Unknown) - or else Get_Wait_State (Callee) = Unknown - or else Get_All_Sensitized_State (Callee) = Unknown) - then - Res1 := Update_And_Check_Pure_Wait (Callee); - if Res1 = Update_Pure_Missing then - Res := Update_Pure_Missing; - end if; - end if; - - -- Check purity only if the subprogram is not impure. - if Depth /= Iir_Depth_Impure then - Depth_Callee := Get_Impure_Depth (Callee_Bod); - - -- Check purity depth. - if Depth_Callee < Subprg_Depth then - -- The call is an impure call because it calls an outer - -- subprogram (or an impure subprogram). - -- FIXME: check the compare. - Depth_Callee := Iir_Depth_Impure; - if Kind = K_Function then - -- FIXME: report call location - Error_Pure (Elaboration, Subprg_Bod, Callee, Null_Iir); - end if; - end if; - - -- Update purity depth. - if Depth_Callee < Depth then - Depth := Depth_Callee; - if Kind = K_Procedure then - -- Update for recursivity. - Set_Impure_Depth (Subprg_Bod, Depth); - if Depth = Iir_Depth_Impure then - Set_Purity_State (Subprg, Impure); - end if; - end if; - end if; - end if; - end if; - - -- Check wait. - if Has_Wait_Errors = False - and then Get_Wait_State (Callee) = True - then - if Kind = K_Procedure then - Set_Wait_State (Subprg, True); - else - Error_Wait (Subprg, Callee); - Has_Wait_Errors := True; - end if; - end if; - - if Get_All_Sensitized_State (Callee) = Invalid_Signal then - case Kind is - when K_Function | K_Procedure => - Set_All_Sensitized_State (Subprg, Invalid_Signal); - when K_Process => - -- LRM08 11.3 - -- - -- It is an error if a process statement with the - -- reserved word ALL as its process sensitivity list - -- is the parent of a subprogram declared in a design - -- unit other than that containing the process statement - -- and the subprogram reads an explicitly declared - -- signal that is not a formal signal parameter or - -- member of a formal signal parameter of the - -- subprogram or of any of its parents. Similarly, - -- it is an error if such subprogram reads an implicit - -- signal whose explicit ancestor is not a formal signal - -- parameter or member of a formal parameter of - -- the subprogram or of any of its parents. - Error_Msg_Sem - (+Subprg, "all-sensitized %n can't call %n", - (+Subprg, +Callee), Cont => True); - Error_Msg_Sem - (+Subprg, - " (as this subprogram reads (indirectly) a signal)"); - end case; - end if; - - -- Keep in list. - if Callee_Bod = Null_Iir - or else - (Get_Kind (Callee) = Iir_Kind_Procedure_Declaration - and then Get_Purity_State (Callee) = Unknown - and then Depth /= Iir_Depth_Impure) - or else - (Get_Wait_State (Callee) = Unknown - and then (Kind /= K_Procedure - or else Get_Wait_State (Subprg) = Unknown)) - or else - (Vhdl_Std >= Vhdl_08 - and then - (Get_All_Sensitized_State (Callee) = Unknown - or else Get_All_Sensitized_State (Callee) = Read_Signal)) - then - Append_Element (New_List, Callee); - end if; - Next (Callees_It); - end loop; - - -- End of callee loop. - if Is_Empty (New_List) then - Destroy_Iir_List (Callees_List); - Callees_List := Null_Iir_List; - Destroy_Iir_List (New_List); - if Kind = K_Procedure then - if Get_Purity_State (Subprg) = Unknown then - Set_Purity_State (Subprg, Maybe_Impure); - end if; - if Get_Wait_State (Subprg) = Unknown then - Set_Wait_State (Subprg, False); - end if; - end if; - if Kind = K_Procedure or Kind = K_Function then - if Get_All_Sensitized_State (Subprg) = Unknown then - Set_All_Sensitized_State (Subprg, No_Signal); - end if; - end if; - Res := Update_Pure_Done; - exit; - else - Destroy_Iir_List (Callees_List); - Callees_List := New_List; - end if; - end loop; - - Set_Callees_List (Callees_List_Holder, New_List); - - return Res; - end Update_And_Check_Pure_Wait; - - -- Check pure/wait/all-sensitized issues for SUBPRG (subprogram or - -- process). Return False if the analysis is incomplete (and must - -- be deferred). - function Root_Update_And_Check_Pure_Wait (Subprg : Iir) return Boolean - is - Res : Update_Pure_Status; - begin - Res := Update_And_Check_Pure_Wait (Subprg); - case Res is - when Update_Pure_Done => - return True; - when Update_Pure_Missing => - return False; - when Update_Pure_Unknown => - -- The purity/wait is unknown, but all callee were walked. - -- This means there are recursive calls but without violations. - if Get_Kind (Subprg) = Iir_Kind_Procedure_Declaration then - if Get_Purity_State (Subprg) = Unknown then - Set_Purity_State (Subprg, Maybe_Impure); - end if; - if Get_Wait_State (Subprg) = Unknown then - Set_Wait_State (Subprg, False); - end if; - end if; - if Get_Kind (Subprg) in Iir_Kinds_Subprogram_Declaration then - if Get_All_Sensitized_State (Subprg) = Unknown then - Set_All_Sensitized_State (Subprg, No_Signal); - end if; - end if; - return True; - end case; - end Root_Update_And_Check_Pure_Wait; - - procedure Sem_Analysis_Checks_List (Unit : Iir_Design_Unit; - Emit_Warnings : Boolean) - is - List : Iir_List; - El : Iir; - It : List_Iterator; - Keep : Boolean; - New_List : Iir_List; - begin - List := Get_Analysis_Checks_List (Unit); - if List = Null_Iir_List then - -- Return now if there is nothing to check. - return; - end if; - - New_List := Create_Iir_List; - It := List_Iterate (List); - while Is_Valid (It) loop - El := Get_Element (It); - Keep := False; - case Get_Kind (El) is - when Iir_Kind_Function_Declaration => - -- FIXME: remove from list if fully tested ? - if not Root_Update_And_Check_Pure_Wait (El) then - Keep := True; - if Emit_Warnings then - declare - Bod : constant Iir := Get_Subprogram_Body (El); - Callees : constant Iir_List := Get_Callees_List (Bod); - pragma Assert (Callees /= Null_Iir_List); - Callee : constant Iir := Get_First_Element (Callees); - begin - Warning_Msg_Sem - (Warnid_Delayed_Checks, +El, - "can't assert that all calls in %n" - & " are pure or have not wait;" - & " will be checked at elaboration", - +El, Cont => True); - -- FIXME: could improve this message by displaying - -- the chain of calls until the first subprograms in - -- unknown state. - Warning_Msg_Sem - (Warnid_Delayed_Checks, +Callee, - "(first such call is to %n)", +Callee); - end; - end if; - end if; - when Iir_Kind_Sensitized_Process_Statement => - if not Root_Update_And_Check_Pure_Wait (El) then - Keep := True; - if Emit_Warnings then - Warning_Msg_Sem - (Warnid_Delayed_Checks, +El, - "can't assert that %n has no wait; " - & "will be checked at elaboration", +El); - end if; - end if; - when others => - Error_Kind ("sem_analysis_checks_list", El); - end case; - if Keep then - Append_Element (New_List, El); - end if; - Next (It); - end loop; - if Is_Empty (New_List) then - Destroy_Iir_List (New_List); - New_List := Null_Iir_List; -- OK, redundant but clearer. - end if; - Destroy_Iir_List (List); - Set_Analysis_Checks_List (Unit, New_List); - end Sem_Analysis_Checks_List; - - -- Return true if package declaration DECL needs a body. - -- Ie, it contains subprogram specification or deferred constants. - function Package_Need_Body_P (Decl: Iir_Package_Declaration) - return Boolean - is - El: Iir; - Def : Iir; - begin - El := Get_Declaration_Chain (Decl); - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - if not Is_Implicit_Subprogram (El) then - return True; - end if; - when Iir_Kind_Constant_Declaration => - if Get_Default_Value (El) = Null_Iir then - return True; - end if; - when Iir_Kind_Variable_Declaration - | Iir_Kind_File_Declaration - | Iir_Kind_Signal_Declaration - | Iir_Kind_Object_Alias_Declaration - | Iir_Kind_Non_Object_Alias_Declaration - | Iir_Kind_Group_Template_Declaration - | Iir_Kind_Group_Declaration => - null; - when Iir_Kind_Type_Declaration => - Def := Get_Type_Definition (El); - if Def /= Null_Iir - and then Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration - then - return True; - end if; - when Iir_Kind_Anonymous_Type_Declaration - | Iir_Kind_Subtype_Declaration => - null; - when Iir_Kind_Attribute_Declaration - | Iir_Kind_Attribute_Specification => - null; - when Iir_Kind_Disconnection_Specification => - null; - when Iir_Kind_Use_Clause => - null; - when Iir_Kind_Component_Declaration => - null; - when Iir_Kind_Protected_Type_Body => - null; - when Iir_Kind_Package_Declaration => - -- LRM08 4.8 Package bodies - -- A package body that is not a library unit shall appear - -- immediately within the same declarative region as the - -- corresponding package declaration and textually subsequent - -- to that package declaration. - if Get_Need_Body (El) then - return True; - end if; - when Iir_Kind_Package_Body => - null; - when Iir_Kind_Package_Instantiation_Declaration => - null; - when Iir_Kind_Nature_Declaration - | Iir_Kind_Subnature_Declaration => - null; - when Iir_Kind_Terminal_Declaration => - null; - when others => - pragma Assert (Flags.Flag_Force_Analysis); - null; - end case; - El := Get_Chain (El); - end loop; - return False; - end Package_Need_Body_P; - - -- Return true if package declaration DECL contains at least one package - -- instantiation that needs a body. - function Package_Need_Instance_Bodies_P (Decl: Iir_Package_Declaration) - return Boolean - is - El: Iir; - begin - El := Get_Declaration_Chain (Decl); - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Package_Instantiation_Declaration => - declare - Pkg : constant Iir := Get_Uninstantiated_Package_Decl (El); - begin - if not Is_Error (Pkg) - and then Get_Need_Body (Pkg) - then - return True; - end if; - end; - when others => - null; - end case; - El := Get_Chain (El); - end loop; - return False; - end Package_Need_Instance_Bodies_P; - - -- Return true if uninstantiated pckage DECL must be macro-expanded (at - -- least one interface type). - function Is_Package_Macro_Expanded - (Decl : Iir_Package_Declaration) return Boolean - is - Header : constant Iir := Get_Package_Header (Decl); - Inter : Iir; - begin - Inter := Get_Generic_Chain (Header); - while Is_Valid (Inter) loop - case Iir_Kinds_Interface_Declaration (Get_Kind (Inter)) is - when Iir_Kinds_Interface_Object_Declaration => - null; - when Iir_Kind_Interface_Type_Declaration => - return True; - when Iir_Kind_Interface_Package_Declaration => - declare - Pkg : constant Iir := - Get_Uninstantiated_Package_Decl (Inter); - begin - if Get_Macro_Expanded_Flag (Pkg) then - return True; - end if; - end; - when Iir_Kinds_Interface_Subprogram_Declaration => - return True; - end case; - Inter := Get_Chain (Inter); - end loop; - return False; - end Is_Package_Macro_Expanded; - - -- LRM 2.5 Package Declarations. - procedure Sem_Package_Declaration (Pkg : Iir_Package_Declaration) - is - Unit : constant Iir_Design_Unit := Get_Design_Unit (Pkg); - Header : constant Iir := Get_Package_Header (Pkg); - Implicit : Implicit_Signal_Declaration_Type; - begin - Sem_Scopes.Add_Name (Pkg); - Set_Visible_Flag (Pkg, True); - Xref_Decl (Pkg); - - Set_Is_Within_Flag (Pkg, True); - - -- Identify IEEE.Std_Logic_1164 for VHDL08. - if Get_Identifier (Pkg) = Std_Names.Name_Std_Logic_1164 - and then (Get_Identifier (Get_Library (Get_Design_File (Unit))) - = Std_Names.Name_Ieee) - then - Ieee.Std_Logic_1164.Std_Logic_1164_Pkg := Pkg; - end if; - - -- LRM93 10.1 Declarative Region - -- 4. A package declaration, together with the corresponding - -- body (if any). - Open_Declarative_Region; - - Push_Signals_Declarative_Part (Implicit, Pkg); - - if Header /= Null_Iir then - declare - Generic_Chain : constant Iir := Get_Generic_Chain (Header); - Generic_Map : constant Iir := - Get_Generic_Map_Aspect_Chain (Header); - Assoc_El : Iir; - Inter_El : Iir; - Inter : Iir; - begin - Sem_Interface_Chain (Generic_Chain, Generic_Interface_List); - - if Generic_Map /= Null_Iir then - -- Generic-mapped packages are not macro-expanded. - Set_Macro_Expanded_Flag (Pkg, False); - - if Sem_Generic_Association_Chain (Header, Header) then - -- For generic-mapped packages, use the actual type for - -- interface type. - Assoc_El := Get_Generic_Map_Aspect_Chain (Header); - Inter_El := Generic_Chain; - while Is_Valid (Assoc_El) loop - if Get_Kind (Assoc_El) = Iir_Kind_Association_Element_Type - then - Inter := - Get_Association_Interface (Assoc_El, Inter_El); - Sem_Inst.Substitute_On_Chain - (Generic_Chain, - Get_Type (Inter), - Get_Type (Get_Named_Entity - (Get_Actual (Assoc_El)))); - end if; - Next_Association_Interface (Assoc_El, Inter_El); - end loop; - end if; - else - -- Uninstantiated package. Maybe macro expanded. - Set_Macro_Expanded_Flag - (Pkg, Is_Package_Macro_Expanded (Pkg)); - end if; - end; - else - -- Simple packages are never expanded. - Set_Macro_Expanded_Flag (Pkg, False); - end if; - - Sem_Declaration_Chain (Pkg); - -- GHDL: subprogram bodies appear in package body. - - Pop_Signals_Declarative_Part (Implicit); - Close_Declarative_Region; - Set_Is_Within_Flag (Pkg, False); - - Set_Need_Body (Pkg, Package_Need_Body_P (Pkg)); - - if Vhdl_Std >= Vhdl_08 then - Set_Need_Instance_Bodies - (Pkg, Package_Need_Instance_Bodies_P (Pkg)); - end if; - end Sem_Package_Declaration; - - -- LRM 2.6 Package Bodies. - procedure Sem_Package_Body (Decl : Iir) - is - Package_Ident : constant Name_Id := Get_Identifier (Decl); - Package_Decl : Iir; - begin - -- First, find the package declaration. - if not Is_Nested_Package (Decl) then - declare - Design_Unit: Iir_Design_Unit; - begin - Design_Unit := Load_Primary_Unit - (Get_Library (Get_Design_File (Get_Current_Design_Unit)), - Package_Ident, Decl); - if Design_Unit = Null_Iir then - Error_Msg_Sem - (+Decl, "package %i was not analysed", +Package_Ident); - return; - end if; - - Package_Decl := Get_Library_Unit (Design_Unit); - if Get_Kind (Package_Decl) /= Iir_Kind_Package_Declaration then - Error_Msg_Sem - (+Decl, "primary unit %i is not a package", +Package_Ident); - return; - end if; - - -- LRM08 13.5 Order of analysis - -- In each case, the second unit depends on the first unit - Add_Dependence (Design_Unit); - - Add_Name (Design_Unit); - - -- Add the context clauses from the primary unit. - Add_Context_Clauses (Design_Unit); - end; - else - declare - Interp : Name_Interpretation_Type; - begin - Interp := Get_Interpretation (Get_Identifier (Decl)); - if not Valid_Interpretation (Interp) - or else not Is_In_Current_Declarative_Region (Interp) - or else Is_Potentially_Visible (Interp) - then - Error_Msg_Sem - (+Decl, "no corresponding package declaration for %i", - +Package_Ident); - return; - end if; - - Package_Decl := Get_Declaration (Interp); - if Get_Kind (Package_Decl) /= Iir_Kind_Package_Declaration then - Error_Msg_Sem - (+Decl, "declaration %i is not a package", +Package_Ident); - return; - end if; - end; - end if; - - -- Emit a warning is a body is not necessary. - if not Get_Need_Body (Package_Decl) then - Warning_Msg_Sem (Warnid_Body, +Decl, - "%n does not require a body", +Package_Decl); - end if; - - Set_Package (Decl, Package_Decl); - Xref_Body (Decl, Package_Decl); - Set_Package_Body (Package_Decl, Decl); - Set_Is_Within_Flag (Package_Decl, True); - - -- LRM93 10.1 Declarative Region - -- 4. A package declaration, together with the corresponding - -- body (if any). - Open_Declarative_Region; - - Sem_Scopes.Add_Package_Declarations (Package_Decl); - - Sem_Declaration_Chain (Decl); - Check_Full_Declaration (Decl, Decl); - Check_Full_Declaration (Package_Decl, Decl); - - Close_Declarative_Region; - Set_Is_Within_Flag (Package_Decl, False); - end Sem_Package_Body; - - function Sem_Uninstantiated_Package_Name (Decl : Iir) return Iir - is - Name : Iir; - Pkg : Iir; - begin - Name := Sem_Denoting_Name (Get_Uninstantiated_Package_Name (Decl)); - Set_Uninstantiated_Package_Name (Decl, Name); - Pkg := Get_Named_Entity (Name); - if Is_Error (Pkg) then - null; - elsif Get_Kind (Pkg) /= Iir_Kind_Package_Declaration then - Error_Class_Match (Name, "package"); - Pkg := Create_Error (Pkg); - elsif not Is_Uninstantiated_Package (Pkg) then - Error_Msg_Sem (+Name, "%n is not an uninstantiated package", +Pkg); - Pkg := Create_Error (Pkg); - end if; - - Set_Uninstantiated_Package_Decl (Decl, Pkg); - - return Pkg; - end Sem_Uninstantiated_Package_Name; - - -- LRM08 4.9 Package Instantiation Declaration - procedure Sem_Package_Instantiation_Declaration (Decl : Iir) - is - Hdr : Iir; - Pkg : Iir; - Bod : Iir_Design_Unit; - begin - Sem_Scopes.Add_Name (Decl); - Set_Visible_Flag (Decl, True); - Xref_Decl (Decl); - - -- LRM08 4.9 - -- The uninstantiated package name shall denote an uninstantiated - -- package declared in a package declaration. - Pkg := Sem_Uninstantiated_Package_Name (Decl); - if Pkg = Null_Iir or Is_Error (Pkg) then - -- What could be done ? - return; - end if; - - -- LRM08 4.9 - -- The generic map aspect, if present, optionally associates a single - -- actual with each formal generic (or member thereof) in the - -- corresponding package declaration. Each formal generic (or member - -- thereof) shall be associated at most once. - - -- GHDL: the generics are first instantiated (ie copied) and then - -- the actuals are associated with the instantiated formal. - -- FIXME: do it in Instantiate_Package_Declaration ? - Hdr := Get_Package_Header (Pkg); - if not Sem_Generic_Association_Chain (Hdr, Decl) then - -- FIXME: stop analysis here ? - return; - end if; - - -- FIXME: unless the parent is a package declaration library unit, the - -- design unit depends on the body. - if Get_Need_Body (Pkg) and then not Is_Nested_Package (Pkg) then - Bod := Get_Package_Body (Pkg); - if Is_Null (Bod) then - Bod := Load_Secondary_Unit - (Get_Design_Unit (Pkg), Null_Identifier, Decl); - else - Bod := Get_Design_Unit (Bod); - end if; - if Is_Null (Bod) then - Error_Msg_Sem (+Decl, "cannot find package body of %n", +Pkg); - else - Add_Dependence (Bod); - end if; - end if; - - -- Instantiate the declaration after analyse of the body. So that - -- the use_flag on the declaration can be propagated to the instance. - Sem_Inst.Instantiate_Package_Declaration (Decl, Pkg); - end Sem_Package_Instantiation_Declaration; - - -- LRM 10.4 Use Clauses. - procedure Sem_Use_Clause_Name (Clause : Iir) - is - Name: Iir; - Prefix: Iir; - Name_Prefix : Iir; - begin - -- LRM93 10.4 - -- A use clause achieves direct visibility of declarations that are - -- visible by selection. - -- Each selected name is a use clause identifies one or more - -- declarations that will potentialy become directly visible. - - Name := Get_Selected_Name (Clause); - if Name = Null_Iir then - pragma Assert (Flags.Flag_Force_Analysis); - return; - end if; - - case Get_Kind (Name) is - when Iir_Kind_Selected_By_All_Name - | Iir_Kind_Selected_Name => - Name_Prefix := Get_Prefix (Name); - when others => - Error_Msg_Sem (+Name, "use clause allows only selected name"); - Set_Selected_Name (Clause, Create_Error_Name (Name)); - return; - end case; - - case Get_Kind (Name_Prefix) is - when Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name => - null; - when others => - Error_Msg_Sem - (+Name_Prefix, - "use clause prefix must be a name or a selected name"); - Set_Selected_Name (Clause, Create_Error_Name (Name)); - return; - end case; - - Name_Prefix := Sem_Denoting_Name (Name_Prefix); - Set_Prefix (Name, Name_Prefix); - Prefix := Get_Named_Entity (Name_Prefix); - if Is_Error (Prefix) then - Set_Selected_Name (Clause, Create_Error_Name (Name)); - return; - end if; - - -- LRM 10.4 Use Clauses - -- - -- If the suffix of the selected name is [...], then the - -- selected name identifies only the declaration(s) of that - -- [...] contained within the package or library denoted by - -- the prefix of the selected name. - -- - -- If the suffix is the reserved word ALL, then the selected name - -- identifies all declarations that are contained within the package - -- or library denoted by the prefix of the selected name. - -- - -- GHDL: therefore, the suffix must be either a package or a library. - case Get_Kind (Prefix) is - when Iir_Kind_Library_Declaration => - null; - when Iir_Kind_Package_Instantiation_Declaration - | Iir_Kind_Interface_Package_Declaration => - null; - when Iir_Kind_Package_Declaration => - -- LRM08 12.4 Use clauses - -- It is an error if the prefix of a selected name in a use - -- clause denotes an uninstantiated package. - if Is_Uninstantiated_Package (Prefix) then - Error_Msg_Sem - (+Name_Prefix, - "use of uninstantiated package is not allowed"); - Set_Prefix (Name, Create_Error_Name (Name_Prefix)); - return; - end if; - when others => - Error_Msg_Sem - (+Prefix, "prefix must designate a package or a library"); - Set_Prefix (Name, Create_Error_Name (Name_Prefix)); - return; - end case; - - case Get_Kind (Name) is - when Iir_Kind_Selected_Name => - Sem_Name (Name, True); - case Get_Kind (Get_Named_Entity (Name)) is - when Iir_Kind_Error => - -- Continue in case of error. - null; - when Iir_Kind_Overload_List => - -- Analyze is correct as is. - null; - when others => - Name := Finish_Sem_Name (Name); - Set_Selected_Name (Clause, Name); - end case; - when Iir_Kind_Selected_By_All_Name => - null; - when others => - raise Internal_Error; - end case; - end Sem_Use_Clause_Name; - - -- LRM 10.4 Use Clauses. - procedure Sem_Use_Clause (Clauses: Iir_Use_Clause) - is - Clause : Iir_Use_Clause; - begin - Clause := Clauses; - loop - Sem_Use_Clause_Name (Clause); - - Clause := Get_Use_Clause_Chain (Clause); - exit when Clause = Null_Iir; - end loop; - - -- LRM 10.4 - -- For each use clause, there is a certain region of text called the - -- scope of the use clause. This region starts immediatly after the - -- use clause. - Sem_Scopes.Add_Use_Clause (Clauses); - end Sem_Use_Clause; - - -- LRM 11.2 Design Libraries. - procedure Sem_Library_Clause (Decl: Iir_Library_Clause) - is - Ident : Name_Id; - Lib: Iir; - begin - -- GHDL: 'redeclaration' is handled in sem_scopes. - - Ident := Get_Identifier (Decl); - Lib := Libraries.Get_Library (Ident, Get_Location (Decl)); - if Lib = Null_Iir then - Error_Msg_Sem (+Decl, "no resource library %i", +Ident); - else - Set_Library_Declaration (Decl, Lib); - Sem_Scopes.Add_Name (Lib, Ident, False); - Set_Visible_Flag (Lib, True); - Xref_Ref (Decl, Lib); - end if; - end Sem_Library_Clause; - - -- LRM08 13.4 Context clauses. - procedure Sem_One_Context_Reference (Ref : Iir) - is - Name : Iir; - Ent : Iir; - begin - Name := Get_Selected_Name (Ref); - if Get_Kind (Name) /= Iir_Kind_Selected_Name then - Error_Msg_Sem - (+Name, "context reference only allows selected names"); - return; - end if; - - Name := Sem_Denoting_Name (Name); - Set_Selected_Name (Ref, Name); - Ent := Get_Named_Entity (Name); - if Is_Error (Ent) then - return; - end if; - - -- LRM08 13.4 Context clauses - -- It is an error if a selected name in a context reference does not - -- denote a context declaration. - if Get_Kind (Ent) /= Iir_Kind_Context_Declaration then - Error_Msg_Sem (+Name, "name must denote a context declaration"); - Set_Named_Entity (Name, Null_Iir); - return; - end if; - end Sem_One_Context_Reference; - - -- LRM08 13.4 Context clauses. - procedure Sem_Context_Reference (Ctxt : Iir) - is - Ref : Iir; - begin - Ref := Ctxt; - loop - Sem_One_Context_Reference (Ref); - Ref := Get_Context_Reference_Chain (Ref); - exit when Ref = Null_Iir; - end loop; - - -- FIXME: must be done clause after clause ? - Add_Context_Reference (Ctxt); - end Sem_Context_Reference; - - -- LRM 11.3 Context Clauses. - procedure Sem_Context_Clauses (Unit: Iir) - is - El: Iir; - begin - El := Get_Context_Items (Unit); - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Use_Clause => - Sem_Use_Clause (El); - when Iir_Kind_Library_Clause => - Sem_Library_Clause (El); - when Iir_Kind_Context_Reference => - Sem_Context_Reference (El); - when others => - Error_Kind ("sem_context_clauses", El); - end case; - El := Get_Chain (El); - end loop; - end Sem_Context_Clauses; - - -- LRM08 13.3 Context declarations - procedure Sem_Context_Declaration (Decl: Iir) - is - -- Return TRUE iff the first prefix of NAME denotes library WORK. - function Has_Work_Library_Prefix (Name : Iir) return Boolean - is - Prefix : Iir; - begin - Prefix := Name; - while Get_Kind (Prefix) = Iir_Kind_Selected_Name - or else Get_Kind (Prefix) = Iir_Kind_Selected_By_All_Name - loop - Prefix := Get_Prefix (Prefix); - end loop; - return Get_Kind (Prefix) = Iir_Kind_Simple_Name - and then Get_Identifier (Prefix) = Std_Names.Name_Work - and then (Get_Kind (Get_Named_Entity (Prefix)) - = Iir_Kind_Library_Declaration); - end Has_Work_Library_Prefix; - - procedure Error_Work_Prefix (Loc : Iir) is - begin - Error_Msg_Sem - (+Loc, "'work' not allowed as prefix in context declaration"); - end Error_Work_Prefix; - - El : Iir; - El1 : Iir; - begin - Sem_Scopes.Add_Name (Decl); - Xref_Decl (Decl); - - Sem_Context_Clauses (Decl); - - El := Get_Context_Items (Decl); - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Library_Clause => - -- LRM08 13.3 Context declarations - -- It is an error if a library clause in a context declaration - -- defines the library logical name WORK, [...] - if Get_Identifier (El) = Std_Names.Name_Work then - Error_Msg_Sem - (+El, "'library work' not allowed in context declaration"); - end if; - when Iir_Kind_Use_Clause => - -- LRM08 13.3 Context declarations - -- [...] or if a selected name in a use clause [or a context - -- reference] in a context declaration has the library logic - -- name WORK as a prefix. - El1 := El; - while El1 /= Null_Iir loop - if Has_Work_Library_Prefix (Get_Selected_Name (El1)) then - Error_Work_Prefix (El1); - exit; - end if; - El1 := Get_Use_Clause_Chain (El1); - end loop; - when Iir_Kind_Context_Reference => - -- LRM08 13.3 Context declarations - -- [...] or if a selected name in [a use clause or] a context - -- reference in a context declaration has the library logic - -- name WORK as a prefix. - El1 := El; - while El1 /= Null_Iir loop - if Has_Work_Library_Prefix (Get_Selected_Name (El1)) then - Error_Work_Prefix (El1); - exit; - end if; - El1 := Get_Context_Reference_Chain (El1); - end loop; - when others => - raise Internal_Error; - end case; - El := Get_Chain (El); - end loop; - - -- GHDL: forbid self-reference by making declaration visible at the end. - -- This violates LRM08 12.3 Visibility: A declaration is visible only - -- within a certain part of its scope; ... - Set_Visible_Flag (Decl, True); - end Sem_Context_Declaration; - - -- Access to the current design unit. This is set, saved, restored, cleared - -- by the procedure semantic. - Current_Design_Unit: Iir_Design_Unit := Null_Iir; - - function Get_Current_Design_Unit return Iir_Design_Unit is - begin - return Current_Design_Unit; - end Get_Current_Design_Unit; - - -- LRM 11.1 Design units. - procedure Semantic (Design_Unit : Iir_Design_Unit) - is - Library_Unit : constant Iir := Get_Library_Unit (Design_Unit); - Library : constant Iir := Get_Library (Get_Design_File (Design_Unit)); - Prev_Unit : Iir; - Old_Design_Unit : Iir_Design_Unit; - Implicit : Implicit_Signal_Declaration_Type; - begin - -- Sanity check: can analyze either previously analyzed unit or just - -- parsed unit. - case Get_Date (Design_Unit) is - when Date_Parsed => - Set_Date (Design_Unit, Date_Analyzing); - when Date_Valid => - null; - when Date_Obsolete => - -- This happens only when design files are added into the library - -- and keeping obsolete units (eg: to pretty print a file). - Set_Date (Design_Unit, Date_Analyzing); - when others => - raise Internal_Error; - end case; - - -- If there is already a unit with the same name, mark it as being - -- replaced. - if Library_Unit /= Null_Iir then - if Get_Kind (Library_Unit) in Iir_Kinds_Primary_Unit then - Prev_Unit := Libraries.Find_Primary_Unit - (Library, Get_Identifier (Library_Unit)); - if Is_Valid (Prev_Unit) and then Prev_Unit /= Design_Unit then - Set_Date (Prev_Unit, Date_Replacing); - end if; - end if; - end if; - - -- Save and set current_design_unit. - Old_Design_Unit := Current_Design_Unit; - Current_Design_Unit := Design_Unit; - Push_Signals_Declarative_Part (Implicit, Null_Iir); - - -- Have a clean and empty state for scopes. - Push_Interpretations; - - -- LRM02 10.1 Declarative Region. - -- In addition to the above declarative region, there is a root - -- declarative region, not associated with a portion of the text of the - -- description, but encompassing any given primary unit. At the - -- beginning of the analysis of a given primary unit, there are no - -- declarations whose scopes (see 10.2) are within the root declarative - -- region. Moreover, the root declarative region associated with any - -- given secondary unit is the root declarative region of the - -- corresponding primary unit. - -- GHDL: for any revision of VHDL, a root declarative region is created, - -- due to reasons given by LCS 3 (VHDL Issue # 1028). - Open_Declarative_Region; - - -- LRM 11.2 - -- Every design unit is assumed to contain the following implicit - -- context items as part of its context clause: - -- library STD, WORK; use STD.STANDARD.all; - Sem_Scopes.Add_Name (Libraries.Std_Library, Std_Names.Name_Std, False); - Sem_Scopes.Add_Name (Library, Std_Names.Name_Work, False); - Sem_Scopes.Use_All_Names (Standard_Package); - if Get_Dependence_List (Design_Unit) = Null_Iir_List then - Set_Dependence_List (Design_Unit, Create_Iir_List); - end if; - Add_Dependence (Std_Standard_Unit); - - -- Analyze context clauses. - Sem_Context_Clauses (Design_Unit); - - -- Analyze the library unit. - if Library_Unit /= Null_Iir then - -- Can be null_iir in case of parse error. - case Iir_Kinds_Library_Unit (Get_Kind (Library_Unit)) is - when Iir_Kind_Entity_Declaration => - Sem_Entity_Declaration (Library_Unit); - when Iir_Kind_Architecture_Body => - Sem_Architecture_Body (Library_Unit); - when Iir_Kind_Package_Declaration => - Sem_Package_Declaration (Library_Unit); - when Iir_Kind_Package_Body => - Sem_Package_Body (Library_Unit); - when Iir_Kind_Configuration_Declaration => - Sem_Configuration_Declaration (Library_Unit); - when Iir_Kind_Package_Instantiation_Declaration => - Sem_Package_Instantiation_Declaration (Library_Unit); - when Iir_Kind_Context_Declaration => - Sem_Context_Declaration (Library_Unit); - end case; - end if; - - Close_Declarative_Region; - - Pop_Interpretations; - - if Get_Date (Design_Unit) = Date_Analyzing then - Set_Date (Design_Unit, Date_Analyzed); - end if; - - if Get_Analysis_Checks_List (Design_Unit) /= Null_Iir_List then - Sem_Analysis_Checks_List (Design_Unit, False); - end if; - - -- Restore current_design_unit. - Current_Design_Unit := Old_Design_Unit; - Pop_Signals_Declarative_Part (Implicit); - end Semantic; -end Sem; diff --git a/src/vhdl/sem.ads b/src/vhdl/sem.ads deleted file mode 100644 index c42301031..000000000 --- a/src/vhdl/sem.ads +++ /dev/null @@ -1,94 +0,0 @@ --- Semantic analysis pass. --- 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 Iirs; use Iirs; -with Types; use Types; - -package Sem is - -- Semantic analysis for chapters 1, 2, 10 (uses clauses) and 11. - - -- Do the semantic analysis of design unit DESIGN_UNIT. - -- Also add a few node or change some nodes, when for exemple an - -- identifier is changed into an access to the type. - procedure Semantic (Design_Unit: Iir_Design_Unit); - - -- Get the current design unit, ie, the parameter of the procedure semantic. - function Get_Current_Design_Unit return Iir_Design_Unit; - - -- Makes the current design unit depends on UNIT. - -- UNIT must be either an entity_aspect or a design_unit. - procedure Add_Dependence (Unit : Iir); - - -- Add EL in the current design unit list of items to be checked later. - procedure Add_Analysis_Checks_List (El : Iir); - - -- INTER_PARENT contains generics and ports interfaces; - -- ASSOC_PARENT constains generics and ports map aspects. - procedure Sem_Generic_Port_Association_Chain - (Inter_Parent : Iir; Assoc_Parent : Iir); - - -- INTER_PARENT contains generics interfaces; - -- ASSOC_PARENT constains generic aspects. - procedure Sem_Generic_Association_Chain - (Inter_Parent : Iir; Assoc_Parent : Iir); - - -- Return TRUE iff the actual of ASSOC can be the formal FORMAL. - -- ASSOC must be an association_element_by_expression. - function Can_Collapse_Signals (Assoc : Iir; Formal : Iir) return Boolean; - - -- Return TRUE iff LEFT and RIGHT are (in depth) equal. - -- This corresponds to conformance rules, LRM 2.7 - function Are_Trees_Equal (Left, Right : Iir) return Boolean; - - -- Check requirements on number of interfaces for subprogram specification - -- SUBPRG for a symbol operator ID. Requirements only concern operators, - -- and are defined in LRM 2.3.1. - -- If ID is not an operator name, this subprogram does no checks. - -- ID might be different from the identifier of SUBPRG when non object - -- aliases are checked. - procedure Check_Operator_Requirements (Id : Name_Id; Subprg : Iir); - - -- Analyze an use clause. - -- This may adds use clauses to the chain. - procedure Sem_Use_Clause (Clauses : Iir_Use_Clause); - - -- LRM 2.1 Subprogram Declarations. - procedure Sem_Subprogram_Specification (Subprg : Iir); - procedure Sem_Subprogram_Declaration (Subprg : Iir); - - -- LRM 2.2 Subprogram Bodies. - procedure Sem_Subprogram_Body (Subprg : Iir); - - -- LRM 2.5 Package Declarations. - procedure Sem_Package_Declaration (Pkg : Iir_Package_Declaration); - - -- LRM 2.6 Package Bodies. - procedure Sem_Package_Body (Decl : Iir); - - -- LRM08 4.9 Package Instantiation Declaration - procedure Sem_Package_Instantiation_Declaration (Decl : Iir); - - -- Do late analysis checks (pure rules). - procedure Sem_Analysis_Checks_List (Unit : Iir_Design_Unit; - Emit_Warnings : Boolean); - - -- Analyze the uninstantiated package name of DECL, and return the - -- package declaration. Return Null_Iir if the name doesn't denote an - -- uninstantiated package. - function Sem_Uninstantiated_Package_Name (Decl : Iir) return Iir; - -end Sem; diff --git a/src/vhdl/sem_assocs.adb b/src/vhdl/sem_assocs.adb deleted file mode 100644 index b04962c58..000000000 --- a/src/vhdl/sem_assocs.adb +++ /dev/null @@ -1,2571 +0,0 @@ --- Semantic analysis. --- 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 Evaluation; use Evaluation; -with Errorout; use Errorout; -with Flags; use Flags; -with Types; use Types; -with Iirs_Utils; use Iirs_Utils; -with Vhdl.Parse; -with Std_Names; -with Sem_Names; use Sem_Names; -with Sem_Types; -with Sem_Decls; -with Std_Package; -with Sem_Scopes; -with Iir_Chains; use Iir_Chains; -with Xrefs; - -package body Sem_Assocs is - function Rewrite_Non_Object_Association (Assoc : Iir; Inter : Iir) - return Iir - is - N_Assoc : Iir; - Actual : Iir; - begin - Actual := Get_Actual (Assoc); - case Get_Kind (Inter) is - when Iir_Kind_Interface_Package_Declaration => - N_Assoc := Create_Iir (Iir_Kind_Association_Element_Package); - when Iir_Kind_Interface_Type_Declaration => - N_Assoc := Create_Iir (Iir_Kind_Association_Element_Type); - if Get_Kind (Actual) = Iir_Kind_Parenthesis_Name then - -- Convert parenthesis name to array subtype. - declare - N_Actual : Iir; - Sub_Assoc : Iir; - Indexes : Iir_List; - Old : Iir; - begin - N_Actual := Create_Iir (Iir_Kind_Array_Subtype_Definition); - Location_Copy (N_Actual, Actual); - Set_Subtype_Type_Mark (N_Actual, Get_Prefix (Actual)); - Sub_Assoc := Get_Association_Chain (Actual); - Indexes := Create_Iir_List; - while Is_Valid (Sub_Assoc) loop - if Get_Kind (Sub_Assoc) - /= Iir_Kind_Association_Element_By_Expression - then - Error_Msg_Sem - (+Sub_Assoc, "index constraint must be a range"); - else - if Get_Formal (Sub_Assoc) /= Null_Iir then - Error_Msg_Sem - (+Sub_Assoc, "formal part not allowed"); - end if; - Append_Element (Indexes, Get_Actual (Sub_Assoc)); - end if; - Old := Sub_Assoc; - Sub_Assoc := Get_Chain (Sub_Assoc); - Free_Iir (Old); - end loop; - Old := Actual; - Free_Iir (Old); - Set_Index_Constraint_List - (N_Actual, List_To_Flist (Indexes)); - Actual := N_Actual; - end; - end if; - when Iir_Kinds_Interface_Subprogram_Declaration => - N_Assoc := Create_Iir (Iir_Kind_Association_Element_Subprogram); - if Get_Kind (Actual) = Iir_Kind_String_Literal8 then - Actual := Vhdl.Parse.String_To_Operator_Symbol (Actual); - end if; - when others => - Error_Kind ("rewrite_non_object_association", Inter); - end case; - Location_Copy (N_Assoc, Assoc); - Set_Formal (N_Assoc, Get_Formal (Assoc)); - Set_Actual (N_Assoc, Actual); - Set_Chain (N_Assoc, Get_Chain (Assoc)); - Set_Whole_Association_Flag (N_Assoc, True); - Free_Iir (Assoc); - return N_Assoc; - end Rewrite_Non_Object_Association; - - function Extract_Non_Object_Association - (Assoc_Chain : Iir; Inter_Chain : Iir) return Iir - is - Inter : Iir; - Assoc : Iir; - -- N_Assoc : Iir; - Prev_Assoc : Iir; - Formal : Iir; - Res : Iir; - begin - Inter := Inter_Chain; - Assoc := Assoc_Chain; - Prev_Assoc := Null_Iir; - Res := Null_Iir; - - -- Common case: only objects in interfaces. - while Is_Valid (Inter) loop - exit when Get_Kind (Inter) - not in Iir_Kinds_Interface_Object_Declaration; - Inter := Get_Chain (Inter); - end loop; - if Is_Null (Inter) then - -- Only interface object, nothing to to. - return Assoc_Chain; - end if; - - Inter := Inter_Chain; - loop - -- Don't try to detect errors. - if Is_Null (Assoc) then - return Res; - end if; - - Formal := Get_Formal (Assoc); - if Formal = Null_Iir then - -- Positional association. - - if Inter = Null_Iir then - -- But after a named one. Be silent on that error. - null; - elsif Get_Kind (Inter) - not in Iir_Kinds_Interface_Object_Declaration - then - Assoc := Rewrite_Non_Object_Association (Assoc, Inter); - end if; - else - if Kind_In (Formal, Iir_Kind_Simple_Name, Iir_Kind_Operator_Symbol) - then - -- A candidate. Search the corresponding interface. - Inter := Find_Name_In_Chain - (Inter_Chain, Get_Identifier (Formal)); - if Inter /= Null_Iir - and then - Get_Kind (Inter) not in Iir_Kinds_Interface_Object_Declaration - then - Assoc := Rewrite_Non_Object_Association (Assoc, Inter); - end if; - end if; - - -- No more association by position. - Inter := Null_Iir; - end if; - - if Prev_Assoc = Null_Iir then - Res := Assoc; - else - Set_Chain (Prev_Assoc, Assoc); - end if; - Prev_Assoc := Assoc; - Assoc := Get_Chain (Assoc); - if Is_Valid (Inter) then - Inter := Get_Chain (Inter); - end if; - end loop; - end Extract_Non_Object_Association; - - -- Analyze all arguments of ASSOC_CHAIN - -- Return TRUE if no error. - function Sem_Actual_Of_Association_Chain (Assoc_Chain : Iir) - return Boolean - is - Has_Named : Boolean; - Ok : Boolean; - Assoc : Iir; - Res : Iir; - Formal : Iir; - begin - -- Analyze all arguments. - -- OK is false if there is an error during semantic of one of the - -- argument, but continue analyze. - Has_Named := False; - Ok := True; - Assoc := Assoc_Chain; - while Assoc /= Null_Iir loop - Formal := Get_Formal (Assoc); - if Formal /= Null_Iir then - Has_Named := True; - -- FIXME: check FORMAL is well composed. - elsif Has_Named then - -- FIXME: do the check in parser. - Error_Msg_Sem (+Assoc, "positional argument after named argument"); - Ok := False; - end if; - if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression then - Res := Sem_Expression_Ov (Get_Actual (Assoc), Null_Iir); - if Res = Null_Iir then - Ok := False; - else - Set_Actual (Assoc, Res); - end if; - end if; - Assoc := Get_Chain (Assoc); - end loop; - return Ok; - end Sem_Actual_Of_Association_Chain; - - procedure Check_Parameter_Association_Restriction - (Inter : Iir; Base_Actual : Iir; Loc : Iir) is - begin - case Iir_Parameter_Modes (Get_Mode (Inter)) is - when Iir_In_Mode => - if Can_Interface_Be_Read (Base_Actual) then - return; - end if; - when Iir_Out_Mode => - if Can_Interface_Be_Updated (Base_Actual) then - return; - end if; - when Iir_Inout_Mode => - if Can_Interface_Be_Read (Base_Actual) - and then Can_Interface_Be_Updated (Base_Actual) - then - return; - end if; - end case; - Error_Msg_Sem - (+Loc, "cannot associate an " & Get_Mode_Name (Get_Mode (Base_Actual)) - & " object with " & Get_Mode_Name (Get_Mode (Inter)) & " %n", - +Inter); - end Check_Parameter_Association_Restriction; - - procedure Check_Subprogram_Associations - (Inter_Chain : Iir; Assoc_Chain : Iir) - is - Assoc : Iir; - Formal_Inter : Iir; - Actual : Iir; - Prefix : Iir; - Object : Iir; - Inter : Iir; - begin - Assoc := Assoc_Chain; - Inter := Inter_Chain; - while Assoc /= Null_Iir loop - Formal_Inter := Get_Association_Interface (Assoc, Inter); - case Get_Kind (Assoc) is - when Iir_Kind_Association_Element_Open => - if Get_Default_Value (Formal_Inter) = Null_Iir then - Error_Msg_Sem - (+Assoc, "no parameter for %n", +Formal_Inter); - end if; - when Iir_Kind_Association_Element_By_Expression => - Actual := Get_Actual (Assoc); - Object := Name_To_Object (Actual); - if Object /= Null_Iir then - Prefix := Get_Object_Prefix (Object); - else - Prefix := Actual; - end if; - - case Get_Kind (Formal_Inter) is - when Iir_Kind_Interface_Signal_Declaration => - -- LRM93 2.1.1 - -- In a subprogram call, the actual designator - -- associated with a formal parameter of class - -- signal must be a signal. - case Get_Kind (Prefix) is - when Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Signal_Declaration - | Iir_Kind_Guard_Signal_Declaration - | Iir_Kinds_Signal_Attribute => - -- LRM93 2.1.1.2 - -- If an actual signal is associated with - -- a signal parameter of any mode, the actual - -- must be denoted by a static signal name. - if Get_Name_Staticness (Object) < Globally then - Error_Msg_Sem - (+Actual, - "actual signal must be a static name"); - else - -- Inherit has_active_flag. - Set_Has_Active_Flag - (Prefix, Get_Has_Active_Flag (Formal_Inter)); - end if; - when others => - Error_Msg_Sem - (+Assoc, - "signal parameter requires a signal expression"); - end case; - - case Get_Kind (Prefix) is - when Iir_Kind_Interface_Signal_Declaration => - Check_Parameter_Association_Restriction - (Formal_Inter, Prefix, Assoc); - when Iir_Kind_Guard_Signal_Declaration => - if Get_Mode (Formal_Inter) /= Iir_In_Mode then - Error_Msg_Sem - (+Assoc, - "cannot associate a guard signal with " - & Get_Mode_Name (Get_Mode (Formal_Inter)) - & " %n", +Formal_Inter); - end if; - when Iir_Kinds_Signal_Attribute => - if Get_Mode (Formal_Inter) /= Iir_In_Mode then - Error_Msg_Sem - (+Assoc, - "cannot associate a signal attribute with " - & Get_Mode_Name (Get_Mode (Formal_Inter)) - & " %n", +Formal_Inter); - end if; - when others => - null; - end case; - - -- LRM 2.1.1.2 Signal parameters - -- It is an error if a conversion function or type - -- conversion appears in either the formal part or the - -- actual part of an association element that associates - -- an actual signal with a formal signal parameter. - if Get_Actual_Conversion (Assoc) /= Null_Iir - or Get_Formal_Conversion (Assoc) /= Null_Iir - then - Error_Msg_Sem - (+Assoc, - "conversion are not allowed for signal parameters"); - end if; - when Iir_Kind_Interface_Variable_Declaration => - -- LRM93 2.1.1 - -- The actual designator associated with a formal of - -- class variable must be a variable. - case Get_Kind (Prefix) is - when Iir_Kind_Interface_Variable_Declaration => - Check_Parameter_Association_Restriction - (Formal_Inter, Prefix, Assoc); - when Iir_Kind_Variable_Declaration - | Iir_Kind_Dereference - | Iir_Kind_Implicit_Dereference => - null; - when Iir_Kind_Interface_File_Declaration - | Iir_Kind_File_Declaration => - -- LRM87 4.3.1.4 - -- Such an object is a member of the variable - -- class of objects; - if Flags.Vhdl_Std >= Vhdl_93 then - Error_Msg_Sem - (+Assoc, "variable parameter cannot be a " - & "file (vhdl93)"); - end if; - when others => - Error_Msg_Sem - (+Assoc, "variable parameter must be a variable"); - end case; - when Iir_Kind_Interface_File_Declaration => - -- LRM93 2.1.1 - -- The actual designator associated with a formal - -- of class file must be a file. - case Get_Kind (Prefix) is - when Iir_Kind_Interface_File_Declaration - | Iir_Kind_File_Declaration => - null; - when Iir_Kind_Variable_Declaration - | Iir_Kind_Interface_Variable_Declaration => - if Flags.Vhdl_Std >= Vhdl_93 then - Error_Msg_Sem (+Assoc, "file parameter " - & "must be a file (vhdl93)"); - end if; - when others => - Error_Msg_Sem - (+Assoc, "file parameter must be a file"); - end case; - - -- LRM 2.1.1.3 File parameters - -- It is an error if an association element associates - -- an actual with a formal parameter of a file type and - -- that association element contains a conversion - -- function or type conversion. - if Get_Actual_Conversion (Assoc) /= Null_Iir - or Get_Formal_Conversion (Assoc) /= Null_Iir - then - Error_Msg_Sem (+Assoc, "conversion are not allowed " - & "for file parameters"); - end if; - when Iir_Kind_Interface_Constant_Declaration => - -- LRM93 2.1.1 - -- The actual designator associated with a formal of - -- class constant must be an expression. - -- GHDL: unless this is in a formal_part. - if not Get_In_Formal_Flag (Assoc) then - Check_Read (Actual); - end if; - when others => - Error_Kind - ("check_subprogram_association(3)", Formal_Inter); - end case; - when Iir_Kind_Association_Element_By_Individual => - null; - when others => - Error_Kind ("check_subprogram_associations", Assoc); - end case; - Next_Association_Interface (Assoc, Inter); - end loop; - end Check_Subprogram_Associations; - - -- Assocs_Right_Map (FORMAL_MODE, ACTUAL_MODE) is true iff it is allowed - -- to associate a formal port of mode FORMAL_MODE with an actual port of - -- mode ACTUAL_MODE. - subtype Iir_Known_Mode is Iir_Mode range Iir_Linkage_Mode .. Iir_In_Mode; - type Assocs_Right_Map is array (Iir_Known_Mode, Iir_Known_Mode) of Boolean; - - -- LRM93 1.1.1.2 Ports - Vhdl93_Assocs_Map : constant Assocs_Right_Map := - (Iir_In_Mode => - (Iir_In_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, - others => False), - Iir_Out_Mode => - (Iir_Out_Mode | Iir_Inout_Mode => True, - others => False), - Iir_Inout_Mode => - (Iir_Inout_Mode => True, - others => False), - Iir_Buffer_Mode => - (Iir_Buffer_Mode => True, others => False), - Iir_Linkage_Mode => - (others => True)); - - -- LRM02 1.1.1.2 Ports - Vhdl02_Assocs_Map : constant Assocs_Right_Map := - (Iir_In_Mode => - (Iir_In_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, - others => False), - Iir_Out_Mode => - (Iir_Out_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, - others => False), - Iir_Inout_Mode => - (Iir_Inout_Mode | Iir_Buffer_Mode => True, - others => False), - Iir_Buffer_Mode => - (Iir_Out_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, - others => False), - Iir_Linkage_Mode => - (others => True)); - - -- LRM08 6.5.6.3 Port clauses - Vhdl08_Assocs_Map : constant Assocs_Right_Map := - (Iir_In_Mode => - (Iir_In_Mode | Iir_Out_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, - others => False), - Iir_Out_Mode => - (Iir_Out_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, - others => False), - Iir_Inout_Mode => - (Iir_Out_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, - others => False), - Iir_Buffer_Mode => - (Iir_Out_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, - others => False), - Iir_Linkage_Mode => (others => True)); - - -- Check for restrictions in LRM 1.1.1.2 - -- Return FALSE in case of error. - function Check_Port_Association_Mode_Restrictions - (Formal : Iir_Interface_Signal_Declaration; - Actual : Iir_Interface_Signal_Declaration; - Assoc : Iir) - return Boolean - is - Fmode : constant Iir_Mode := Get_Mode (Formal); - Amode : constant Iir_Mode := Get_Mode (Actual); - begin - pragma Assert (Fmode /= Iir_Unknown_Mode); - pragma Assert (Amode /= Iir_Unknown_Mode); - - case Flags.Vhdl_Std is - when Vhdl_87 | Vhdl_93c | Vhdl_93 | Vhdl_00 => - if Vhdl93_Assocs_Map (Fmode, Amode) then - return True; - end if; - when Vhdl_02 => - if Vhdl02_Assocs_Map (Fmode, Amode) then - return True; - end if; - when Vhdl_08 => - if Vhdl08_Assocs_Map (Fmode, Amode) then - return True; - end if; - end case; - - if Assoc /= Null_Iir then - Error_Msg_Sem - (+Assoc, "cannot associate " & Get_Mode_Name (Fmode) & " %n" - & " with actual port of mode " - & Get_Mode_Name (Amode), +Formal); - end if; - return False; - end Check_Port_Association_Mode_Restrictions; - - -- Check restrictions of LRM02 12.2.4 - procedure Check_Port_Association_Bounds_Restrictions - (Formal : Iir; Actual : Iir; Assoc : Iir) - is - Inter : constant Iir := Get_Object_Prefix (Formal, False); - - function Is_Scalar_Type_Compatible (Src : Iir; Dest : Iir) - return Boolean - is - Src_Range : Iir; - Dst_Range : Iir; - begin - if Get_Kind (Src) not in Iir_Kinds_Scalar_Type_And_Subtype_Definition - then - return True; - end if; - - Src_Range := Get_Range_Constraint (Src); - Dst_Range := Get_Range_Constraint (Dest); - if Get_Expr_Staticness (Src_Range) /= Locally - or else Get_Expr_Staticness (Dst_Range) /= Locally - then - return True; - end if; - - -- FIXME: non-static bounds have to be checked at run-time - -- (during elaboration). - - -- In vhdl08, the subtypes must be compatible. Use the that rule - -- for 93c and relaxed rules. - if Vhdl_Std >= Vhdl_08 - or else Vhdl_Std = Vhdl_93c - or else Flag_Relaxed_Rules - then - return Eval_Is_Range_In_Bound (Src, Dest, True); - end if; - - -- Prior vhdl08, the subtypes must be identical. - if not Eval_Is_Eq (Get_Left_Limit (Src_Range), - Get_Left_Limit (Dst_Range)) - or else not Eval_Is_Eq (Get_Right_Limit (Src_Range), - Get_Right_Limit (Dst_Range)) - or else Get_Direction (Src_Range) /= Get_Direction (Dst_Range) - then - return False; - end if; - - return True; - end Is_Scalar_Type_Compatible; - - procedure Error_Msg - is - Id : Msgid_Type; - Orig : Report_Origin; - begin - if Flag_Elaborate then - Id := Msgid_Error; - Orig := Elaboration; - else - Id := Warnid_Port_Bounds; - Orig := Semantic; - end if; - Report_Msg - (Id, Orig, +Assoc, - "bounds or direction of actual don't match with %n", - (1 => +Inter)); - end Error_Msg; - - Ftype : constant Iir := Get_Type (Formal); - Atype : constant Iir := Get_Type (Actual); - F_Conv : constant Iir := Get_Formal_Conversion (Assoc); - A_Conv : constant Iir := Get_Actual_Conversion (Assoc); - F2a_Type : Iir; - A2f_Type : Iir; - begin - -- LRM02 12.2.4 The port map aspect - -- If an actual signal is associated with a port of any mode, and if - -- the type of the formal is a scalar type, then it is an error if - -- (after applying any conversion function or type conversion - -- expression present in the actual part) the bounds and direction of - -- the subtype denoted by the subtype indication of the formal are not - -- identical to the bounds and direction of the subtype denoted by the - -- subtype indication of the actual. - - -- LRM08 14.3.5 Port map aspect - -- If an actual signal is associated with a port of mode IN or INOUT, - -- and if the type of the formal is a scalar type, then it is an error - -- if (after applying any conversion function or type conversion - -- expression present in the actual part) the subtype of the actual is - -- not compatible with the subtype of the formal. [...] - -- - -- Similarly, if an actual signal is associated with a port of mode - -- OUT, INOUT, or BUFFER, and the type of the actual is a scalar type, - -- then it is an error if (after applying any conversion function or - -- type conversion expression present in the formal part) the subtype - -- or the formal is not compatible with the subtype of the actual. - if Is_Valid (F_Conv) then - F2a_Type := Get_Type (F_Conv); - else - F2a_Type := Ftype; - end if; - if Is_Valid (A_Conv) then - A2f_Type := Get_Type (A_Conv); - else - A2f_Type := Atype; - end if; - if Get_Mode (Inter) in Iir_In_Modes - and then not Is_Scalar_Type_Compatible (A2f_Type, Ftype) - then - Error_Msg; - end if; - if Get_Mode (Inter) in Iir_Out_Modes - and then not Is_Scalar_Type_Compatible (F2a_Type, Atype) - then - Error_Msg; - end if; - end Check_Port_Association_Bounds_Restrictions; - - -- Handle indexed name - -- FORMAL is the formal name to be handled. - -- BASE_ASSOC is an association_by_individual in which the formal will be - -- inserted. - procedure Add_Individual_Assoc_Indexed_Name - (Choice : out Iir; Base_Assoc : Iir; Formal : Iir) - is - Index_List : constant Iir_Flist := Get_Index_List (Formal); - Nbr : constant Natural := Get_Nbr_Elements (Index_List); - Last_Choice : Iir; - Index : Iir; - Staticness : Iir_Staticness; - Sub_Assoc : Iir; - begin - -- Find element. - Sub_Assoc := Base_Assoc; - for I in 0 .. Nbr - 1 loop - Index := Get_Nth_Element (Index_List, I); - - -- Evaluate index. - Staticness := Get_Expr_Staticness (Index); - if Staticness = Locally then - Index := Eval_Expr (Index); - Set_Nth_Element (Index_List, I, Index); - else - Error_Msg_Sem (+Index, "index expression must be locally static"); - Set_Choice_Staticness (Base_Assoc, None); - end if; - - -- Find index in choice list. - Last_Choice := Null_Iir; - Choice := Get_Individual_Association_Chain (Sub_Assoc); - while Choice /= Null_Iir loop - case Get_Kind (Choice) is - when Iir_Kind_Choice_By_Expression => - if Eval_Pos (Get_Choice_Expression (Choice)) - = Eval_Pos (Index) - then - goto Found; - end if; - when Iir_Kind_Choice_By_Range => - declare - Choice_Range : constant Iir := Get_Choice_Range (Choice); - begin - if Get_Expr_Staticness (Choice_Range) = Locally - and then - Eval_Int_In_Range (Eval_Pos (Index), Choice_Range) - then - -- FIXME: overlap. - raise Internal_Error; - end if; - end; - when others => - Error_Kind ("add_individual_assoc_index_name", Choice); - end case; - Last_Choice := Choice; - Choice := Get_Chain (Choice); - end loop; - - -- If not found, append it. - Choice := Create_Iir (Iir_Kind_Choice_By_Expression); - Set_Choice_Expression (Choice, Index); - Set_Choice_Staticness (Choice, Staticness); - Location_Copy (Choice, Formal); - if Last_Choice = Null_Iir then - Set_Individual_Association_Chain (Sub_Assoc, Choice); - else - Set_Chain (Last_Choice, Choice); - end if; - - << Found >> null; - - if I < Nbr - 1 then - -- Create an intermediate assoc by individual. - Sub_Assoc := Get_Associated_Expr (Choice); - if Sub_Assoc = Null_Iir then - Sub_Assoc := Create_Iir - (Iir_Kind_Association_Element_By_Individual); - Location_Copy (Sub_Assoc, Index); - Set_Associated_Expr (Choice, Sub_Assoc); - Set_Choice_Staticness (Sub_Assoc, Locally); - end if; - end if; - end loop; - end Add_Individual_Assoc_Indexed_Name; - - procedure Add_Individual_Assoc_Slice_Name - (Choice : out Iir; Sub_Assoc : Iir; Formal : Iir) - is - Index : Iir; - Staticness : Iir_Staticness; - begin - -- FIXME: handle cases such as param(5 to 6)(5) - - -- Find element. - Index := Get_Suffix (Formal); - - -- Evaluate index. - Staticness := Get_Expr_Staticness (Index); - if Staticness = Locally then - Index := Eval_Range (Index); - Set_Suffix (Formal, Index); - else - Error_Msg_Sem (+Index, "range expression must be locally static"); - Set_Choice_Staticness (Sub_Assoc, None); - end if; - - Choice := Create_Iir (Iir_Kind_Choice_By_Range); - Location_Copy (Choice, Formal); - Set_Choice_Range (Choice, Index); - Set_Chain (Choice, Get_Individual_Association_Chain (Sub_Assoc)); - Set_Choice_Staticness (Choice, Staticness); - Set_Individual_Association_Chain (Sub_Assoc, Choice); - end Add_Individual_Assoc_Slice_Name; - - procedure Add_Individual_Assoc_Selected_Name - (Choice : out Iir; Sub_Assoc : Iir; Formal : Iir) - is - Element : constant Iir := Get_Named_Entity (Formal); - Last_Choice : Iir; - begin - -- Try to find the existing choice. - Last_Choice := Null_Iir; - Choice := Get_Individual_Association_Chain (Sub_Assoc); - while Choice /= Null_Iir loop - if Get_Choice_Name (Choice) = Element then - return; - end if; - Last_Choice := Choice; - Choice := Get_Chain (Choice); - end loop; - - -- If not found, append it. - Choice := Create_Iir (Iir_Kind_Choice_By_Name); - Location_Copy (Choice, Formal); - Set_Choice_Name (Choice, Element); - if Last_Choice = Null_Iir then - Set_Individual_Association_Chain (Sub_Assoc, Choice); - else - Set_Chain (Last_Choice, Choice); - end if; - end Add_Individual_Assoc_Selected_Name; - - -- Subroutine of Add_Individual_Association. - -- Search/build the tree of choices for FORMAL, starting for IASSOC. - -- The root of the tree is an association by individual node. Each node - -- points to a chain of choices, whose associated expression is either an - -- association by individual (and the tree continue) or an association - -- by expression coming from the initial association (and this is a leaf). - procedure Add_Individual_Association_1 - (Iassoc : in out Iir; Formal : Iir; Last : Boolean) - is - Base_Assoc : constant Iir := Iassoc; - Formal_Object : constant Iir := Name_To_Object (Formal); - Sub : Iir; - Choice : Iir; - begin - pragma Assert - (Get_Kind (Iassoc) = Iir_Kind_Association_Element_By_Individual); - - -- Recurse to start from the basename of the formal. - case Get_Kind (Formal_Object) is - when Iir_Kind_Indexed_Name - | Iir_Kind_Slice_Name - | Iir_Kind_Selected_Element => - Add_Individual_Association_1 - (Iassoc, Get_Prefix (Formal_Object), False); - when Iir_Kinds_Interface_Object_Declaration => - -- At the root of the formal. - pragma Assert - (Formal_Object = Get_Named_Entity (Get_Formal (Iassoc))); - return; - when others => - Error_Kind ("add_individual_association_1", Formal); - end case; - - -- Add the choices for the indexes/slice/element. - case Get_Kind (Formal_Object) is - when Iir_Kind_Indexed_Name => - Add_Individual_Assoc_Indexed_Name (Choice, Iassoc, Formal_Object); - when Iir_Kind_Slice_Name => - Add_Individual_Assoc_Slice_Name (Choice, Iassoc, Formal_Object); - when Iir_Kind_Selected_Element => - Add_Individual_Assoc_Selected_Name (Choice, Iassoc, Formal_Object); - when others => - Error_Kind ("add_individual_association_1(3)", Formal); - end case; - - Sub := Get_Associated_Expr (Choice); - if Sub = Null_Iir then - if not Last then - -- Create the individual association for the choice. - Sub := Create_Iir (Iir_Kind_Association_Element_By_Individual); - Location_Copy (Sub, Formal); - Set_Choice_Staticness (Sub, Locally); - Set_Formal (Sub, Formal); - Set_Associated_Expr (Choice, Sub); - end if; - else - if Last - or else Get_Kind (Sub) /= Iir_Kind_Association_Element_By_Individual - then - -- A final association. - pragma Assert - (Get_Kind (Sub) = Iir_Kind_Association_Element_By_Expression); - Error_Msg_Sem - (+Formal, "individual association of %n" - & " conflicts with that at %l", - (+Get_Interface_Of_Formal (Get_Formal (Iassoc)), - +Sub)); - else - if Get_Choice_Staticness (Sub) /= Locally then - -- Propagate error. - Set_Choice_Staticness (Base_Assoc, None); - end if; - end if; - end if; - - if Last then - Iassoc := Choice; - else - Iassoc := Sub; - end if; - end Add_Individual_Association_1; - - -- Insert ASSOC into the tree of individual assoc rooted by IASSOC. - -- This is done so that duplicate or missing associations are found (using - -- the same routine for aggregate/case statement). - procedure Add_Individual_Association (Iassoc : Iir; Assoc : Iir) - is - Formal : constant Iir := Get_Formal (Assoc); - Res_Iass : Iir; - Prev : Iir; - begin - -- Create the individual association for the formal. - Res_Iass := Iassoc; - Add_Individual_Association_1 (Res_Iass, Formal, True); - - Prev := Get_Associated_Expr (Res_Iass); - if Prev = Null_Iir then - Set_Associated_Expr (Res_Iass, Assoc); - end if; - end Add_Individual_Association; - - procedure Finish_Individual_Assoc_Array_Subtype - (Assoc : Iir; Atype : Iir; Dim : Positive) - is - Index_Tlist : constant Iir_Flist := Get_Index_Subtype_List (Atype); - Nbr_Dims : constant Natural := Get_Nbr_Elements (Index_Tlist); - Index_Type : constant Iir := Get_Nth_Element (Index_Tlist, Dim - 1); - Chain : constant Iir := Get_Individual_Association_Chain (Assoc); - Low, High : Iir; - El : Iir; - begin - Sem_Check_Continuous_Choices - (Chain, Index_Type, Low, High, Get_Location (Assoc), False); - if Dim < Nbr_Dims then - El := Chain; - while El /= Null_Iir loop - pragma Assert (Get_Kind (El) = Iir_Kind_Choice_By_Expression); - Finish_Individual_Assoc_Array_Subtype - (Get_Associated_Expr (El), Atype, Dim + 1); - El := Get_Chain (El); - end loop; - end if; - end Finish_Individual_Assoc_Array_Subtype; - - procedure Finish_Individual_Assoc_Array - (Actual : Iir; Assoc : Iir; Dim : Natural) - is - Actual_Type : constant Iir := Get_Actual_Type (Actual); - Actual_Index : Iir; - Base_Type : Iir; - Base_Index : Iir; - Low, High : Iir; - Chain : Iir; - begin - Actual_Index := Get_Nth_Element (Get_Index_Subtype_List (Actual_Type), - Dim - 1); - if Actual_Index /= Null_Iir then - Base_Index := Actual_Index; - else - Base_Type := Get_Base_Type (Actual_Type); - Base_Index := Get_Index_Type (Base_Type, Dim - 1); - end if; - Chain := Get_Individual_Association_Chain (Assoc); - Sem_Choices_Range - (Chain, Base_Index, Low, High, Get_Location (Assoc), True, False); - Set_Individual_Association_Chain (Assoc, Chain); - if Actual_Index = Null_Iir then - declare - Index_Constraint : Iir; - Index_Subtype_Constraint : Iir; - begin - -- Create an index subtype. - case Get_Kind (Base_Index) is - when Iir_Kind_Integer_Subtype_Definition => - Actual_Index := - Create_Iir (Iir_Kind_Integer_Subtype_Definition); - when Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Enumeration_Subtype_Definition => - Actual_Index := - Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); - when others => - Error_Kind ("finish_individual_assoc_array", Base_Index); - end case; - Location_Copy (Actual_Index, Actual); - Set_Base_Type (Actual_Index, Get_Base_Type (Base_Index)); - Index_Constraint := Get_Range_Constraint (Base_Index); - - Index_Subtype_Constraint := Create_Iir (Iir_Kind_Range_Expression); - Location_Copy (Index_Subtype_Constraint, Actual); - Set_Range_Constraint (Actual_Index, Index_Subtype_Constraint); - Set_Type_Staticness (Actual_Index, Locally); - Set_Direction (Index_Subtype_Constraint, - Get_Direction (Index_Constraint)); - - -- For ownership purpose, the bounds must be copied otherwise - -- they would be referenced before being defined. This is non - -- optimal but it doesn't happen often. - Low := Copy_Constant (Low); - High := Copy_Constant (High); - - case Get_Direction (Index_Constraint) is - when Iir_To => - Set_Left_Limit (Index_Subtype_Constraint, Low); - Set_Left_Limit_Expr (Index_Subtype_Constraint, Low); - Set_Right_Limit (Index_Subtype_Constraint, High); - Set_Right_Limit_Expr (Index_Subtype_Constraint, High); - when Iir_Downto => - Set_Left_Limit (Index_Subtype_Constraint, High); - Set_Left_Limit_Expr (Index_Subtype_Constraint, High); - Set_Right_Limit (Index_Subtype_Constraint, Low); - Set_Right_Limit_Expr (Index_Subtype_Constraint, Low); - end case; - Set_Expr_Staticness (Index_Subtype_Constraint, Locally); - Set_Nth_Element (Get_Index_Subtype_List (Actual_Type), Dim - 1, - Actual_Index); - end; - else - declare - Act_High, Act_Low : Iir; - begin - Get_Low_High_Limit (Get_Range_Constraint (Actual_Type), - Act_Low, Act_High); - if Eval_Pos (Act_Low) /= Eval_Pos (Low) - or Eval_Pos (Act_High) /= Eval_Pos (High) - then - Error_Msg_Sem - (+Assoc, "indexes of individual association mismatch"); - end if; - end; - end if; - end Finish_Individual_Assoc_Array; - - procedure Finish_Individual_Assoc_Record (Assoc : Iir; Atype : Iir) - is - El_List : constant Iir_Flist := Get_Elements_Declaration_List (Atype); - Nbr_El : constant Natural := Get_Nbr_Elements (El_List); - Matches : Iir_Array (0 .. Nbr_El - 1); - Ch : Iir; - Pos : Natural; - Rec_El : Iir; - begin - -- Check for duplicate associations. - Matches := (others => Null_Iir); - Ch := Get_Individual_Association_Chain (Assoc); - while Ch /= Null_Iir loop - Rec_El := Get_Choice_Name (Ch); - Pos := Natural (Get_Element_Position (Rec_El)); - if Matches (Pos) /= Null_Iir then - Error_Msg_Sem (+Ch, "individual %n already associated at %l", - (+Rec_El, +Matches (Pos))); - else - Matches (Pos) := Ch; - end if; - Ch := Get_Chain (Ch); - end loop; - - -- Check for missing associations. - for I in Matches'Range loop - Rec_El := Get_Nth_Element (El_List, I); - if Matches (I) = Null_Iir then - Error_Msg_Sem (+Assoc, "%n not associated", +Rec_El); - end if; - end loop; - - if Get_Constraint_State (Atype) /= Fully_Constrained then - -- Some (sub-)elements are unbounded, create a bounded subtype. - declare - Inter : constant Iir := - Get_Interface_Of_Formal (Get_Formal (Assoc)); - Ntype : Iir; - Nel_List : Iir_Flist; - Nrec_El : Iir; - Rec_El_Type : Iir; - Staticness : Iir_Staticness; - begin - Ntype := Create_Iir (Iir_Kind_Record_Subtype_Definition); - Location_Copy (Ntype, Assoc); - Set_Base_Type (Ntype, Get_Base_Type (Atype)); - if Get_Kind (Atype) = Iir_Kind_Record_Subtype_Definition then - Set_Resolution_Indication - (Ntype, Get_Resolution_Indication (Atype)); - end if; - if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration - then - -- The subtype is used for signals. - Set_Has_Signal_Flag (Ntype, True); - end if; - - Nel_List := Create_Iir_Flist (Nbr_El); - Set_Elements_Declaration_List (Ntype, Nel_List); - - Staticness := Locally; - for I in Matches'Range loop - Rec_El := Get_Nth_Element (El_List, I); - Rec_El_Type := Get_Type (Rec_El); - if (Get_Kind (Rec_El_Type) - not in Iir_Kinds_Composite_Type_Definition) - or else - Get_Constraint_State (Rec_El_Type) = Fully_Constrained - or else - Matches (I) = Null_Iir -- In case of error. - then - Nrec_El := Rec_El; - else - Nrec_El := Create_Iir (Iir_Kind_Record_Element_Constraint); - Ch := Matches (I); - Location_Copy (Nrec_El, Ch); - Set_Parent (Nrec_El, Ntype); - Set_Identifier (Nrec_El, Get_Identifier (Rec_El)); - pragma Assert (I = Natural (Get_Element_Position (Rec_El))); - Set_Element_Position (Nrec_El, Iir_Index32 (I)); - Ch := Get_Associated_Expr (Ch); - Set_Type (Nrec_El, Get_Type (Get_Actual (Ch))); - Append_Owned_Element_Constraint (Ntype, Nrec_El); - end if; - Staticness := Min (Staticness, - Get_Type_Staticness (Get_Type (Nrec_El))); - Set_Nth_Element (Nel_List, I, Nrec_El); - end loop; - Set_Type_Staticness (Ntype, Staticness); - Set_Constraint_State (Ntype, Fully_Constrained); - - Set_Actual_Type (Assoc, Ntype); - end; - else - Set_Actual_Type (Assoc, Atype); - end if; - end Finish_Individual_Assoc_Record; - - -- Free recursively all the choices of ASSOC. Once the type is computed - -- this is not needed anymore. - procedure Clean_Individual_Association (Assoc : Iir) - is - El, N_El : Iir; - Expr : Iir; - begin - El := Get_Individual_Association_Chain (Assoc); - Set_Individual_Association_Chain (Assoc, Null_Iir); - - while Is_Valid (El) loop - N_El := Get_Chain (El); - - pragma Assert (Get_Kind (El) in Iir_Kinds_Choice); - Expr := Get_Associated_Expr (El); - if Get_Kind (Expr) = Iir_Kind_Association_Element_By_Individual then - Clean_Individual_Association (Expr); - Free_Iir (Expr); - end if; - - Free_Iir (El); - El := N_El; - end loop; - end Clean_Individual_Association; - - -- Called by sem_individual_association to finish the analyze of - -- individual association ASSOC: compute bounds, detect missing elements. - procedure Finish_Individual_Association (Assoc : Iir) - is - Inter : Iir; - Atype : Iir; - begin - -- Guard. - if Assoc = Null_Iir or else Get_Choice_Staticness (Assoc) /= Locally then - return; - end if; - - Inter := Get_Interface_Of_Formal (Get_Formal (Assoc)); - Atype := Get_Type (Inter); - Set_Whole_Association_Flag (Assoc, True); - - case Get_Kind (Atype) is - when Iir_Kind_Array_Subtype_Definition - | Iir_Kind_Array_Type_Definition => - if Get_Constraint_State (Atype) = Fully_Constrained then - Finish_Individual_Assoc_Array_Subtype (Assoc, Atype, 1); - Set_Actual_Type (Assoc, Atype); - else - Atype := Create_Array_Subtype (Atype, Get_Location (Assoc)); - Set_Index_Constraint_Flag (Atype, True); - Set_Constraint_State (Atype, Fully_Constrained); - if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration - then - -- The subtype is used for signals. - Set_Has_Signal_Flag (Atype, True); - end if; - Set_Actual_Type (Assoc, Atype); - Set_Actual_Type_Definition (Assoc, Atype); - Finish_Individual_Assoc_Array (Assoc, Assoc, 1); - end if; - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - Finish_Individual_Assoc_Record (Assoc, Atype); - when others => - Error_Kind ("finish_individual_association", Atype); - end case; - - -- Free the hierarchy, keep only the top individual association. - Clean_Individual_Association (Assoc); - end Finish_Individual_Association; - - -- Sem individual associations of ASSOCS: - -- Add an Iir_Kind_Association_Element_By_Individual before each - -- group of individual association for the same formal, and call - -- Finish_Individual_Association with each of these added nodes. - -- - -- The purpose of By_Individual association is to have the type of the - -- actual (might be an array subtype), and also to be sure that all - -- sub-elements are associated. For that a tree is created. The tree is - -- rooted by the top Association_Element_By_Individual, which contains a - -- chain of choices (like the aggregate). The child of a choice is either - -- an Association_Element written by the user, or a new subtree rooted - -- by another Association_Element_By_Individual. The tree doesn't - -- follow all the ownership rules: the formal of sub association_element - -- are directly set to the association, and the associated_expr of the - -- choices are directly set to formals. - -- - -- This tree is temporary (used only during analysis of the individual - -- association) and removed once the check is done. - procedure Sem_Individual_Association (Assoc_Chain : in out Iir) - is - Assoc : Iir; - Prev_Assoc : Iir; - Iassoc : Iir_Association_Element_By_Individual; - Cur_Iface : Iir; - Formal : Iir; - begin - Iassoc := Null_Iir; - Cur_Iface := Null_Iir; - Prev_Assoc := Null_Iir; - Assoc := Assoc_Chain; - while Assoc /= Null_Iir loop - Formal := Get_Formal (Assoc); - if Formal /= Null_Iir then - Formal := Get_Object_Prefix (Formal); - end if; - if Formal = Null_Iir or else Formal /= Cur_Iface then - -- New formal name, analyze the current individual association - -- (if any). - Finish_Individual_Association (Iassoc); - Cur_Iface := Formal; - Iassoc := Null_Iir; - end if; - - if Get_Whole_Association_Flag (Assoc) = False then - -- Individual association. - if Iassoc = Null_Iir then - -- The first one for the interface: create a new individual - -- association. - Iassoc := - Create_Iir (Iir_Kind_Association_Element_By_Individual); - Location_Copy (Iassoc, Assoc); - Set_Choice_Staticness (Iassoc, Locally); - pragma Assert (Cur_Iface /= Null_Iir); - Set_Formal - (Iassoc, - Build_Simple_Name (Cur_Iface, Get_Location (Formal))); - -- Insert IASSOC. - if Prev_Assoc = Null_Iir then - Assoc_Chain := Iassoc; - else - Set_Chain (Prev_Assoc, Iassoc); - end if; - Set_Chain (Iassoc, Assoc); - end if; - - -- Add this individual association to the tree. - Add_Individual_Association (Iassoc, Assoc); - end if; - Prev_Assoc := Assoc; - Assoc := Get_Chain (Assoc); - end loop; - -- There is maybe a remaining iassoc. - Finish_Individual_Association (Iassoc); - end Sem_Individual_Association; - - function Is_Conversion_Function (Assoc_Chain : Iir) return Boolean is - begin - -- [...] whose single parameter of the function [...] - if not Is_Chain_Length_One (Assoc_Chain) then - return False; - end if; - if Get_Kind (Assoc_Chain) /= Iir_Kind_Association_Element_By_Expression - then - return False; - end if; - -- FIXME: unfortunatly, the formal may already be set with the - -- interface. --- if Get_Formal (Assoc_Chain) /= Null_Iir then --- return Null_Iir; --- end if; - return True; - end Is_Conversion_Function; - - function Is_Valid_Conversion - (Func : Iir; Res_Base_Type : Iir; Param_Base_Type : Iir) return Boolean - is - R_Type : Iir; - P_Type : Iir; - begin - case Get_Kind (Func) is - when Iir_Kind_Function_Declaration => - R_Type := Get_Type (Func); - P_Type := Get_Type (Get_Interface_Declaration_Chain (Func)); - if Get_Base_Type (R_Type) = Res_Base_Type - and then Get_Base_Type (P_Type) = Param_Base_Type - then - return True; - else - return False; - end if; - when Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration => - R_Type := Get_Type (Func); - if Get_Base_Type (R_Type) = Res_Base_Type - and then Are_Types_Closely_Related (R_Type, Param_Base_Type) - then - return True; - else - return False; - end if; - when Iir_Kind_Function_Call => - return Is_Valid_Conversion (Get_Implementation (Func), - Res_Base_Type, Param_Base_Type); - when Iir_Kind_Type_Conversion => - return Is_Valid_Conversion (Get_Type_Mark (Func), - Res_Base_Type, Param_Base_Type); - when Iir_Kinds_Denoting_Name => - return Is_Valid_Conversion (Get_Named_Entity (Func), - Res_Base_Type, Param_Base_Type); - when others => - return False; - end case; - end Is_Valid_Conversion; - - function Extract_Conversion - (Conv : Iir; Res_Type : Iir; Param_Type : Iir; Loc : Iir) return Iir - is - List : Iir_List; - It : List_Iterator; - Res_Base_Type : Iir; - Param_Base_Type : Iir; - El : Iir; - Res : Iir; - begin - Res_Base_Type := Get_Base_Type (Res_Type); - if Param_Type = Null_Iir then - -- In case of error. - return Null_Iir; - end if; - Param_Base_Type := Get_Base_Type (Param_Type); - if Is_Overload_List (Conv) then - List := Get_Overload_List (Conv); - Res := Null_Iir; - It := List_Iterate (List); - while Is_Valid (It) loop - El := Get_Element (It); - if Is_Valid_Conversion (El, Res_Base_Type, Param_Base_Type) then - if Res /= Null_Iir then - raise Internal_Error; - end if; - Free_Iir (Conv); - Res := El; - end if; - Next (It); - end loop; - else - if Is_Valid_Conversion (Conv, Res_Base_Type, Param_Base_Type) then - Res := Conv; - else - Res := Null_Iir; - Error_Msg_Sem (+Loc, "conversion function or type does not match"); - end if; - end if; - return Res; - end Extract_Conversion; - - function Extract_In_Conversion - (Conv : Iir; Res_Type : Iir; Param_Type : Iir) return Iir - is - Func : Iir; - Assoc : Iir; - begin - if Conv = Null_Iir then - return Null_Iir; - end if; - Func := Extract_Conversion (Conv, Res_Type, Param_Type, Conv); - if Func = Null_Iir then - return Null_Iir; - end if; - case Get_Kind (Func) is - when Iir_Kind_Function_Call => - Assoc := Get_Parameter_Association_Chain (Func); - Free_Iir (Assoc); - Set_Parameter_Association_Chain (Func, Null_Iir); - Name_To_Method_Object (Func, Conv); - return Func; - when Iir_Kind_Type_Conversion => - return Func; - when others => - Error_Kind ("extract_in_conversion", Func); - end case; - end Extract_In_Conversion; - - function Extract_Out_Conversion - (Conv : Iir; Res_Type : Iir; Param_Type : Iir) return Iir - is - Func : Iir; - begin - if Conv = Null_Iir then - return Null_Iir; - end if; - Func := Extract_Conversion (Conv, Res_Type, Param_Type, Conv); - - return Func; - end Extract_Out_Conversion; - - procedure Sem_Association_Open - (Assoc : Iir; - Finish : Boolean; - Match : out Compatibility_Level) - is - Formal : Iir; - begin - if Finish then - -- LRM 4.3.3.2 Associations lists - -- It is an error if an actual of open is associated with a - -- formal that is associated individually. - if Get_Whole_Association_Flag (Assoc) = False then - Error_Msg_Sem - (+Assoc, "cannot associate individually with open"); - end if; - - Formal := Get_Formal (Assoc); - if Formal /= Null_Iir then - Set_Formal (Assoc, Finish_Sem_Name (Formal)); - end if; - end if; - Match := Fully_Compatible; - end Sem_Association_Open; - - procedure Sem_Association_Package_Type_Not_Finish - (Assoc : Iir; - Inter : Iir; - Match : out Compatibility_Level) - is - Formal : constant Iir := Get_Formal (Assoc); - begin - if Formal = Null_Iir then - -- Can be associated only once - Match := Fully_Compatible; - else - if Kind_In (Formal, Iir_Kind_Simple_Name, Iir_Kind_Operator_Symbol) - and then Get_Identifier (Formal) = Get_Identifier (Inter) - then - Match := Fully_Compatible; - else - Match := Not_Compatible; - end if; - end if; - end Sem_Association_Package_Type_Not_Finish; - - procedure Sem_Association_Package_Type_Finish (Assoc : Iir; Inter : Iir) - is - Formal : constant Iir := Get_Formal (Assoc); - begin - if Formal /= Null_Iir then - pragma Assert (Get_Identifier (Formal) = Get_Identifier (Inter)); - pragma Assert (Get_Named_Entity (Formal) = Inter); - Set_Formal (Assoc, Finish_Sem_Name (Formal)); - end if; - end Sem_Association_Package_Type_Finish; - - procedure Sem_Association_Package - (Assoc : Iir; - Inter : Iir; - Finish : Boolean; - Match : out Compatibility_Level) - is - Actual : Iir; - Package_Inter : Iir; - begin - if not Finish then - Sem_Association_Package_Type_Not_Finish (Assoc, Inter, Match); - return; - end if; - - Match := Not_Compatible; - Sem_Association_Package_Type_Finish (Assoc, Inter); - - -- Analyze actual. - Actual := Get_Actual (Assoc); - Actual := Sem_Denoting_Name (Actual); - Set_Actual (Assoc, Actual); - - Actual := Get_Named_Entity (Actual); - if Is_Error (Actual) then - return; - end if; - - -- LRM08 6.5.7.2 Generic map aspects - -- An actual associated with a formal generic package in a - -- generic map aspect shall be the name that denotes an instance - -- of the uninstantiated package named in the formal generic - -- package declaration [...] - if Get_Kind (Actual) /= Iir_Kind_Package_Instantiation_Declaration then - Error_Msg_Sem - (+Assoc, "actual of association is not a package instantiation"); - return; - end if; - - Package_Inter := Get_Uninstantiated_Package_Decl (Inter); - if Get_Uninstantiated_Package_Decl (Actual) /= Package_Inter then - Error_Msg_Sem - (+Assoc, - "actual package name is not an instance of interface package"); - return; - end if; - - -- LRM08 6.5.7.2 Generic map aspects - -- b) If the formal generic package declaration includes an interface - -- generic map aspect in the form that includes the box (<>) symbol, - -- then the instantiaed package denotes by the actual may be any - -- instance of the uninstantiated package named in the formal - -- generic package declaration. - if Get_Generic_Map_Aspect_Chain (Inter) = Null_Iir then - null; - else - -- Other cases not yet handled. - raise Internal_Error; - end if; - - Match := Fully_Compatible; - - return; - end Sem_Association_Package; - - -- Create an implicit association_element_subprogram for the declaration - -- of function ID for ACTUAL_Type (a type/subtype definition). - function Sem_Implicit_Operator_Association - (Id : Name_Id; Actual_Type : Iir; Actual_Name : Iir) return Iir - is - use Sem_Scopes; - - -- Return TRUE if DECL is a function declaration with a comparaison - -- operator profile. - function Has_Comparaison_Profile (Decl : Iir) return Boolean - is - Inter : Iir; - begin - -- A function declaration. - if not Is_Function_Declaration (Decl) then - return False; - end if; - -- That returns a boolean. - if (Get_Base_Type (Get_Return_Type (Decl)) - /= Std_Package.Boolean_Type_Definition) - then - return False; - end if; - - -- With 2 interfaces of type ATYPE. - Inter := Get_Interface_Declaration_Chain (Decl); - for I in 1 .. 2 loop - if Inter = Null_Iir then - return False; - end if; - if Get_Base_Type (Get_Type (Inter)) /= Get_Base_Type (Actual_Type) - then - return False; - end if; - Inter := Get_Chain (Inter); - end loop; - if Inter /= Null_Iir then - return False; - end if; - return True; - end Has_Comparaison_Profile; - - Interp : Name_Interpretation_Type; - Decl : Iir; - Res : Iir; - begin - Interp := Get_Interpretation (Id); - while Valid_Interpretation (Interp) loop - Decl := Get_Declaration (Interp); - if Has_Comparaison_Profile (Decl) then - Res := Create_Iir (Iir_Kind_Association_Element_Subprogram); - Location_Copy (Res, Actual_Name); - Set_Actual - (Res, Build_Simple_Name (Decl, Get_Location (Actual_Name))); - Set_Use_Flag (Decl, True); - return Res; - end if; - Interp := Get_Next_Interpretation (Interp); - end loop; - - Error_Msg_Sem (+Actual_Name, "cannot find a %i declaration for type %i", - (+Id, +Actual_Name)); - return Null_Iir; - end Sem_Implicit_Operator_Association; - - procedure Sem_Association_Type (Assoc : Iir; - Inter : Iir; - Finish : Boolean; - Match : out Compatibility_Level) - is - Inter_Def : constant Iir := Get_Type (Inter); - Actual : Iir; - Actual_Type : Iir; - Op_Eq, Op_Neq : Iir; - begin - if not Finish then - Sem_Association_Package_Type_Not_Finish (Assoc, Inter, Match); - return; - end if; - - Match := Fully_Compatible; - Sem_Association_Package_Type_Finish (Assoc, Inter); - Actual := Get_Actual (Assoc); - - -- LRM08 6.5.7.2 Generic map aspects - -- An actual associated with a formal generic type must be a subtype - -- indication. - -- FIXME: ghdl only supports type_mark! - Actual := Sem_Types.Sem_Subtype_Indication (Actual); - Set_Actual (Assoc, Actual); - - -- Set type association for analysis of reference to this interface. - pragma Assert (Is_Null (Get_Associated_Type (Inter_Def))); - if Get_Kind (Actual) in Iir_Kinds_Subtype_Definition then - Actual_Type := Actual; - else - Actual_Type := Get_Type (Actual); - end if; - Set_Actual_Type (Assoc, Actual_Type); - Set_Associated_Type (Inter_Def, Actual_Type); - - -- FIXME: it is not clear at all from the LRM how the implicit - -- associations are done... - Op_Eq := Sem_Implicit_Operator_Association - (Std_Names.Name_Op_Equality, Actual_Type, Actual); - if Op_Eq /= Null_Iir then - Op_Neq := Sem_Implicit_Operator_Association - (Std_Names.Name_Op_Inequality, Actual_Type, Actual); - Set_Chain (Op_Eq, Op_Neq); - Set_Subprogram_Association_Chain (Assoc, Op_Eq); - end if; - end Sem_Association_Type; - - function Has_Interface_Subprogram_Profile - (Inter : Iir; - Decl : Iir; - Explain_Loc : Location_Type := No_Location) return Boolean - is - -- Handle previous assocation of interface type before full - -- instantiation. - function Get_Inter_Type (Inter : Iir) return Iir - is - Res : Iir; - begin - Res := Get_Type (Inter); - if Get_Kind (Res) = Iir_Kind_Interface_Type_Definition then - -- FIXME: recurse ? - return Get_Associated_Type (Res); - else - return Res; - end if; - end Get_Inter_Type; - - Explain : constant Boolean := Explain_Loc /= No_Location; - El_Inter, El_Decl : Iir; - begin - case Iir_Kinds_Interface_Subprogram_Declaration (Get_Kind (Inter)) is - when Iir_Kind_Interface_Function_Declaration => - if not Is_Function_Declaration (Decl) then - if Explain then - Error_Msg_Sem (Explain_Loc, " actual is not a function"); - end if; - return False; - end if; - if Get_Base_Type (Get_Inter_Type (Inter)) - /= Get_Base_Type (Get_Type (Decl)) - then - if Explain then - Error_Msg_Sem (Explain_Loc, " return type doesn't match"); - end if; - return False; - end if; - when Iir_Kind_Interface_Procedure_Declaration => - if not Is_Procedure_Declaration (Decl) then - if Explain then - Error_Msg_Sem (Explain_Loc, " actual is not a procedure"); - end if; - return False; - end if; - end case; - - El_Inter := Get_Interface_Declaration_Chain (Inter); - El_Decl := Get_Interface_Declaration_Chain (Decl); - loop - exit when Is_Null (El_Inter) and Is_Null (El_Decl); - if Is_Null (El_Inter) or Is_Null (El_Decl) then - if Explain then - Error_Msg_Sem - (Explain_Loc, " number of interfaces doesn't match"); - end if; - return False; - end if; - if Get_Base_Type (Get_Inter_Type (El_Inter)) - /= Get_Base_Type (Get_Type (El_Decl)) - then - if Explain then - Error_Msg_Sem - (Explain_Loc, - " type of interface %i doesn't match", +El_Inter); - end if; - return False; - end if; - El_Inter := Get_Chain (El_Inter); - El_Decl := Get_Chain (El_Decl); - end loop; - - return True; - end Has_Interface_Subprogram_Profile; - - procedure Sem_Association_Subprogram (Assoc : Iir; - Inter : Iir; - Finish : Boolean; - Match : out Compatibility_Level) - is - Discard : Boolean; - pragma Unreferenced (Discard); - Actual : Iir; - Res : Iir; - begin - if not Finish then - Sem_Association_Package_Type_Not_Finish (Assoc, Inter, Match); - return; - end if; - - Match := Fully_Compatible; - Sem_Association_Package_Type_Finish (Assoc, Inter); - Actual := Get_Actual (Assoc); - - -- LRM08 6.5.7.2 Generic map aspects - -- An actual associated with a formal generic subprogram shall be a name - -- that denotes a subprogram whose profile conforms to that of the - -- formal, or the reserved word OPEN. The actual, if a predefined - -- attribute name that denotes a function, shall be one of the - -- predefined attributes 'IMAGE, 'VALUE, 'POS, 'VAL, 'SUCC, 'PREV, - -- 'LEFTOF, or 'RIGHTOF. - Sem_Name (Actual); - Res := Get_Named_Entity (Actual); - - if Is_Error (Res) then - return; - end if; - - case Get_Kind (Res) is - when Iir_Kinds_Subprogram_Declaration - | Iir_Kinds_Interface_Subprogram_Declaration => - if not Has_Interface_Subprogram_Profile (Inter, Res) then - Error_Msg_Sem - (+Assoc, "profile of %n doesn't match profile of %n", - (+Actual, +Inter)); - -- Explain - Discard := Has_Interface_Subprogram_Profile - (Inter, Res, Get_Location (Assoc)); - return; - end if; - when Iir_Kind_Overload_List => - declare - Nbr_Errors : Natural; - List : Iir_List; - It : List_Iterator; - El, R : Iir; - begin - Nbr_Errors := 0; - R := Null_Iir; - List := Get_Overload_List (Res); - It := List_Iterate (List); - while Is_Valid (It) loop - El := Get_Element (It); - if Has_Interface_Subprogram_Profile (Inter, El) then - if Is_Null (R) then - R := El; - else - if Nbr_Errors = 0 then - Error_Msg_Sem - (+Assoc, - "many possible actual subprogram for %n:", - +Inter); - Error_Msg_Sem - (+Assoc, " %n declared at %l", (+R, + R)); - else - Error_Msg_Sem - (+Assoc, " %n declared at %l", (+El, +El)); - end if; - Nbr_Errors := Nbr_Errors + 1; - end if; - end if; - Next (It); - end loop; - if Is_Null (R) then - Error_Msg_Sem - (+Assoc, "no matching name for %n", +Inter); - if True then - Error_Msg_Sem - (+Assoc, " these names were incompatible:"); - It := List_Iterate (List); - while Is_Valid (It) loop - El := Get_Element (It); - Error_Msg_Sem - (+Assoc, " %n declared at %l", (+El, +El)); - Next (It); - end loop; - end if; - return; - elsif Nbr_Errors > 0 then - return; - end if; - Free_Overload_List (Res); - Res := R; - end; - when others => - Error_Kind ("sem_association_subprogram", Res); - end case; - - Set_Named_Entity (Actual, Res); - Xrefs.Xref_Name (Actual); - Sem_Decls.Mark_Subprogram_Used (Res); - end Sem_Association_Subprogram; - - -- Associate ASSOC with interface INTERFACE - -- This sets MATCH. - procedure Sem_Association_By_Expression - (Assoc : Iir; - Inter : Iir; - Formal_Name : Iir; - Formal_Conv : Iir; - Finish : Boolean; - Match : out Compatibility_Level) - is - Formal_Type : Iir; - Actual: Iir; - Out_Conv, In_Conv : Iir; - Expr : Iir; - Res_Type : Iir; - begin - Out_Conv := Formal_Conv; - if Formal_Name /= Null_Iir then - Formal_Type := Get_Type (Formal_Name); - else - Formal_Type := Get_Type (Inter); - end if; - - -- Extract conversion from actual. - -- LRM08 6.5.7.1 Association lists - Actual := Get_Actual (Assoc); - In_Conv := Null_Iir; - if Get_Kind (Inter) /= Iir_Kind_Interface_Constant_Declaration then - declare - -- Actual before the extraction of the conversion. - Prev_Actual : constant Iir := Actual; - begin - -- Extract conversion and new actual (conv_expr). - case Get_Kind (Actual) is - when Iir_Kind_Function_Call => - Expr := Get_Parameter_Association_Chain (Actual); - if Is_Conversion_Function (Expr) then - In_Conv := Actual; - Actual := Get_Actual (Expr); - end if; - when Iir_Kind_Type_Conversion => - if Flags.Vhdl_Std > Vhdl_87 then - In_Conv := Actual; - Actual := Get_Expression (Actual); - end if; - when others => - null; - end case; - - if Actual = Null_Iir then - Match := Fully_Compatible; - return; - end if; - - -- There could be an ambiguity between a conversion and a normal - -- actual expression. Check if the new actual is an object and - -- if the object is of the corresponding class. - if Is_Valid (In_Conv) then - if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then - if not Is_Signal_Object (Actual) then - -- Actual is not a signal object. This is not a - -- conversion but a regular association. - In_Conv := Null_Iir; - Actual := Prev_Actual; - end if; - else - -- Variable: let as is. - null; - end if; - end if; - end; - end if; - - -- 4 cases: F:out_conv, G:in_conv. - -- A => B type of A = type of B - -- F(A) => B type of B = type of F - -- A => G(B) type of A = type of G - -- F(A) => G(B) type of B = type of F, type of A = type of G - if Out_Conv = Null_Iir and then In_Conv = Null_Iir then - Match := Is_Expr_Compatible (Formal_Type, Actual); - else - Match := Fully_Compatible; - if In_Conv /= Null_Iir then - Match := Compatibility_Level'Min - (Match, Is_Expr_Compatible (Formal_Type, In_Conv)); - end if; - if Out_Conv /= Null_Iir then - Match := Compatibility_Level'Min - (Match, Is_Expr_Compatible (Get_Type (Out_Conv), Actual)); - end if; - end if; - - if Match = Not_Compatible then - if Finish and then not Is_Error (Actual) then - Error_Msg_Sem (+Assoc, "can't associate %n with %n", - (+Actual, +Inter), Cont => True); - Error_Msg_Sem - (+Assoc, "(type of %n is " & Disp_Type_Of (Actual) & ")", - (1 => +Actual), Cont => True); - Error_Msg_Sem - (+Inter, "(type of %n is " & Disp_Type_Of (Inter) & ")", +Inter); - end if; - return; - end if; - - if not Finish then - return; - end if; - - -- At that point, the analysis is being finished. - - if Out_Conv = Null_Iir and then In_Conv = Null_Iir then - Res_Type := Formal_Type; - else - if Out_Conv /= Null_Iir then - Res_Type := Search_Compatible_Type (Get_Type (Out_Conv), - Get_Type (Actual)); - else - Res_Type := Get_Type (Actual); - end if; - - if In_Conv /= Null_Iir then - In_Conv := Extract_In_Conversion (In_Conv, Formal_Type, Res_Type); - end if; - if Out_Conv /= Null_Iir then - Out_Conv := Extract_Out_Conversion (Out_Conv, - Res_Type, Formal_Type); - end if; - end if; - - if Res_Type = Null_Iir then - -- In case of error, do not go farther. - Match := Not_Compatible; - return; - end if; - - if Formal_Name /= Null_Iir then - declare - Formal : Iir; - Conv_Assoc : Iir; - begin - -- Extract formal from the conversion (and unlink it from the - -- conversion, as the owner of the formal is the association, not - -- the conversion). - Formal := Finish_Sem_Name (Get_Formal (Assoc)); - case Get_Kind (Formal) is - when Iir_Kind_Function_Call => - pragma Assert (Formal_Conv /= Null_Iir); - Set_Formal_Conversion (Assoc, Formal); - Conv_Assoc := Get_Parameter_Association_Chain (Formal); - Set_Parameter_Association_Chain (Formal, Null_Iir); - Formal := Get_Actual (Conv_Assoc); - Free_Iir (Conv_Assoc); - -- Name_To_Method_Object (Func, Conv); - when Iir_Kind_Type_Conversion => - pragma Assert (Formal_Conv /= Null_Iir); - Conv_Assoc := Formal; - Set_Formal_Conversion (Assoc, Formal); - Formal := Get_Expression (Formal); - Set_Expression (Conv_Assoc, Null_Iir); - when others => - pragma Assert (Formal_Conv = Null_Iir); - null; - end case; - Set_Formal (Assoc, Formal); - - -- Use the type of the formal to analyze the actual. In - -- particular, the formal may be constrained while the actual is - -- not. - Formal_Type := Get_Type (Formal); - if Out_Conv = Null_Iir and In_Conv = Null_Iir then - Res_Type := Formal_Type; - end if; - end; - end if; - - -- LRM08 6.5.7 Association lists - -- The formal part of a named association element may be in the form of - -- a function call [...] if and only if the formal is an interface - -- object, the mode of the formal is OUT, INOUT, BUFFER or LINKAGE [...] - if Out_Conv /= Null_Iir - and then Get_Mode (Inter) = Iir_In_Mode - then - Error_Msg_Sem - (+Assoc, "can't use an out conversion for an in interface"); - end if; - - -- LRM08 6.5.7 Association lists - -- The actual part of an association element may be in the form of a - -- function call [...] if and only if the mode of the format is IN, - -- INOUT or LINKAGE [...] - Set_Actual_Conversion (Assoc, In_Conv); - if In_Conv /= Null_Iir - and then Get_Mode (Inter) in Iir_Buffer_Mode .. Iir_Out_Mode - then - Error_Msg_Sem - (+Assoc, "can't use an in conversion for an out/buffer interface"); - end if; - - -- LRM08 5.3.2.2 Index constraints and discrete ranges - -- e) [...] - -- 3) [...] - -- -- For an interface object or subelement whose mode is IN, INOUT - -- or LINKAGE, if the actual part includes a conversion function - -- or a type conversion, then the result type of that function - -- or the type mark of the type conversion shall define a - -- constraint for the index range corresponding to the index - -- range of the objet, [...] - -- -- For an interface object or subelement whose mode is OUT, - -- BUFFER, INOUT or LINKAGE, if the formal part includes a - -- conversion function or a type conversion, then the parameter - -- subtype of that function or the type mark of the type - -- conversion shall define a constraint for the index range - -- corresponding to the index range of the object, [...] - if not Is_Fully_Constrained_Type (Formal_Type) then - if (Get_Mode (Inter) in Iir_In_Modes - or else Get_Mode (Inter) = Iir_Linkage_Mode) - and then In_Conv /= Null_Iir - and then not Is_Fully_Constrained_Type (Get_Type (In_Conv)) - then - Error_Msg_Sem - (+Assoc, "type of actual conversion must be fully constrained"); - end if; - if (Get_Mode (Inter) in Iir_Out_Modes - or else Get_Mode (Inter) = Iir_Linkage_Mode) - and then Out_Conv /= Null_Iir - and then not Is_Fully_Constrained_Type (Get_Type (Out_Conv)) - then - Error_Msg_Sem - (+Assoc, "type of formal conversion must be fully constrained"); - end if; - end if; - - -- FIXME: LRM refs - -- This is somewhat wrong. A missing conversion is not an error but - -- may result in a type mismatch. - if Get_Mode (Inter) = Iir_Inout_Mode then - if In_Conv = Null_Iir and then Out_Conv /= Null_Iir then - Error_Msg_Sem - (+Assoc, "out conversion without corresponding in conversion"); - elsif In_Conv /= Null_Iir and then Out_Conv = Null_Iir then - Error_Msg_Sem - (+Assoc, "in conversion without corresponding out conversion"); - end if; - end if; - Set_Actual (Assoc, Actual); - - -- Analyze actual. - Expr := Sem_Expression (Actual, Res_Type); - if Expr /= Null_Iir then - Expr := Eval_Expr_Check_If_Static (Expr, Res_Type); - Set_Actual (Assoc, Expr); - if In_Conv = Null_Iir and then Out_Conv = Null_Iir then - if not Eval_Is_In_Bound (Expr, Formal_Type) then - Error_Msg_Sem - (+Assoc, "actual constraints don't match formal ones"); - end if; - end if; - end if; - end Sem_Association_By_Expression; - - -- Associate ASSOC with interface INTERFACE - -- This sets MATCH. - procedure Sem_Association (Assoc : Iir; - Inter : Iir; - Formal : Iir; - Formal_Conv : Iir; - Finish : Boolean; - Match : out Compatibility_Level) is - begin - case Iir_Kinds_Interface_Declaration (Get_Kind (Inter)) is - when Iir_Kinds_Interface_Object_Declaration => - if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then - Sem_Association_Open (Assoc, Finish, Match); - else - Sem_Association_By_Expression - (Assoc, Inter, Formal, Formal_Conv, Finish, Match); - end if; - - when Iir_Kind_Interface_Package_Declaration => - Sem_Association_Package (Assoc, Inter, Finish, Match); - - when Iir_Kind_Interface_Type_Declaration => - Sem_Association_Type (Assoc, Inter, Finish, Match); - - when Iir_Kinds_Interface_Subprogram_Declaration => - Sem_Association_Subprogram (Assoc, Inter, Finish, Match); - end case; - end Sem_Association; - - procedure Sem_Association_Chain - (Interface_Chain : Iir; - Assoc_Chain: in out Iir; - Finish: Boolean; - Missing : Missing_Type; - Loc : Iir; - Match : out Compatibility_Level) - is - Assoc : Iir; - Inter : Iir; - - -- True if -Whide is enabled (save the state). - Warn_Hide_Enabled : Boolean; - - type Param_Assoc_Type is (None, Open, Individual, Whole); - - type Assoc_Array is array (Natural range <>) of Param_Assoc_Type; - Nbr_Inter : constant Natural := Get_Chain_Length (Interface_Chain); - Inter_Matched : Assoc_Array (0 .. Nbr_Inter - 1) := (others => None); - - Last_Individual : Iir; - Has_Individual : Boolean; - Pos : Integer; - Formal : Iir; - - First_Named_Assoc : Iir; - Last_Named_Assoc : Iir; - - Formal_Name : Iir; - Formal_Conv : Iir; - begin - Match := Fully_Compatible; - First_Named_Assoc := Null_Iir; - Has_Individual := False; - - -- Loop on every assoc element, try to match it. - Inter := Interface_Chain; - Last_Individual := Null_Iir; - Pos := 0; - - -- First positional associations - Assoc := Assoc_Chain; - while Assoc /= Null_Iir loop - Formal := Get_Formal (Assoc); - exit when Formal /= Null_Iir; - - -- Try to match actual of ASSOC with the interface. - if Inter = Null_Iir then - if Finish then - Error_Msg_Sem (+Assoc, "too many actuals for %n", +Loc); - end if; - Match := Not_Compatible; - return; - end if; - Set_Whole_Association_Flag (Assoc, True); - Sem_Association (Assoc, Inter, Null_Iir, Null_Iir, Finish, Match); - if Match = Not_Compatible then - return; - end if; - if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then - Inter_Matched (Pos) := Open; - else - Inter_Matched (Pos) := Whole; - end if; - Set_Whole_Association_Flag (Assoc, True); - Inter := Get_Chain (Inter); - - Pos := Pos + 1; - Assoc := Get_Chain (Assoc); - end loop; - - -- Then association by name. - if Assoc /= Null_Iir then - -- Make interfaces visible - -- - -- LRM08 12.3 Visibility - -- A declaration is visible by selection at places that are defined - -- as follows: - -- j) For a formal parameter declaration of a given subprogram - -- declaration: at the place of the formal part (before the - -- compound delimiter =>) of a named parameter association - -- element of a corresponding subprogram call. - -- k) For a local generic declaration of a given component - -- declaration ... - -- l) For a local port declaration of a given component declaration: - -- ... - -- m) For a formal generic declaration of a given entity declaration: - -- ... - -- n) For a formal port declaration of a given entity declaration: - -- ... - -- o) For a formal generic declaration or a formal port declaration - -- of a given block statement: ... - -- p) For a formal generic declaration of a given package - -- declaration: ... - -- q) For a formal generic declaration of a given subprogram - -- declarations: ... - -- - -- At a place in which a given declaration is visible by selection, - -- every declaration with the same designator as the given - -- declaration and that would otherwise be directly visible is - -- hidden. - Sem_Scopes.Open_Declarative_Region; - - -- Do not warn about hidding here, way to common, way useless. - Warn_Hide_Enabled := Is_Warning_Enabled (Warnid_Hide); - Enable_Warning (Warnid_Hide, False); - - Sem_Scopes.Add_Declarations_From_Interface_Chain (Interface_Chain); - - Enable_Warning (Warnid_Hide, Warn_Hide_Enabled); - - First_Named_Assoc := Assoc; - loop - if Formal = Null_Iir then - -- Positional after named argument. Already caught by - -- Sem_Actual_Of_Association_Chain (because it is called only - -- once, while sem_association_chain may be called several - -- times). - Match := Not_Compatible; - exit; - end if; - - -- Last assoc to be cleaned up. - Last_Named_Assoc := Assoc; - - if Finish then - Sem_Name (Formal); - else - Sem_Name_Soft (Formal); - end if; - Formal_Name := Get_Named_Entity (Formal); - if Is_Error (Formal_Name) then - if Finish then - -- FIXME: display the name of subprg or component/entity. - -- FIXME: fetch the interface (for parenthesis_name). - -- FIXME: this is always a duplicate of a message from - -- Sem_Name. - Error_Msg_Sem (+Assoc, "no interface for %n in association", - +Get_Formal (Assoc)); - end if; - Match := Not_Compatible; - exit; - end if; - - Assoc := Get_Chain (Assoc); - exit when Assoc = Null_Iir; - Formal := Get_Formal (Assoc); - end loop; - - -- Remove visibility by selection of interfaces. This is needed - -- to correctly analyze actuals. - Sem_Scopes.Close_Declarative_Region; - - if Match /= Not_Compatible then - Assoc := First_Named_Assoc; - loop - Formal := Get_Formal (Assoc); - Formal_Name := Get_Named_Entity (Formal); - - -- Extract conversion - Formal_Conv := Null_Iir; - case Get_Kind (Formal_Name) is - when Iir_Kind_Function_Call => - -- Only one actual - declare - Call_Assoc : constant Iir := - Get_Parameter_Association_Chain (Formal_Name); - begin - if (Get_Kind (Call_Assoc) - /= Iir_Kind_Association_Element_By_Expression) - or else Get_Chain (Call_Assoc) /= Null_Iir - or else Get_Formal (Call_Assoc) /= Null_Iir - or else (Get_Actual_Conversion (Call_Assoc) - /= Null_Iir) - then - if Finish then - Error_Msg_Sem - (+Assoc, "ill-formed formal conversion"); - end if; - Match := Not_Compatible; - exit; - end if; - Formal_Conv := Formal_Name; - Formal_Name := Get_Actual (Call_Assoc); - end; - when Iir_Kind_Type_Conversion => - Formal_Conv := Formal_Name; - Formal_Name := Get_Expression (Formal_Name); - when Iir_Kind_Slice_Name - | Iir_Kind_Indexed_Name - | Iir_Kind_Selected_Element - | Iir_Kind_Simple_Name => - null; - when others => - Formal_Name := Formal; - end case; - case Get_Kind (Formal_Name) is - when Iir_Kind_Selected_Element - | Iir_Kind_Slice_Name - | Iir_Kind_Indexed_Name => - Inter := Get_Base_Name (Formal_Name); - Set_Whole_Association_Flag (Assoc, False); - when Iir_Kind_Simple_Name - | Iir_Kind_Operator_Symbol => - Inter := Get_Named_Entity (Formal_Name); - Formal_Name := Inter; - Set_Whole_Association_Flag (Assoc, True); - when others => - -- Error - if Finish then - Error_Msg_Sem (+Assoc, "formal is not a name"); - end if; - Match := Not_Compatible; - exit; - end case; - - -- Simplify overload list (for interface subprogram). - -- FIXME: Interface must hide previous subprogram declarations, - -- so there should be no need to filter. - if Is_Overload_List (Inter) then - declare - List : constant Iir_List := Get_Overload_List (Inter); - It : List_Iterator; - Filtered_Inter : Iir; - El : Iir; - begin - Filtered_Inter := Null_Iir; - It := List_Iterate (List); - while Is_Valid (It) loop - El := Get_Element (It); - if Get_Kind (El) in Iir_Kinds_Interface_Declaration - and then - Get_Parent (El) = Get_Parent (Interface_Chain) - then - Add_Result (Filtered_Inter, El); - end if; - Next (It); - end loop; - Free_Overload_List (Inter); - Inter := Filtered_Inter; - - pragma Assert - (Get_Kind (Formal) = Iir_Kind_Simple_Name - or else - Get_Kind (Formal) = Iir_Kind_Operator_Symbol); - Set_Named_Entity (Formal, Inter); - - if Inter = Null_Iir then - if Finish then - Error_Msg_Sem (+Assoc, "no interface %i for %n", - (+Formal, +Loc)); - end if; - Match := Not_Compatible; - exit; - end if; - - if Is_Overload_List (Inter) then - if Finish then - Error_Msg_Sem (+Assoc, "ambiguous formal name"); - end if; - Match := Not_Compatible; - exit; - end if; - end; - end if; - if Get_Kind (Inter) not in Iir_Kinds_Interface_Declaration - or else Interface_Chain = Null_Iir - or else Get_Parent (Inter) /= Get_Parent (Interface_Chain) - then - if Finish then - Error_Msg_Sem - (+Assoc, "%n is not an interface name", +Inter); - end if; - Match := Not_Compatible; - exit; - end if; - - -- LRM 4.3.2.2 Association Lists - -- The formal part of a named element association may be - -- in the form of a function call, [...], if and only - -- if the mode of the formal is OUT, INOUT, BUFFER, or - -- LINKAGE, and the actual is not OPEN. - if Formal_Conv /= Null_Iir - and then (Get_Kind (Inter) - not in Iir_Kinds_Interface_Object_Declaration - or else Get_Mode (Inter) = Iir_In_Mode) - then - if Finish then - Error_Msg_Sem - (+Assoc, - "formal conversion allowed only for interface object"); - end if; - Match := Not_Compatible; - exit; - end if; - - -- Find the Interface. - declare - Inter1 : Iir; - begin - Inter1 := Interface_Chain; - Pos := 0; - while Inter1 /= Null_Iir loop - exit when Inter = Inter1; - Inter1 := Get_Chain (Inter1); - Pos := Pos + 1; - end loop; - if Inter1 = Null_Iir then - if Finish then - Error_Msg_Sem - (+Assoc, - "no corresponding interface for %i", +Inter); - end if; - Match := Not_Compatible; - exit; - end if; - end; - - Sem_Association - (Assoc, Inter, Formal_Name, Formal_Conv, Finish, Match); - exit when Match = Not_Compatible; - - if Get_Whole_Association_Flag (Assoc) then - -- Whole association. - Last_Individual := Null_Iir; - if Inter_Matched (Pos) = None then - if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open - then - Inter_Matched (Pos) := Open; - else - Inter_Matched (Pos) := Whole; - end if; - else - if Finish then - Error_Msg_Sem - (+Assoc, "%n already associated", +Inter); - end if; - Match := Not_Compatible; - exit; - end if; - else - -- Individual association. - Has_Individual := True; - if Inter_Matched (Pos) /= Whole then - if Finish - and then Inter_Matched (Pos) = Individual - and then Last_Individual /= Inter - then - Error_Msg_Sem - (+Assoc, - "non consecutive individual association for %n", - +Inter); - Match := Not_Compatible; - exit; - end if; - Last_Individual := Inter; - Inter_Matched (Pos) := Individual; - else - if Finish then - Error_Msg_Sem - (+Assoc, "%n already associated", +Inter); - Match := Not_Compatible; - exit; - end if; - end if; - end if; - - Assoc := Get_Chain (Assoc); - exit when Assoc = Null_Iir; - end loop; - end if; - - if Finish and Has_Individual and Match /= Not_Compatible then - Sem_Individual_Association (Assoc_Chain); - end if; - - if not Finish then - -- Always cleanup if not finishing: there can be other tries in - -- case of overloading. - Assoc := First_Named_Assoc; - while Assoc /= Null_Iir loop - Formal := Get_Formal (Assoc); - -- User may have used by position assoc after named - -- assocs. - if Is_Valid (Formal) then - Sem_Name_Clean (Formal); - end if; - exit when Assoc = Last_Named_Assoc; - Assoc := Get_Chain (Assoc); - end loop; - end if; - - if Match = Not_Compatible then - return; - end if; - end if; - - if Missing = Missing_Allowed then - -- No need to check for missing associations. - return; - end if; - - -- LRM93 8.6 Procedure Call Statement - -- For each formal parameter of a procedure, a procedure call must - -- specify exactly one corresponding actual parameter. - -- This actual parameter is specified either explicitly, by an - -- association element (other than the actual OPEN) in the association - -- list, or in the absence of such an association element, by a default - -- expression (see Section 4.3.3.2). - - -- LRM93 7.3.3 Function Calls - -- For each formal parameter of a function, a function call must - -- specify exactly one corresponding actual parameter. - -- This actual parameter is specified either explicitly, by an - -- association element (other than the actual OPEN) in the association - -- list, or in the absence of such an association element, by a default - -- expression (see Section 4.3.3.2). - - -- LRM93 1.1.1.2 / LRM08 6.5.6.3 Port clauses - -- A port of mode IN may be unconnected or unassociated only if its - -- declaration includes a default expression. - -- A port of any mode other than IN may be unconnected or unassociated - -- as long as its type is not an unconstrained array type. - - -- LRM08 6.5.6.2 Generic clauses - -- It is an error if no such actual [instantiated package] is specified - -- for a given formal generic package (either because the formal generic - -- is unassociated or because the actual is OPEN). - - Inter := Interface_Chain; - Pos := 0; - while Inter /= Null_Iir loop - if Inter_Matched (Pos) <= Open then - -- Interface is unassociated (none or open). - case Get_Kind (Inter) is - when Iir_Kinds_Interface_Object_Declaration => - case Missing is - when Missing_Parameter - | Missing_Generic => - if Get_Mode (Inter) /= Iir_In_Mode - or else Get_Default_Value (Inter) = Null_Iir - then - if Finish then - Error_Msg_Sem (+Loc, "no actual for %n", +Inter); - end if; - Match := Not_Compatible; - return; - end if; - when Missing_Port => - case Get_Mode (Inter) is - when Iir_In_Mode => - -- No overloading for components/entities. - pragma Assert (Finish); - if Get_Default_Value (Inter) = Null_Iir then - Error_Msg_Sem - (+Loc, - "%n of mode IN must be connected", +Inter); - Match := Not_Compatible; - return; - end if; - when Iir_Out_Mode - | Iir_Linkage_Mode - | Iir_Inout_Mode - | Iir_Buffer_Mode => - -- No overloading for components/entities. - pragma Assert (Finish); - if not (Is_Fully_Constrained_Type - (Get_Type (Inter))) - then - Error_Msg_Sem - (+Loc, - "unconstrained %n must be connected", - +Inter); - Match := Not_Compatible; - return; - end if; - when Iir_Unknown_Mode => - raise Internal_Error; - end case; - when Missing_Allowed => - null; - end case; - when Iir_Kind_Interface_Package_Declaration - | Iir_Kind_Interface_Function_Declaration - | Iir_Kind_Interface_Procedure_Declaration => - Error_Msg_Sem (+Loc, "%n must be associated", +Inter); - Match := Not_Compatible; - when others => - Error_Kind ("sem_association_chain", Inter); - end case; - end if; - - -- Clear associated type of interface type. - if Get_Kind (Inter) = Iir_Kind_Interface_Type_Declaration then - Set_Associated_Type (Get_Type (Inter), Null_Iir); - end if; - - Inter := Get_Chain (Inter); - Pos := Pos + 1; - end loop; - end Sem_Association_Chain; -end Sem_Assocs; diff --git a/src/vhdl/sem_assocs.ads b/src/vhdl/sem_assocs.ads deleted file mode 100644 index 9563138ce..000000000 --- a/src/vhdl/sem_assocs.ads +++ /dev/null @@ -1,68 +0,0 @@ --- Semantic analysis. --- 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 Iirs; use Iirs; -with Sem_Expr; use Sem_Expr; - -package Sem_Assocs is - -- Rewrite the association chain by changing the kind of assocation - -- corresponding to non-object interfaces. Such an association mustn't be - -- handled an like association for object as the actual is not an - -- expression. - function Extract_Non_Object_Association - (Assoc_Chain : Iir; Inter_Chain : Iir) return Iir; - - -- Analyze actuals of ASSOC_CHAIN. - -- Check all named associations are after positionnal one. - -- Return TRUE if no error. - function Sem_Actual_Of_Association_Chain (Assoc_Chain : Iir) return Boolean; - - -- Analyze association chain ASSOC_CHAIN with interfaces from - -- INTERFACE_CHAIN. - -- Return the level of compatibility between the two chains in LEVEL. - -- If FINISH is true, then ASSOC_CHAIN may be modifies (individual assoc - -- added), and error messages (if any) are displayed. - -- MISSING control unassociated interfaces. - -- LOC is the association. - -- Sem_Actual_Of_Association_Chain must have been called before. - type Missing_Type is (Missing_Parameter, Missing_Port, Missing_Generic, - Missing_Allowed); - procedure Sem_Association_Chain - (Interface_Chain : Iir; - Assoc_Chain: in out Iir; - Finish: Boolean; - Missing : Missing_Type; - Loc : Iir; - Match : out Compatibility_Level); - - -- Do port Sem_Association_Chain checks for subprograms. - procedure Check_Subprogram_Associations - (Inter_Chain : Iir; Assoc_Chain : Iir); - - -- Check for restrictions in LRM93 1.1.1.2 - -- Return FALSE in case of error. - function Check_Port_Association_Mode_Restrictions - (Formal : Iir_Interface_Signal_Declaration; - Actual : Iir_Interface_Signal_Declaration; - Assoc : Iir) - return Boolean; - - -- Check restrictions of LRM02 12.2.4 - procedure Check_Port_Association_Bounds_Restrictions - (Formal : Iir; Actual : Iir; Assoc : Iir); - -end Sem_Assocs; diff --git a/src/vhdl/sem_decls.adb b/src/vhdl/sem_decls.adb deleted file mode 100644 index 6e1a745c0..000000000 --- a/src/vhdl/sem_decls.adb +++ /dev/null @@ -1,2342 +0,0 @@ --- Semantic analysis. --- 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 Errorout; use Errorout; -with Types; use Types; -with Std_Names; -with Vhdl.Tokens; -with Flags; use Flags; -with Std_Package; use Std_Package; -with Evaluation; use Evaluation; -with Iirs_Utils; use Iirs_Utils; -with Sem; use Sem; -with Sem_Utils; use Sem_Utils; -with Sem_Expr; use Sem_Expr; -with Sem_Scopes; use Sem_Scopes; -with Sem_Names; use Sem_Names; -with Sem_Specs; use Sem_Specs; -with Sem_Types; use Sem_Types; -with Sem_Psl; -with Sem_Inst; -with Xrefs; use Xrefs; - -package body Sem_Decls is - -- Region that can declare signals. Used to add implicit declarations. - Current_Signals_Region : Implicit_Signal_Declaration_Type := - (Null_Iir, Null_Iir, Null_Iir, False, Null_Iir); - - procedure Push_Signals_Declarative_Part - (Cell: out Implicit_Signal_Declaration_Type; Decls_Parent : Iir) is - begin - Cell := Current_Signals_Region; - Current_Signals_Region := - (Decls_Parent, Null_Iir, Null_Iir, False, Null_Iir); - end Push_Signals_Declarative_Part; - - procedure Pop_Signals_Declarative_Part - (Cell: in Implicit_Signal_Declaration_Type) is - begin - Current_Signals_Region := Cell; - end Pop_Signals_Declarative_Part; - - -- Insert the implicit signal declaration after LAST_DECL. - procedure Insert_Implicit_Signal (Last_Decl : Iir) is - begin - if Last_Decl = Null_Iir then - Set_Declaration_Chain (Current_Signals_Region.Decls_Parent, - Current_Signals_Region.Implicit_Decl); - else - Set_Chain (Last_Decl, Current_Signals_Region.Implicit_Decl); - end if; - end Insert_Implicit_Signal; - - -- Add SIG as an implicit declaration in the current region. - procedure Add_Declaration_For_Implicit_Signal (Sig : Iir) - is - Decl : Iir; - begin - -- We deal only with signal attribute. - pragma Assert (Get_Kind (Sig) in Iir_Kinds_Signal_Attribute); - - -- There must be a declarative part for implicit signals. - pragma Assert (Current_Signals_Region.Decls_Parent /= Null_Iir); - - -- Attr_Chain must be empty. - pragma Assert (Get_Attr_Chain (Sig) = Null_Iir); - - if Current_Signals_Region.Implicit_Decl = Null_Iir then - -- Create the signal_attribute_declaration to hold all the implicit - -- signals. - Decl := Create_Iir (Iir_Kind_Signal_Attribute_Declaration); - Location_Copy (Decl, Sig); - Set_Parent (Decl, Current_Signals_Region.Decls_Parent); - - -- Save the implicit declaration. - Current_Signals_Region.Implicit_Decl := Decl; - - -- Append SIG (this is the first one). - Set_Signal_Attribute_Chain (Decl, Sig); - - if Current_Signals_Region.Decls_Analyzed then - -- Declarative region was completely analyzed. Just append DECL - -- at the end of declarations. - Insert_Implicit_Signal (Current_Signals_Region.Last_Decl); - end if; - else - -- Append SIG. - Set_Attr_Chain (Current_Signals_Region.Last_Attribute_Signal, Sig); - end if; - Current_Signals_Region.Last_Attribute_Signal := Sig; - - Set_Signal_Attribute_Declaration - (Sig, Current_Signals_Region.Implicit_Decl); - end Add_Declaration_For_Implicit_Signal; - - -- Insert pending implicit declarations after the last analyzed LAST_DECL, - -- and update it. Then the caller has to insert the declaration which - -- created the implicit declarations. - procedure Insert_Pending_Implicit_Declarations - (Parent : Iir; Last_Decl : in out Iir) is - begin - if Current_Signals_Region.Decls_Parent = Parent - and then Current_Signals_Region.Implicit_Decl /= Null_Iir - then - pragma Assert (not Current_Signals_Region.Decls_Analyzed); - - -- Add pending implicit declarations before the current one. - Insert_Implicit_Signal (Last_Decl); - Last_Decl := Current_Signals_Region.Implicit_Decl; - - -- Detach the implicit declaration. - Current_Signals_Region.Implicit_Decl := Null_Iir; - Current_Signals_Region.Last_Attribute_Signal := Null_Iir; - end if; - end Insert_Pending_Implicit_Declarations; - - -- Mark the end of declaration analysis. New implicit declarations will - -- simply be appended to the last declaration. - procedure End_Of_Declarations_For_Implicit_Declarations - (Parent : Iir; Last_Decl : Iir) is - begin - if Current_Signals_Region.Decls_Parent = Parent then - pragma Assert (not Current_Signals_Region.Decls_Analyzed); - - -- All declarations have been analyzed, new implicit declarations - -- will be appended. - Current_Signals_Region.Decls_Analyzed := True; - Current_Signals_Region.Last_Decl := Last_Decl; - end if; - end End_Of_Declarations_For_Implicit_Declarations; - - procedure Mark_Subprogram_Used (Subprg : Iir) - is - N : Iir; - begin - N := Subprg; - loop - exit when Get_Use_Flag (N); - Set_Use_Flag (N, True); - N := Sem_Inst.Get_Origin (N); - -- The origin may also be an instance. - exit when N = Null_Iir; - end loop; - end Mark_Subprogram_Used; - - -- Emit an error if the type of DECL is a file type, access type, - -- protected type or if a subelement of DECL is an access type. - procedure Check_Signal_Type (Decl : Iir) - is - Decl_Type : constant Iir := Get_Type (Decl); - begin - if Get_Signal_Type_Flag (Decl_Type) then - return; - end if; - - if Is_Error (Decl_Type) then - return; - end if; - - Error_Msg_Sem (+Decl, "type of %n cannot be %n", (+Decl, +Decl_Type)); - case Get_Kind (Decl_Type) is - when Iir_Kind_File_Type_Definition => - null; - when Iir_Kind_Protected_Type_Declaration => - null; - when Iir_Kind_Interface_Type_Definition => - null; - when Iir_Kind_Access_Type_Definition - | Iir_Kind_Access_Subtype_Definition => - null; - when Iir_Kinds_Array_Type_Definition - | Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - Error_Msg_Sem (+Decl, "(%n has an access subelement)", +Decl_Type); - when others => - Error_Kind ("check_signal_type", Decl_Type); - end case; - end Check_Signal_Type; - - procedure Sem_Interface_Object_Declaration - (Inter, Last : Iir; Interface_Kind : Interface_Kind_Type) - is - A_Type: Iir; - Default_Value: Iir; - begin - -- Avoid the reanalysed duplicated types. - -- This is not an optimization, since the unanalysed type must have - -- been freed. - A_Type := Get_Subtype_Indication (Inter); - if A_Type = Null_Iir then - if Last = Null_Iir or else not Get_Has_Identifier_List (Last) then - -- Subtype indication was not parsed. - A_Type := Create_Error_Type (Null_Iir); - Set_Subtype_Indication (Inter, A_Type); - else - A_Type := Get_Type (Last); - Default_Value := Get_Default_Value (Last); - end if; - else - A_Type := Sem_Subtype_Indication (A_Type); - Set_Subtype_Indication (Inter, A_Type); - A_Type := Get_Type_Of_Subtype_Indication (A_Type); - - Default_Value := Get_Default_Value (Inter); - if Default_Value /= Null_Iir and then not Is_Error (A_Type) then - Deferred_Constant_Allowed := True; - Default_Value := Sem_Expression (Default_Value, A_Type); - Default_Value := - Eval_Expr_Check_If_Static (Default_Value, A_Type); - Deferred_Constant_Allowed := False; - Check_Read (Default_Value); - end if; - end if; - - Set_Name_Staticness (Inter, Locally); - Xref_Decl (Inter); - - if not Is_Error (A_Type) then - Set_Type (Inter, A_Type); - - if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then - if Get_Guarded_Signal_Flag (Inter) then - case Get_Signal_Kind (Inter) is - when Iir_Bus_Kind => - -- LRM93 4.3.1.2 - -- It is also an error if a guarded signal of a scalar - -- type is neither a resolved signal nor a subelement of - -- a resolved signal. - if not Get_Resolved_Flag (A_Type) then - Error_Msg_Sem - (+Inter, "%n of guarded %n is not resolved", - (+A_Type, +Inter)); - end if; - - -- LRM 2.1.1.2 Signal parameter - -- It is an error if the declaration of a formal signal - -- parameter includes the reserved word BUS. - if Flags.Vhdl_Std >= Vhdl_93 - and then Interface_Kind in Parameter_Interface_List - then - Error_Msg_Sem - (+Inter, "signal parameter can't be of kind bus"); - end if; - when Iir_Register_Kind => - -- LRM93 4.3.2 Interface declarations - -- Grammar for interface_signal_declaration. - Error_Msg_Sem - (+Inter, "interface signal can't be of kind register"); - end case; - end if; - Set_Type_Has_Signal (A_Type); - end if; - - case Get_Kind (Inter) is - when Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_Signal_Declaration => - -- LRM 4.3.2 Interface declarations - -- For an interface constant declaration or an interface - -- signal declaration, the subtype indication must define - -- a subtype that is neither a file type, an access type, - -- nor a protected type. Moreover, the subtype indication - -- must not denote a composite type with a subelement that - -- is a file type, an access type, or a protected type. - Check_Signal_Type (Inter); - when Iir_Kind_Interface_Variable_Declaration => - case Get_Kind (Get_Base_Type (A_Type)) is - when Iir_Kind_File_Type_Definition => - if Flags.Vhdl_Std >= Vhdl_93 then - Error_Msg_Sem - (+Inter, - "variable formal can't be a file (vhdl 93)"); - end if; - when Iir_Kind_Protected_Type_Declaration => - -- LRM 2.1.1.1 Constant and variable parameters - -- It is an error if the mode of the parameter is - -- other that INOUT. - if Get_Mode (Inter) /= Iir_Inout_Mode then - Error_Msg_Sem - (+Inter, - "parameter of protected type must be inout"); - end if; - when others => - null; - end case; - when Iir_Kind_Interface_File_Declaration => - if Get_Kind (Get_Base_Type (A_Type)) - /= Iir_Kind_File_Type_Definition - then - Error_Msg_Sem - (+Inter, "file formal type must be a file type"); - end if; - when others => - -- Inter is not an interface. - raise Internal_Error; - end case; - - if Default_Value /= Null_Iir then - Set_Default_Value (Inter, Default_Value); - - -- LRM 4.3.2 Interface declarations. - -- It is an error if a default expression appears in an - -- interface declaration and any of the following conditions - -- hold: - -- - The mode is linkage - -- - The interface object is a formal signal parameter - -- - The interface object is a formal variable parameter of - -- mode other than in - -- - The subtype indication of the interface declaration - -- denotes a protected type. - case Get_Kind (Inter) is - when Iir_Kind_Interface_Constant_Declaration => - null; - when Iir_Kind_Interface_Signal_Declaration => - if Get_Mode (Inter) = Iir_Linkage_Mode then - Error_Msg_Sem - (+Inter, - "default expression not allowed for linkage port"); - elsif Interface_Kind in Parameter_Interface_List then - Error_Msg_Sem - (+Inter, - "default expression not allowed for signal parameter"); - end if; - when Iir_Kind_Interface_Variable_Declaration => - if Get_Mode (Inter) /= Iir_In_Mode then - Error_Msg_Sem - (+Inter, "default expression not allowed for" - & " out or inout variable parameter"); - elsif Get_Kind (A_Type) = Iir_Kind_Protected_Type_Declaration - then - Error_Msg_Sem - (+Inter, "default expression not allowed for" - & " variable parameter of protected type"); - end if; - when Iir_Kind_Interface_File_Declaration => - raise Internal_Error; - when others => - null; - end case; - end if; - else - Set_Type (Inter, Error_Type); - end if; - - Sem_Scopes.Add_Name (Inter); - - -- By default, interface are not static. - -- This may be changed just below. - Set_Expr_Staticness (Inter, None); - - case Interface_Kind is - when Generic_Interface_List => - -- LRM93 1.1.1 - -- The generic list in the formal generic clause defines - -- generic constants whose values may be determined by the - -- environment. - if Get_Kind (Inter) /= Iir_Kind_Interface_Constant_Declaration then - Error_Msg_Sem (+Inter, "generic %n must be a constant", +Inter); - else - -- LRM93 7.4.2 (Globally static primaries) - -- 3. a generic constant. - Set_Expr_Staticness (Inter, Globally); - end if; - when Port_Interface_List => - if Get_Kind (Inter) /= Iir_Kind_Interface_Signal_Declaration then - Error_Msg_Sem (+Inter, "port %n must be a signal", +Inter); - end if; - when Parameter_Interface_List => - if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration - and then Interface_Kind = Function_Parameter_Interface_List - then - Error_Msg_Sem (+Inter, "variable interface parameter are not " - & "allowed for a function (use a constant)"); - end if; - - -- By default, we suppose a subprogram read the activity of - -- a signal. - -- This will be adjusted when the body is analyzed. - if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration - and then Get_Mode (Inter) in Iir_In_Modes - then - Set_Has_Active_Flag (Inter, True); - end if; - - case Get_Mode (Inter) is - when Iir_Unknown_Mode => - raise Internal_Error; - when Iir_In_Mode => - null; - when Iir_Inout_Mode - | Iir_Out_Mode => - if Interface_Kind = Function_Parameter_Interface_List - and then - Get_Kind (Inter) /= Iir_Kind_Interface_File_Declaration - then - Error_Msg_Sem - (+Inter, - "mode of a function parameter cannot be inout or out"); - end if; - when Iir_Buffer_Mode - | Iir_Linkage_Mode => - Error_Msg_Sem - (+Inter, "buffer or linkage mode is not allowed " - & "for a subprogram parameter"); - end case; - end case; - end Sem_Interface_Object_Declaration; - - procedure Sem_Interface_Package_Declaration (Inter : Iir) - is - Pkg : Iir; - begin - -- LRM08 6.5.5 Interface package declarations - -- the uninstantiated_package_name shall denote an uninstantiated - -- package declared in a package declaration. - Pkg := Sem_Uninstantiated_Package_Name (Inter); - if Pkg = Null_Iir then - return; - end if; - - if Get_Generic_Map_Aspect_Chain (Inter) /= Null_Iir then - Sem_Generic_Association_Chain (Get_Package_Header (Pkg), Inter); - -- Not yet fully supported - need to check the instance. - raise Internal_Error; - end if; - - Sem_Inst.Instantiate_Package_Declaration (Inter, Pkg); - - Sem_Scopes.Add_Name (Inter); - Set_Is_Within_Flag (Inter, True); - Xref_Decl (Inter); - end Sem_Interface_Package_Declaration; - - function Create_Implicit_Interface_Function (Name : Name_Id; - Decl : Iir; - Interface_Chain : Iir; - Return_Type : Iir) - return Iir - is - Operation : Iir_Function_Declaration; - begin - Operation := Create_Iir (Iir_Kind_Interface_Function_Declaration); - Location_Copy (Operation, Decl); - Set_Parent (Operation, Get_Parent (Decl)); - Set_Interface_Declaration_Chain (Operation, Interface_Chain); - Set_Return_Type (Operation, Return_Type); - Set_Identifier (Operation, Name); - Set_Visible_Flag (Operation, True); - Set_Pure_Flag (Operation, True); - Compute_Subprogram_Hash (Operation); - return Operation; - end Create_Implicit_Interface_Function; - - procedure Sem_Interface_Type_Declaration (Inter : Iir) - is - Def : Iir; - Finters : Iir; - Op_Eq, Op_Neq : Iir; - begin - -- Create type definition. - Def := Create_Iir (Iir_Kind_Interface_Type_Definition); - Set_Location (Def, Get_Location (Inter)); - Set_Type_Declarator (Def, Inter); - Set_Type (Inter, Def); - Set_Base_Type (Def, Def); - Set_Type_Staticness (Def, None); - Set_Resolved_Flag (Def, False); - Set_Signal_Type_Flag (Def, True); - Set_Has_Signal_Flag (Def, False); - - -- Create operations for the interface type. - Finters := Create_Anonymous_Interface (Def); - Set_Chain (Finters, Create_Anonymous_Interface (Def)); - - Op_Eq := Create_Implicit_Interface_Function - (Std_Names.Name_Op_Equality, - Inter, Finters, Std_Package.Boolean_Type_Definition); - - Op_Neq := Create_Implicit_Interface_Function - (Std_Names.Name_Op_Inequality, - Inter, Finters, Std_Package.Boolean_Type_Definition); - - Set_Interface_Type_Subprograms (Inter, Op_Eq); - Set_Chain (Op_Eq, Op_Neq); - - Sem_Scopes.Add_Name (Inter); - Sem_Scopes.Add_Name (Op_Eq); - Sem_Scopes.Add_Name (Op_Neq); - Xref_Decl (Inter); - end Sem_Interface_Type_Declaration; - - procedure Sem_Interface_Subprogram_Declaration (Inter : Iir) is - begin - Sem_Subprogram_Specification (Inter); - Sem_Scopes.Add_Name (Inter); - Xref_Decl (Inter); - end Sem_Interface_Subprogram_Declaration; - - procedure Sem_Interface_Chain (Interface_Chain: Iir; - Interface_Kind : Interface_Kind_Type) - is - -- Control visibility of interface object. See below for its use. - Immediately_Visible : constant Boolean := - Interface_Kind = Generic_Interface_List - and then Flags.Vhdl_Std >= Vhdl_08; - - Inter : Iir; - - -- LAST is the last interface declaration that has a type. This is - -- used to set type and default value for the following declarations - -- that appeared in a list of identifiers. - Last : Iir; - begin - Last := Null_Iir; - - Inter := Interface_Chain; - while Inter /= Null_Iir loop - case Iir_Kinds_Interface_Declaration (Get_Kind (Inter)) is - when Iir_Kinds_Interface_Object_Declaration => - Sem_Interface_Object_Declaration (Inter, Last, Interface_Kind); - Last := Inter; - when Iir_Kind_Interface_Package_Declaration => - Sem_Interface_Package_Declaration (Inter); - when Iir_Kind_Interface_Type_Declaration => - Sem_Interface_Type_Declaration (Inter); - when Iir_Kinds_Interface_Subprogram_Declaration => - Sem_Interface_Subprogram_Declaration (Inter); - end case; - - -- LRM08 6.5.6 Interface lists - -- A name that denotes an interface object declared in a port - -- interface list of a prameter interface list shall not appear in - -- any interface declaration within the interface list containing the - -- denoted interface object expect to declare this object. - -- A name that denotes an interface declaration in a generic - -- interface list may appear in an interface declaration within the - -- interface list containing the denoted interface declaration. - if Immediately_Visible then - Name_Visible (Inter); - end if; - - Inter := Get_Chain (Inter); - end loop; - - -- LRM 10.3 Visibility - -- A declaration is visible only within a certain part of its scope; - -- this starts at the end of the declaration [...] - - -- LRM 4.3.2.1 Interface List - -- A name that denotes an interface object must not appear in any - -- interface declaration within the interface list containing the - -- denotes interface except to declare this object. - - -- GHDL: this is achieved by making the interface object visible after - -- having analyzed the interface list. - if not Immediately_Visible then - Inter := Interface_Chain; - while Inter /= Null_Iir loop - Name_Visible (Inter); - Inter := Get_Chain (Inter); - end loop; - end if; - end Sem_Interface_Chain; - - -- Analyze a type or an anonymous type declaration. - procedure Sem_Type_Declaration (Decl: Iir; Is_Global : Boolean) - is - Def: Iir; - Inter : Name_Interpretation_Type; - Old_Decl : Iir; - St_Decl : Iir_Subtype_Declaration; - Bt_Def : Iir; - begin - -- Check if DECL complete a previous incomplete type declaration. - Inter := Get_Interpretation (Get_Identifier (Decl)); - if Valid_Interpretation (Inter) - and then Is_In_Current_Declarative_Region (Inter) - then - Old_Decl := Get_Declaration (Inter); - if Get_Kind (Old_Decl) /= Iir_Kind_Type_Declaration - or else (Get_Kind (Get_Type_Definition (Old_Decl)) /= - Iir_Kind_Incomplete_Type_Definition) - then - Old_Decl := Null_Iir; - else - Set_Incomplete_Type_Declaration (Decl, Old_Decl); - end if; - else - Old_Decl := Null_Iir; - end if; - - if Old_Decl = Null_Iir then - if Get_Kind (Decl) = Iir_Kind_Type_Declaration then - -- This is necessary at least for enumeration type definition. - -- Type declaration for anonymous types don't have name, only - -- their subtype have names. Those are added later. - Sem_Scopes.Add_Name (Decl); - end if; - else - -- This is a way to prevent: - -- type a; - -- type a is access a; - -- which is non-sense. - Set_Visible_Flag (Old_Decl, False); - end if; - - -- Check the definition of the type. - Def := Get_Type_Definition (Decl); - if Def = Null_Iir then - -- Incomplete type declaration - Def := Create_Iir (Iir_Kind_Incomplete_Type_Definition); - Location_Copy (Def, Decl); - Set_Type_Definition (Decl, Def); - Set_Base_Type (Def, Def); - Set_Signal_Type_Flag (Def, True); - Set_Type_Declarator (Def, Decl); - Set_Visible_Flag (Decl, True); - Xref_Decl (Decl); - - return; - - end if; - - -- A complete type declaration. - if Old_Decl = Null_Iir then - Xref_Decl (Decl); - else - Xref_Body (Decl, Old_Decl); - end if; - - Def := Sem_Type_Definition (Def, Decl); - if Def = Null_Iir then - return; - end if; - - case Get_Kind (Def) is - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition - | Iir_Kind_Array_Subtype_Definition => - -- Some type declaration are in fact subtype declarations. - St_Decl := Create_Iir (Iir_Kind_Subtype_Declaration); - Location_Copy (St_Decl, Decl); - Set_Identifier (St_Decl, Get_Identifier (Decl)); - Set_Parent (St_Decl, Get_Parent (Decl)); - Set_Type (St_Decl, Def); - Set_Subtype_Indication (St_Decl, Def); - Set_Type_Declarator (Def, St_Decl); - Set_Chain (St_Decl, Get_Chain (Decl)); - Set_Chain (Decl, St_Decl); - - -- The type declaration declares the base type. - Bt_Def := Get_Base_Type (Def); - Set_Type_Definition (Decl, Bt_Def); - Set_Type_Declarator (Bt_Def, Decl); - Set_Subtype_Definition (Decl, Def); - - if Old_Decl = Null_Iir then - Sem_Scopes.Add_Name (St_Decl); - end if; - - Sem_Scopes.Name_Visible (St_Decl); - - -- The implicit subprogram will be added in the - -- scope just after. - Create_Implicit_Operations (Decl, False); - - when Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Array_Type_Definition - | Iir_Kind_Record_Type_Definition - | Iir_Kind_Access_Type_Definition - | Iir_Kind_File_Type_Definition => - St_Decl := Null_Iir; - Set_Type_Declarator (Def, Decl); - - Sem_Scopes.Name_Visible (Decl); - - -- The implicit subprogram will be added in the - -- scope just after. - Create_Implicit_Operations (Decl, False); - - when Iir_Kind_Protected_Type_Declaration => - Set_Type_Declarator (Def, Decl); - St_Decl := Null_Iir; - -- No implicit subprograms. - - when others => - Error_Kind ("sem_type_declaration", Def); - end case; - - if Old_Decl /= Null_Iir then - -- Complete the type definition. - declare - Old_Def : constant Iir := Get_Type_Definition (Old_Decl); - Ref : Iir; - begin - Set_Signal_Type_Flag (Old_Def, Get_Signal_Type_Flag (Def)); - Ref := Get_Incomplete_Type_Ref_Chain (Old_Def); - while Is_Valid (Ref) loop - pragma Assert - (Get_Kind (Ref) = Iir_Kind_Access_Type_Definition); - Set_Designated_Type (Ref, Def); - Ref := Get_Incomplete_Type_Ref_Chain (Ref); - end loop; - Set_Complete_Type_Definition (Old_Def, Def); - - -- The identifier now designates the complete type declaration. - if St_Decl = Null_Iir then - Replace_Name (Get_Identifier (Decl), Old_Decl, Decl); - else - Replace_Name (Get_Identifier (Decl), Old_Decl, St_Decl); - end if; - end; - end if; - - if Is_Global then - Set_Type_Has_Signal (Def); - end if; - end Sem_Type_Declaration; - - procedure Sem_Subtype_Declaration (Decl: Iir; Is_Global : Boolean) - is - Def: Iir; - Ind : Iir; - begin - -- Real hack to skip subtype declarations of anonymous type decls. - if Get_Visible_Flag (Decl) then - return; - end if; - - Sem_Scopes.Add_Name (Decl); - Xref_Decl (Decl); - - -- Analyze the definition of the type. - Ind := Get_Subtype_Indication (Decl); - Ind := Sem_Subtype_Indication (Ind); - Set_Subtype_Indication (Decl, Ind); - Def := Get_Type_Of_Subtype_Indication (Ind); - if Def = Null_Iir or else Is_Error (Def) then - return; - end if; - - if not Is_Anonymous_Type_Definition (Def) then - -- There is no added constraints and therefore the subtype - -- declaration is in fact an alias of the type. Create a copy so - -- that it has its own type declarator. - Def := Copy_Subtype_Indication (Def); - Location_Copy (Def, Decl); - Set_Subtype_Type_Mark (Def, Ind); - Set_Subtype_Indication (Decl, Def); - end if; - - Set_Type (Decl, Def); - Set_Type_Declarator (Def, Decl); - Name_Visible (Decl); - if Is_Global then - Set_Type_Has_Signal (Def); - end if; - end Sem_Subtype_Declaration; - - -- If DECL is a constant declaration, and there is already a incomplete - -- constant declaration in the current scope with the same name, then - -- return it. Otherwise, return NULL. - function Get_Deferred_Constant (Decl : Iir) return Iir - is - Deferred_Const : Iir; - Interp : Name_Interpretation_Type; - begin - if Get_Kind (Decl) /= Iir_Kind_Constant_Declaration then - return Null_Iir; - end if; - Interp := Get_Interpretation (Get_Identifier (Decl)); - if not Valid_Interpretation (Interp) then - return Null_Iir; - end if; - - if not Is_In_Current_Declarative_Region (Interp) - or else Is_Potentially_Visible (Interp) - then - -- Deferred and full declarations must be declared in the same - -- declarative region. - return Null_Iir; - end if; - - Deferred_Const := Get_Declaration (Interp); - if Get_Kind (Deferred_Const) /= Iir_Kind_Constant_Declaration then - return Null_Iir; - end if; - if not Get_Deferred_Declaration_Flag (Deferred_Const) then - -- Just a 'normal' duplicate declaration - return Null_Iir; - end if; - -- LRM93 4.3.1.1 - -- The corresponding full constant declaration, which defines the value - -- of the constant, must appear in the body of the package. - if Get_Kind (Get_Library_Unit (Get_Current_Design_Unit)) - /= Iir_Kind_Package_Body - then - Error_Msg_Sem - (+Decl, "full constant declaration must appear in package body"); - end if; - return Deferred_Const; - end Get_Deferred_Constant; - - procedure Sem_Object_Type_From_Value (Decl : Iir; Value : Iir) - is - Atype : constant Iir := Get_Type (Decl); - Value_Type : constant Iir := Get_Type (Value); - begin - if not Is_Fully_Constrained_Type (Atype) - and then not Is_Error (Value_Type) - then - if Get_Type_Staticness (Value_Type) >= Globally then - Set_Type (Decl, Value_Type); - end if; - end if; - end Sem_Object_Type_From_Value; - - -- LAST_DECL is set only if DECL is part of a list of declarations (they - -- share the same type and the same default value). - procedure Sem_Object_Declaration (Decl: Iir; Parent : Iir; Last_Decl : Iir) - is - Deferred_Const : constant Iir := Get_Deferred_Constant (Decl); - Atype: Iir; - Default_Value : Iir; - Staticness : Iir_Staticness; - begin - -- LRM08 12.2 Scope of declarations - -- Then scope of a declaration [...] extends from the beginning of the - -- declaration [...] - if Deferred_Const = Null_Iir then - Sem_Scopes.Add_Name (Decl); - Xref_Decl (Decl); - else - Xref_Ref (Decl, Deferred_Const); - end if; - - -- Analyze type and default value: - Atype := Get_Subtype_Indication (Decl); - if Last_Decl = Null_Iir then - Atype := Sem_Subtype_Indication (Atype); - Set_Subtype_Indication (Decl, Atype); - Atype := Get_Type_Of_Subtype_Indication (Atype); - if Atype = Null_Iir then - Atype := Create_Error_Type (Get_Type (Decl)); - end if; - - Default_Value := Get_Default_Value (Decl); - if Default_Value /= Null_Iir then - Default_Value := Sem_Expression (Default_Value, Atype); - if Default_Value = Null_Iir then - Default_Value := - Create_Error_Expr (Get_Default_Value (Decl), Atype); - end if; - Check_Read (Default_Value); - Default_Value := Eval_Expr_Check_If_Static (Default_Value, Atype); - end if; - else - pragma Assert (Atype = Null_Iir); - Default_Value := Get_Default_Value (Last_Decl); - if Is_Valid (Default_Value) then - Set_Is_Ref (Decl, True); - end if; - Atype := Get_Type (Last_Decl); - end if; - - Set_Type (Decl, Atype); - Set_Default_Value (Decl, Default_Value); - Set_Name_Staticness (Decl, Locally); - Set_Visible_Flag (Decl, True); - - -- LRM93 2.6 - -- The subtype indication given in the full declaration of the deferred - -- constant must conform to that given in the deferred constant - -- declaration. - if Deferred_Const /= Null_Iir - and then not Are_Trees_Equal (Get_Type (Decl), - Get_Type (Deferred_Const)) - then - Error_Msg_Sem - (+Decl, - "subtype indication doesn't conform with the deferred constant"); - end if; - - -- LRM93 4.3.1.3 - -- It is an error if a variable declaration declares a variable that is - -- of a file type. - -- - -- LRM93 4.3.1.1 - -- It is an error if a constant declaration declares a constant that is - -- of a file type, or an access type, or a composite type which has - -- subelement that is a file type of an access type. - -- - -- LRM93 4.3.1.2 - -- It is an error if a signal declaration declares a signal that is of - -- a file type [or an access type]. - case Get_Kind (Atype) is - when Iir_Kind_File_Type_Definition => - Error_Msg_Sem (+Decl, "%n cannot be of type file", +Decl); - when Iir_Kind_Error => - null; - when others => - if Get_Kind (Decl) /= Iir_Kind_Variable_Declaration then - Check_Signal_Type (Decl); - end if; - end case; - - if Is_Valid (Default_Value) - and then not Eval_Is_In_Bound (Default_Value, Atype) - and then Get_Kind (Default_Value) /= Iir_Kind_Overflow_Literal - then - Warning_Msg_Sem - (Warnid_Runtime_Error, +Decl, - "default value constraints don't match object type ones"); - Default_Value := Build_Overflow (Default_Value, Atype); - Set_Default_Value (Decl, Default_Value); - end if; - - case Get_Kind (Decl) is - when Iir_Kind_Constant_Declaration => - -- LRM93 4.3.1.1 - -- If the assignment symbol ":=" followed by an expression is not - -- present in a constant declaration, then the declaration - -- declares a deferred constant. - -- Such a constant declaration may only appear in a package - -- declaration. - if Deferred_Const /= Null_Iir then - Set_Deferred_Declaration (Decl, Deferred_Const); - Set_Deferred_Declaration (Deferred_Const, Decl); - end if; - if Default_Value = Null_Iir then - if Deferred_Const /= Null_Iir then - Error_Msg_Sem - (+Decl, - "full constant declaration must have a default value"); - else - Set_Deferred_Declaration_Flag (Decl, True); - end if; - if Get_Kind (Parent) /= Iir_Kind_Package_Declaration then - Error_Msg_Sem - (+Decl, "a constant must have a default value"); - end if; - Set_Expr_Staticness (Decl, Globally); - else - -- LRM93 7.4.1: a locally static primary is defined: - -- A constant (other than deferred constant) explicitly - -- declared by a constant declaration and initialized - -- with a locally static expression. - -- Note: the staticness of the full declaration may be locally. - if False and Deferred_Const /= Null_Iir then - -- This is a deferred constant. - Staticness := Globally; - else - Staticness := Min (Get_Expr_Staticness (Default_Value), - Get_Type_Staticness (Atype)); - -- What about expr staticness of c in: - -- constant c : bit_vector (a to b) := "01"; - -- where a and b are not locally static ? - --Staticness := Get_Expr_Staticness (Default_Value); - - -- LRM 7.4.2 (Globally static primaries) - -- 5. a constant - if Staticness < Globally then - Staticness := Globally; - end if; - end if; - Set_Expr_Staticness (Decl, Staticness); - end if; - - when Iir_Kind_Signal_Declaration => - -- LRM93 4.3.1.2 - -- It is also an error if a guarded signal of a scalar type is - -- neither a resolved signal nor a subelement of a resolved - -- signal. - if Get_Guarded_Signal_Flag (Decl) - and then not Get_Resolved_Flag (Atype) - then - Error_Msg_Sem (+Decl, "guarded %n must be resolved", +Decl); - end if; - Set_Expr_Staticness (Decl, None); - Set_Has_Disconnect_Flag (Decl, False); - Set_Type_Has_Signal (Atype); - - when Iir_Kind_Variable_Declaration => - -- GHDL: restriction for shared variables are checked during - -- parse. - if Flags.Vhdl_Std >= Vhdl_00 then - declare - Base_Type : constant Iir := Get_Base_Type (Atype); - Is_Protected : constant Boolean := - Get_Kind (Base_Type) = Iir_Kind_Protected_Type_Declaration; - begin - -- LRM00 4.3.1.3 - -- The base type of the subtype indication of a - -- shared variable declaration must be a protected type. - if Get_Shared_Flag (Decl) and not Is_Protected then - Error_Msg_Sem_Relaxed - (Decl, Warnid_Shared, - "type of a shared variable must be a protected type"); - end if; - - -- LRM00 4.3.1.3 Variable declarations - -- If a given variable appears (directly or indirectly) - -- within a protected type body, then the base type - -- denoted by the subtype indication of the variable - -- declarations must not be a protected type defined by - -- the protected type body. - -- FIXME: indirectly ? - if Is_Protected - and then Get_Kind (Parent) = Iir_Kind_Protected_Type_Body - and then Base_Type - = Get_Protected_Type_Declaration (Parent) - then - Error_Msg_Sem (+Decl, "variable type must not be of the " - & "protected type body"); - end if; - end; - end if; - Set_Expr_Staticness (Decl, None); - when others => - Error_Kind ("sem_object_declaration", Decl); - end case; - - case Get_Kind (Decl) is - when Iir_Kind_Constant_Declaration => - -- LRM93 3.2.1.1 - -- For a constant declared by an object declaration, the index - -- ranges are defined by the initial value, if the subtype of the - -- constant is unconstrained; otherwise they are defined by this - -- subtype. - if Default_Value /= Null_Iir then - Sem_Object_Type_From_Value (Decl, Default_Value); - end if; - - when Iir_Kind_Variable_Declaration - | Iir_Kind_Signal_Declaration => - -- LRM93 3.2.1.1 / LRM08 5.3.2.2 - -- For a variable or signal declared by an object declaration, the - -- subtype indication of the corressponding object declaration - -- must define a constrained array subtype. - if not Is_Fully_Constrained_Type (Atype) then - Error_Msg_Sem - (+Decl, - "declaration of %n with unconstrained %n is not allowed", - (+Decl, +Atype)); - if Default_Value /= Null_Iir then - Error_Msg_Sem (+Decl, "(even with a default value)"); - end if; - end if; - - when others => - Error_Kind ("sem_object_declaration(2)", Decl); - end case; - end Sem_Object_Declaration; - - procedure Sem_File_Declaration (Decl: Iir_File_Declaration; Last_Decl : Iir) - is - Atype: Iir; - Logical_Name: Iir; - Open_Kind : Iir; - begin - Sem_Scopes.Add_Name (Decl); - Set_Expr_Staticness (Decl, None); - Xref_Decl (Decl); - - -- Try to find a type. - Atype := Get_Subtype_Indication (Decl); - if Atype /= Null_Iir then - Atype := Sem_Subtype_Indication (Atype); - Set_Subtype_Indication (Decl, Atype); - Atype := Get_Type_Of_Subtype_Indication (Atype); - if Atype = Null_Iir then - Atype := Create_Error_Type (Get_Type (Decl)); - end if; - else - Atype := Get_Type (Last_Decl); - end if; - Set_Type (Decl, Atype); - - -- LRM93 4.3.1.4 - -- The subtype indication of a file declaration must define a file - -- subtype. - if Get_Kind (Atype) /= Iir_Kind_File_Type_Definition then - Error_Msg_Sem (+Decl, "file subtype expected for a file declaration"); - return; - end if; - - Logical_Name := Get_File_Logical_Name (Decl); - -- LRM93 4.3.1.4 - -- The file logical name must be an expression of predefined type - -- STRING. - if Logical_Name /= Null_Iir then - Logical_Name := Sem_Expression (Logical_Name, String_Type_Definition); - if Logical_Name /= Null_Iir then - Check_Read (Logical_Name); - Set_File_Logical_Name (Decl, Logical_Name); - end if; - end if; - - Open_Kind := Get_File_Open_Kind (Decl); - if Open_Kind /= Null_Iir then - Open_Kind := - Sem_Expression (Open_Kind, File_Open_Kind_Type_Definition); - if Open_Kind /= Null_Iir then - Check_Read (Open_Kind); - Set_File_Open_Kind (Decl, Open_Kind); - end if; - else - -- LRM93 4.3.1.4 - -- If a file open kind expression is not included in the file open - -- information of a given file declaration, then the default value - -- of READ_MODE is used during elaboration of the file declaration. - -- - -- LRM87 4.3.1.4 - -- The default mode is IN, if no mode is specified. - if Get_Mode (Decl) = Iir_Unknown_Mode then - if Flags.Vhdl_Std = Vhdl_87 then - Set_Mode (Decl, Iir_In_Mode); - else - null; - -- Set_File_Open_Kind (Decl, File_Open_Kind_Read_Mode); - end if; - end if; - end if; - Name_Visible (Decl); - - -- LRM 93 2.2 - -- If a pure function is the parent of a given procedure, then - -- that procedure must not contain a reference to an explicitly - -- declared file object [...] - -- - -- A pure function must not contain a reference to an explicitly - -- declared file. - - -- Note: this check is also performed when a file is referenced. - -- But a file can be declared without being explicitly referenced. - declare - Parent : Iir; - Spec : Iir; - begin - Parent := Get_Parent (Decl); - case Get_Kind (Parent) is - when Iir_Kind_Function_Body => - Spec := Get_Subprogram_Specification (Parent); - if Get_Pure_Flag (Spec) then - Error_Msg_Sem_Relaxed - (Decl, Warnid_Pure, - "cannot declare a file in a pure function"); - end if; - when Iir_Kind_Procedure_Body => - Spec := Get_Subprogram_Specification (Parent); - Set_Purity_State (Spec, Impure); - Set_Impure_Depth (Parent, Iir_Depth_Impure); - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - Error_Kind ("sem_file_declaration", Parent); - when others => - null; - end case; - end; - end Sem_File_Declaration; - - procedure Sem_Attribute_Declaration (Decl: Iir_Attribute_Declaration) - is - A_Type : Iir; - Ident : Name_Id; - begin - -- LRM93 4.4 - -- The identifier is said to be the designator of the attribute. - Ident := Get_Identifier (Decl); - if Ident in Std_Names.Name_Id_Attributes - or else (Flags.Vhdl_Std = Vhdl_87 - and then Ident in Std_Names.Name_Id_Vhdl87_Attributes) - or else (Flags.Vhdl_Std > Vhdl_87 - and then Ident in Std_Names.Name_Id_Vhdl93_Attributes) - then - Error_Msg_Sem (+Decl, "predefined attribute %i overriden", +Decl); - end if; - Sem_Scopes.Add_Name (Decl); - Xref_Decl (Decl); - - A_Type := Sem_Type_Mark (Get_Type_Mark (Decl)); - Set_Type_Mark (Decl, A_Type); - A_Type := Get_Type (A_Type); - Set_Type (Decl, A_Type); - - -- LRM93 4.4 Attribute declarations. - -- It is an error if the type mark denotes an access type, a file type, - -- a protected type, or a composite type with a subelement that is - -- an access type, a file type, or a protected type. - -- The subtype need not be constrained. - Check_Signal_Type (Decl); - Name_Visible (Decl); - end Sem_Attribute_Declaration; - - procedure Sem_Component_Declaration (Component: Iir_Component_Declaration) - is - begin - Sem_Scopes.Add_Name (Component); - Xref_Decl (Component); - - -- LRM 10.1 Declarative region - -- 6. A component declaration. - Open_Declarative_Region; - - Sem_Interface_Chain - (Get_Generic_Chain (Component), Generic_Interface_List); - Sem_Interface_Chain - (Get_Port_Chain (Component), Port_Interface_List); - - Close_Declarative_Region; - - Name_Visible (Component); - end Sem_Component_Declaration; - - procedure Sem_Object_Alias_Declaration (Alias: Iir_Object_Alias_Declaration) - is - N_Name: constant Iir := Get_Name (Alias); - N_Type: Iir; - Name_Type : Iir; - begin - -- LRM93 4.3.3.1 Object Aliases. - -- 1. A signature may not appear in a declaration of an object alias. - -- FIXME: todo. - -- - -- 2. The name must be a static name that denotes an object. - if Get_Name_Staticness (N_Name) < Globally then - Error_Msg_Sem (+Alias, "aliased name must be a static name"); - end if; - - -- LRM93 4.3.3.1 - -- The base type of the name specified in an alias declaration must be - -- the same as the base type of the type mark in the subtype indication - -- (if the subtype indication is present); - Name_Type := Get_Type (N_Name); - N_Type := Get_Subtype_Indication (Alias); - if N_Type = Null_Iir then - Set_Type (Alias, Name_Type); - N_Type := Name_Type; - else - -- FIXME: must be analyzed before calling Name_Visibility. - N_Type := Sem_Subtype_Indication (N_Type); - Set_Subtype_Indication (Alias, N_Type); - N_Type := Get_Type_Of_Subtype_Indication (N_Type); - if N_Type /= Null_Iir then - Set_Type (Alias, N_Type); - if Get_Base_Type (N_Type) /= Get_Base_Type (Name_Type) then - Error_Msg_Sem - (+Alias, "base type of aliased name and name mismatch"); - end if; - end if; - - -- LRM08 6.6.2 Object aliases - -- The following rules apply yo object aliases: - -- b) If the name is an external name, a subtype indication shall not - -- appear in the alias declaration. - if Get_Kind (N_Name) in Iir_Kinds_External_Name then - Error_Msg_Sem - (+Alias, - "subtype indication not allowed in alias of external name"); - end if; - end if; - - -- LRM93 4.3.3.1 - -- This type must not be a multi-dimensional array type. - if Get_Kind (N_Type) in Iir_Kinds_Array_Type_Definition then - if not Is_One_Dimensional_Array_Type (N_Type) then - Error_Msg_Sem - (+Alias, - "aliased name must not be a multi-dimensional array type"); - end if; - if Get_Type_Staticness (N_Type) = Locally - and then Get_Type_Staticness (Name_Type) = Locally - and then Eval_Discrete_Type_Length - (Get_Nth_Element (Get_Index_Subtype_List (N_Type), 0)) - /= Eval_Discrete_Type_Length - (Get_Nth_Element (Get_Index_Subtype_List (Name_Type), 0)) - then - Error_Msg_Sem - (+Alias, "number of elements not matching in type and name"); - end if; - end if; - - Set_Name_Staticness (Alias, Get_Name_Staticness (N_Name)); - Set_Expr_Staticness (Alias, Get_Expr_Staticness (N_Name)); - if Is_Signal_Object (N_Name) then - Set_Type_Has_Signal (N_Type); - end if; - end Sem_Object_Alias_Declaration; - - function Signature_Match (N_Entity : Iir; Sig : Iir_Signature) - return Boolean - is - List : constant Iir_Flist := Get_Type_Marks_List (Sig); - Inter : Iir; - El : Iir; - begin - case Get_Kind (N_Entity) is - when Iir_Kind_Enumeration_Literal => - -- LRM93 2.3.2 Signatures - -- * Similarly, a signature is said to match the parameter and - -- result type profile of a given enumeration literal if - -- the signature matches the parameter and result type profile - -- of the subprogram equivalent to the enumeration literal, - -- defined in Section 3.1.1 - if Get_Return_Type_Mark (Sig) = Null_Iir then - return False; - end if; - return List = Null_Iir_Flist - and then (Get_Type (N_Entity) - = Get_Type (Get_Return_Type_Mark (Sig))); - when Iir_Kind_Function_Declaration - | Iir_Kind_Interface_Function_Declaration => - -- LRM93 2.3.2 Signatures - -- * if the reserved word RETURN is present, the subprogram is - -- a function and the base type of the type mark following - -- the reserved word in the signature is the same as the base - -- type of the return type of the function, [...] - if Get_Return_Type_Mark (Sig) = Null_Iir then - return False; - end if; - if Get_Type (Get_Return_Type_Mark (Sig)) /= - Get_Base_Type (Get_Return_Type (N_Entity)) - then - return False; - end if; - when Iir_Kind_Procedure_Declaration - | Iir_Kind_Interface_Procedure_Declaration => - -- LRM93 2.3.2 Signatures - -- * [...] or the reserved word RETURN is absent and the - -- subprogram is a procedure. - if Get_Return_Type_Mark (Sig) /= Null_Iir then - return False; - end if; - when others => - -- LRM93 2.3.2 Signatures - -- A signature distinguishes between overloaded subprograms and - -- overloaded enumeration literals based on their parameter - -- and result type profiles. - return False; - end case; - - -- LRM93 2.3.2 Signature - -- * the number of type marks prior the reserved word RETURN, if any, - -- matches the number of formal parameters of the subprogram; - -- * at each parameter position, the base type denoted by the type - -- mark of the signature is the same as the base type of the - -- corresponding formal parameter of the subprogram; [and finally, ] - Inter := Get_Interface_Declaration_Chain (N_Entity); - if List = Null_Iir_Flist then - return Inter = Null_Iir; - end if; - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - if Inter = Null_Iir then - -- More type marks in the signature than in the interface. - return False; - end if; - if Get_Base_Type (Get_Type (Inter)) /= Get_Type (El) then - return False; - end if; - Inter := Get_Chain (Inter); - end loop; - -- Match only if the number of type marks is the same. - return Inter = Null_Iir; - end Signature_Match; - - -- Extract from NAME the named entity whose profile matches with SIG. - function Sem_Signature (Name : Iir; Sig : Iir_Signature) return Iir - is - List : constant Iir_Flist := Get_Type_Marks_List (Sig); - Res : Iir; - El : Iir; - Error : Boolean; - Ov_List : Iir_List; - Ov_It : List_Iterator; - begin - -- Sem signature. - if List /= Null_Iir_Flist then - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - El := Sem_Type_Mark (El); - Set_Nth_Element (List, I, El); - - -- Reuse the Type field of the name for the base type. This is - -- a deviation from the use of Type in a name, but restricted to - -- analysis of signatures. - Set_Type (El, Get_Base_Type (Get_Type (El))); - end loop; - end if; - El := Get_Return_Type_Mark (Sig); - if El /= Null_Iir then - El := Sem_Type_Mark (El); - Set_Return_Type_Mark (Sig, El); - -- Likewise. - Set_Type (El, Get_Base_Type (Get_Type (El))); - end if; - - -- FIXME: what to do in case of error ? - Res := Null_Iir; - Error := False; - if Is_Overload_List (Name) then - Ov_List := Get_Overload_List (Name); - Ov_It := List_Iterate (Ov_List); - while Is_Valid (Ov_It) loop - El := Get_Element (Ov_It); - if Signature_Match (El, Sig) then - if Res = Null_Iir then - Res := El; - else - Error := True; - Error_Msg_Sem - (+Sig, - "cannot resolve signature, many matching subprograms:", - Cont => True); - Error_Msg_Sem (+Res, "found: %n", (1 => +Res), Cont => True); - end if; - if Error then - Error_Msg_Sem (+El, "found: %n", +El); - end if; - end if; - Next (Ov_It); - end loop; - - -- Free the overload list (with a workaround as only variables can - -- be free). - declare - Name_Ov : Iir; - begin - Name_Ov := Name; - Free_Overload_List (Name_Ov); - end; - else - if Signature_Match (Name, Sig) then - Res := Name; - end if; - end if; - - if Error then - return Null_Iir; - end if; - if Res = Null_Iir then - Error_Msg_Sem - (+Sig, "cannot resolve signature, no matching subprogram"); - end if; - - return Res; - end Sem_Signature; - - -- Create implicit aliases for an alias ALIAS of a type or of a subtype. - procedure Add_Aliases_For_Type_Alias (Alias : Iir) - is - N_Entity : constant Iir := Get_Named_Entity (Get_Name (Alias)); - Def : constant Iir := Get_Base_Type (Get_Type (N_Entity)); - Type_Decl : constant Iir := Get_Type_Declarator (Def); - Last : Iir; - El : Iir; - Enum_List : Iir_Flist; - - -- Append an implicit alias - procedure Add_Implicit_Alias (Decl : Iir) - is - N_Alias : constant Iir_Non_Object_Alias_Declaration := - Create_Iir (Iir_Kind_Non_Object_Alias_Declaration); - N_Name : constant Iir := Create_Iir (Iir_Kind_Simple_Name); - begin - -- Create the name (can be in fact a character literal or a symbol - -- operator). - Location_Copy (N_Name, Alias); - Set_Identifier (N_Name, Get_Identifier (Decl)); - Set_Named_Entity (N_Name, Decl); - - Location_Copy (N_Alias, Alias); - Set_Identifier (N_Alias, Get_Identifier (Decl)); - Set_Name (N_Alias, N_Name); - Set_Parent (N_Alias, Get_Parent (Alias)); - Set_Implicit_Alias_Flag (N_Alias, True); - - Sem_Scopes.Add_Name (N_Alias); - Set_Visible_Flag (N_Alias, True); - - -- Append in the declaration chain. - Set_Chain (N_Alias, Get_Chain (Last)); - Set_Chain (Last, N_Alias); - Last := N_Alias; - end Add_Implicit_Alias; - begin - Last := Alias; - - if Get_Kind (Def) = Iir_Kind_Enumeration_Type_Definition then - -- LRM93 4.3.3.2 Non-Object Aliases - -- 3. If the name denotes an enumeration type, then one - -- implicit alias declaration for each of the - -- literals of the type immediatly follows the alias - -- declaration for the enumeration type; [...] - -- - -- LRM08 6.6.3 Nonobject aliases - -- c) If the name denotes an enumeration type or a subtype of an - -- enumeration type, then one implicit alias declaration for each - -- of the literals of the base type immediately follows the - -- alias declaration for the enumeration type; [...] - Enum_List := Get_Enumeration_Literal_List (Def); - for I in Flist_First .. Flist_Last (Enum_List) loop - El := Get_Nth_Element (Enum_List, I); - -- LRM93 4.3.3.2 Non-Object Aliases - -- [...] each such implicit declaration has, as its alias - -- designator, the simple name or character literal of the - -- literal, and has, as its name, a name constructed by taking - -- the name of the alias for the enumeration type and - -- substituting the simple name or character literal being - -- aliased for the simple name of the type. Each implicit - -- alias has a signature that matches the parameter and result - -- type profile of the literal being aliased. - -- - -- LRM08 6.6.3 Nonobject aliases - -- [...] each such implicit declaration has, as its alias - -- designator, the simple name or character literal of the - -- literal and has, as its name, a name constructed by taking - -- the name of the alias for the enumeration type or subtype - -- and substituing the simple name or character literal being - -- aliased for the simple name of the type or subtype. Each - -- implicit alias has a signature that matches the parameter - -- and result type profile of the literal being aliased. - Add_Implicit_Alias (El); - end loop; - end if; - - -- LRM93 4.3.3.2 Non-Object Aliases - -- 4. Alternatively, if the name denotes a physical type - -- [...] - -- GHDL: this is not possible, since a physical type is - -- anonymous (LRM93 is buggy on this point). - -- - -- LRM08 6.6.3 Nonobject aliases - -- d) Alternatively, if the name denotes a subtype of a physical type, - -- [...] - if Get_Kind (Def) = Iir_Kind_Physical_Type_Definition then - -- LRM08 6.3.3 Nonobject aliases - -- [...] then one implicit alias declaration for each of the - -- units of the base type immediately follows the alias - -- declaration for the physical type; each such implicit - -- declaration has, as its alias designator, the simple name of - -- the unit and has, as its name, a name constructed by taking - -- the name of the alias for the subtype of the physical type - -- and substituting the simple name of the unit being aliased for - -- the simple name of the subtype. - El := Get_Unit_Chain (Def); - while El /= Null_Iir loop - Add_Implicit_Alias (El); - El := Get_Chain (El); - end loop; - end if; - - -- LRM93 4.3.3.2 Non-Object Aliases - -- 5. Finally, if the name denotes a type, then implicit - -- alias declarations for each predefined operator - -- for the type immediatly follow the explicit alias - -- declaration for the type, and if present, any - -- implicit alias declarations for literals or units - -- of the type. - -- Each implicit alias has a signature that matches the - -- parameter and result type profule of the implicit - -- operator being aliased. - -- - -- LRM08 6.6.3 Nonobject aliases - -- e) Finally, if the name denotes a type of a subtype, then implicit - -- alias declarations for each predefined operation for the type - -- immediately follow the explicit alias declaration for the type or - -- subtype and, if present, any implicit alias declarations for - -- literals or units of the type. Each implicit alias has a - -- signature that matches the parameter and result type profile of - -- the implicit operation being aliased. - El := Get_Chain (Type_Decl); - while El /= Null_Iir loop - if Is_Implicit_Subprogram (El) - and then Is_Operation_For_Type (El, Def) - then - Add_Implicit_Alias (El); - El := Get_Chain (El); - else - exit; - end if; - end loop; - end Add_Aliases_For_Type_Alias; - - procedure Sem_Non_Object_Alias_Declaration - (Alias : Iir_Non_Object_Alias_Declaration) - is - use Std_Names; - N_Entity : constant Iir := Get_Named_Entity (Get_Name (Alias)); - Id : Name_Id; - begin - case Get_Kind (N_Entity) is - when Iir_Kinds_Subprogram_Declaration - | Iir_Kinds_Interface_Subprogram_Declaration => - -- LRM93 4.3.3.2 Non-Object Aliases - -- 2. A signature is required if the name denotes a subprogram - -- (including an operator) or enumeration literal. - if Get_Alias_Signature (Alias) = Null_Iir then - Error_Msg_Sem (+Alias, "signature required for subprogram"); - end if; - when Iir_Kind_Enumeration_Literal => - if Get_Alias_Signature (Alias) = Null_Iir then - Error_Msg_Sem - (+Alias, "signature required for enumeration literal"); - end if; - when Iir_Kind_Type_Declaration => - Add_Aliases_For_Type_Alias (Alias); - when Iir_Kind_Subtype_Declaration => - -- LRM08 6.6.3 Nonobject aliases - -- ... or a subtype ... - if Flags.Vhdl_Std >= Vhdl_08 then - Add_Aliases_For_Type_Alias (Alias); - end if; - when Iir_Kinds_Object_Declaration => - raise Internal_Error; - when Iir_Kind_Attribute_Declaration - | Iir_Kind_Component_Declaration => - null; - when Iir_Kind_Library_Declaration => - -- Not explicitly allowed before vhdl-08. - null; - when Iir_Kind_Terminal_Declaration => - null; - when Iir_Kind_Base_Attribute => - Error_Msg_Sem (+Alias, "base attribute not allowed in alias"); - return; - when others => - Error_Kind ("sem_non_object_alias_declaration", N_Entity); - end case; - - Id := Get_Identifier (Alias); - - case Id is - when Name_Characters => - -- LRM 4.3.3 Alias declarations - -- If the alias designator is a character literal, the - -- name must denote an enumeration literal. - if Get_Kind (N_Entity) /= Iir_Kind_Enumeration_Literal then - Error_Msg_Sem - (+Alias, - "alias of a character must denote an enumeration literal"); - return; - end if; - when Name_Id_Operators - | Name_Shift_Operators - | Name_Word_Operators => - -- LRM 4.3.3 Alias declarations - -- If the alias designator is an operator symbol, the - -- name must denote a function, and that function then - -- overloads the operator symbol. In this latter case, - -- the operator symbol and the function both must meet the - -- requirements of 2.3.1. - if Get_Kind (N_Entity) /= Iir_Kind_Function_Declaration then - Error_Msg_Sem - (+Alias, "alias of an operator must denote a function"); - return; - end if; - Check_Operator_Requirements (Id, N_Entity); - when others => - null; - end case; - end Sem_Non_Object_Alias_Declaration; - - function Sem_Alias_Declaration (Alias : Iir) return Iir - is - Name : Iir; - Sig : Iir_Signature; - N_Entity : Iir; - Res : Iir; - begin - Xref_Decl (Alias); - - Name := Get_Name (Alias); - case Get_Kind (Name) is - when Iir_Kind_Signature => - Sig := Name; - Name := Get_Signature_Prefix (Sig); - Sem_Name (Name); - Set_Signature_Prefix (Sig, Name); - when Iir_Kind_Error => - pragma Assert (Flags.Flag_Force_Analysis); - return Alias; - when others => - Sem_Name (Name); - Sig := Null_Iir; - end case; - - N_Entity := Get_Named_Entity (Name); - if N_Entity = Error_Mark then - return Alias; - end if; - - if Is_Overload_List (N_Entity) then - if Sig = Null_Iir then - Error_Msg_Sem - (+Alias, "signature required for alias of a subprogram"); - return Alias; - end if; - end if; - - if Sig /= Null_Iir then - N_Entity := Sem_Signature (N_Entity, Sig); - end if; - if N_Entity = Null_Iir then - return Alias; - end if; - - Set_Named_Entity (Name, N_Entity); - Name := Finish_Sem_Name (Name); - Set_Name (Alias, Name); - - if Is_Object_Name (N_Entity) then - -- Object alias declaration. - - Sem_Scopes.Add_Name (Alias); - Name_Visible (Alias); - - if Sig /= Null_Iir then - Error_Msg_Sem (+Sig, "signature not allowed for object alias"); - end if; - Sem_Object_Alias_Declaration (Alias); - return Alias; - else - -- Non object alias declaration. - - if Get_Subtype_Indication (Alias) /= Null_Iir then - Error_Msg_Sem - (+Alias, - "subtype indication shall not appear in a nonobject alias"); - end if; - - Res := Create_Iir (Iir_Kind_Non_Object_Alias_Declaration); - Location_Copy (Res, Alias); - Set_Parent (Res, Get_Parent (Alias)); - Set_Chain (Res, Get_Chain (Alias)); - Set_Identifier (Res, Get_Identifier (Alias)); - Set_Name (Res, Get_Name (Alias)); - Set_Alias_Signature (Res, Sig); - - if Is_Valid (Sig) then - -- The prefix is owned by the non_object_alias_declaration. - Set_Signature_Prefix (Sig, Null_Iir); - end if; - - Sem_Scopes.Add_Name (Res); - Name_Visible (Res); - - Free_Iir (Alias); - - if Get_Kind (Name) in Iir_Kinds_Denoting_And_External_Name then - Sem_Non_Object_Alias_Declaration (Res); - else - Error_Msg_Sem - (+Name, "name of nonobject alias is not a name"); - - -- Create a simple name to an error node. - N_Entity := Create_Error (Name); - Name := Create_Iir (Iir_Kind_Simple_Name); - Location_Copy (Name, N_Entity); - Set_Identifier (Name, Get_Identifier (Res)); -- Better idea ? - Set_Named_Entity (Name, N_Entity); - Set_Base_Name (Name, Name); - Set_Name (Res, Name); - end if; - - return Res; - end if; - end Sem_Alias_Declaration; - - procedure Sem_Group_Template_Declaration - (Decl : Iir_Group_Template_Declaration) is - begin - Sem_Scopes.Add_Name (Decl); - Sem_Scopes.Name_Visible (Decl); - Xref_Decl (Decl); - end Sem_Group_Template_Declaration; - - procedure Sem_Group_Declaration (Group : Iir_Group_Declaration) - is - use Vhdl.Tokens; - - Constituent_List : Iir_Flist; - Template : Iir_Group_Template_Declaration; - Template_Name : Iir; - Class, Prev_Class : Token_Type; - El : Iir; - El_Name : Iir; - El_Entity : Iir_Entity_Class; - begin - Sem_Scopes.Add_Name (Group); - Xref_Decl (Group); - - Template_Name := Sem_Denoting_Name (Get_Group_Template_Name (Group)); - Set_Group_Template_Name (Group, Template_Name); - Template := Get_Named_Entity (Template_Name); - if Get_Kind (Template) /= Iir_Kind_Group_Template_Declaration then - Error_Class_Match (Template_Name, "group template"); - return; - end if; - Constituent_List := Get_Group_Constituent_List (Group); - El_Entity := Get_Entity_Class_Entry_Chain (Template); - Prev_Class := Tok_Eof; - for I in Flist_First .. Flist_Last (Constituent_List) loop - El := Get_Nth_Element (Constituent_List, I); - - Sem_Name (El); - - if El_Entity = Null_Iir then - Error_Msg_Sem - (+Group, "too many elements in group constituent list"); - exit; - end if; - - Class := Get_Entity_Class (El_Entity); - if Class = Tok_Box then - -- LRM93 4.6 - -- An entity class entry that includes a box (<>) allows zero - -- or more group constituents to appear in this position in the - -- corresponding group declaration. - Class := Prev_Class; - else - Prev_Class := Class; - El_Entity := Get_Chain (El_Entity); - end if; - - El_Name := Get_Named_Entity (El); - if Is_Error (El_Name) then - null; - elsif Is_Overload_List (El_Name) then - Error_Overload (El_Name); - else - El := Finish_Sem_Name (El); - Set_Nth_Element (Constituent_List, I, El); - El_Name := Get_Named_Entity (El); - - -- Statements are textually afer the group declaration. To avoid - -- adding a flag on each node with a base_name, this field is - -- cleared, as we don't care about base name. - if Class = Tok_Label then - Set_Is_Forward_Ref (El, True); - end if; - Set_Base_Name (El, Null_Iir); - - -- LRM93 4.7 - -- It is an error if the class of any group constituent in the - -- group constituent list is not the same as the class specified - -- by the corresponding entity class entry in the entity class - -- entry list of the group template. - if Get_Entity_Class_Kind (El_Name) /= Class then - Error_Msg_Sem (+El, "constituent not of class %t", +Class); - end if; - end if; - end loop; - - -- End of entity_class list reached or zero or more constituent allowed. - if not (El_Entity = Null_Iir - or else Get_Entity_Class (El_Entity) = Tok_Box) - then - Error_Msg_Sem - (+Group, "not enough elements in group constituent list"); - end if; - Set_Visible_Flag (Group, True); - end Sem_Group_Declaration; - - function Sem_Scalar_Nature_Definition (Def : Iir; Decl : Iir) return Iir - is - function Sem_Scalar_Nature_Typemark (T : Iir; Name : String) return Iir - is - Res : Iir; - begin - Res := Sem_Type_Mark (T); - Res := Get_Type (Res); - if Is_Error (Res) then - return Real_Type_Definition; - end if; - -- LRM93 3.5.1 - -- The type marks must denote floating point types - case Get_Kind (Res) is - when Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Floating_Type_Definition => - return Res; - when others => - Error_Msg_Sem (+T, Name & "type must be a floating point type"); - return Real_Type_Definition; - end case; - end Sem_Scalar_Nature_Typemark; - - Tm : Iir; - Ref : Iir; - begin - Tm := Get_Across_Type (Def); - Tm := Sem_Scalar_Nature_Typemark (Tm, "across"); - Set_Across_Type (Def, Tm); - - Tm := Get_Through_Type (Def); - Tm := Sem_Scalar_Nature_Typemark (Tm, "through"); - Set_Through_Type (Def, Tm); - - -- Declare the reference - Ref := Get_Reference (Def); - Set_Nature (Ref, Def); - Set_Chain (Ref, Get_Chain (Decl)); - Set_Chain (Decl, Ref); - - return Def; - end Sem_Scalar_Nature_Definition; - - function Sem_Nature_Definition (Def : Iir; Decl : Iir) return Iir - is - begin - case Get_Kind (Def) is - when Iir_Kind_Scalar_Nature_Definition => - return Sem_Scalar_Nature_Definition (Def, Decl); - when others => - Error_Kind ("sem_nature_definition", Def); - return Null_Iir; - end case; - end Sem_Nature_Definition; - - procedure Sem_Nature_Declaration (Decl : Iir) - is - Def : Iir; - begin - Def := Get_Nature (Decl); - if Def /= Null_Iir then - Sem_Scopes.Add_Name (Decl); - Xref_Decl (Decl); - - Def := Sem_Nature_Definition (Def, Decl); - if Def /= Null_Iir then - Set_Nature_Declarator (Def, Decl); - Sem_Scopes.Name_Visible (Decl); - end if; - end if; - end Sem_Nature_Declaration; - - procedure Sem_Terminal_Declaration (Decl : Iir; Last_Decl : Iir) - is - Def, Nature : Iir; - begin - Sem_Scopes.Add_Name (Decl); - Xref_Decl (Decl); - - Def := Get_Nature (Decl); - - if Def = Null_Iir then - Nature := Get_Nature (Last_Decl); - else - Nature := Sem_Subnature_Indication (Def); - end if; - - if Nature /= Null_Iir then - Set_Nature (Decl, Nature); - Sem_Scopes.Name_Visible (Decl); - end if; - end Sem_Terminal_Declaration; - - procedure Sem_Branch_Quantity_Declaration (Decl : Iir; Last_Decl : Iir) - is - Plus_Name : Iir; - Minus_Name : Iir; - Branch_Type : Iir; - Value : Iir; - Is_Second : Boolean; - begin - Sem_Scopes.Add_Name (Decl); - Xref_Decl (Decl); - - Plus_Name := Get_Plus_Terminal (Decl); - if Plus_Name = Null_Iir then - -- List of identifier. - Is_Second := True; - Plus_Name := Get_Plus_Terminal (Last_Decl); - Minus_Name := Get_Minus_Terminal (Last_Decl); - Value := Get_Default_Value (Last_Decl); - else - Is_Second := False; - Plus_Name := Sem_Terminal_Name (Plus_Name); - Minus_Name := Get_Minus_Terminal (Decl); - if Minus_Name /= Null_Iir then - Minus_Name := Sem_Terminal_Name (Minus_Name); - end if; - Value := Get_Default_Value (Decl); - end if; - Set_Plus_Terminal (Decl, Plus_Name); - Set_Minus_Terminal (Decl, Minus_Name); - case Get_Kind (Decl) is - when Iir_Kind_Across_Quantity_Declaration => - Branch_Type := Get_Across_Type (Get_Nature (Plus_Name)); - when Iir_Kind_Through_Quantity_Declaration => - Branch_Type := Get_Through_Type (Get_Nature (Plus_Name)); - when others => - raise Program_Error; - end case; - Set_Type (Decl, Branch_Type); - - if not Is_Second and then Value /= Null_Iir then - Value := Sem_Expression (Value, Branch_Type); - end if; - Set_Default_Value (Decl, Value); - - -- TODO: tolerance - - Sem_Scopes.Name_Visible (Decl); - end Sem_Branch_Quantity_Declaration; - - procedure Sem_Declaration_Chain (Parent : Iir) - is - Decl : Iir; - Kind : Iir_Kind; - Attr_Spec_Chain : Iir; - - -- New declaration chain (declarations like implicit signals may be - -- added, some like aliases may mutate). - Last_Decl : Iir; - - -- Used for list of identifiers in object declarations to get the type - -- and default value for the following declarations. - Last_Obj_Decl : Iir; - - -- If IS_GLOBAL is set, then declarations may be seen outside of unit. - -- This must be set for entities and packages (except when - -- Flags.Flag_Whole_Analyze is set). - Is_Global : Boolean; - begin - case Get_Kind (Parent) is - when Iir_Kind_Entity_Declaration - | Iir_Kind_Package_Declaration => - Is_Global := not Flags.Flag_Whole_Analyze; - when others => - Is_Global := False; - end case; - - -- Due to implicit declarations, the list can grow during sem. - Decl := Get_Declaration_Chain (Parent); - Last_Decl := Null_Iir; - Attr_Spec_Chain := Null_Iir; - Last_Obj_Decl := Null_Iir; - - while Decl /= Null_Iir loop - Kind := Get_Kind (Decl); - case Kind is - when Iir_Kind_Type_Declaration - | Iir_Kind_Anonymous_Type_Declaration => - Sem_Type_Declaration (Decl, Is_Global); - when Iir_Kind_Subtype_Declaration => - Sem_Subtype_Declaration (Decl, Is_Global); - when Iir_Kind_Signal_Declaration - | Iir_Kind_Constant_Declaration - | Iir_Kind_Variable_Declaration => - Sem_Object_Declaration (Decl, Parent, Last_Obj_Decl); - when Iir_Kind_File_Declaration => - Sem_File_Declaration (Decl, Last_Obj_Decl); - when Iir_Kind_Attribute_Declaration => - Sem_Attribute_Declaration (Decl); - when Iir_Kind_Attribute_Specification => - Sem_Attribute_Specification (Decl, Parent); - if Get_Entity_Name_List (Decl) in Iir_Flists_All_Others then - Set_Attribute_Specification_Chain (Decl, Attr_Spec_Chain); - Attr_Spec_Chain := Decl; - end if; - when Iir_Kind_Component_Declaration => - Sem_Component_Declaration (Decl); - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - if Is_Implicit_Subprogram (Decl) then - Sem_Scopes.Add_Name (Decl); - -- Implicit subprogram are already visible. - else - Sem_Subprogram_Declaration (Decl); - if Is_Global - and then Get_Kind (Decl) = Iir_Kind_Function_Declaration - and then Is_A_Resolution_Function (Decl, Null_Iir) - then - Set_Resolution_Function_Flag (Decl, True); - end if; - end if; - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body => - Sem_Subprogram_Body (Decl); - when Iir_Kind_Non_Object_Alias_Declaration => - -- Added by Sem_Alias_Declaration. Need to check that no - -- existing attribute specification apply to them. - null; - when Iir_Kind_Object_Alias_Declaration => - Decl := Sem_Alias_Declaration (Decl); - -- An alias may add new alias declarations. Do not skip - -- them: check that no existing attribute specifications - -- apply to them. - when Iir_Kind_Use_Clause => - Sem_Use_Clause (Decl); - when Iir_Kind_Configuration_Specification => - null; - when Iir_Kind_Disconnection_Specification => - Sem_Disconnection_Specification (Decl); - when Iir_Kind_Group_Template_Declaration => - Sem_Group_Template_Declaration (Decl); - when Iir_Kind_Group_Declaration => - Sem_Group_Declaration (Decl); - when Iir_Kinds_Signal_Attribute => - -- Added by sem, so nothing to do. - null; - when Iir_Kind_Protected_Type_Body => - Sem_Protected_Type_Body (Decl); - - when Iir_Kind_Package_Declaration => - Sem_Package_Declaration (Decl); - when Iir_Kind_Package_Body => - Sem_Package_Body (Decl); - when Iir_Kind_Package_Instantiation_Declaration => - Sem_Package_Instantiation_Declaration (Decl); - - when Iir_Kind_Nature_Declaration => - Sem_Nature_Declaration (Decl); - when Iir_Kind_Terminal_Declaration => - Sem_Terminal_Declaration (Decl, Last_Obj_Decl); - when Iir_Kind_Across_Quantity_Declaration - | Iir_Kind_Through_Quantity_Declaration => - Sem_Branch_Quantity_Declaration (Decl, Last_Obj_Decl); - - when Iir_Kind_Psl_Declaration => - Sem_Psl.Sem_Psl_Declaration (Decl); - when Iir_Kind_Psl_Default_Clock => - Sem_Psl.Sem_Psl_Default_Clock (Decl); - - when others => - Error_Kind ("sem_declaration_chain", Decl); - end case; - - -- For object declarations, set Last_Obj_Decl; otherwise clear it. - case Kind is - when Iir_Kind_Signal_Declaration - | Iir_Kind_Constant_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_File_Declaration - | Iir_Kind_Terminal_Declaration - | Iir_Kind_Across_Quantity_Declaration - | Iir_Kind_Through_Quantity_Declaration => - if Get_Has_Identifier_List (Decl) then - Last_Obj_Decl := Decl; - else - Last_Obj_Decl := Null_Iir; - end if; - when others => - Last_Obj_Decl := Null_Iir; - end case; - - if Attr_Spec_Chain /= Null_Iir then - Check_Post_Attribute_Specification (Attr_Spec_Chain, Decl); - end if; - - -- Insert *before* DECL pending implicit signal declarations created - -- for DECL after LAST_DECL. This updates LAST_DECL. - Insert_Pending_Implicit_Declarations (Parent, Last_Decl); - - if Last_Decl = Null_Iir then - -- Append now to handle expand names. - Set_Declaration_Chain (Parent, Decl); - else - Set_Chain (Last_Decl, Decl); - end if; - Last_Decl := Decl; - Decl := Get_Chain (Decl); - end loop; - - -- Keep the point of insertion for implicit signal declarations. - End_Of_Declarations_For_Implicit_Declarations (Parent, Last_Decl); - end Sem_Declaration_Chain; - - procedure Check_Full_Declaration (Decls_Parent : Iir; Decl: Iir) - is - El: Iir; - - -- If set, emit a warning if a declaration is not used. - Check_Unused : Boolean; - begin - -- LRM 3.5 Protected types. - -- Each protected type declaration appearing immediatly within a given - -- declaration region must have exactly one corresponding protected type - -- body appearing immediatly within the same declarative region and - -- textually subsequent to the protected type declaration. - - -- LRM 3.3.1 Incomplete type declarations - -- For each incomplete type declaration, there must be a corresponding - -- full type declaration with the same identifier. This full type - -- declaration must occur later and immediatly within the same - -- declarative part as the incomplete type declaration to which it - -- correspinds. - - -- LRM 4.3.1.1 Constant declarations - -- If the assignment symbol ":=" followed by an expression is not - -- present in a constant declaration, then the declaration declares a - -- deferred constant. Such a constant declaration must appear in a - -- package declaration. The corresponding full constant declaration, - -- which defines the value of the constant, must appear in the body of - -- the package (see 2.6). - - -- LRM 2.2 Subprogram bodies - -- If both a declaration and a body are given, [...]. Furthermore, - -- both the declaration and the body must occur immediatly within the - -- same declaration region. - - -- Set Check_Unused. - Check_Unused := False; - if Is_Warning_Enabled (Warnid_Unused) then - case Get_Kind (Decl) is - when Iir_Kind_Entity_Declaration => - -- May be used in architecture. - null; - when Iir_Kind_Architecture_Body - | Iir_Kind_Block_Statement => - -- Might be used in a configuration. - -- FIXME: create a second level of warning. - null; - when Iir_Kind_Generate_Statement_Body => - -- Might be used in a configuration. - null; - when Iir_Kind_Package_Body - | Iir_Kind_Protected_Type_Body => - -- Check only for declarations of the body. - if Decls_Parent = Decl then - Check_Unused := True; - end if; - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body - | Iir_Kind_Process_Statement - | Iir_Kind_Sensitized_Process_Statement => - Check_Unused := True; - when others => - -- Note: Check_Full_Declaration is not called - -- for package declarations or protected type declarations. - Error_Kind ("check_full_declaration", Decl); - end case; - end if; - - El := Get_Declaration_Chain (Decls_Parent); - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Constant_Declaration => - if Get_Deferred_Declaration_Flag (El) then - if Get_Deferred_Declaration (El) = Null_Iir then - Error_Msg_Sem - (+Decl, - "missing value for constant declared at %l", +El); - end if; - end if; - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - if not Is_Implicit_Subprogram (El) - and then Get_Subprogram_Body (El) = Null_Iir - then - Error_Msg_Sem - (+Decl, "missing body for %n declared at %l", (+El, +El)); - end if; - when Iir_Kind_Type_Declaration => - declare - Def : constant Iir := Get_Type_Definition (El); - begin - if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition - and then Is_Null (Get_Complete_Type_Definition (Def)) - then - Error_Msg_Sem - (+El, "missing full type declaration for %n", +El); - elsif Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration - and then Get_Protected_Type_Body (Def) = Null_Iir - then - Error_Msg_Sem - (+El, "missing protected type body for %n", +El); - end if; - end; - when Iir_Kind_Package_Declaration => - if Is_Null (Get_Package_Origin (El)) - and then Get_Need_Body (El) - and then Get_Package_Body (El) = Null_Iir - then - Error_Msg_Sem (+El, "missing package body for %n", +El); - end if; - when others => - null; - end case; - - if Check_Unused then - -- All subprograms declared in the specification (package or - -- protected type) have only their *body* in the body. - -- Therefore, they don't appear as declaration in body. - -- Only private subprograms appears as declarations. - case Get_Kind (El) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - if not Get_Use_Flag (El) - and then not Is_Implicit_Subprogram (El) - and then not Is_Second_Subprogram_Specification (El) - then - Warning_Msg_Sem (Warnid_Unused, +El, - "%n is never referenced", +El); - end if; - when others => - null; - end case; - end if; - - El := Get_Chain (El); - end loop; - end Check_Full_Declaration; - - procedure Sem_Iterator (Iterator : Iir_Iterator_Declaration; - Staticness : Iir_Staticness) - is - It_Range: constant Iir := Get_Discrete_Range (Iterator); - It_Type : Iir; - A_Range: Iir; - begin - Xref_Decl (Iterator); - - A_Range := Sem_Discrete_Range_Integer (It_Range); - if A_Range = Null_Iir then - Set_Type (Iterator, Create_Error_Type (It_Range)); - return; - end if; - - Set_Discrete_Range (Iterator, Null_Iir); - - It_Type := Range_To_Subtype_Indication (A_Range); - Set_Subtype_Indication (Iterator, It_Type); - Set_Type (Iterator, Get_Type_Of_Subtype_Indication (It_Type)); - - Set_Expr_Staticness (Iterator, Staticness); - end Sem_Iterator; -end Sem_Decls; diff --git a/src/vhdl/sem_decls.ads b/src/vhdl/sem_decls.ads deleted file mode 100644 index 4362a34fd..000000000 --- a/src/vhdl/sem_decls.ads +++ /dev/null @@ -1,105 +0,0 @@ --- Semantic analysis. --- 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 Iirs; use Iirs; - -package Sem_Decls is - -- Analyze an interface chain. - procedure Sem_Interface_Chain (Interface_Chain: Iir; - Interface_Kind : Interface_Kind_Type); - - -- Analyze declarations of PARENT. - procedure Sem_Declaration_Chain (Parent : Iir); - - -- Check all declarations of DECLS_PARENT are complete - -- This checks subprograms, deferred constants, incomplete types and - -- protected types. - -- - -- DECL is the declaration that contains the declaration_list DECLS_PARENT. - -- (location of errors). - -- DECL is different from DECLS_PARENT for package bodies and protected - -- type bodies. - -- - -- Also, report unused declarations if DECL = DECLS_PARENT. - -- As a consequence, Check_Full_Declaration must be called after analyze - -- of statements, if any. - procedure Check_Full_Declaration (Decls_Parent : Iir; Decl: Iir); - - procedure Sem_Iterator (Iterator : Iir_Iterator_Declaration; - Staticness : Iir_Staticness); - - -- Extract from NAME the named entity whose profile matches SIG. If NAME - -- is an overload list, it is destroyed. - function Sem_Signature (Name : Iir; Sig : Iir_Signature) return Iir; - - -- If the type of DECL is unconstrained, create a contrained subtype - -- either locally or globally static (according to VALUE). - -- This is to apply rules of LRM93 3.2.1.1 Index constraints and - -- discrete ranges. - procedure Sem_Object_Type_From_Value (Decl : Iir; Value : Iir); - - -- Mark SUBPRG as used. If SUBPRG is an instance, its generic is also - -- marked. - procedure Mark_Subprogram_Used (Subprg : Iir); - - -- The attribute signals ('stable, 'quiet and 'transaction) are - -- implicitely declared. - -- Note: guard signals are also implicitly declared but with a guard - -- expression, which is at a known location. - -- Since these signals need resources and are not easily located (can be - -- nearly in every expression), it is useful to add a node into a - -- declaration list to declare them. - -- However, only a few declaration_list can declare signals. These - -- declarations lists must register and unregister themselves with - -- push_declarative_region_with_signals and - -- pop_declarative_region_with_signals. - type Implicit_Signal_Declaration_Type is private; - - procedure Push_Signals_Declarative_Part - (Cell: out Implicit_Signal_Declaration_Type; Decls_Parent : Iir); - - procedure Pop_Signals_Declarative_Part - (Cell: in Implicit_Signal_Declaration_Type); - - -- Declare an implicit signal. - procedure Add_Declaration_For_Implicit_Signal (Sig : Iir); - -private - type Implicit_Signal_Declaration_Type is record - -- Declaration or statement than will contain implicit declarations. - Decls_Parent : Iir; - - -- Set to the signal_attribute_declaration when created (ie when the - -- first attribute signal is added). - Implicit_Decl : Iir; - - -- Last attribute signal inserted in the current Implicit_Decl. - Last_Attribute_Signal : Iir; - - -- If True, declarations of DECLS_PARENT have already been analyzed. - -- So implicit declarations are appended to the parent, and the last - -- declaration is LAST_DECL. - -- If False, declarations are being analyzed. Implicit declarations - -- are appended to IMPLICIT_DECL/LAST_ATTRIBUTE_SIGNAL and will be - -- inserted before the current declaration. - Decls_Analyzed : Boolean; - - -- Last declaration in the region. If an implicit_decl is createed, it - -- will be appended to LAST_DECL. - Last_Decl : Iir; - end record; -end Sem_Decls; diff --git a/src/vhdl/sem_expr.adb b/src/vhdl/sem_expr.adb deleted file mode 100644 index e26739bde..000000000 --- a/src/vhdl/sem_expr.adb +++ /dev/null @@ -1,5229 +0,0 @@ --- Semantic analysis. --- 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 Grt.Algos; -with Std_Package; use Std_Package; -with Errorout; use Errorout; -with Flags; use Flags; -with Sem_Scopes; use Sem_Scopes; -with Sem_Names; use Sem_Names; -with Sem; -with Name_Table; -with Str_Table; -with Iirs_Utils; use Iirs_Utils; -with Evaluation; use Evaluation; -with Iir_Chains; use Iir_Chains; -with Sem_Types; -with Sem_Stmts; use Sem_Stmts; -with Sem_Assocs; use Sem_Assocs; -with Sem_Decls; -with Xrefs; use Xrefs; - -package body Sem_Expr is - - -- Replace type of TARGET by A_TYPE. - -- If TARGET has already a type, it must be an overload list, and in this - -- case, this list is freed, or it must be A_TYPE. - -- A_TYPE can't be an overload list. - -- - -- This procedure can be called in the second pass, when the type is known. - procedure Replace_Type (Target: Iir; A_Type: Iir) - is - Old_Type: Iir; - begin - pragma Assert (not Is_Overload_List (A_Type)); - - Old_Type := Get_Type (Target); - if Old_Type /= Null_Iir then - if Is_Overload_List (Old_Type) then - Free_Iir (Old_Type); - elsif Old_Type = A_Type then - return; - else - -- Cannot replace an existing type by another one. - raise Internal_Error; - end if; - end if; - if A_Type = Null_Iir then - return; - end if; - Set_Type (Target, A_Type); - end Replace_Type; - - -- Return true if EXPR is overloaded, ie has several meanings. - function Is_Overloaded (Expr : Iir) return Boolean - is - Expr_Type : constant Iir := Get_Type (Expr); - begin - return Expr_Type = Null_Iir or else Is_Overload_List (Expr_Type); - end Is_Overloaded; - - -- Return the common type of base types LEFT and RIGHT. - -- LEFT are RIGHT must be really base types (not subtypes). - -- Roughly speaking, it returns LEFT (= RIGHT) if LEFT = RIGHT (ie, same - -- type), null otherwise. - -- However, it handles implicite conversions of universal types. - function Get_Common_Basetype (Left: Iir; Right: Iir) - return Iir is - begin - if Left = Right then - return Left; - end if; - case Get_Kind (Left) is - when Iir_Kind_Integer_Type_Definition => - if Right = Convertible_Integer_Type_Definition then - return Left; - elsif Left = Convertible_Integer_Type_Definition - and then Get_Kind (Right) = Iir_Kind_Integer_Type_Definition - then - return Right; - end if; - when Iir_Kind_Floating_Type_Definition => - if Right = Convertible_Real_Type_Definition then - return Left; - elsif Left = Convertible_Real_Type_Definition - and then Get_Kind (Right) = Iir_Kind_Floating_Type_Definition - then - return Right; - end if; - when others => - null; - end case; - return Null_Iir; - end Get_Common_Basetype; - - -- LEFT are RIGHT must be really a type (not a subtype). - function Are_Basetypes_Compatible (Left: Iir; Right: Iir) - return Compatibility_Level is - begin - if Left = Right then - return Fully_Compatible; - end if; - case Get_Kind (Left) is - when Iir_Kind_Integer_Type_Definition => - if Right = Convertible_Integer_Type_Definition then - if Left = Universal_Integer_Type_Definition then - return Fully_Compatible; - else - return Via_Conversion; - end if; - elsif Left = Convertible_Integer_Type_Definition - and then Get_Kind (Right) = Iir_Kind_Integer_Type_Definition - then - if Right = Universal_Integer_Type_Definition then - return Fully_Compatible; - else - return Via_Conversion; - end if; - end if; - when Iir_Kind_Floating_Type_Definition => - if Right = Convertible_Real_Type_Definition then - if Left = Universal_Real_Type_Definition then - return Fully_Compatible; - else - return Via_Conversion; - end if; - elsif Left = Convertible_Real_Type_Definition - and then Get_Kind (Right) = Iir_Kind_Floating_Type_Definition - then - if Right = Universal_Real_Type_Definition then - return Fully_Compatible; - else - return Via_Conversion; - end if; - end if; - when others => - null; - end case; - return Not_Compatible; - end Are_Basetypes_Compatible; - - function Are_Types_Compatible (Left: Iir; Right: Iir) - return Compatibility_Level is - begin - return Are_Basetypes_Compatible (Get_Base_Type (Left), - Get_Base_Type (Right)); - end Are_Types_Compatible; - - function Are_Nodes_Compatible (Left: Iir; Right: Iir) - return Compatibility_Level is - begin - return Are_Types_Compatible (Get_Type (Left), Get_Type (Right)); - end Are_Nodes_Compatible; - - -- Return TRUE iif LEFT_TYPE and RIGHT_TYPES are compatible. RIGHT_TYPES - -- may be an overload list. - function Compatibility_Types1 (Left_Type : Iir; Right_Types : Iir) - return Compatibility_Level - is - El : Iir; - Right_List : Iir_List; - It : List_Iterator; - Level : Compatibility_Level; - begin - pragma Assert (not Is_Overload_List (Left_Type)); - - if Is_Overload_List (Right_Types) then - Right_List := Get_Overload_List (Right_Types); - Level := Not_Compatible; - It := List_Iterate (Right_List); - while Is_Valid (It) loop - El := Get_Element (It); - Level := Compatibility_Level'Max - (Level, Are_Types_Compatible (Left_Type, El)); - if Level = Fully_Compatible then - return Fully_Compatible; - end if; - Next (It); - end loop; - return Level; - else - return Are_Types_Compatible (Left_Type, Right_Types); - end if; - end Compatibility_Types1; - - -- Return compatibility for nodes LEFT and RIGHT. - -- LEFT is expected to be an interface of a function definition. - -- Type of RIGHT can be an overload_list - -- RIGHT might be implicitly converted to LEFT. - function Compatibility_Nodes (Left : Iir; Right : Iir) - return Compatibility_Level - is - Left_Type : constant Iir := Get_Base_Type (Get_Type (Left)); - Right_Type : constant Iir := Get_Type (Right); - begin - -- Check. - case Get_Kind (Left_Type) is - when Iir_Kind_Floating_Type_Definition - | Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Integer_Type_Definition - | Iir_Kind_Record_Type_Definition - | Iir_Kind_File_Type_Definition - | Iir_Kind_Physical_Type_Definition - | Iir_Kind_Access_Type_Definition - | Iir_Kind_Array_Type_Definition => - null; - when others => - Error_Kind ("compatibility_nodes", Left_Type); - end case; - - return Compatibility_Types1 (Left_Type, Right_Type); - end Compatibility_Nodes; - - function Is_String_Type (A_Type : Iir) return Boolean - is - Base_Type : constant Iir := Get_Base_Type (A_Type); - El_Bt : Iir; - begin - -- LRM 7.3.1 - -- [...] the type of the literal must be a one-dimensional array ... - if not Is_One_Dimensional_Array_Type (Base_Type) then - return False; - end if; - -- LRM 7.3.1 - -- ... of a character type ... - El_Bt := Get_Base_Type (Get_Element_Subtype (Base_Type)); - if Get_Kind (El_Bt) /= Iir_Kind_Enumeration_Type_Definition then - return False; - end if; - -- FIXME: character type - return True; - end Is_String_Type; - - -- Return TRUE iff A_TYPE can be the type of string or bit string literal - -- EXPR. EXPR is needed to distinguish between string and bit string - -- for VHDL87 rule about the type of a bit string. - function Is_String_Literal_Type (A_Type : Iir; Expr : Iir) return Boolean - is - El_Bt : Iir; - begin - if not Is_String_Type (A_Type) then - return False; - end if; - El_Bt := Get_Base_Type (Get_Element_Subtype (A_Type)); - -- LRM87 7.3.1 - -- ... (for string literals) or of type BIT (for bit string literals). - if Flags.Vhdl_Std = Vhdl_87 - and then Get_Bit_String_Base (Expr) /= Base_None - and then El_Bt /= Bit_Type_Definition - then - return False; - end if; - return True; - end Is_String_Literal_Type; - - -- Return TRUE iff A_TYPE can be the type of an aggregate. - function Is_Aggregate_Type (A_Type : Iir) return Boolean is - begin - -- LRM 7.3.2 Aggregates - -- [...] the type of the aggregate must be a composite type. - case Get_Kind (Get_Base_Type (A_Type)) is - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Record_Type_Definition => - return True; - when others => - return False; - end case; - end Is_Aggregate_Type; - - -- Return TRUE iff A_TYPE can be the type of a null literal. - function Is_Null_Literal_Type (A_Type : Iir) return Boolean is - begin - -- LRM 7.3.1 Literals - -- The literal NULL represents the null access value for any access - -- type. - return - Get_Kind (Get_Base_Type (A_Type)) = Iir_Kind_Access_Type_Definition; - end Is_Null_Literal_Type; - - -- Return TRUE iff A_TYPE can be the type of allocator EXPR. Note that - -- the allocator must have been analyzed. - function Is_Allocator_Type (A_Type : Iir; Expr : Iir) return Boolean - is - Base_Type : constant Iir := Get_Base_Type (A_Type); - Designated_Type : Iir; - begin - -- LRM 7.3.6 Allocators - -- [...] the value returned is of an access type having the named - -- designated type. - - if Get_Kind (Base_Type) /= Iir_Kind_Access_Type_Definition then - return False; - end if; - Designated_Type := Get_Allocator_Designated_Type (Expr); - pragma Assert (Designated_Type /= Null_Iir); - -- Cheat: there is no allocators on universal types. - return Get_Base_Type (Get_Designated_Type (Base_Type)) - = Get_Base_Type (Designated_Type); - end Is_Allocator_Type; - - -- Return TRUE iff the type of EXPR is compatible with A_TYPE - function Is_Expr_Compatible (A_Type : Iir; Expr : Iir) - return Compatibility_Level - is - Expr_Type : constant Iir := Get_Type (Expr); - Is_Compatible : Boolean; - begin - if Expr_Type /= Null_Iir then - return Compatibility_Types1 (A_Type, Expr_Type); - end if; - - case Get_Kind (Expr) is - when Iir_Kind_Aggregate => - Is_Compatible := Is_Aggregate_Type (A_Type); - when Iir_Kind_String_Literal8 => - Is_Compatible := Is_String_Literal_Type (A_Type, Expr); - when Iir_Kind_Null_Literal => - Is_Compatible := Is_Null_Literal_Type (A_Type); - when Iir_Kind_Allocator_By_Expression - | Iir_Kind_Allocator_By_Subtype => - Is_Compatible := Is_Allocator_Type (A_Type, Expr); - when Iir_Kind_Parenthesis_Expression => - return Is_Expr_Compatible (A_Type, Get_Expression (Expr)); - when others => - -- Error while EXPR was typed. FIXME: should create an ERROR - -- node? - Is_Compatible := False; - end case; - if Is_Compatible then - return Fully_Compatible; - else - return Not_Compatible; - end if; - end Is_Expr_Compatible; - - function Check_Is_Expression (Expr : Iir; Loc : Iir) return Iir - is - begin - if Expr = Null_Iir then - return Null_Iir; - end if; - case Get_Kind (Expr) is - when Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration - | Iir_Kinds_Subtype_Definition - | Iir_Kind_Design_Unit - | Iir_Kind_Architecture_Body - | Iir_Kind_Configuration_Declaration - | Iir_Kind_Entity_Declaration - | Iir_Kind_Package_Declaration - | Iir_Kind_Package_Instantiation_Declaration - | Iir_Kinds_Concurrent_Statement - | Iir_Kinds_Sequential_Statement - | Iir_Kind_Library_Declaration - | Iir_Kind_Library_Clause - | Iir_Kind_Component_Declaration - | Iir_Kind_Procedure_Declaration - | Iir_Kind_Range_Array_Attribute - | Iir_Kind_Reverse_Range_Array_Attribute - | Iir_Kind_Element_Declaration - | Iir_Kind_Attribute_Declaration - | Iir_Kind_Psl_Declaration - | Iir_Kind_Signature => - Error_Msg_Sem (+Loc, "%n not allowed in an expression", +Expr); - return Null_Iir; - when Iir_Kind_Function_Declaration => - return Expr; - when Iir_Kind_Overload_List => - return Expr; - when Iir_Kinds_Literal - | Iir_Kind_Character_Literal - | Iir_Kind_Simple_Aggregate - | Iir_Kind_Unit_Declaration - | Iir_Kind_Enumeration_Literal => - return Expr; - when Iir_Kinds_External_Name => - return Expr; - when Iir_Kinds_Object_Declaration - | Iir_Kind_Aggregate - | Iir_Kind_Allocator_By_Expression - | Iir_Kind_Allocator_By_Subtype - | Iir_Kind_Qualified_Expression => - return Expr; - when Iir_Kinds_Quantity_Declaration => - return Expr; - when Iir_Kinds_Dyadic_Operator - | Iir_Kinds_Monadic_Operator => - return Expr; - when Iir_Kind_Slice_Name - | Iir_Kind_Indexed_Name - | Iir_Kind_Selected_Element - | Iir_Kind_Dereference - | Iir_Kind_Implicit_Dereference - | Iir_Kinds_Expression_Attribute - | Iir_Kind_Attribute_Value - | Iir_Kind_Parenthesis_Expression - | Iir_Kind_Type_Conversion - | Iir_Kind_Function_Call => - return Expr; - when Iir_Kind_Psl_Endpoint_Declaration => - return Expr; - when Iir_Kind_Simple_Name - | Iir_Kind_Parenthesis_Name - | Iir_Kind_Attribute_Name - | Iir_Kind_Selected_Name - | Iir_Kind_Selected_By_All_Name => - return Expr; - when Iir_Kind_Error => - return Expr; - when others => - Error_Kind ("check_is_expression", Expr); - --N := Get_Type (Expr); - --return Expr; - end case; - end Check_Is_Expression; - - -- Find a type compatible with A_TYPE in TYPE_LIST (which can be an - -- overload list or a simple type) and return it. - -- In case of failure, return null. - function Search_Overloaded_Type (Type_List: Iir; A_Type: Iir) - return Iir - is - Type_List_List : Iir_List; - It : List_Iterator; - El: Iir; - Com : Iir; - Res : Iir; - begin - if not Is_Overload_List (Type_List) then - return Get_Common_Basetype (Get_Base_Type (Type_List), - Get_Base_Type (A_Type)); - else - Type_List_List := Get_Overload_List (Type_List); - Res := Null_Iir; - It := List_Iterate (Type_List_List); - while Is_Valid (It) loop - El := Get_Element (It); - Com := Get_Common_Basetype (Get_Base_Type (El), - Get_Base_Type (A_Type)); - if Com /= Null_Iir then - if Res = Null_Iir then - Res := Com; - else - -- Several compatible types. - return Null_Iir; - end if; - end if; - Next (It); - end loop; - return Res; - end if; - end Search_Overloaded_Type; - - -- LIST1, LIST2 are either a type node or an overload list of types. - -- Return THE type which is compatible with LIST1 are LIST2. - -- Return null_iir if there is no such type or if there are several types. - function Search_Compatible_Type (List1, List2 : Iir) return Iir - is - List1_List : Iir_List; - It : List_Iterator; - Res : Iir; - El : Iir; - Tmp : Iir; - begin - if Is_Overload_List (List1) then - List1_List := Get_Overload_List (List1); - Res := Null_Iir; - It := List_Iterate (List1_List); - while Is_Valid (It) loop - El := Get_Element (It); - Tmp := Search_Overloaded_Type (List2, El); - if Tmp /= Null_Iir then - if Res = Null_Iir then - Res := Tmp; - else - -- Several types match. - return Null_Iir; - end if; - end if; - Next (It); - end loop; - return Res; - else - return Search_Overloaded_Type (List2, List1); - end if; - end Search_Compatible_Type; - - -- Analyze the range expression EXPR. - -- If A_TYPE is not null_iir, EXPR is expected to be of type A_TYPE. - -- LRM93 3.2.1.1 - -- FIXME: avoid to run it on an already analyzed node, be careful - -- with range_type_expr. - function Sem_Simple_Range_Expression - (Expr: Iir_Range_Expression; A_Type: Iir; Any_Dir : Boolean) - return Iir_Range_Expression - is - Base_Type: Iir; - Left, Right: Iir; - Left_Type, Right_Type : Iir; - Expr_Type : Iir; - begin - Expr_Type := Get_Type (Expr); - Left := Get_Left_Limit_Expr (Expr); - Right := Get_Right_Limit_Expr (Expr); - - if Expr_Type = Null_Iir then - -- Pass 1. - - if A_Type = Null_Iir then - Base_Type := Null_Iir; - else - Base_Type := Get_Base_Type (A_Type); - end if; - - -- Analyze left and right bounds. - Right := Sem_Expression_Ov (Right, Base_Type); - Left := Sem_Expression_Ov (Left, Base_Type); - - if Left = Null_Iir or else Right = Null_Iir then - if A_Type /= Null_Iir then - -- Can continue with the error. - if Left = Null_Iir then - Left := Create_Error_Expr - (Get_Left_Limit_Expr (Expr), A_Type); - end if; - if Right = Null_Iir then - Right := Create_Error_Expr - (Get_Right_Limit_Expr (Expr), A_Type); - end if; - else - -- Error. - return Null_Iir; - end if; - end if; - - Left_Type := Get_Type (Left); - Right_Type := Get_Type (Right); - -- Check for string or aggregate literals - -- FIXME: improve error message - if Left_Type = Null_Iir then - Error_Msg_Sem (+Left, "bad expression for a scalar"); - return Null_Iir; - end if; - if Right_Type = Null_Iir then - Error_Msg_Sem (+Right, "bad expression for a scalar"); - return Null_Iir; - end if; - - if Is_Overload_List (Left_Type) - or else Is_Overload_List (Right_Type) - then - if Base_Type /= Null_Iir then - -- Cannot happen, since sem_expression_ov should resolve - -- ambiguties if a type is given. - raise Internal_Error; - end if; - - -- Try to find a common type. - Expr_Type := Search_Compatible_Type (Left_Type, Right_Type); - if Expr_Type = Null_Iir then - if Compatibility_Types1 (Universal_Integer_Type_Definition, - Left_Type) /= Not_Compatible - and then - Compatibility_Types1 (Universal_Integer_Type_Definition, - Right_Type) /= Not_Compatible - then - Expr_Type := Universal_Integer_Type_Definition; - elsif Compatibility_Types1 (Universal_Real_Type_Definition, - Left_Type) /= Not_Compatible - and then - Compatibility_Types1 (Universal_Real_Type_Definition, - Right_Type) /= Not_Compatible - then - Expr_Type := Universal_Real_Type_Definition; - else - -- FIXME: handle overload - Error_Msg_Sem - (+Expr, - "left and right expressions of range are not compatible"); - return Null_Iir; - end if; - end if; - Left := Sem_Expression (Left, Expr_Type); - Right := Sem_Expression (Right, Expr_Type); - if Left = Null_Iir or else Right = Null_Iir then - return Null_Iir; - end if; - else - Expr_Type := Get_Common_Basetype (Get_Base_Type (Left_Type), - Get_Base_Type (Right_Type)); - if Expr_Type = Null_Iir then - Error_Msg_Sem - (+Expr, - "left and right expressions of range are not compatible"); - return Null_Iir; - end if; - end if; - - -- The type of the range is known, finish analysis. - else - -- Second call. - - pragma Assert (A_Type /= Null_Iir); - - if Is_Overload_List (Expr_Type) then - -- FIXME: resolve overload - raise Internal_Error; - else - if Are_Types_Compatible (Expr_Type, A_Type) = Not_Compatible then - Error_Msg_Sem - (+Expr, "type of range doesn't match expected type"); - return Null_Iir; - end if; - - return Expr; - end if; - end if; - - Left := Eval_Expr_If_Static (Left); - Right := Eval_Expr_If_Static (Right); - - Set_Left_Limit_Expr (Expr, Left); - Set_Right_Limit_Expr (Expr, Right); - - Set_Left_Limit (Expr, Left); - Set_Right_Limit (Expr, Right); - - Set_Expr_Staticness (Expr, Min (Get_Expr_Staticness (Left), - Get_Expr_Staticness (Right))); - - if A_Type /= Null_Iir then - if Are_Types_Compatible (Expr_Type, A_Type) = Not_Compatible then - Error_Msg_Sem (+Expr, "type of range doesn't match expected type"); - return Null_Iir; - end if; - - -- Use A_TYPE for the type of the expression. - Expr_Type := A_Type; - end if; - - Set_Type (Expr, Expr_Type); - if Get_Kind (Expr_Type) - not in Iir_Kinds_Scalar_Type_And_Subtype_Definition - then - Error_Msg_Sem (+Expr, "type of range is not a scalar type"); - return Null_Iir; - end if; - - if Get_Expr_Staticness (Expr) = Locally - and then Get_Type_Staticness (Expr_Type) = Locally - and then Get_Kind (Expr_Type) in Iir_Kinds_Subtype_Definition - then - Eval_Check_Range (Expr, Expr_Type, Any_Dir); - end if; - - return Expr; - end Sem_Simple_Range_Expression; - - -- The result can be: - -- a subtype definition - -- a range attribute - -- a range type definition - -- LRM93 3.2.1.1 - -- FIXME: avoid to run it on an already analyzed node, be careful - -- with range_type_expr. - function Sem_Range_Expression (Expr: Iir; A_Type: Iir; Any_Dir : Boolean) - return Iir - is - Res : Iir; - Res_Type : Iir; - begin - case Get_Kind (Expr) is - when Iir_Kind_Range_Expression => - Res := Sem_Simple_Range_Expression (Expr, A_Type, Any_Dir); - if Res = Null_Iir then - return Null_Iir; - end if; - Res_Type := Get_Type (Res); - - when Iir_Kinds_Denoting_Name - | Iir_Kind_Attribute_Name - | Iir_Kind_Parenthesis_Name => - if Get_Named_Entity (Expr) = Null_Iir then - Sem_Name (Expr); - end if; - Res := Name_To_Range (Expr); - if Is_Error (Res) then - return Null_Iir; - end if; - - case Get_Kind (Res) is - when Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name => - pragma Assert (Get_Kind (Get_Named_Entity (Res)) - in Iir_Kinds_Type_Declaration); - Res_Type := Get_Type (Get_Named_Entity (Res)); - when Iir_Kind_Range_Array_Attribute - | Iir_Kind_Reverse_Range_Array_Attribute => - Res_Type := Get_Type (Res); - when others => - Error_Msg_Sem (+Expr, "name must denote a range"); - return Null_Iir; - end case; - if A_Type /= Null_Iir - and then Get_Base_Type (Res_Type) /= Get_Base_Type (A_Type) - then - Error_Not_Match (Expr, A_Type); - return Null_Iir; - end if; - - when others => - Error_Msg_Sem (+Expr, "range expression required"); - return Null_Iir; - end case; - - if Get_Kind (Res_Type) - not in Iir_Kinds_Scalar_Type_And_Subtype_Definition - then - Error_Msg_Sem (+Expr, "%n is not a range type", +Res); - return Null_Iir; - end if; - - Res := Eval_Range_If_Static (Res); - - if A_Type /= Null_Iir - and then Get_Type_Staticness (A_Type) = Locally - and then Get_Kind (A_Type) in Iir_Kinds_Subtype_Definition - then - if Get_Expr_Staticness (Res) = Locally then - Eval_Check_Range (Res, A_Type, Any_Dir); - end if; - end if; - return Res; - end Sem_Range_Expression; - - function Sem_Discrete_Range_Expression - (Expr: Iir; A_Type: Iir; Any_Dir : Boolean) - return Iir - is - Res : Iir; - Res_Type : Iir; - begin - if Get_Kind (Expr) = Iir_Kind_Subtype_Definition then - Res := Sem_Types.Sem_Subtype_Indication (Expr); - if Res = Null_Iir then - return Null_Iir; - end if; - - Res_Type := Res; - if A_Type /= Null_Iir - and then (Are_Types_Compatible - (A_Type, Get_Type_Of_Subtype_Indication (Res)) - = Not_Compatible) - then - -- A_TYPE is known when analyzing an index_constraint within - -- a subtype indication. - Error_Msg_Sem (+Expr, "subtype %n doesn't match expected type %n", - (+Res, +A_Type)); - -- FIXME: override type of RES ? - end if; - else - Res := Sem_Range_Expression (Expr, A_Type, Any_Dir); - - if Res = Null_Iir then - return Null_Iir; - end if; - - Res_Type := Get_Type (Res); - end if; - - -- Check the type is discrete. - if Get_Kind (Res_Type) not in Iir_Kinds_Discrete_Type_Definition then - if Get_Kind (Res_Type) /= Iir_Kind_Error then - -- FIXME: avoid that test with error. - if Get_Kind (Res) not in Iir_Kinds_Denoting_Name then - Error_Msg_Sem (+Res, "range is not discrete"); - else - Error_Msg_Sem - (+Expr, "%n is not a discrete range type", +Res); - end if; - end if; - return Null_Iir; - end if; - - return Res; - end Sem_Discrete_Range_Expression; - - function Sem_Discrete_Range_Integer (Expr: Iir) return Iir - is - Res : Iir; - Range_Type : Iir; - begin - Res := Sem_Discrete_Range_Expression (Expr, Null_Iir, True); - if Res = Null_Iir then - return Null_Iir; - end if; - if Get_Kind (Expr) /= Iir_Kind_Range_Expression then - return Res; - end if; - - Range_Type := Get_Type (Res); - if Range_Type = Convertible_Integer_Type_Definition then - -- LRM 3.2.1.1 Index constraints and discrete ranges - -- For a discrete range used in a constrained array - -- definition and defined by a range, an implicit - -- conversion to the predefined type INTEGER is assumed - -- if each bound is either a numeric literal or an - -- attribute, and the type of both bounds (prior to the - -- implicit conversion) is the type universal_integer. - - -- FIXME: catch phys/phys. - Set_Type (Res, Integer_Type_Definition); - if Get_Expr_Staticness (Res) = Locally then - Eval_Check_Range (Res, Integer_Subtype_Definition, True); - end if; - elsif Range_Type = Universal_Integer_Type_Definition then - if Vhdl_Std >= Vhdl_08 then - -- LRM08 5.3.2.2 - -- For a discrete range used in a constrained array definition - -- and defined by a range, an implicit conversion to the - -- predefined type INTEGER is assumed if the type of both bounds - -- (prior the implicit conversion) is the type universal_integer. - null; - elsif Vhdl_Std = Vhdl_93c or else Flag_Relaxed_Rules then - null; - elsif Vhdl_Std /= Vhdl_93 then - -- GHDL: this is not allowed, however often used: - -- eg: for i in 0 to v'length + 1 loop - -- eg: for i in -1 to 1 loop - - -- Be tolerant. - Warning_Msg_Sem (Warnid_Universal, +Res, - "universal integer bound must be numeric literal " - & "or attribute"); - else - Error_Msg_Sem (+Res, "universal integer bound must be numeric " - & "literal or attribute"); - end if; - Set_Type (Res, Integer_Type_Definition); - end if; - return Res; - end Sem_Discrete_Range_Integer; - - procedure Set_Function_Call_Staticness (Expr : Iir; Imp : Iir) - is - Staticness : Iir_Staticness; - begin - -- LRM93 7.4.1 (Locally Static Primaries) - -- 4. a function call whose function name denotes an implicitly - -- defined operator, and whose actual parameters are each - -- locally static expressions; - -- - -- LRM93 7.4.2 (Globally Static Primaries) - -- 9. a function call whose function name denotes a pure function, - -- and whose actual parameters are each globally static - -- expressions. - case Get_Kind (Expr) is - when Iir_Kinds_Monadic_Operator => - Staticness := Get_Expr_Staticness (Get_Operand (Expr)); - when Iir_Kinds_Dyadic_Operator => - Staticness := Min (Get_Expr_Staticness (Get_Left (Expr)), - Get_Expr_Staticness (Get_Right (Expr))); - when Iir_Kind_Function_Call => - Staticness := Locally; - declare - Assoc : Iir; - begin - Assoc := Get_Parameter_Association_Chain (Expr); - while Assoc /= Null_Iir loop - if Get_Kind (Assoc) - = Iir_Kind_Association_Element_By_Expression - then - Staticness := Min - (Get_Expr_Staticness (Get_Actual (Assoc)), - Staticness); - end if; - Assoc := Get_Chain (Assoc); - end loop; - end; - when Iir_Kind_Procedure_Call => - return; - when others => - Error_Kind ("set_function_call_staticness (1)", Expr); - end case; - - -- Staticness. - case Get_Kind (Imp) is - when Iir_Kind_Function_Declaration => - case Get_Implicit_Definition (Imp) is - when Iir_Predefined_Error => - raise Internal_Error; - when Iir_Predefined_Pure_Functions => - null; - when Iir_Predefined_Impure_Functions => - -- Predefined functions such as Now, Endfile are not static. - Staticness := None; - when Iir_Predefined_Explicit => - if Get_Pure_Flag (Imp) then - Staticness := Min (Staticness, Globally); - else - Staticness := None; - end if; - end case; - when Iir_Kind_Interface_Function_Declaration => - Staticness := None; - when others => - Error_Kind ("set_function_call_staticness", Imp); - end case; - Set_Expr_Staticness (Expr, Staticness); - end Set_Function_Call_Staticness; - - -- Add CALLEE in the callees list of SUBPRG (which must be a subprg decl). - procedure Add_In_Callees_List (Subprg : Iir; Callee : Iir) - is - Holder : constant Iir := Get_Callees_List_Holder (Subprg); - List : Iir_List; - begin - List := Get_Callees_List (Holder); - if List = Null_Iir_List then - List := Create_Iir_List; - Set_Callees_List (Holder, List); - end if; - -- FIXME: May use a flag in IMP to speed up the - -- add operation. - Add_Element (List, Callee); - end Add_In_Callees_List; - - -- Check purity rules when SUBPRG calls CALLEE. - -- Both SUBPRG and CALLEE are subprogram declarations. - -- Update purity_state/impure_depth of SUBPRG if it is a procedure. - procedure Sem_Call_Purity_Check (Subprg : Iir; Callee : Iir; Loc : Iir) is - begin - if Callee = Subprg then - return; - end if; - - -- Handle easy cases. - case Get_Kind (Subprg) is - when Iir_Kind_Function_Declaration => - if not Get_Pure_Flag (Subprg) then - return; - end if; - when Iir_Kind_Procedure_Declaration => - if Get_Purity_State (Subprg) = Impure then - return; - end if; - when Iir_Kinds_Process_Statement => - return; - when others => - Error_Kind ("sem_call_purity_check(0)", Subprg); - end case; - - case Get_Kind (Callee) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Interface_Function_Declaration => - if Get_Pure_Flag (Callee) then - -- Pure functions may be called anywhere. - return; - end if; - -- CALLEE is impure. - case Get_Kind (Subprg) is - when Iir_Kind_Function_Declaration => - Error_Pure (Semantic, Subprg, Callee, Loc); - when Iir_Kind_Procedure_Declaration => - Set_Purity_State (Subprg, Impure); - when others => - Error_Kind ("sem_call_purity_check(1)", Subprg); - end case; - when Iir_Kind_Procedure_Declaration => - declare - Depth : Iir_Int32; - Callee_Body : constant Iir := Get_Subprogram_Body (Callee); - Subprg_Body : constant Iir := Get_Subprogram_Body (Subprg); - begin - -- Get purity depth of callee, if possible. - case Get_Purity_State (Callee) is - when Pure => - return; - when Impure => - Depth := Iir_Depth_Impure; - when Maybe_Impure => - if Callee_Body = Null_Iir then - -- Cannot be 'maybe_impure' if no body! - raise Internal_Error; - end if; - Depth := Get_Impure_Depth (Callee_Body); - when Unknown => - -- Add in list. - Add_In_Callees_List (Subprg, Callee); - - if Callee_Body /= Null_Iir then - Depth := Get_Impure_Depth (Callee_Body); - else - return; - end if; - end case; - case Get_Kind (Subprg) is - when Iir_Kind_Function_Declaration => - if Depth = Iir_Depth_Impure then - Error_Pure (Semantic, Subprg, Callee, Loc); - else - if Depth < Get_Subprogram_Depth (Subprg) then - Error_Pure (Semantic, Subprg, Callee, Loc); - end if; - end if; - when Iir_Kind_Procedure_Declaration => - if Depth = Iir_Depth_Impure then - Set_Purity_State (Subprg, Impure); - -- FIXME: free callee list ? (wait state). - else - -- Set depth to the worst. - if Depth < Get_Impure_Depth (Subprg_Body) then - Set_Impure_Depth (Subprg_Body, Depth); - end if; - end if; - when others => - Error_Kind ("sem_call_purity_check(2)", Subprg); - end case; - end; - when Iir_Kind_Interface_Procedure_Declaration => - -- We have no idea about this procedure. - null; - when others => - Error_Kind ("sem_call_purity_check", Callee); - end case; - end Sem_Call_Purity_Check; - - procedure Sem_Call_Wait_Check (Subprg : Iir; Callee : Iir; Loc : Iir) - is - procedure Error_Wait is - begin - Error_Msg_Sem - (+Loc, "%n must not contain wait statement, but calls", - (1 => +Subprg), Cont => True); - Error_Msg_Sem - (+Callee, "%n which has (indirectly) a wait statement", +Callee); - --Error_Msg_Sem - -- ("(indirect) wait statement not allowed in " & Where, Loc); - end Error_Wait; - begin - pragma Assert (Get_Kind (Callee) = Iir_Kind_Procedure_Declaration); - - case Get_Wait_State (Callee) is - when False => - return; - when True => - null; - when Unknown => - Add_In_Callees_List (Subprg, Callee); - return; - end case; - - -- LRM 8.1 - -- It is an error if a wait statement appears [...] in a procedure that - -- has a parent that is a function subprogram. - -- - -- Furthermore, it is an error if a wait statement appears [...] in a - -- procedure that has a parent that is such a process statement. - case Get_Kind (Subprg) is - when Iir_Kind_Sensitized_Process_Statement => - Error_Wait; - return; - when Iir_Kind_Process_Statement => - return; - when Iir_Kind_Function_Declaration => - Error_Wait; - return; - when Iir_Kind_Procedure_Declaration => - if Is_Subprogram_Method (Subprg) then - Error_Wait; - else - Set_Wait_State (Subprg, True); - end if; - when others => - Error_Kind ("sem_call_wait_check", Subprg); - end case; - end Sem_Call_Wait_Check; - - procedure Sem_Call_All_Sensitized_Check - (Subprg : Iir; Callee : Iir; Loc : Iir) - is - begin - -- No need to deal with 'process (all)' if standard predates it. - if Vhdl_Std < Vhdl_08 then - return; - end if; - - -- If subprogram called is pure, then there is no signals reference. - case Get_Kind (Callee) is - when Iir_Kind_Function_Declaration => - if Get_Pure_Flag (Callee) then - return; - end if; - when Iir_Kind_Procedure_Declaration => - if Get_Purity_State (Callee) = Pure then - return; - end if; - when Iir_Kind_Interface_Function_Declaration - | Iir_Kind_Interface_Procedure_Declaration => - -- FIXME: how to compute sensitivity ? Recurse ? - return; - when others => - Error_Kind ("sem_call_all_sensitized_check", Callee); - end case; - - case Get_All_Sensitized_State (Callee) is - when Invalid_Signal => - case Get_Kind (Subprg) is - when Iir_Kind_Sensitized_Process_Statement => - if Get_Sensitivity_List (Subprg) = Iir_List_All then - -- LRM08 11.3 - -- - -- It is an error if a process statement with the - -- reserved word ALL as its process sensitivity list - -- is the parent of a subprogram declared in a design - -- unit other than that containing the process statement - -- and the subprogram reads an explicitly declared - -- signal that is not a formal signal parameter or - -- member of a formal signal parameter of the - -- subprogram or of any of its parents. Similarly, - -- it is an error if such subprogram reads an implicit - -- signal whose explicit ancestor is not a formal signal - -- parameter or member of a formal parameter of - -- the subprogram or of any of its parents. - Error_Msg_Sem (+Loc, "all-sensitized %n can't call %n", - (+Subprg, +Callee), Cont => True); - Error_Msg_Sem - (+Loc, - " (as this subprogram reads (indirectly) a signal)"); - end if; - when Iir_Kind_Process_Statement => - return; - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - Set_All_Sensitized_State (Subprg, Invalid_Signal); - when others => - Error_Kind ("sem_call_all_sensitized_check", Subprg); - end case; - when Read_Signal => - -- Put this subprogram in callees list as it may read a signal. - -- Used by canon to build the sensitivity list. - Add_In_Callees_List (Subprg, Callee); - if Get_Kind (Subprg) in Iir_Kinds_Subprogram_Declaration then - if Get_All_Sensitized_State (Subprg) < Read_Signal then - Set_All_Sensitized_State (Subprg, Read_Signal); - end if; - end if; - when Unknown => - -- Put this subprogram in callees list as it may read a signal. - -- Used by canon to build the sensitivity list. - Add_In_Callees_List (Subprg, Callee); - when No_Signal => - null; - end case; - end Sem_Call_All_Sensitized_Check; - - -- Set IMP as the implementation to being called by EXPR. - -- If the context is a subprogram or a process (ie, if current_subprogram - -- is not NULL), then mark IMP as callee of current_subprogram, and - -- update states. - procedure Sem_Subprogram_Call_Finish (Expr : Iir; Imp : Iir) - is - Subprg : constant Iir := Get_Current_Subprogram; - begin - Set_Function_Call_Staticness (Expr, Imp); - Sem_Decls.Mark_Subprogram_Used (Imp); - - -- Check purity/wait/passive. - - if Subprg = Null_Iir then - -- Not inside a suprogram or a process. - return; - end if; - if Subprg = Imp then - -- Recursive call. - return; - end if; - - if Is_Implicit_Subprogram (Imp) then - -- FIXME: impure predefined functions. - null; - else - Sem_Call_Purity_Check (Subprg, Imp, Expr); - Sem_Call_All_Sensitized_Check (Subprg, Imp, Expr); - if Get_Kind (Imp) = Iir_Kind_Procedure_Declaration then - Sem_Call_Wait_Check (Subprg, Imp, Expr); - -- Check passive. - if Get_Passive_Flag (Imp) = False then - case Get_Kind (Subprg) is - when Iir_Kinds_Process_Statement => - if Get_Passive_Flag (Subprg) then - Error_Msg_Sem - (+Expr, "%n is passive, but calls non-passive %n", - (+Subprg, +Imp)); - end if; - when others => - null; - end case; - end if; - end if; - end if; - end Sem_Subprogram_Call_Finish; - - -- EXPR is a function or procedure call. - function Sem_Subprogram_Call_Stage1 - (Expr : Iir; A_Type : Iir; Is_Func_Call : Boolean) return Iir - is - Imp : Iir; - A_Func: Iir; - Imp_List: Iir_List; - New_List : Iir_List; - Assoc_Chain: Iir; - Inter_Chain : Iir; - Res_Type: Iir_List; - Imp_It : List_Iterator; - Inter: Iir; - Match : Compatibility_Level; - Match_Max : Compatibility_Level; - begin - -- Sem_Name has gathered all the possible names for the prefix of this - -- call. Reduce this list to only names that match the types. - Imp := Get_Implementation (Expr); - Imp_List := Get_Overload_List (Imp); - Assoc_Chain := Get_Parameter_Association_Chain (Expr); - Match_Max := Via_Conversion; - - New_List := Create_Iir_List; - Imp_It := List_Iterate (Imp_List); - while Is_Valid (Imp_It) loop - A_Func := Get_Element (Imp_It); - - case Get_Kind (A_Func) is - when Iir_Kinds_Functions_And_Literals - | Iir_Kind_Interface_Function_Declaration => - if not Is_Func_Call then - -- The identifier of a function call must be a function or - -- an enumeration literal. - goto Continue; - end if; - when Iir_Kind_Procedure_Declaration - | Iir_Kind_Interface_Procedure_Declaration => - if Is_Func_Call then - -- The identifier of a procedure call must be a procedure. - goto Continue; - end if; - when others => - Error_Kind ("sem_subprogram_call_stage1", A_Func); - end case; - - -- Keep this interpretation only if compatible. - if A_Type = Null_Iir - or else (Compatibility_Nodes (A_Type, Get_Return_Type (A_Func)) - /= Not_Compatible) - then - Sem_Association_Chain - (Get_Interface_Declaration_Chain (A_Func), - Assoc_Chain, False, Missing_Parameter, Expr, Match); - if Match >= Match_Max then - -- Only previous interpretations were only Via_Conversion - -- compatible, and this one is fully compatible, discard - -- previous and future Via_Conversion interpretations. - if Match > Match_Max then - Destroy_Iir_List (New_List); - New_List := Create_Iir_List; - Match_Max := Match; - end if; - Append_Element (New_List, A_Func); - end if; - end if; - - << Continue >> null; - Next (Imp_It); - end loop; - Destroy_Iir_List (Imp_List); - Imp_List := New_List; - Set_Overload_List (Imp, Imp_List); - - -- Set_Implementation (Expr, Inter_List); - -- A set of possible functions to call is in INTER_LIST. - -- Create a set of possible return type in RES_TYPE. - case Get_Nbr_Elements (Imp_List) is - when 0 => - -- FIXME: display subprogram name. - Error_Msg_Sem - (+Expr, "cannot resolve overloading for subprogram call"); - return Null_Iir; - - when 1 => - -- Simple case: no overloading. - Inter := Get_First_Element (Imp_List); - Free_Overload_List (Imp); - Set_Implementation (Expr, Inter); - if Is_Func_Call then - Set_Type (Expr, Get_Return_Type (Inter)); - end if; - Inter_Chain := Get_Interface_Declaration_Chain (Inter); - Sem_Association_Chain - (Inter_Chain, Assoc_Chain, - True, Missing_Parameter, Expr, Match); - Set_Parameter_Association_Chain (Expr, Assoc_Chain); - pragma Assert (Match /= Not_Compatible); - Check_Subprogram_Associations (Inter_Chain, Assoc_Chain); - Sem_Subprogram_Call_Finish (Expr, Inter); - return Expr; - - when others => - if Is_Func_Call then - if A_Type /= Null_Iir then - -- Cannot find a single interpretation for a given - -- type. - Error_Overload (Expr); - Disp_Overload_List (Imp_List, Expr); - return Null_Iir; - end if; - - -- Create the list of types for the result. - Res_Type := Create_Iir_List; - Imp_It := List_Iterate (Imp_List); - while Is_Valid (Imp_It) loop - Add_Element - (Res_Type, Get_Return_Type (Get_Element (Imp_It))); - Next (Imp_It); - end loop; - - if Get_Nbr_Elements (Res_Type) = 1 then - -- several implementations but one profile. - Error_Overload (Expr); - Disp_Overload_List (Imp_List, Expr); - return Null_Iir; - end if; - Set_Type (Expr, Create_Overload_List (Res_Type)); - else - -- For a procedure call, the context does't help to resolve - -- overload. - Error_Overload (Expr); - Disp_Overload_List (Imp_List, Expr); - end if; - return Expr; - end case; - end Sem_Subprogram_Call_Stage1; - - -- For a procedure call, A_TYPE must be null. - -- Associations must have already been analyzed by sem_association_list. - function Sem_Subprogram_Call (Expr: Iir; A_Type: Iir) return Iir - is - Is_Func: constant Boolean := Get_Kind (Expr) = Iir_Kind_Function_Call; - Res_Type: Iir; - Res: Iir; - Inter_List: Iir; - Param_Chain : Iir; - Inter: Iir; - Assoc_Chain : Iir; - Match : Compatibility_Level; - Overload_List : Iir_List; - Overload_It : List_Iterator; - begin - if Is_Func then - Res_Type := Get_Type (Expr); - end if; - - if not Is_Func or else Res_Type = Null_Iir then - -- First call to sem_subprogram_call. - -- Create the list of possible implementations and possible - -- return types, according to arguments and A_TYPE. - - -- Select possible interpretations among all interpretations. - -- NOTE: the list of possible implementations was already created - -- during the transformation of iir_kind_parenthesis_name to - -- iir_kind_function_call. - Inter_List := Get_Implementation (Expr); - if Get_Kind (Inter_List) = Iir_Kind_Error then - return Null_Iir; - elsif Is_Overload_List (Inter_List) then - -- Subprogram name is overloaded. - return Sem_Subprogram_Call_Stage1 (Expr, A_Type, Is_Func); - else - -- Only one interpretation for the subprogram name. - if Is_Func then - if not Is_Function_Declaration (Inter_List) then - Error_Msg_Sem (+Expr, "name does not designate a function", - Cont => True); - Error_Msg_Sem (+Expr, "name is %n defined at %l", - (+Inter_List, +Inter_List)); - return Null_Iir; - end if; - else - if not Is_Procedure_Declaration (Inter_List) then - Error_Msg_Sem (+Expr, "name does not designate a procedure", - Cont => True); - Error_Msg_Sem (+Expr, "name is %n defined at %l", - (+Inter_List, +Inter_List)); - return Null_Iir; - end if; - end if; - - Assoc_Chain := Get_Parameter_Association_Chain (Expr); - Param_Chain := Get_Interface_Declaration_Chain (Inter_List); - Sem_Association_Chain - (Param_Chain, Assoc_Chain, - True, Missing_Parameter, Expr, Match); - Set_Parameter_Association_Chain (Expr, Assoc_Chain); - if Match = Not_Compatible then - -- No need to disp an error message, this is done by - -- sem_subprogram_arguments. - return Null_Iir; - end if; - if Is_Func then - Set_Type (Expr, Get_Return_Type (Inter_List)); - end if; - Check_Subprogram_Associations (Param_Chain, Assoc_Chain); - Set_Implementation (Expr, Inter_List); - Sem_Subprogram_Call_Finish (Expr, Inter_List); - return Expr; - end if; - end if; - - -- Second call to Sem_Function_Call (only for functions). - pragma Assert (Is_Func); - pragma Assert (A_Type /= Null_Iir); - - -- The implementation list was set. - -- The return type was set. - -- A_TYPE is not null, A_TYPE is *the* return type. - - Inter_List := Get_Implementation (Expr); - - -- Find a single implementation. - Res := Null_Iir; - if Is_Overload_List (Inter_List) then - -- INTER_LIST is a list of possible declaration to call. - -- Find one, based on the return type A_TYPE. - Overload_List := Get_Overload_List (Inter_List); - Overload_It := List_Iterate (Overload_List); - while Is_Valid (Overload_It) loop - Inter := Get_Element (Overload_It); - if Are_Basetypes_Compatible - (A_Type, Get_Base_Type (Get_Return_Type (Inter))) - /= Not_Compatible - then - if Res /= Null_Iir then - Error_Overload (Expr); - Disp_Overload_List (Overload_List, Expr); - return Null_Iir; - else - Res := Inter; - end if; - end if; - Next (Overload_It); - end loop; - else - if Are_Basetypes_Compatible - (A_Type, Get_Base_Type (Get_Return_Type (Inter_List))) - /= Not_Compatible - then - Res := Inter_List; - end if; - end if; - if Res = Null_Iir then - Error_Not_Match (Expr, A_Type); - return Null_Iir; - end if; - - -- Clean up. - if Res_Type /= Null_Iir and then Is_Overload_List (Res_Type) then - Free_Iir (Res_Type); - end if; - - if Is_Overload_List (Inter_List) then - Free_Iir (Inter_List); - end if; - - -- Simple case: this is not a call to a function, but an enumeration - -- literal. - if Get_Kind (Res) = Iir_Kind_Enumeration_Literal then - -- Free_Iir (Expr); - return Res; - end if; - - -- Set types. - Set_Type (Expr, Get_Return_Type (Res)); - Assoc_Chain := Get_Parameter_Association_Chain (Expr); - Param_Chain := Get_Interface_Declaration_Chain (Res); - Sem_Association_Chain - (Param_Chain, Assoc_Chain, True, Missing_Parameter, Expr, Match); - Set_Parameter_Association_Chain (Expr, Assoc_Chain); - if Match = Not_Compatible then - return Null_Iir; - end if; - Check_Subprogram_Associations (Param_Chain, Assoc_Chain); - Set_Implementation (Expr, Res); - Sem_Subprogram_Call_Finish (Expr, Res); - return Expr; - end Sem_Subprogram_Call; - - procedure Sem_Procedure_Call (Call : Iir_Procedure_Call; Stmt : Iir) - is - Imp: Iir; - Name : Iir; - Parameters_Chain : Iir; - Param : Iir; - Formal : Iir; - Prefix : Iir; - Inter : Iir; - begin - Name := Get_Prefix (Call); - -- FIXME: check for denoting name. - Sem_Name (Name); - - -- Return now if the procedure declaration wasn't found. - Imp := Get_Named_Entity (Name); - if Is_Error (Imp) then - return; - end if; - Set_Implementation (Call, Imp); - - Name_To_Method_Object (Call, Name); - Parameters_Chain := Get_Parameter_Association_Chain (Call); - if Sem_Actual_Of_Association_Chain (Parameters_Chain) = False then - return; - end if; - if Sem_Subprogram_Call (Call, Null_Iir) /= Call then - return; - end if; - Imp := Get_Implementation (Call); - if Is_Overload_List (Imp) then - -- Failed to resolve overload. - return; - end if; - Set_Named_Entity (Name, Imp); - Set_Prefix (Call, Finish_Sem_Name (Name)); - - -- LRM 2.1.1.2 Signal Parameters - -- A process statement contains a driver for each actual signal - -- associated with a formal signal parameter of mode OUT or INOUT in - -- a subprogram call. - -- Similarly, a subprogram contains a driver for each formal signal - -- parameter of mode OUT or INOUT declared in its subrogram - -- specification. - Param := Parameters_Chain; - Inter := Get_Interface_Declaration_Chain (Imp); - while Param /= Null_Iir loop - -- Association_Element_By_Individual duplicates existing - -- associations. - if Get_Kind (Param) /= Iir_Kind_Association_Element_By_Individual - then - Formal := Get_Formal (Param); - if Formal = Null_Iir then - Formal := Inter; - Inter := Get_Chain (Inter); - else - Formal := Get_Base_Name (Formal); - Inter := Null_Iir; - end if; - if Get_Kind (Formal) = Iir_Kind_Interface_Signal_Declaration - and then Get_Mode (Formal) in Iir_Out_Modes - then - Prefix := Name_To_Object (Get_Actual (Param)); - if Prefix /= Null_Iir then - case Get_Kind (Get_Object_Prefix (Prefix)) is - when Iir_Kind_Signal_Declaration - | Iir_Kind_Interface_Signal_Declaration => - Prefix := Get_Longuest_Static_Prefix (Prefix); - Sem_Stmts.Sem_Add_Driver (Prefix, Stmt); - when others => - null; - end case; - end if; - end if; - end if; - Param := Get_Chain (Param); - end loop; - end Sem_Procedure_Call; - - -- List must be an overload list containing subprograms declarations. - -- Try to resolve overload and return the uniq interpretation if one, - -- NULL_IIR otherwise. - -- - -- If there are two functions, one primitive of a universal - -- type and the other not, return the primitive of the universal type. - -- This implements implicit type conversions rules. - -- Cf Sem_Names.Extract_Call_Without_Implicit_Conversion - -- - -- The typical case is the use of comparison operator with literals or - -- attributes, like: s'length = 0 - function Get_Non_Implicit_Subprogram (List : Iir_List) return Iir - is - It : List_Iterator; - El : Iir; - Res : Iir; - Ref_Type : Iir; - begin - -- Conditions: - -- 1. All the possible functions must return boolean. - -- 2. There is only one implicit function for universal or real. - Res := Null_Iir; - It := List_Iterate (List); - while Is_Valid (It) loop - El := Get_Element (It); - - -- Only comparison operators need this special handling. - if Get_Base_Type (Get_Return_Type (El)) /= Boolean_Type_Definition - then - return Null_Iir; - end if; - - if Is_Implicit_Subprogram (El) then - Ref_Type := Get_Type (Get_Interface_Declaration_Chain (El)); - if Ref_Type = Universal_Integer_Type_Definition - or Ref_Type = Universal_Real_Type_Definition - then - -- There could be only one such subprogram. - pragma Assert (Res = Null_Iir); - Res := El; - end if; - end if; - Next (It); - end loop; - return Res; - end Get_Non_Implicit_Subprogram; - - -- Honor the -fexplicit flag. - -- If LIST is composed of 2 declarations that matches the 'explicit' rule, - -- return the explicit declaration. - -- Otherwise, return NULL_IIR. - function Get_Explicit_Subprogram (List : Iir_List) return Iir - is - Sub1 : Iir; - Sub2 : Iir; - It : List_Iterator; - Res : Iir; - begin - if Get_Nbr_Elements (List) /= 2 then - return Null_Iir; - end if; - - It := List_Iterate (List); - Sub1 := Get_Element (It); - Next (It); - Sub2 := Get_Element (It); - Next (It); - pragma Assert (not Is_Valid (It)); - - -- One must be an implicit declaration, the other must be an explicit - -- declaration. - pragma Assert (Get_Kind (Sub1) = Iir_Kind_Function_Declaration); - pragma Assert (Get_Kind (Sub2) = Iir_Kind_Function_Declaration); - if Is_Implicit_Subprogram (Sub1) then - if Is_Implicit_Subprogram (Sub2) then - return Null_Iir; - end if; - Res := Sub2; - else - if not Is_Implicit_Subprogram (Sub2) then - return Null_Iir; - end if; - Res := Sub1; - end if; - - -- They must have the same profile. - if Get_Subprogram_Hash (Sub1) /= Get_Subprogram_Hash (Sub2) - or else not Is_Same_Profile (Sub1, Sub2) - then - return Null_Iir; - end if; - - -- They must be declared in a package. - if Get_Kind (Get_Parent (Sub1)) /= Iir_Kind_Package_Declaration - or else Get_Kind (Get_Parent (Sub2)) /= Iir_Kind_Package_Declaration - then - return Null_Iir; - end if; - - return Res; - end Get_Explicit_Subprogram; - - -- Set when the -fexplicit option was adviced. - Explicit_Advice_Given : Boolean := False; - - function Sem_Operator (Expr : Iir; Res_Type : Iir; Arity : Positive) - return Iir - is - Operator : Name_Id; - Left, Right: Iir; - Interpretation : Name_Interpretation_Type; - Decl : Iir; - Overload_List : Iir_List; - Overload : Iir; - Res_Type_List : Iir; - Full_Compat : Iir; - It : List_Iterator; - - -- LEFT and RIGHT must be set. - function Set_Uniq_Interpretation (Decl : Iir) return Iir - is - Interface_Chain : Iir; - Err : Boolean; - begin - Set_Type (Expr, Get_Return_Type (Decl)); - Interface_Chain := Get_Interface_Declaration_Chain (Decl); - Err := False; - if Is_Overloaded (Left) then - Left := Sem_Expression_Ov - (Left, Get_Base_Type (Get_Type (Interface_Chain))); - if Left = Null_Iir then - Err := True; - else - if Arity = 1 then - Set_Operand (Expr, Left); - else - Set_Left (Expr, Left); - end if; - end if; - end if; - Check_Read (Left); - if Arity = 2 then - if Is_Overloaded (Right) then - Right := Sem_Expression_Ov - (Right, - Get_Base_Type (Get_Type (Get_Chain (Interface_Chain)))); - if Right = Null_Iir then - Err := True; - else - Set_Right (Expr, Right); - end if; - end if; - Check_Read (Right); - end if; - Destroy_Iir_List (Overload_List); - if not Err then - Set_Implementation (Expr, Decl); - Sem_Subprogram_Call_Finish (Expr, Decl); - return Eval_Expr_If_Static (Expr); - else - return Expr; - end if; - end Set_Uniq_Interpretation; - - -- Note: operator and implementation node of expr must be set. - procedure Error_Operator_Overload (List : Iir_List) is - begin - Error_Msg_Sem (+Expr, "operator ""%i"" is overloaded", +Operator); - Disp_Overload_List (List, Expr); - end Error_Operator_Overload; - - Interface_Chain : Iir; - begin - if Arity = 1 then - Left := Get_Operand (Expr); - Right := Null_Iir; - else - Left := Get_Left (Expr); - Right := Get_Right (Expr); - end if; - Operator := Iirs_Utils.Get_Operator_Name (Expr); - - if Get_Type (Expr) = Null_Iir then - -- First pass. - -- Analyze operands. - -- FIXME: should try to analyze right operand even if analyze - -- of left operand has failed ?? - if Get_Type (Left) = Null_Iir then - Left := Sem_Expression_Ov (Left, Null_Iir); - if Left = Null_Iir then - return Null_Iir; - end if; - if Arity = 1 then - Set_Operand (Expr, Left); - else - Set_Left (Expr, Left); - end if; - end if; - if Arity = 2 and then Get_Type (Right) = Null_Iir then - Right := Sem_Expression_Ov (Right, Null_Iir); - if Right = Null_Iir then - return Null_Iir; - end if; - Set_Right (Expr, Right); - end if; - - Overload_List := Create_Iir_List; - - -- Try to find an implementation among user defined function - Interpretation := Get_Interpretation (Operator); - while Valid_Interpretation (Interpretation) loop - Decl := Get_Non_Alias_Declaration (Interpretation); - - -- It is compatible with operand types ? - pragma Assert (Is_Function_Declaration (Decl)); - - -- LRM08 12.3 Visibility - -- [...] or all visible declarations denote the same named entity. - -- - -- GHDL: If DECL has already been seen, then skip it. - if Get_Seen_Flag (Decl) then - goto Continue; - end if; - - -- Check return type. - if Res_Type /= Null_Iir - and then (Are_Types_Compatible (Res_Type, Get_Return_Type (Decl)) - = Not_Compatible) - then - goto Continue; - end if; - - Interface_Chain := Get_Interface_Declaration_Chain (Decl); - - -- Check arity. - - -- LRM93 2.5.2 Operator overloading - -- The subprogram specification of a unary operator must have - -- a single parameter [...] - -- The subprogram specification of a binary operator must have - -- two parameters [...] - -- - -- GHDL: So even in presence of default expression in a parameter, - -- a unary operation has to match with a binary operator. - if Iir_Chains.Get_Chain_Length (Interface_Chain) /= Arity then - goto Continue; - end if; - - -- Check operands. - if Is_Expr_Compatible (Get_Type (Interface_Chain), Left) - = Not_Compatible - then - goto Continue; - end if; - if Arity = 2 then - if Is_Expr_Compatible (Get_Type (Get_Chain (Interface_Chain)), - Right) - = Not_Compatible - then - goto Continue; - end if; - end if; - - -- Match. - Set_Seen_Flag (Decl, True); - Append_Element (Overload_List, Decl); - - << Continue >> null; - Interpretation := Get_Next_Interpretation (Interpretation); - end loop; - - -- Clear seen_flags. - It := List_Iterate (Overload_List); - while Is_Valid (It) loop - Set_Seen_Flag (Get_Element (It), False); - Next (It); - end loop; - - -- The list of possible implementations was computed. - case Get_Nbr_Elements (Overload_List) is - when 0 => - if Get_Kind (Expr) = Iir_Kind_Implicit_Condition_Operator then - -- TODO: display expression type. - Error_Msg_Sem (+Expr, "cannot convert expression to boolean " - & "(no ""??"" found)"); - else - Error_Msg_Sem (+Expr, - "no function declarations for %n", +Expr); - end if; - Destroy_Iir_List (Overload_List); - return Null_Iir; - - when 1 => - Decl := Get_First_Element (Overload_List); - return Set_Uniq_Interpretation (Decl); - - when others => - -- Preference for universal operator. - -- This roughly corresponds to: - -- - -- LRM 7.3.5 - -- An implicit conversion of a convertible universal operand - -- is applied if and only if the innermost complete context - -- determines a unique (numeric) target type for the implicit - -- conversion, and there is no legal interpretation of this - -- context without this conversion. - if Arity = 2 then - Decl := Get_Non_Implicit_Subprogram (Overload_List); - if Decl /= Null_Iir then - return Set_Uniq_Interpretation (Decl); - end if; - end if; - - Set_Implementation (Expr, Create_Overload_List (Overload_List)); - - -- Create the list of possible return types, if it is not yet - -- determined. - if Res_Type = Null_Iir then - Res_Type_List := Create_List_Of_Types (Overload_List); - if Is_Overload_List (Res_Type_List) then - -- There are many possible return types. - -- Try again. - Set_Type (Expr, Res_Type_List); - return Expr; - end if; - end if; - - -- The return type is known. - -- Search for explicit subprogram. - - -- It was impossible to find one solution. - Error_Operator_Overload (Overload_List); - - -- Give an advice. - if not Flags.Flag_Explicit - and then not Explicit_Advice_Given - and then Flags.Vhdl_Std < Vhdl_08 - then - Decl := Get_Explicit_Subprogram (Overload_List); - if Decl /= Null_Iir then - Error_Msg_Sem - (+Expr, "(you may want to use the -fexplicit option)"); - Explicit_Advice_Given := True; - end if; - end if; - - return Null_Iir; - end case; - else - -- Second pass - -- Find the uniq implementation for this call. - Overload := Get_Implementation (Expr); - Overload_List := Get_Overload_List (Overload); - Full_Compat := Null_Iir; - It := List_Iterate (Overload_List); - while Is_Valid (It) loop - Decl := Get_Element (It); - -- FIXME: wrong: compatibilty with return type and args. - if Are_Types_Compatible (Get_Return_Type (Decl), Res_Type) - /= Not_Compatible - then - if Full_Compat /= Null_Iir then - Error_Operator_Overload (Overload_List); - return Null_Iir; - else - Full_Compat := Decl; - end if; - end if; - Next (It); - end loop; - Free_Iir (Overload); - Overload := Get_Type (Expr); - Free_Overload_List (Overload); - return Set_Uniq_Interpretation (Full_Compat); - end if; - end Sem_Operator; - - -- Analyze LIT whose elements must be of type EL_TYPE, and return - -- the length. - -- FIXME: the errors are reported, but there is no mark of that. - function Sem_String_Literal (Str : Iir; El_Type : Iir) return Natural - is - function Find_Literal (Etype : Iir_Enumeration_Type_Definition; - C : Character) - return Iir_Enumeration_Literal - is - Id : constant Name_Id := Name_Table.Get_Identifier (C); - Inter : Name_Interpretation_Type; - Decl : Iir; - begin - Inter := Get_Interpretation (Id); - while Valid_Interpretation (Inter) loop - Decl := Get_Non_Alias_Declaration (Inter); - if Get_Kind (Decl) = Iir_Kind_Enumeration_Literal - and then Get_Type (Decl) = Etype - then - return Decl; - end if; - Inter := Get_Next_Interpretation (Inter); - end loop; - - -- LRM08 9.3 Operands - -- The character literals corresponding to the graphic characters - -- contained within a string literal or a bit string literal shall - -- be visible at the place of the string literal. - - -- Character C is not visible... - if Find_Name_In_Flist (Get_Enumeration_Literal_List (Etype), Id) - = Null_Iir - then - -- ... because it is not defined. - Error_Msg_Sem - (+Str, "type %n does not define character %c", (+Etype, +C)); - else - -- ... because it is not visible. - Error_Msg_Sem (+Str, "character %c of type %n is not visible", - (+C, +Etype)); - end if; - return Null_Iir; - end Find_Literal; - - type Characters_Pos is array (Character range <>) of Nat8; - Len : constant Nat32 := Get_String_Length (Str); - Id : constant String8_Id := Get_String8_Id (Str); - El : Iir; - Enum_Pos : Iir_Int32; - Ch : Character; - - -- Create a cache of literals, to speed-up a little bit the - -- search. - No_Pos : constant Nat8 := Nat8'Last; - Map : Characters_Pos (' ' .. Character'Last) := (others => No_Pos); - Res : Nat8; - begin - for I in 1 .. Len loop - Ch := Str_Table.Char_String8 (Id, I); - if Ch not in Map'Range then - -- Invalid character. - pragma Assert (Flags.Flag_Force_Analysis); - Res := 0; - else - Res := Map (Ch); - if Res = No_Pos then - El := Find_Literal (El_Type, Ch); - if El = Null_Iir then - Res := 0; - else - Enum_Pos := Get_Enum_Pos (El); - Res := Nat8 (Enum_Pos); - Map (Ch) := Res; - end if; - end if; - end if; - Str_Table.Set_Element_String8 (Id, I, Res); - end loop; - - -- LRM08 9.4.2 Locally static primaries - -- a) A literal of any type other than type TIME - Set_Expr_Staticness (Str, Locally); - - return Natural (Len); - end Sem_String_Literal; - - procedure Sem_String_Literal (Lit: Iir) - is - Lit_Type : constant Iir := Get_Type (Lit); - Lit_Base_Type : constant Iir := Get_Base_Type (Lit_Type); - - -- The subtype created for the literal. - N_Type: Iir; - -- type of the index of the array type. - Index_Type: Iir; - Len : Natural; - El_Type : Iir; - begin - El_Type := Get_Base_Type (Get_Element_Subtype (Lit_Base_Type)); - Len := Sem_String_Literal (Lit, El_Type); - - if Get_Constraint_State (Lit_Type) = Fully_Constrained then - -- The type of the context is constrained. - Index_Type := Get_Index_Type (Lit_Type, 0); - if Get_Type_Staticness (Index_Type) = Locally then - if Eval_Discrete_Type_Length (Index_Type) /= Iir_Int64 (Len) then - Error_Msg_Sem (+Lit, "string length does not match that of %n", - +Index_Type); - end if; - else - -- FIXME: emit a warning because of dubious construct (the type - -- of the string is not locally constrained) ? - null; - end if; - else - -- Context type is not constained. Set type of the string literal, - -- according to LRM93 7.3.2.2. - N_Type := Create_Unidim_Array_By_Length - (Lit_Base_Type, Iir_Int64 (Len), Lit); - Set_Type (Lit, N_Type); - Set_Literal_Subtype (Lit, N_Type); - end if; - end Sem_String_Literal; - - procedure Count_Choices (Info : out Choice_Info_Type; - Choice_Chain : Iir) - is - Choice : Iir; - S : Iir_Staticness; - begin - Info := (Nbr_Choices => 0, - Nbr_Alternatives => 0, - Others_Choice => Null_Iir, - Arr => null, - Annex_Arr => null); - Choice := Choice_Chain; - while Is_Valid (Choice) loop - case Iir_Kinds_Case_Choice (Get_Kind (Choice)) is - when Iir_Kind_Choice_By_Expression => - S := Get_Expr_Staticness (Get_Choice_Expression (Choice)); - pragma Assert (S = Get_Choice_Staticness (Choice)); - if S = Locally then - Info.Nbr_Choices := Info.Nbr_Choices + 1; - end if; - when Iir_Kind_Choice_By_Range => - S := Get_Expr_Staticness (Get_Choice_Range (Choice)); - pragma Assert (S = Get_Choice_Staticness (Choice)); - if S = Locally then - Info.Nbr_Choices := Info.Nbr_Choices + 1; - end if; - when Iir_Kind_Choice_By_Others => - Info.Others_Choice := Choice; - end case; - if not Get_Same_Alternative_Flag (Choice) then - Info.Nbr_Alternatives := Info.Nbr_Alternatives + 1; - end if; - Choice := Get_Chain (Choice); - end loop; - end Count_Choices; - - procedure Fill_Choices_Array (Info : in out Choice_Info_Type; - Choice_Chain : Iir) - is - Index : Natural; - Choice : Iir; - Expr : Iir; - begin - Info.Arr := new Iir_Array (1 .. Info.Nbr_Choices); - - -- Fill the array. - Index := 0; - Choice := Choice_Chain; - while Choice /= Null_Iir loop - case Iir_Kinds_Case_Choice (Get_Kind (Choice)) is - when Iir_Kind_Choice_By_Expression => - Expr := Get_Choice_Expression (Choice); - when Iir_Kind_Choice_By_Range => - Expr := Get_Choice_Range (Choice); - when Iir_Kind_Choice_By_Others => - Expr := Null_Iir; - end case; - if Is_Valid (Expr) and then Get_Expr_Staticness (Expr) = Locally - then - Index := Index + 1; - Info.Arr (Index) := Choice; - end if; - Choice := Get_Chain (Choice); - end loop; - - pragma Assert (Index = Info.Nbr_Choices); - end Fill_Choices_Array; - - procedure Swap_Choice_Info (Info : Choice_Info_Type; - From : Natural; To : Natural) - is - Tmp : Iir; - begin - Tmp := Info.Arr (To); - Info.Arr (To) := Info.Arr (From); - Info.Arr (From) := Tmp; - - if Info.Annex_Arr /= null then - declare - T : Int32; - begin - T := Info.Annex_Arr (To); - Info.Annex_Arr (To) := Info.Annex_Arr (From); - Info.Annex_Arr (From) := T; - end; - end if; - end Swap_Choice_Info; - - procedure Sort_String_Choices (Info : in out Choice_Info_Type) - is - -- Compare two elements of ARR. - -- Return true iff OP1 < OP2. - function Lt (Op1, Op2 : Natural) return Boolean is - begin - return Compare_String_Literals - (Get_Choice_Expression (Info.Arr (Op1)), - Get_Choice_Expression (Info.Arr (Op2))) - = Compare_Lt; - end Lt; - - procedure Swap (From : Natural; To : Natural) is - begin - Swap_Choice_Info (Info, From, To); - end Swap; - - procedure Str_Heap_Sort is - new Grt.Algos.Heap_Sort (Lt => Lt, Swap => Swap); - begin - Str_Heap_Sort (Info.Nbr_Choices); - end Sort_String_Choices; - - procedure Sem_String_Choices_Range (Choice_Chain : Iir; Sel : Iir) - is - -- Type of SEL. - Sel_Type : Iir; - - -- Type of the element of SEL. - Sel_El_Type : Iir; - -- Number of literals in the element type. - Sel_El_Length : Iir_Int64; - - -- Length of SEL (number of characters in SEL). - Sel_Length : Iir_Int64; - - -- True if length of a choice mismatches - Has_Length_Error : Boolean := False; - - El : Iir; - - Info : Choice_Info_Type; - - procedure Sem_Simple_Choice (Choice : Iir) - is - Expr : Iir; - Choice_Len : Iir_Int64; - begin - -- LRM93 8.8 - -- In such case, each choice appearing in any of the case statement - -- alternative must be a locally static expression whose value is of - -- the same length as that of the case expression. - Expr := Sem_Expression (Get_Choice_Expression (Choice), Sel_Type); - if Expr = Null_Iir then - Has_Length_Error := True; - return; - end if; - Set_Choice_Expression (Choice, Expr); - if Get_Expr_Staticness (Expr) < Locally then - Error_Msg_Sem (+Expr, "choice must be locally static expression"); - Has_Length_Error := True; - return; - end if; - Set_Choice_Staticness (Choice, Locally); - Expr := Eval_Expr (Expr); - Set_Choice_Expression (Choice, Expr); - if Get_Kind (Expr) = Iir_Kind_Overflow_Literal then - Error_Msg_Sem - (+Expr, "bound error during evaluation of choice expression"); - Has_Length_Error := True; - return; - end if; - - Choice_Len := Eval_Discrete_Type_Length - (Get_String_Type_Bound_Type (Get_Type (Expr))); - if Sel_Length = -1 then - Sel_Length := Choice_Len; - else - if Choice_Len /= Sel_Length then - Has_Length_Error := True; - Error_Msg_Sem (+Expr, "incorrect length for the choice value"); - return; - end if; - end if; - end Sem_Simple_Choice; - - function Eq (Op1, Op2 : Natural) return Boolean is - begin - return Compare_String_Literals - (Get_Choice_Expression (Info.Arr (Op1)), - Get_Choice_Expression (Info.Arr (Op2))) - = Compare_Eq; - end Eq; - begin - -- LRM93 8.8 - -- If the expression is of one-dimensional character array type, then - -- the expression must be one of the following: - -- FIXME: to complete. - Sel_Type := Get_Type (Sel); - if not Is_One_Dimensional_Array_Type (Sel_Type) then - Error_Msg_Sem - (+Sel, - "expression must be discrete or one-dimension array subtype"); - return; - end if; - if Get_Type_Staticness (Sel_Type) = Locally then - Sel_Length := Eval_Discrete_Type_Length - (Get_String_Type_Bound_Type (Sel_Type)); - else - -- LRM08 10.9 Case statement - -- If the expression is of a one-dimensional character array type and - -- is not described by either of the preceding two paragraphs, then - -- the values of all of the choices, except the OTHERS choice, if - -- present, shall be of the same length. - if Flags.Vhdl_Std >= Vhdl_08 then - Sel_Length := -1; - else - Error_Msg_Sem (+Sel, "array type must be locally static"); - return; - end if; - -- Use the base type so that the subtype of the choices is computed. - Sel_Type := Get_Base_Type (Sel_Type); - end if; - Sel_El_Type := Get_Element_Subtype (Sel_Type); - Sel_El_Length := Eval_Discrete_Type_Length (Sel_El_Type); - - El := Choice_Chain; - Info.Others_Choice := Null_Iir; - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Choice_By_None => - raise Internal_Error; - when Iir_Kind_Choice_By_Range => - Error_Msg_Sem - (+El, "range choice are not allowed for non-discrete type"); - when Iir_Kind_Choice_By_Expression => - Sem_Simple_Choice (El); - when Iir_Kind_Choice_By_Others => - if Info.Others_Choice /= Null_Iir then - Error_Msg_Sem (+El, "duplicate others choice"); - elsif Get_Chain (El) /= Null_Iir then - Error_Msg_Sem - (+El, "choice others must be the last alternative"); - end if; - Info.Others_Choice := El; - when others => - Error_Kind ("sem_string_choices_range", El); - end case; - El := Get_Chain (El); - end loop; - - -- Null choices. - if Sel_Length = 0 then - return; - end if; - if Has_Length_Error then - return; - end if; - - -- LRM 8.8 - -- - -- If the expression is the name of an object whose subtype is locally - -- static, whether a scalar type or an array type, then each value of - -- the subtype must be represented once and only once in the set of - -- choices of the case statement and no other value is allowed; [...] - - -- 1. Allocate Arr, fill it and sort - Count_Choices (Info, Choice_Chain); - Fill_Choices_Array (Info, Choice_Chain); - Sort_String_Choices (Info); - - -- 2. Check for duplicate choices - for I in 1 .. Info.Nbr_Choices - 1 loop - if Eq (I, I + 1) then - Error_Msg_Sem - (+Info.Arr (I), - "duplicate choice with choice at %l", +Info.Arr (I + 1)); - exit; - end if; - end loop; - - -- 3. Free Arr - Free (Info.Arr); - - -- Check for missing choice. - -- Do not try to compute the expected number of choices as this can - -- easily overflow. - if Info.Others_Choice = Null_Iir then - declare - Nbr : Iir_Int64 := Iir_Int64 (Info.Nbr_Choices); - begin - for I in 1 .. Sel_Length loop - Nbr := Nbr / Sel_El_Length; - if Nbr = 0 then - Error_Msg_Sem (+Choice_Chain, "missing choice(s)"); - exit; - end if; - end loop; - end; - end if; - end Sem_String_Choices_Range; - - -- Get low limit of ASSOC. - -- First, get the expression of the association, then the low limit. - -- ASSOC may be either association_by_range (in this case the low limit - -- is to be fetched), or association_by_expression (and the low limit - -- is the expression). - function Get_Assoc_Low (Assoc : Iir) return Iir - is - Expr : Iir; - begin - case Get_Kind (Assoc) is - when Iir_Kind_Choice_By_Expression => - return Get_Choice_Expression (Assoc); - when Iir_Kind_Choice_By_Range => - Expr := Get_Choice_Range (Assoc); - case Get_Kind (Expr) is - when Iir_Kind_Range_Expression => - return Get_Low_Limit (Expr); - when others => - return Expr; - end case; - when others => - Error_Kind ("get_assoc_low", Assoc); - end case; - end Get_Assoc_Low; - - function Get_Assoc_High (Assoc : Iir) return Iir - is - Expr : Iir; - begin - case Get_Kind (Assoc) is - when Iir_Kind_Choice_By_Expression => - return Get_Choice_Expression (Assoc); - when Iir_Kind_Choice_By_Range => - Expr := Get_Choice_Range (Assoc); - case Get_Kind (Expr) is - when Iir_Kind_Range_Expression => - return Get_High_Limit (Expr); - when others => - return Expr; - end case; - when others => - Error_Kind ("get_assoc_high", Assoc); - end case; - end Get_Assoc_High; - - procedure Sort_Discrete_Choices (Info : in out Choice_Info_Type) - is - -- Compare two elements of ARR. - -- Return true iff OP1 < OP2. - function Lt (Op1, Op2 : Natural) return Boolean is - begin - return (Eval_Pos (Get_Assoc_Low (Info.Arr (Op1))) - < Eval_Pos (Get_Assoc_Low (Info.Arr (Op2)))); - end Lt; - - procedure Swap (From : Natural; To : Natural) is - begin - Swap_Choice_Info (Info, From, To); - end Swap; - - procedure Disc_Heap_Sort is - new Grt.Algos.Heap_Sort (Lt => Lt, Swap => Swap); - begin - Disc_Heap_Sort (Info.Nbr_Choices); - end Sort_Discrete_Choices; - - procedure Sem_Check_Continuous_Choices (Choice_Chain : Iir; - Choice_Type : Iir; - Low : out Iir; - High : out Iir; - Loc : Location_Type; - Is_Sub_Range : Boolean) - is - -- Nodes that can appear. - Info : Choice_Info_Type; - - Type_Has_Bounds : Boolean; - begin - -- Set TYPE_HAS_BOUNDS - case Get_Kind (Choice_Type) is - when Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Integer_Subtype_Definition => - Type_Has_Bounds := True; - when Iir_Kind_Integer_Type_Definition => - Type_Has_Bounds := False; - when others => - Error_Kind ("sem_check_continuous_choices(3)", Choice_Type); - end case; - - -- Check the choices are within the bounds. - if Type_Has_Bounds - and then Get_Type_Staticness (Choice_Type) = Locally - then - declare - Choice : Iir; - Ok : Boolean; - Has_Err : Boolean; - Expr : Iir; - begin - Has_Err := False; - Choice := Choice_Chain; - while Choice /= Null_Iir loop - Ok := True; - case Iir_Kinds_Case_Choice (Get_Kind (Choice)) is - when Iir_Kind_Choice_By_Expression => - Expr := Get_Choice_Expression (Choice); - if Get_Expr_Staticness (Expr) = Locally then - Ok := Eval_Is_In_Bound (Expr, Choice_Type); - end if; - when Iir_Kind_Choice_By_Range => - Expr := Get_Choice_Range (Choice); - if Get_Expr_Staticness (Expr) = Locally then - Ok := Eval_Is_Range_In_Bound (Expr, Choice_Type, True); - end if; - when Iir_Kind_Choice_By_Others => - null; - end case; - if not Ok then - Error_Msg_Sem (+Choice, "%n out of index range", +Expr); - Has_Err := True; - end if; - Choice := Get_Chain (Choice); - end loop; - - -- In case of error (value not in range), don't try to extract - -- bounds or to sort values. - if Has_Err then - High := Null_Iir; - Low := Null_Iir; - return; - end if; - end; - end if; - - -- Compute the number of elements and sort. - Count_Choices (Info, Choice_Chain); - Fill_Choices_Array (Info, Choice_Chain); - Sort_Discrete_Choices (Info); - - for I in Info.Arr'Range loop - Set_Choice_Order (Info.Arr (I), Int32 (I)); - end loop; - - -- Set low and high bounds. - if Info.Nbr_Choices > 0 then - Low := Get_Assoc_Low (Info.Arr (Info.Arr'First)); - High := Get_Assoc_High (Info.Arr (Info.Arr'Last)); - else - Low := Null_Iir; - High := Null_Iir; - end if; - - -- Fourth: - -- check for lacking choice (if no others) - -- check for overlapping choices - declare - -- Emit an error message for absence of choices in position L to H - -- of index type BT at location LOC. - procedure Error_No_Choice (Bt : Iir; - L, H : Iir_Int64; - Loc : Location_Type) is - begin - if L = H then - Error_Msg_Sem (+Loc, "no choice for " & Disp_Discrete (Bt, L)); - else - Error_Msg_Sem - (+Loc, "no choices for " & Disp_Discrete (Bt, L) - & " to " & Disp_Discrete (Bt, H)); - end if; - end Error_No_Choice; - - -- Lowest and highest bounds. - Lb, Hb : Iir; - Pos : Iir_Int64; - Pos_Max : Iir_Int64; - E_Pos : Iir_Int64; - Choice : Iir; - Need_Others : Boolean; - - Bt : constant Iir := Get_Base_Type (Choice_Type); - begin - if not Is_Sub_Range - and then Get_Type_Staticness (Choice_Type) = Locally - and then Type_Has_Bounds - then - Get_Low_High_Limit (Get_Range_Constraint (Choice_Type), Lb, Hb); - else - Lb := Low; - Hb := High; - end if; - if Lb = Null_Iir or else Hb = Null_Iir then - -- Return now in case of error. - Free (Info.Arr); - return; - end if; - -- Checks all values between POS and POS_MAX are handled. - Pos := Eval_Pos (Lb); - Pos_Max := Eval_Pos (Hb); - if Pos > Pos_Max then - -- Null range. - Free (Info.Arr); - return; - end if; - Need_Others := False; - for I in Info.Arr'Range loop - Choice := Info.Arr (I); - E_Pos := Eval_Pos (Get_Assoc_Low (Choice)); - if E_Pos > Pos_Max then - -- Choice out of bound, already handled. - Error_No_Choice (Bt, Pos, Pos_Max, Get_Location (Choice)); - -- Avoid other errors. - Pos := Pos_Max + 1; - exit; - end if; - if Pos < E_Pos then - Need_Others := True; - if Info.Others_Choice = Null_Iir then - Error_No_Choice (Bt, Pos, E_Pos - 1, Get_Location (Choice)); - end if; - elsif Pos > E_Pos then - Need_Others := True; - if Pos = E_Pos + 1 then - Error_Msg_Sem - (+Choice, - "duplicate choice for " & Disp_Discrete (Bt, E_Pos)); - else - Error_Msg_Sem - (+Choice, "duplicate choices for " - & Disp_Discrete (Bt, E_Pos) - & " to " & Disp_Discrete (Bt, Pos)); - end if; - end if; - - if Get_Kind (Choice) = Iir_Kind_Choice_By_Range then - Pos := Eval_Pos (Get_Assoc_High (Choice)) + 1; - else - Pos := E_Pos + 1; - end if; - end loop; - if Pos /= Pos_Max + 1 then - Need_Others := True; - if Info.Others_Choice = Null_Iir then - Error_No_Choice (Bt, Pos, Pos_Max, Loc); - end if; - end if; - - if not Need_Others and then Info.Others_Choice /= Null_Iir then - Warning_Msg_Sem (Warnid_Others, +Info.Others_Choice, - "redundant 'others' choices"); - end if; - end; - - -- LRM93 7.3.2.2 Array aggregates - -- An others choice is locally static if the applicable index constraint - -- if locally static. - if Info.Nbr_Choices > 0 - and then Info.Others_Choice /= Null_Iir - and then Get_Type_Staticness (Choice_Type) /= Locally - then - Warning_Msg_Sem - (Warnid_Static, +Info.Others_Choice, - "'others' choice allowed only if the index constraint is static"); - end if; - - Free (Info.Arr); - end Sem_Check_Continuous_Choices; - - procedure Sem_Choices_Range (Choice_Chain : in out Iir; - Choice_Type : Iir; - Low : out Iir; - High : out Iir; - Loc : Location_Type; - Is_Sub_Range : Boolean; - Is_Case_Stmt : Boolean) - is - -- Number of positionnal choice. - Nbr_Pos : Iir_Int64; - - -- Number of named choices. - Nbr_Named : Natural; - - -- True if others choice is present. - Has_Others : Boolean; - - Has_Error : Boolean; - - Pos_Max : Iir_Int64; - El : Iir; - Prev_El : Iir; - - -- Staticness of the current choice. - Choice_Staticness : Iir_Staticness; - - -- Staticness of all the choices. - Staticness : Iir_Staticness; - - function Replace_By_Range_Choice (Name : Iir; Range_Type : Iir) - return Boolean - is - N_Choice : Iir; - Name1 : Iir; - begin - if Are_Types_Compatible (Range_Type, Choice_Type) = Not_Compatible - then - Error_Not_Match (Name, Choice_Type); - return False; - end if; - - Name1 := Finish_Sem_Name (Name); - N_Choice := Create_Iir (Iir_Kind_Choice_By_Range); - Location_Copy (N_Choice, El); - Set_Chain (N_Choice, Get_Chain (El)); - Set_Associated_Expr (N_Choice, Get_Associated_Expr (El)); - Set_Associated_Chain (N_Choice, Get_Associated_Chain (El)); - Set_Same_Alternative_Flag (N_Choice, Get_Same_Alternative_Flag (El)); - Set_Choice_Range (N_Choice, Eval_Range_If_Static (Name1)); - Set_Choice_Staticness (N_Choice, Get_Type_Staticness (Range_Type)); - Set_Element_Type_Flag (N_Choice, Get_Element_Type_Flag (El)); - Free_Iir (El); - - if Prev_El = Null_Iir then - Choice_Chain := N_Choice; - else - Set_Chain (Prev_El, N_Choice); - end if; - El := N_Choice; - - return True; - end Replace_By_Range_Choice; - - -- Analyze a simple (by expression or by range) choice. - -- Return FALSE in case of error. - function Sem_Simple_Choice return Boolean - is - Expr : Iir; - Ent : Iir; - begin - if Get_Kind (El) = Iir_Kind_Choice_By_Range then - Expr := Get_Choice_Range (El); - Expr := Sem_Discrete_Range_Expression (Expr, Choice_Type, True); - if Expr = Null_Iir then - return False; - end if; - Expr := Eval_Range_If_Static (Expr); - Set_Choice_Range (El, Expr); - else - Expr := Get_Choice_Expression (El); - case Get_Kind (Expr) is - when Iir_Kind_Selected_Name - | Iir_Kind_Simple_Name - | Iir_Kind_Character_Literal - | Iir_Kind_Parenthesis_Name - | Iir_Kind_Selected_By_All_Name - | Iir_Kind_Attribute_Name => - Sem_Name (Expr); - Ent := Get_Named_Entity (Expr); - if Ent = Error_Mark then - return False; - end if; - - -- So range or expression ? - -- FIXME: share code with sem_name for slice/index. - case Get_Kind (Ent) is - when Iir_Kind_Range_Array_Attribute - | Iir_Kind_Reverse_Range_Array_Attribute - | Iir_Kind_Range_Expression => - return Replace_By_Range_Choice (Expr, Ent); - when Iir_Kind_Subtype_Declaration - | Iir_Kind_Type_Declaration => - Ent := Is_Type_Name (Expr); - Set_Expr_Staticness (Expr, Get_Type_Staticness (Ent)); - return Replace_By_Range_Choice (Expr, Ent); - when others => - Expr := Name_To_Expression - (Expr, Get_Base_Type (Choice_Type)); - end case; - when others => - Expr := - Sem_Expression_Ov (Expr, Get_Base_Type (Choice_Type)); - end case; - if Expr = Null_Iir then - return False; - end if; - Expr := Eval_Expr_If_Static (Expr); - Set_Choice_Expression (El, Expr); - end if; - Set_Choice_Staticness (El, Get_Expr_Staticness (Expr)); - return True; - end Sem_Simple_Choice; - begin - Low := Null_Iir; - High := Null_Iir; - - -- First: - -- Analyze the choices - -- compute the range of positionnal choices - -- compute the number of choice elements (extracted from lists). - -- check for others presence. - Nbr_Pos := 0; - Nbr_Named := 0; - Has_Others := False; - Has_Error := False; - Staticness := Locally; - El := Choice_Chain; - Prev_El := Null_Iir; - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Choice_By_None => - Nbr_Pos := Nbr_Pos + 1; - when Iir_Kind_Choice_By_Expression - | Iir_Kind_Choice_By_Range => - if Sem_Simple_Choice then - Choice_Staticness := Get_Choice_Staticness (El); - Staticness := Min (Staticness, Choice_Staticness); - if Choice_Staticness /= Locally - and then Is_Case_Stmt - then - -- FIXME: explain why - Error_Msg_Sem (+El, "choice is not locally static"); - end if; - else - Has_Error := True; - end if; - Nbr_Named := Nbr_Named + 1; - when Iir_Kind_Choice_By_Name => - -- It is not possible to have such a choice in an array - -- aggregate. - -- Should have been caught previously. - raise Internal_Error; - when Iir_Kind_Choice_By_Others => - if Has_Others then - Error_Msg_Sem (+El, "duplicate others choice"); - elsif Get_Chain (El) /= Null_Iir then - Error_Msg_Sem - (+El, "choice others should be the last alternative"); - end if; - Has_Others := True; - when others => - Error_Kind ("sem_choices_range", El); - end case; - Prev_El := El; - El := Get_Chain (El); - end loop; - - if Has_Error then - -- Nothing can be done here... - return; - end if; - if Nbr_Pos > 0 and then Nbr_Named > 0 then - -- LRM93 7.3.2.2 - -- Apart from the final element with the single choice OTHERS, the - -- rest (if any) of the element associations of an array aggregate - -- must be either all positionnal or all named. - Error_Msg_Sem - (+Loc, "element associations must be all positional or all named"); - return; - end if; - - -- For a positional aggregate. - if Nbr_Pos > 0 then - -- Check number of elements match, but only if it is possible. - if Get_Type_Staticness (Choice_Type) /= Locally then - return; - end if; - Pos_Max := Eval_Discrete_Type_Length (Choice_Type); - if (not Has_Others and not Is_Sub_Range) - and then Nbr_Pos < Pos_Max - then - Error_Msg_Sem (+Loc, "not enough elements associated"); - elsif Nbr_Pos > Pos_Max then - Error_Msg_Sem (+Loc, "too many elements associated"); - end if; - return; - end if; - - -- Second: - -- Create the list of choices - if Nbr_Named = 0 and then Has_Others then - -- This is only a others association. - return; - end if; - if Staticness /= Locally then - -- Emit a message for aggregrate. The message has already been - -- emitted for a case stmt. - -- FIXME: what about individual associations? - if not Is_Case_Stmt then - -- LRM93 §7.3.2.2 - -- A named association of an array aggregate is allowed to have - -- a choice that is not locally static, or likewise a choice that - -- is a null range, only if the aggregate includes a single - -- element association and the element association has a single - -- choice. - if Nbr_Named > 1 or Has_Others then - Error_Msg_Sem (+Loc, "not static choice exclude others choice"); - end if; - end if; - return; - end if; - - Sem_Check_Continuous_Choices - (Choice_Chain, Choice_Type, Low, High, Loc, Is_Sub_Range); - end Sem_Choices_Range; - - -- Perform semantisation on a (sub)aggregate AGGR, which is of type - -- A_TYPE. - -- return FALSE is case of failure - function Sem_Record_Aggregate (Aggr: Iir_Aggregate; A_Type: Iir) - return boolean - is - El_List : constant Iir_Flist := Get_Elements_Declaration_List (A_Type); - - -- Type of the element. - El_Type : Iir; - - Matches: Iir_Array (0 .. Get_Nbr_Elements (El_List) - 1); - Ok : Boolean; - - -- Add a choice for element REC_EL. - -- Checks the element is not already associated. - -- Checks type of expression is compatible with type of element. - procedure Add_Match (El : Iir; Rec_El : Iir_Element_Declaration) - is - Ass_Type : Iir; - Pos : constant Natural := Natural (Get_Element_Position (Rec_El)); - begin - if Matches (Pos) /= Null_Iir then - Error_Msg_Sem (+El, "%n was already associated", +Matches (Pos)); - Ok := False; - return; - end if; - Matches (Pos) := El; - - -- LRM 7.3.2.1 Record aggregates - -- An element association with more than once choice, [...], is - -- only allowed if the elements specified are all of the same type. - Ass_Type := Get_Type (Rec_El); - if El_Type = Null_Iir then - El_Type := Ass_Type; - elsif Are_Types_Compatible (El_Type, Ass_Type) = Not_Compatible then - Error_Msg_Sem (+El, "elements are not of the same type"); - Ok := False; - end if; - end Add_Match; - - -- Analyze a simple choice: extract the record element corresponding - -- to the expression, and create a choice_by_name. - -- FIXME: should mutate the node. - function Sem_Simple_Choice (Ass : Iir) return Iir - is - Expr : constant Iir := Get_Choice_Expression (Ass); - N_El : Iir; - Aggr_El : Iir_Element_Declaration; - begin - if Get_Kind (Expr) /= Iir_Kind_Simple_Name then - Error_Msg_Sem (+Ass, "element association must be a simple name"); - Ok := False; - return Ass; - end if; - Aggr_El := Find_Name_In_Flist (El_List, Get_Identifier (Expr)); - if Aggr_El = Null_Iir then - Error_Msg_Sem (+Ass, "record has no such element %n", +Ass); - Ok := False; - return Ass; - end if; - Set_Named_Entity (Expr, Aggr_El); - Xref_Ref (Expr, Aggr_El); - - -- Was a choice_by_expression, now by_name. - N_El := Create_Iir (Iir_Kind_Choice_By_Name); - Location_Copy (N_El, Ass); - Set_Choice_Name (N_El, Expr); - Set_Associated_Expr (N_El, Get_Associated_Expr (Ass)); - Set_Associated_Chain (N_El, Get_Associated_Chain (Ass)); - Set_Chain (N_El, Get_Chain (Ass)); - Set_Same_Alternative_Flag (N_El, Get_Same_Alternative_Flag (Ass)); - - Free_Iir (Ass); - Add_Match (N_El, Aggr_El); - return N_El; - end Sem_Simple_Choice; - - Assoc_Chain : Iir; - El, Prev_El : Iir; - Expr: Iir; - Has_Named : Boolean; - Rec_El_Index : Natural; - Expr_Staticness : Iir_Staticness; - - -- True if at least one element constrains the subtype. For unbounded - -- records. - Add_Constraints : Boolean; - begin - -- Not yet handled. - Set_Aggregate_Expand_Flag (Aggr, False); - - Ok := True; - Assoc_Chain := Get_Association_Choices_Chain (Aggr); - Matches := (others => Null_Iir); - Expr_Staticness := Locally; - Add_Constraints := False; - - El_Type := Null_Iir; - Has_Named := False; - Rec_El_Index := 0; - Prev_El := Null_Iir; - El := Assoc_Chain; - while El /= Null_Iir loop - Expr := Get_Associated_Expr (El); - - -- If there is an associated expression with the choice, then the - -- choice is a new alternative, and has no expected type. - if not Get_Same_Alternative_Flag (El) then - pragma Assert (Expr /= Null_Iir); - El_Type := Null_Iir; - end if; - - case Get_Kind (El) is - when Iir_Kind_Choice_By_None => - if Has_Named then - Error_Msg_Sem - (+El, "positional association after named one"); - Ok := False; - elsif Rec_El_Index > Matches'Last then - Error_Msg_Sem (+El, "too many elements"); - exit; - else - Add_Match (El, Get_Nth_Element (El_List, Rec_El_Index)); - Rec_El_Index := Rec_El_Index + 1; - end if; - when Iir_Kind_Choice_By_Expression => - Has_Named := True; - El := Sem_Simple_Choice (El); - -- This creates a choice_by_name, which replaces the - -- choice_by_expression. - if Prev_El = Null_Iir then - Set_Association_Choices_Chain (Aggr, El); - else - Set_Chain (Prev_El, El); - end if; - when Iir_Kind_Choice_By_Others => - Has_Named := True; - if Get_Chain (El) /= Null_Iir then - Error_Msg_Sem - (+El, "choice others must be the last alternative"); - end if; - declare - Found : Boolean := False; - begin - for I in Matches'Range loop - if Matches (I) = Null_Iir then - Add_Match (El, Get_Nth_Element (El_List, I)); - Found := True; - end if; - end loop; - if not Found then - Error_Msg_Sem (+El, "no element for choice others"); - Ok := False; - end if; - end; - when others => - Error_Kind ("sem_record_aggregate", El); - end case; - - -- Analyze the expression associated. - if not Get_Same_Alternative_Flag (El) then - if El_Type /= Null_Iir then - -- Analyze the expression only if the choice is correct. - Expr := Sem_Expression (Expr, El_Type); - if Expr /= Null_Iir then - Set_Associated_Expr (El, Eval_Expr_If_Static (Expr)); - Expr_Staticness := Min (Expr_Staticness, - Get_Expr_Staticness (Expr)); - if not Add_Constraints - and then Is_Fully_Constrained_Type (Get_Type (Expr)) - and then not Is_Fully_Constrained_Type (El_Type) - then - Add_Constraints := True; - end if; - else - Ok := False; - end if; - else - -- This case is not possible unless there is an error. - pragma Assert (not Ok); - null; - end if; - end if; - - Prev_El := El; - El := Get_Chain (El); - end loop; - - -- Check for missing associations. - for I in Matches'Range loop - if Matches (I) = Null_Iir then - Error_Msg_Sem - (+Aggr, "no value for %n", +Get_Nth_Element (El_List, I)); - Ok := False; - end if; - end loop; - Set_Expr_Staticness (Aggr, Min (Get_Expr_Staticness (Aggr), - Expr_Staticness)); - - if Ok and Add_Constraints then - declare - Rec_Type : Iir; - Rec_El_List : Iir_Flist; - Rec_El : Iir; - Rec_El_Type : Iir; - New_Rec_El : Iir; - Constraint : Iir_Constraint; - Composite_Found : Boolean; - Staticness : Iir_Staticness; - begin - Rec_Type := Sem_Types.Copy_Subtype_Indication (Get_Type (Aggr)); - Rec_El_List := Get_Elements_Declaration_List (Rec_Type); - Constraint := Fully_Constrained; - Composite_Found := False; - Staticness := Locally; - for I in Flist_First .. Flist_Last (El_List) loop - El := Matches (I); - El_Type := Get_Type (Get_Associated_Expr (El)); - Rec_El := Get_Nth_Element (Rec_El_List, I); - Rec_El_Type := Get_Type (Rec_El); - if Is_Fully_Constrained_Type (El_Type) - and then not Is_Fully_Constrained_Type (Rec_El_Type) - then - Rec_El_Type := El_Type; - New_Rec_El := - Create_Iir (Iir_Kind_Record_Element_Constraint); - Location_Copy (New_Rec_El, Rec_El); - Set_Parent (New_Rec_El, Rec_Type); - Set_Identifier (New_Rec_El, Get_Identifier (Rec_El)); - pragma Assert (I = Natural (Get_Element_Position (Rec_El))); - Set_Element_Position (New_Rec_El, Iir_Index32 (I)); - Set_Nth_Element (Rec_El_List, I, New_Rec_El); - Set_Type (New_Rec_El, Rec_El_Type); - Append_Owned_Element_Constraint (Rec_Type, New_Rec_El); - end if; - Staticness := Min (Staticness, - Get_Type_Staticness (Rec_El_Type)); - Sem_Types.Update_Record_Constraint - (Constraint, Composite_Found, Rec_El_Type); - end loop; - Set_Type_Staticness (Rec_Type, Staticness); - Set_Constraint_State (Rec_Type, Constraint); - Set_Type (Aggr, Rec_Type); - Set_Literal_Subtype (Aggr, Rec_Type); - end; - end if; - - return Ok; - end Sem_Record_Aggregate; - - -- Information for each dimension of an aggregate. - type Array_Aggr_Info is record - -- False if one sub-aggregate has no others choices. - -- If FALSE, the dimension is constrained. - Has_Others : Boolean := True; - - -- True if one sub-aggregate is by named/by position. - Has_Named : Boolean := False; - - -- True if one sub-aggregate is dynamic. - Has_Dynamic : Boolean := False; - - -- LOW and HIGH limits for the dimension. - Low : Iir := Null_Iir; - High : Iir := Null_Iir; - - -- Minimum length of the dimension. This is a minimax. - Min_Length : Natural := 0; - - -- If not NULL_IIR, this is the bounds of the dimension. - -- If every dimension has bounds, then the aggregate is constrained. - Index_Subtype : Iir := Null_Iir; - - -- Number of associations in last-level (not for sub-aggregate). This - -- is used only to decide whether or not a static aggregate can be - -- expanded. - Nbr_Assocs : Natural := 0; - - -- True if there is an error. - Error : Boolean := False; - - -- True if one element doesn't match the bounds. - Has_Bound_Error : Boolean := False; - end record; - - type Array_Aggr_Info_Arr is array (Natural range <>) of Array_Aggr_Info; - - procedure Sem_Array_Aggregate_Elements - (Aggr : Iir; - A_Type : Iir; - Expr_Staticness : in out Iir_Staticness; - Info : in out Array_Aggr_Info) - is - Element_Type : constant Iir := Get_Element_Subtype (A_Type); - El : Iir; - El_Expr : Iir; - Expr : Iir; - El_Staticness : Iir_Staticness; - Assoc_Chain : Iir; - Res_Type : Iir; - - -- True if the type of the expression is the type of the aggregate. - Is_Array : Boolean; - - -- Null_Iir if the type of aggregagte elements myst be of the element - -- type. - Elements_Types : Iir; - Elements_Types_List : Iir_List; - begin - -- LRM93 7.3.2.2 Array aggregates - -- [...] the expression of each element association must be of the - -- element type. - - -- LRM08 9.3.3.3 Array aggregates - -- For an aggregate of a one-dimensional array type, [each choice shall - -- specify values of the index type], and the expression of each element - -- association shall be of either the element type or the type of the - -- aggregate. - if Flags.Vhdl_Std >= Vhdl_08 - and then Is_One_Dimensional_Array_Type (A_Type) - then - Elements_Types_List := Create_Iir_List; - Append_Element (Elements_Types_List, Element_Type); - Append_Element (Elements_Types_List, Get_Base_Type (A_Type)); - Elements_Types := Create_Overload_List (Elements_Types_List); - else - Elements_Types := Null_Iir; - end if; - - Assoc_Chain := Get_Association_Choices_Chain (Aggr); - - El := Assoc_Chain; - while El /= Null_Iir loop - if not Get_Same_Alternative_Flag (El) then - El_Expr := Get_Associated_Expr (El); - Is_Array := False; - - -- Directly analyze the expression with the type of the element - -- if it cannot be the type of the aggregate. - -- In VHDL-2008, also do it when the expression is an aggregate. - -- This is not in the LRM, but otherwise this would create a lot - -- of ambiguities when the element type is a composite type. Eg: - -- - -- type time_unit is record - -- val : time; - -- name : string (1 to 3); - -- end record; - -- type time_names_type is array (1 to 2) of time_unit; - -- constant time_names : time_names_type := - -- ((fs, "fs "), (ps, "ps ")); - -- - -- The type of the first sub-aggregate could be either time_unit - -- or time_names_type. Because it's determined by the context, - -- it is ambiguous. But there is no point in using aggregates - -- to specify a range of choices. - -- FIXME: fix LRM ? - if Elements_Types = Null_Iir - or else Get_Kind (El_Expr) = Iir_Kind_Aggregate - then - Expr := Sem_Expression (El_Expr, Element_Type); - else - Expr := Sem_Expression_Wildcard (El_Expr, Null_Iir); - if Expr /= Null_Iir then - Res_Type := Compatible_Types_Intersect - (Get_Type (Expr), Elements_Types); - if Res_Type = Null_Iir then - Error_Msg_Sem - (+Get_Associated_Expr (El), - "type of element not compatible with the " - & "expected type"); - Set_Type (El_Expr, Error_Type); - Expr := Null_Iir; - elsif Is_Overload_List (Res_Type) then - Error_Msg_Sem - (+Expr, "type of element is ambiguous"); - Free_Overload_List (Res_Type); - Set_Type (El_Expr, Error_Type); - Expr := Null_Iir; - else - pragma Assert (Is_Defined_Type (Res_Type)); - Is_Array := - Get_Base_Type (Res_Type) = Get_Base_Type (A_Type); - Expr := Sem_Expression_Wildcard (Expr, Res_Type); - end if; - end if; - end if; - - if Expr /= Null_Iir then - El_Staticness := Get_Expr_Staticness (Expr); - Expr := Eval_Expr_If_Static (Expr); - Set_Associated_Expr (El, Expr); - - if not Is_Static_Construct (Expr) then - Set_Aggregate_Expand_Flag (Aggr, False); - end if; - - if not Is_Array - and then not Eval_Is_In_Bound (Expr, Element_Type) - then - Info.Has_Bound_Error := True; - Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, - "element is out of the bounds"); - end if; - - Expr_Staticness := Min (Expr_Staticness, El_Staticness); - - Info.Nbr_Assocs := Info.Nbr_Assocs + 1; - else - Info.Error := True; - end if; - end if; - - Set_Element_Type_Flag (El, not Is_Array); - - if Is_Array then - -- LRM08 9.3.3.3 Array aggregates - -- If the type of the expression of an element association - -- is the type of the aggregate, then either the element - -- association shall be positional or the choice shall be - -- a discrete range. - - -- GHDL: must be checked for all associations, so do it outside - -- the above 'if' statement. - -- GHDL: improve error message. - case Get_Kind (El) is - when Iir_Kind_Choice_By_None - | Iir_Kind_Choice_By_Range => - null; - when Iir_Kind_Choice_By_Others => - Error_Msg_Sem - (+El, "expression for 'others' must be an element"); - when others => - Error_Msg_Sem - (+El, "positional association or " - & "discrete range choice required"); - end case; - end if; - - El := Get_Chain (El); - end loop; - - if Elements_Types /= Null_Iir then - Free_Overload_List (Elements_Types); - end if; - end Sem_Array_Aggregate_Elements; - - -- Analyze an array aggregate AGGR of *base type* A_TYPE. - -- The type of the array is computed into A_SUBTYPE. - -- DIM is the dimension index in A_TYPE. - -- Return FALSE in case of error. - procedure Sem_Array_Aggregate_1 (Aggr: Iir; - A_Type: Iir; - Infos : in out Array_Aggr_Info_Arr; - Constrained : Boolean; - Dim: Natural) - is - Index_List : constant Iir_Flist := Get_Index_Subtype_List (A_Type); - - -- Type of the index (this is also the type of the choices). - Index_Type : constant Iir := Get_Index_Type (Index_List, Dim - 1); - - Assoc_Chain : Iir; - Choice: Iir; - Is_Positional: Tri_State_Type; - Has_Positional_Choice: Boolean; - Low, High : Iir; - Has_Others : Boolean; - - Len : Natural; - - Index_Subtype_Constraint : Iir_Range_Expression; - Index_Constraint : Iir_Range_Expression; -- FIXME: 'range. - Dir : Iir_Direction; - Choice_Staticness : Iir_Staticness; - Len_Staticness : Iir_Staticness; - Expr_Staticness : Iir_Staticness; - - Info : Array_Aggr_Info renames Infos (Dim); - begin - -- Analyze aggregate elements. - if Constrained then - Expr_Staticness := Get_Type_Staticness (Index_Type); - if Expr_Staticness /= Locally then - -- Cannot be statically built as the bounds are not known and - -- must be checked at run-time. - Set_Aggregate_Expand_Flag (Aggr, False); - end if; - else - Expr_Staticness := Locally; - end if; - - if Dim = Get_Nbr_Elements (Index_List) then - -- A type has been found for AGGR, analyze AGGR as if it was - -- an aggregate with a subtype (and not a string). - if Get_Kind (Aggr) = Iir_Kind_Aggregate then - Sem_Array_Aggregate_Elements (Aggr, A_Type, Expr_Staticness, Info); - else - -- Nothing to do for a string. - null; - end if; - else - -- A sub-aggregate: recurse. - declare - Sub_Aggr : Iir; - begin - -- Here we know that AGGR is an aggregate because: - -- * either this is the first call (ie DIM = 1) and therefore - -- AGGR is an aggregate (an aggregate is being analyzed). - -- * or DIM > 1 and the use of strings is checked (just bellow). - Assoc_Chain := Get_Association_Choices_Chain (Aggr); - Choice := Assoc_Chain; - while Choice /= Null_Iir loop - if not Get_Same_Alternative_Flag (Choice) then - Sub_Aggr := Get_Associated_Expr (Choice); - case Get_Kind (Sub_Aggr) is - when Iir_Kind_Aggregate => - Sem_Array_Aggregate_1 - (Sub_Aggr, A_Type, Infos, Constrained, Dim + 1); - if not Get_Aggregate_Expand_Flag (Sub_Aggr) then - Set_Aggregate_Expand_Flag (Aggr, False); - end if; - when Iir_Kind_String_Literal8 => - if Dim + 1 = Get_Nbr_Elements (Index_List) then - Sem_Array_Aggregate_1 - (Sub_Aggr, A_Type, Infos, Constrained, Dim + 1); - else - Error_Msg_Sem - (+Sub_Aggr, "string literal not allowed here"); - Infos (Dim + 1).Error := True; - end if; - when others => - Error_Msg_Sem (+Sub_Aggr, "sub-aggregate expected"); - Infos (Dim + 1).Error := True; - end case; - end if; - - -- Always true for a sub-aggregate. - Set_Element_Type_Flag (Choice, True); - - Choice := Get_Chain (Choice); - end loop; - end; - end if; - Set_Expr_Staticness - (Aggr, Min (Expr_Staticness, Get_Expr_Staticness (Aggr))); - - -- Analyze choices. - Len_Staticness := Locally; - case Get_Kind (Aggr) is - when Iir_Kind_Aggregate => - Assoc_Chain := Get_Association_Choices_Chain (Aggr); - Sem_Choices_Range (Assoc_Chain, Index_Type, Low, High, - Get_Location (Aggr), not Constrained, False); - Set_Association_Choices_Chain (Aggr, Assoc_Chain); - - -- Update infos. - if Low /= Null_Iir - and then (Info.Low = Null_Iir - or else Eval_Pos (Low) < Eval_Pos (Info.Low)) - then - Info.Low := Low; - end if; - if High /= Null_Iir - and then (Info.High = Null_Iir - or else Eval_Pos (High) > Eval_Pos (Info.High)) - then - Info.High := High; - end if; - - -- Determine if the aggregate is positionnal or named; - -- and compute choice staticness. - Is_Positional := Unknown; - Choice_Staticness := Locally; - Has_Positional_Choice := False; - Has_Others := False; - Len := 0; - Choice := Assoc_Chain; - while Choice /= Null_Iir loop - case Get_Kind (Choice) is - when Iir_Kind_Choice_By_Range - | Iir_Kind_Choice_By_Expression => - Is_Positional := False; - Choice_Staticness := - Iirs.Min (Choice_Staticness, - Get_Choice_Staticness (Choice)); - -- FIXME: not true for range. - Len := Len + 1; - when Iir_Kind_Choice_By_None => - Has_Positional_Choice := True; - if Get_Element_Type_Flag (Choice) then - Len := Len + 1; - else - -- Extract length from associated expression. - declare - -- Always has an associated expr, as not named. - Expr : constant Iir := Get_Associated_Expr (Choice); - Expr_Type : constant Iir := Get_Type (Expr); - Expr_Index : Iir; - Index_Staticness : Iir_Staticness; - begin - if not Is_Error (Expr_Type) then - Expr_Index := Get_Index_Type (Expr_Type, 0); - Index_Staticness := - Get_Type_Staticness (Expr_Index); - case Index_Staticness is - when Locally => - Len := Len + Natural - (Eval_Discrete_Type_Length (Expr_Index)); - when Globally | None => - Len_Staticness := Iirs.Min - (Len_Staticness, Index_Staticness); - when Unknown => - -- Must have been caught by Is_Error. - raise Internal_Error; - end case; - end if; - end; - end if; - when Iir_Kind_Choice_By_Others => - if not Constrained then - Error_Msg_Sem (+Aggr, "'others' choice not allowed " - & "for an aggregate in this context"); - Infos (Dim).Error := True; - return; - end if; - Has_Others := True; - when others => - Error_Kind ("sem_array_aggregate", Choice); - end case; - -- LRM93 7.3.2.2 - -- Apart from the final element with the single choice - -- OTHERS, the rest (if any) of the element - -- associations of an array aggregate must be either - -- all positionnal or all named. - if Has_Positional_Choice then - if Is_Positional = False then - -- The error has already been emited - -- by sem_choices_range. - Infos (Dim).Error := True; - return; - end if; - Is_Positional := True; - end if; - Choice := Get_Chain (Choice); - end loop; - - Info.Min_Length := Integer'Max (Info.Min_Length, Len); - - if Choice_Staticness = Unknown then - -- This is possible when a choice is erroneous. - Infos (Dim).Error := True; - return; - end if; - - when Iir_Kind_String_Literal8 => - Len := Sem_String_Literal - (Aggr, Get_Base_Type (Get_Element_Subtype (A_Type))); - Assoc_Chain := Null_Iir; - Info.Min_Length := Integer'Max (Info.Min_Length, Len); - Is_Positional := True; - Has_Others := False; - Choice_Staticness := Locally; - Info.Nbr_Assocs := Info.Nbr_Assocs + Len; - - when others => - Error_Kind ("sem_array_aggregate(1)", Aggr); - end case; - - if Is_Positional = False then - Info.Has_Named := True; - end if; - if not Has_Others then - Info.Has_Others := False; - end if; - - -- LRM93 7.3.2.2 - -- A named association of an array aggregate is allowed to have a choice - -- that is not locally static, [or likewise a choice that is a null - -- range], only if the aggregate includes a single element association - -- and this element association has a single choice. - if Is_Positional = False and then Choice_Staticness /= Locally then - Choice := Assoc_Chain; - if not Is_Chain_Length_One (Assoc_Chain) or else - (Get_Kind (Choice) /= Iir_Kind_Choice_By_Expression - and then Get_Kind (Choice) /= Iir_Kind_Choice_By_Range) - then - Error_Msg_Sem (+Aggr, "non-locally static choice for an aggregate " - & "is allowed only if only choice"); - Infos (Dim).Error := True; - return; - end if; - Info.Has_Dynamic := True; - Set_Aggregate_Expand_Flag (Aggr, False); - end if; - - -- Compute bounds of the index if there is no index subtype. - if Info.Index_Subtype = Null_Iir and then Has_Others = False then - -- LRM93 7.3.2.2 - -- the direction of the index subtype of the aggregate is that of the - -- index subtype of the base type of the aggregate. - - if Is_Positional = True then - -- LRM93 7.3.2.2 - -- For a positionnal aggregate, [...] the leftmost bound is given - -- by S'LEFT where S is the index subtype of the base type of the - -- array; [...] the rightmost bound is determined by the direction - -- of the index subtype and the number of element. - if Get_Type_Staticness (Index_Type) = Locally - and then Len_Staticness = Locally - then - Info.Index_Subtype := Create_Range_Subtype_By_Length - (Index_Type, Iir_Int64 (Len), Get_Location (Aggr)); - end if; - else - -- Create an index subtype. - case Get_Kind (Index_Type) is - when Iir_Kind_Integer_Subtype_Definition => - Info.Index_Subtype := - Create_Iir (Iir_Kind_Integer_Subtype_Definition); - when Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Enumeration_Subtype_Definition => - Info.Index_Subtype := - Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); - when others => - Error_Kind ("sem_array_aggregate(2)", Index_Type); - end case; - Location_Copy (Info.Index_Subtype, Aggr); - Set_Base_Type (Info.Index_Subtype, Get_Base_Type (Index_Type)); - Index_Constraint := Get_Range_Constraint (Index_Type); - - -- LRM93 7.3.2.2 - -- If the aggregate appears in one of the above contexts, then the - -- direction of the index subtype of the aggregate is that of the - -- corresponding constrained array subtype; [...] - Index_Subtype_Constraint := Create_Iir (Iir_Kind_Range_Expression); - Location_Copy (Index_Subtype_Constraint, Aggr); - Set_Range_Constraint - (Info.Index_Subtype, Index_Subtype_Constraint); - Set_Type_Staticness (Info.Index_Subtype, Choice_Staticness); - Set_Expr_Staticness (Index_Subtype_Constraint, Choice_Staticness); - Set_Type (Index_Subtype_Constraint, Index_Type); - if Get_Kind (Index_Constraint) = Iir_Kind_Range_Expression then - Dir := Get_Direction (Index_Constraint); - else - -- This is not correct, as the direction must be the one of - -- the corresponding constraint. But it may not be determined - -- at analysis time (if 'Range), and it doesn't really matter - -- because of implicit subtype conversion. So choose one - -- arbitrary direction. - Dir := Iir_To; - end if; - - -- LRM93 7.3.2.2 - -- For an aggregate that has named associations, the leftmost and - -- the rightmost bounds are determined by the direction of the - -- index subtype of the aggregate and the smallest and largest - -- choice given. - if Choice_Staticness = Locally then - if Low = Null_Iir or High = Null_Iir then - -- Avoid error propagation. - Set_Range_Constraint (Info.Index_Subtype, - Get_Range_Constraint (Index_Type)); - Free_Iir (Index_Subtype_Constraint); - else - Set_Direction (Index_Subtype_Constraint, Dir); - case Dir is - when Iir_To => - Set_Left_Limit (Index_Subtype_Constraint, Low); - Set_Right_Limit (Index_Subtype_Constraint, High); - when Iir_Downto => - Set_Left_Limit (Index_Subtype_Constraint, High); - Set_Right_Limit (Index_Subtype_Constraint, Low); - end case; - end if; - else - -- Dynamic aggregate. - Set_Aggregate_Expand_Flag (Aggr, False); - - declare - -- There is only one choice. - Choice : constant Iir := Assoc_Chain; - Expr : Iir; - begin - case Get_Kind (Choice) is - when Iir_Kind_Choice_By_Expression => - Expr := Get_Choice_Expression (Choice); - Set_Direction (Index_Subtype_Constraint, Dir); - Set_Left_Limit (Index_Subtype_Constraint, Expr); - Set_Right_Limit (Index_Subtype_Constraint, Expr); - when Iir_Kind_Choice_By_Range => - Expr := Get_Choice_Range (Choice); - Set_Range_Constraint (Info.Index_Subtype, Expr); - Set_Is_Ref (Info.Index_Subtype, True); - -- FIXME: avoid allocation-free. - Free_Iir (Index_Subtype_Constraint); - when others => - raise Internal_Error; - end case; - end; - end if; - end if; - --Set_Type_Staticness - -- (A_Subtype, Iirs.Min (Get_Type_Staticness (A_Subtype), - -- Get_Type_Staticness (Index_Subtype))); - --Append_Element (Get_Index_List (A_Subtype), Index_Subtype); - elsif Has_Others = False then - -- Check the subaggregate bounds are the same. - if Is_Positional = True then - if Eval_Pos (Eval_Discrete_Range_Left (Get_Range_Constraint - (Info.Index_Subtype))) - /= Eval_Pos (Eval_Discrete_Range_Left (Get_Range_Constraint - (Index_Type))) - then - Error_Msg_Sem (+Aggr, "subaggregate bounds mismatch"); - else - if Eval_Discrete_Type_Length (Info.Index_Subtype) - /= Iir_Int64 (Len) - then - Error_Msg_Sem (+Aggr, "subaggregate length mismatch"); - end if; - end if; - else - declare - L, H : Iir; - begin - Get_Low_High_Limit - (Get_Range_Constraint (Info.Index_Subtype), L, H); - if Eval_Pos (L) /= Eval_Pos (Low) - or else Eval_Pos (H) /= Eval_Pos (H) - then - Error_Msg_Sem (+Aggr, "subagregate bounds mismatch"); - end if; - end; - end if; - end if; - - Expr_Staticness := Min (Get_Expr_Staticness (Aggr), Choice_Staticness); - Set_Expr_Staticness (Aggr, Expr_Staticness); - end Sem_Array_Aggregate_1; - - -- Analyze an array aggregate whose type is AGGR_TYPE. - -- If CONSTRAINED is true, then the aggregate appears in one of the - -- context and can have an 'others' choice. - -- If CONSTRAINED is false, the aggregate can not have an 'others' choice. - -- Create a subtype for this aggregate. - -- Return NULL_IIR in case of error, or AGGR if not. - function Sem_Array_Aggregate - (Aggr : Iir; Aggr_Type : Iir; Constrained : Boolean) return Iir - is - A_Subtype: Iir; - Base_Type : Iir; - Index_List : constant Iir_Flist := Get_Index_Subtype_List (Aggr_Type); - Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); - Infos : Array_Aggr_Info_Arr (1 .. Nbr_Dim); - Aggr_Constrained : Boolean; - Info, Prev_Info : Iir_Aggregate_Info; - Type_Staticness : Iir_Staticness; - begin - -- By default, consider the aggregate can be statically built. - Set_Aggregate_Expand_Flag (Aggr, True); - - -- Analyze the aggregate. - Sem_Array_Aggregate_1 (Aggr, Aggr_Type, Infos, Constrained, 1); - - Aggr_Constrained := True; - for I in Infos'Range loop - -- Return now in case of error. - if Infos (I).Error then - Set_Aggregate_Expand_Flag (Aggr, False); - return Null_Iir; - end if; - if Infos (I).Index_Subtype = Null_Iir then - Aggr_Constrained := False; - end if; - end loop; - Base_Type := Get_Base_Type (Aggr_Type); - - -- Reuse AGGR_TYPE iff AGGR_TYPE is fully constrained - -- and statically match the subtype of the aggregate. - if Aggr_Constrained then - Type_Staticness := Locally; - for I in Infos'Range loop - Type_Staticness := Min - (Type_Staticness, Get_Type_Staticness (Infos (I).Index_Subtype)); - end loop; - - if Get_Constraint_State (Aggr_Type) = Fully_Constrained - and then Get_Type_Staticness (Aggr_Type) = Locally - and then Type_Staticness = Locally - then - Set_Type (Aggr, Aggr_Type); - else - A_Subtype := Create_Array_Subtype (Base_Type, Get_Location (Aggr)); - -- FIXME: extract element subtype ? - Set_Element_Subtype (A_Subtype, Get_Element_Subtype (Aggr_Type)); - Type_Staticness := Min (Type_Staticness, - Get_Type_Staticness (A_Subtype)); - for I in Infos'Range loop - Set_Nth_Element (Get_Index_Subtype_List (A_Subtype), I - 1, - Infos (I).Index_Subtype); - end loop; - Set_Type_Staticness (A_Subtype, Type_Staticness); - Set_Index_Constraint_Flag (A_Subtype, True); - -- FIXME: the element can be unconstrained. - Set_Constraint_State (A_Subtype, Fully_Constrained); - Set_Type (Aggr, A_Subtype); - Set_Literal_Subtype (Aggr, A_Subtype); - end if; - if Type_Staticness = Locally and then Get_Aggregate_Expand_Flag (Aggr) - then - -- Compute ratio of elements vs size of the aggregate to determine - -- if the aggregate can be expanded. - declare - Size : Iir_Int64; - begin - Size := 1; - for I in Infos'Range loop - Size := Size - * Eval_Discrete_Type_Length (Infos (I).Index_Subtype); - end loop; - Set_Aggregate_Expand_Flag - (Aggr, Infos (Nbr_Dim).Nbr_Assocs >= Natural (Size / 10)); - end; - else - Set_Aggregate_Expand_Flag (Aggr, False); - end if; - else - -- Free unused indexes subtype. - for I in Infos'Range loop - declare - St : constant Iir := Infos (I).Index_Subtype; - Rng : Iir; - begin - if St /= Null_Iir then - Rng := Get_Range_Constraint (St); - Free_Iir (Get_Right_Limit_Expr (Rng)); - Free_Iir (Rng); - Free_Iir (St); - end if; - end; - end loop; - - -- If bounds are not known, the aggregate cannot be statically built. - Set_Aggregate_Expand_Flag (Aggr, False); - end if; - - if Infos (Nbr_Dim).Has_Bound_Error then - return Build_Overflow (Aggr, Get_Type (Aggr)); - end if; - - Prev_Info := Null_Iir; - for I in Infos'Range loop - -- Create info and link. - Info := Create_Iir (Iir_Kind_Aggregate_Info); - if I = 1 then - Set_Aggregate_Info (Aggr, Info); - else - Set_Sub_Aggregate_Info (Prev_Info, Info); - end if; - Prev_Info := Info; - - -- Fill info. - Set_Aggr_Dynamic_Flag (Info, Infos (I).Has_Dynamic); - Set_Aggr_Named_Flag (Info, Infos (I).Has_Named); - Set_Aggr_Low_Limit (Info, Infos (I).Low); - Set_Aggr_High_Limit (Info, Infos (I).High); - Set_Aggr_Min_Length (Info, Iir_Int32 (Infos (I).Min_Length)); - Set_Aggr_Others_Flag (Info, Infos (I).Has_Others); - end loop; - return Aggr; - end Sem_Array_Aggregate; - - -- Analyze aggregate EXPR whose type is expected to be A_TYPE. - -- A_TYPE cannot be null_iir (this case is handled in sem_expression_ov) - -- If FORCE_CONSTRAINED is true, the aggregate type is constrained by the - -- context, even if its type isn't. This is to deal with cases like: - -- procedure set (v : out string) is - -- begin - -- v := (others => ' '); - -- end set; - -- but this is not allowed by: - -- LRM08 9.3.3.3 Array aggregates - -- e) As a value expression in an assignment statement, where the target - -- is a declared object (or member thereof), and either the subtype of - -- the target is a fully constrained array subtype or the target is a - -- slice name. - function Sem_Aggregate - (Expr: Iir_Aggregate; A_Type: Iir; Force_Constrained : Boolean) - return Iir_Aggregate - is - Force_Constrained2 : constant Boolean := - Force_Constrained and Flag_Relaxed_Rules; - begin - pragma Assert (A_Type /= Null_Iir); - - if Flags.Vhdl_Std >= Vhdl_08 then - -- An aggregate can be a locally static primary according to LRM08 - -- 9.4.2 Locally static primaries l) and m). - Set_Expr_Staticness (Expr, Locally); - else - -- An aggregate is at most globally static. - Set_Expr_Staticness (Expr, Globally); - end if; - - Set_Type (Expr, A_Type); -- FIXME: should free old type - case Get_Kind (A_Type) is - when Iir_Kind_Array_Subtype_Definition => - return Sem_Array_Aggregate - (Expr, A_Type, - Force_Constrained2 or else Get_Index_Constraint_Flag (A_Type)); - when Iir_Kind_Array_Type_Definition => - return Sem_Array_Aggregate (Expr, A_Type, Force_Constrained2); - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - if not Sem_Record_Aggregate (Expr, A_Type) then - return Null_Iir; - end if; - return Expr; - when Iir_Kind_Error => - return Null_Iir; - when others => - Error_Msg_Sem (+Expr, "type %n is not composite", +A_Type); - return Null_Iir; - end case; - end Sem_Aggregate; - - function Is_Physical_Literal_Zero (Lit : Iir) return Boolean is - begin - case Iir_Kinds_Physical_Literal (Get_Kind (Lit)) is - when Iir_Kind_Physical_Int_Literal => - return Get_Value (Lit) = 0; - when Iir_Kind_Physical_Fp_Literal => - return Get_Fp_Value (Lit) = 0.0; - end case; - end Is_Physical_Literal_Zero; - - -- Transform LIT into a physical_literal. - -- LIT can be either a not analyzed physical literal or - -- a simple name that is a physical unit. In the later case, a physical - -- literal is created. - function Sem_Physical_Literal (Lit: Iir) return Iir - is - Unit_Name : Iir; - Unit : Iir; - Unit_Type : Iir; - Res: Iir; - begin - case Get_Kind (Lit) is - when Iir_Kind_Physical_Int_Literal - | Iir_Kind_Physical_Fp_Literal => - Unit_Name := Get_Unit_Name (Lit); - Res := Lit; - when Iir_Kinds_Denoting_Name => - Res := Create_Iir (Iir_Kind_Physical_Int_Literal); - Location_Copy (Res, Lit); - Set_Value (Res, 1); - Set_Literal_Origin (Res, Lit); - Unit_Name := Lit; - when others => - Error_Kind ("sem_physical_literal", Lit); - end case; - if Is_Error (Unit_Name) then - return Create_Error_Expr (Res, Error_Mark); - end if; - - Unit_Name := Sem_Denoting_Name (Unit_Name); - Unit := Get_Named_Entity (Unit_Name); - if Get_Kind (Unit) /= Iir_Kind_Unit_Declaration then - if not Is_Error (Unit) then - Error_Class_Match (Unit_Name, "unit"); - end if; - Set_Named_Entity (Unit_Name, Create_Error_Name (Unit_Name)); - else - -- Physical unit is used. - Set_Use_Flag (Unit, True); - - if Get_Type (Unit) = Time_Type_Definition - and then Get_Value (Get_Physical_Literal (Unit)) = 0 - and then not Is_Physical_Literal_Zero (Res) - then - -- LRM08 5.2.4.2 Predefined physical types - -- It is an error if a given unit of type TIME appears anywhere - -- within the design hierarchy defining a model to be elaborated, - -- and if the position number of that unit is less than that of - -- the secondary unit selected as the resolution limit for type - -- TIME during the elaboration of the model, unless that unit is - -- part of a physical literal whose abstract literal is either - -- the integer value zero or the floating-point value zero. - Error_Msg_Sem - (+Res, "physical unit %i is below the time resolution", +Unit); - end if; - end if; - Set_Unit_Name (Res, Unit_Name); - Set_Physical_Unit (Res, Get_Named_Entity (Unit_Name)); - Unit_Type := Get_Type (Unit_Name); - Set_Type (Res, Unit_Type); - - -- LRM93 7.4.2 - -- 1. a literal of type TIME. - -- - -- LRM93 7.4.1 - -- 1. a literal of any type other than type TIME; - Set_Expr_Staticness (Res, Get_Expr_Staticness (Unit_Name)); - --Eval_Check_Constraints (Res); - return Res; - end Sem_Physical_Literal; - - -- Analyze an allocator by expression or an allocator by subtype. - function Sem_Allocator (Expr : Iir; A_Type : Iir) return Iir - is - Arg: Iir; - Arg_Type : Iir; - begin - Set_Expr_Staticness (Expr, None); - - Arg_Type := Get_Allocator_Designated_Type (Expr); - - if Arg_Type = Null_Iir then - -- Expression was not analyzed. - case Iir_Kinds_Allocator (Get_Kind (Expr)) is - when Iir_Kind_Allocator_By_Expression => - Arg := Get_Expression (Expr); - pragma Assert (Get_Kind (Arg) = Iir_Kind_Qualified_Expression); - Arg := Sem_Expression (Arg, Null_Iir); - if Arg = Null_Iir then - return Null_Iir; - end if; - Check_Read (Arg); - Set_Expression (Expr, Arg); - Arg_Type := Get_Type (Arg); - - when Iir_Kind_Allocator_By_Subtype => - -- Analyze subtype indication. - Arg := Get_Subtype_Indication (Expr); - Arg := Sem_Types.Sem_Subtype_Indication (Arg); - Set_Subtype_Indication (Expr, Arg); - Arg := Get_Type_Of_Subtype_Indication (Arg); - if Arg = Null_Iir or else Is_Error (Arg) then - return Null_Iir; - end if; - if Is_Anonymous_Type_Definition (Arg) then - Set_Allocator_Subtype (Expr, Get_Subtype_Indication (Expr)); - end if; - - -- LRM93 7.3.6 - -- If an allocator includes a subtype indication and if the - -- type of the object created is an array type, then the - -- subtype indication must either denote a constrained - -- subtype or include an explicit index constraint. - if not Is_Fully_Constrained_Type (Arg) then - Error_Msg_Sem - (+Expr, "allocator of unconstrained %n is not allowed", - +Arg); - end if; - -- LRM93 7.3.6 - -- A subtype indication that is part of an allocator must - -- not include a resolution function. - if Is_Anonymous_Type_Definition (Arg) - and then Get_Kind (Arg) /= Iir_Kind_Access_Subtype_Definition - and then Get_Resolution_Indication (Arg) /= Null_Iir - then - Error_Msg_Sem (+Expr, "subtype indication must not include" - & " a resolution function"); - end if; - Arg_Type := Arg; - end case; - Set_Allocator_Designated_Type (Expr, Arg_Type); - end if; - - -- LRM 7.3.6 Allocators - -- The type of the access value returned by an allocator must be - -- determinable solely from the context, but using the fact that the - -- value returned is of an access type having the named designated - -- type. - if A_Type = Null_Iir then - -- Type of the context is not yet known. - return Expr; - else - if not Is_Allocator_Type (A_Type, Expr) then - if Get_Kind (A_Type) /= Iir_Kind_Access_Type_Definition then - if Get_Kind (A_Type) /= Iir_Kind_Error then - Error_Msg_Sem (+Expr, "expected type is not an access type"); - end if; - else - Error_Not_Match (Expr, A_Type); - end if; - return Null_Iir; - end if; - Set_Type (Expr, A_Type); - return Expr; - end if; - end Sem_Allocator; - - function Sem_Qualified_Expression (Expr : Iir; A_Type : Iir) return Iir - is - N_Type: Iir; - Res: Iir; - begin - N_Type := Sem_Type_Mark (Get_Type_Mark (Expr)); - Set_Type_Mark (Expr, N_Type); - N_Type := Get_Type (N_Type); - Set_Type (Expr, N_Type); - if A_Type /= Null_Iir - and then Are_Types_Compatible (A_Type, N_Type) = Not_Compatible - then - Error_Not_Match (Expr, A_Type); - return Null_Iir; - end if; - Res := Sem_Expression (Get_Expression (Expr), N_Type); - if Res = Null_Iir then - return Null_Iir; - end if; - Check_Read (Res); - Set_Expression (Expr, Res); - - -- LRM93 7.4.1 Locally static primaries - -- h) A qualified expression whose operand is a locally static - -- expression. - -- - -- LRM08 9.4.2 Locally static primaries - -- i) A qualified expression whose type mark denotes a locally static - -- subtype and whose operand is a locally static expression. - -- - -- We always use the vhdl08, because it is weird to have locally - -- static expression with a non-locally static subtype. - Set_Expr_Staticness (Expr, Min (Get_Expr_Staticness (Res), - Get_Type_Staticness (N_Type))); - - -- When possible, use the type of the expression as the type of the - -- qualified expression. - -- TODO: also handle unbounded subtypes, but only if this is a proper - -- subtype. - case Get_Kind (N_Type) is - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Record_Type_Definition => - Set_Type (Expr, Get_Type (Res)); - when others => - null; - end case; - - return Expr; - end Sem_Qualified_Expression; - - function Is_Signal_Parameter (Obj : Iir) return Boolean is - begin - return Get_Kind (Obj) = Iir_Kind_Interface_Signal_Declaration - and then - Get_Kind (Get_Parent (Obj)) in Iir_Kinds_Subprogram_Declaration; - end Is_Signal_Parameter; - - function Can_Interface_Be_Read (Inter : Iir) return Boolean is - begin - case Get_Mode (Inter) is - when Iir_In_Mode - | Iir_Inout_Mode - | Iir_Buffer_Mode => - -- LRM08 6.5.3 Interface object declarations - -- - in. The value of the interface object is allowed - -- to be read, [...] - -- - inout or buffer. Reading and updating the value of - -- the interface object is allowed. [...] - null; - when Iir_Out_Mode => - -- LRM93 4.3.2 Interface declarations - -- - out. The value of the interface object is allowed to be - -- updated, but it must not be read. - -- - -- LRM08 6.5.3 Interface object declarations - -- - out. The value of the interface object is allowed - -- [to be updated and,] provided it is not a signal - -- parameter, read. - if Vhdl_Std < Vhdl_08 or else Is_Signal_Parameter (Inter) then - return False; - end if; - when Iir_Linkage_Mode => - -- LRM08 6.5.3 Interface object declarations - -- - linkage. Reading and updating the value of the - -- interface object is allowed, but only by appearing - -- as an actual corresponding to an interface object - -- of mode LINKAGE. No other reading or updating is - -- permitted. - return False; - when Iir_Unknown_Mode => - raise Internal_Error; - end case; - return True; - end Can_Interface_Be_Read; - - function Can_Interface_Be_Updated (Inter : Iir) return Boolean is - begin - case Get_Mode (Inter) is - when Iir_In_Mode => - -- LRM08 6.5.3 Interface object declarations - -- - in. The value of the interface object is allowed to be read, - -- but it shall not be updated. - return False; - when Iir_Out_Mode => - -- LRM08 6.5.3 Interface object declarations - -- - out. The value of the interface object is allowed - -- to be updated [and, ...] - return True; - when Iir_Inout_Mode - | Iir_Buffer_Mode => - -- LRM08 6.5.3 Interface object declarations - -- - inout or buffer. Reading and updating the value of the - -- interface is allowed. - return True; - when Iir_Linkage_Mode => - -- LRM08 6.5.3 Interface object declarations - -- - linkage. Reading and updating the value of the - -- interface object is allowed, but only by appearing - -- as an actual corresponding to an interface object - -- of mode LINKAGE. No other reading or updating is - -- permitted. - return False; - when Iir_Unknown_Mode => - raise Internal_Error; - end case; - end Can_Interface_Be_Updated; - - procedure Check_Read_Aggregate (Aggr : Iir) - is - pragma Unreferenced (Aggr); - begin - -- FIXME: todo. - null; - end Check_Read_Aggregate; - - -- Check EXPR can be read. - procedure Check_Read (Expr : Iir) - is - Obj : Iir; - begin - if Expr = Null_Iir then - return; - end if; - - Obj := Expr; - loop - case Get_Kind (Obj) is - when Iir_Kind_Signal_Declaration - | Iir_Kind_Constant_Declaration - | Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_Attribute_Value - | Iir_Kind_Iterator_Declaration - | Iir_Kind_Guard_Signal_Declaration => - return; - when Iir_Kinds_Quantity_Declaration => - return; - when Iir_Kinds_External_Name => - return; - when Iir_Kind_Psl_Endpoint_Declaration => - return; - when Iir_Kind_File_Declaration - | Iir_Kind_Interface_File_Declaration => - -- LRM 4.3.2 Interface declarations - -- The value of an object is said to be read [...] - -- - When the object is a file and a READ operation is - -- performed on the file. - return; - when Iir_Kind_Object_Alias_Declaration => - Obj := Get_Name (Obj); - when Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Interface_Variable_Declaration => - if not Can_Interface_Be_Read (Obj) then - Error_Msg_Sem (+Expr, "%n cannot be read", +Obj); - end if; - return; - when Iir_Kind_Enumeration_Literal - | Iir_Kind_Physical_Int_Literal - | Iir_Kind_Physical_Fp_Literal - | Iir_Kind_String_Literal8 - | Iir_Kind_Character_Literal - | Iir_Kind_Integer_Literal - | Iir_Kind_Floating_Point_Literal - | Iir_Kind_Null_Literal - | Iir_Kind_Unit_Declaration - | Iir_Kind_Simple_Aggregate - | Iir_Kind_Overflow_Literal => - return; - when Iir_Kinds_Monadic_Operator - | Iir_Kinds_Dyadic_Operator - | Iir_Kind_Function_Call => - return; - when Iir_Kind_Parenthesis_Expression => - Obj := Get_Expression (Obj); - when Iir_Kind_Qualified_Expression => - return; - when Iir_Kind_Type_Conversion - | Iir_Kind_Allocator_By_Expression - | Iir_Kind_Allocator_By_Subtype - | Iir_Kind_Implicit_Dereference - | Iir_Kind_Dereference - | Iir_Kind_Attribute_Name => - return; - when Iir_Kinds_Scalar_Type_Attribute - | Iir_Kinds_Type_Attribute - | Iir_Kinds_Array_Attribute - | Iir_Kind_Image_Attribute - | Iir_Kind_Value_Attribute - | Iir_Kinds_Name_Attribute - | Iir_Kinds_Signal_Attribute - | Iir_Kinds_Signal_Value_Attribute => - return; - when Iir_Kind_Aggregate => - Check_Read_Aggregate (Obj); - return; - when Iir_Kind_Indexed_Name - | Iir_Kind_Slice_Name - | Iir_Kind_Selected_Element => - -- FIXME: speed up using Base_Name - -- Obj := Get_Base_Name (Obj); - Obj := Get_Prefix (Obj); - when Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name => - Obj := Get_Named_Entity (Obj); - when Iir_Kind_Error => - return; - when others => - Error_Kind ("check_read", Obj); - end case; - end loop; - end Check_Read; - - procedure Check_Update (Expr : Iir) - is - pragma Unreferenced (Expr); - begin - null; - end Check_Update; - - -- Emit an error if the constant EXPR is deferred and cannot be used in - -- the current context. - procedure Check_Constant_Restriction (Expr : Iir; Loc : Iir) - is - Lib : Iir; - Cur_Lib : Iir; - begin - -- LRM93 §2.6 - -- Within a package declaration that contains the declaration - -- of a deferred constant, and within the body of that package, - -- before the end of the corresponding full declaration, the - -- use of a name that denotes the deferred constant is only - -- allowed in the default expression for a local generic, - -- local port or formal parameter. - if Get_Deferred_Declaration_Flag (Expr) = False - or else Get_Deferred_Declaration (Expr) /= Null_Iir - then - -- The constant declaration is not deferred - -- or the it has been fully declared. - return; - end if; - - Lib := Get_Parent (Expr); - Cur_Lib := Get_Library_Unit (Sem.Get_Current_Design_Unit); - if (Get_Kind (Cur_Lib) = Iir_Kind_Package_Declaration - and then Lib = Cur_Lib) - or else (Get_Kind (Cur_Lib) = Iir_Kind_Package_Body - and then Get_Package (Cur_Lib) = Lib) - then - Error_Msg_Sem (+Loc, "invalid use of a deferred constant"); - end if; - end Check_Constant_Restriction; - - -- Set semantic to EXPR. - -- Replace simple_name with the referenced node, - -- Set type to nodes, - -- Resolve overloading - - -- If A_TYPE is not null, then EXPR must be of type A_TYPE. - -- Return null in case of error. - function Sem_Expression_Ov (Expr: Iir; A_Type1: Iir) return Iir - is - A_Type: Iir; - begin --- -- Avoid to run sem_expression_ov when a node was already analyzed --- -- except to resolve overload. --- if Get_Type (Expr) /= Null_Iir then --- -- EXPR was already analyzed. --- if A_Type1 = null or else not Is_Overload_List (Get_Type (Expr)) then --- -- This call to sem_expression_ov do not add any informations. --- Check_Restrictions (Expr, Restriction); --- return Expr; --- end if; --- -- This is an overload list that will be reduced. --- end if; - - -- A_TYPE must be a type definition and not a subtype. - if A_Type1 /= Null_Iir then - A_Type := Get_Base_Type (A_Type1); - if A_Type /= A_Type1 then - raise Internal_Error; - end if; - else - A_Type := Null_Iir; - end if; - - case Get_Kind (Expr) is - when Iir_Kind_Selected_Name - | Iir_Kind_Simple_Name - | Iir_Kind_Character_Literal - | Iir_Kind_Parenthesis_Name - | Iir_Kind_Selected_By_All_Name - | Iir_Kind_Attribute_Name => - declare - E : Iir; - begin - E := Get_Named_Entity (Expr); - if E = Null_Iir then - Sem_Name (Expr); - E := Get_Named_Entity (Expr); - pragma Assert (E /= Null_Iir); - end if; - if E = Error_Mark then - return Null_Iir; - end if; - if Get_Kind (E) = Iir_Kind_Constant_Declaration - and then not Deferred_Constant_Allowed - then - Check_Constant_Restriction (E, Expr); - end if; - E := Name_To_Expression (Expr, A_Type); - return E; - end; - - when Iir_Kinds_External_Name => - Sem_External_Name (Expr); - return Expr; - - when Iir_Kinds_Monadic_Operator => - return Sem_Operator (Expr, A_Type, 1); - - when Iir_Kinds_Dyadic_Operator => - return Sem_Operator (Expr, A_Type, 2); - - when Iir_Kind_Enumeration_Literal - | Iir_Kinds_Object_Declaration => - -- All these case have already a type. - if Get_Type (Expr) = Null_Iir then - return Null_Iir; - end if; - if A_Type /= Null_Iir - and then Are_Basetypes_Compatible - (A_Type, Get_Base_Type (Get_Type (Expr))) = Not_Compatible - then - Error_Not_Match (Expr, A_Type); - return Null_Iir; - end if; - return Expr; - - when Iir_Kind_Integer_Literal => - Set_Expr_Staticness (Expr, Locally); - if A_Type = Null_Iir then - Set_Type (Expr, Convertible_Integer_Type_Definition); - return Expr; - elsif Get_Kind (A_Type) = Iir_Kind_Integer_Type_Definition then - Set_Type (Expr, A_Type); - return Expr; - else - Error_Not_Match (Expr, A_Type); - return Null_Iir; - end if; - - when Iir_Kind_Floating_Point_Literal => - Set_Expr_Staticness (Expr, Locally); - if A_Type = Null_Iir then - Set_Type (Expr, Convertible_Real_Type_Definition); - return Expr; - elsif Get_Kind (A_Type) = Iir_Kind_Floating_Type_Definition then - Set_Type (Expr, A_Type); - return Expr; - else - Error_Not_Match (Expr, A_Type); - return Null_Iir; - end if; - - when Iir_Kind_Physical_Int_Literal - | Iir_Kind_Physical_Fp_Literal - | Iir_Kind_Unit_Declaration => - declare - Res: Iir; - Res_Type : Iir; - begin - Res := Sem_Physical_Literal (Expr); - Res_Type := Get_Type (Res); - if Is_Null (Res_Type) then - return Null_Iir; - end if; - if A_Type /= Null_Iir and then Res_Type /= A_Type then - Error_Not_Match (Res, A_Type); - return Null_Iir; - end if; - return Res; - end; - - when Iir_Kind_String_Literal8 => - -- LRM93 7.3.1 Literals - -- The type of a string or bit string literal must be - -- determinable solely from the context in whcih the literal - -- appears, excluding the literal itself [...] - if A_Type = Null_Iir then - return Expr; - end if; - - if not Is_String_Literal_Type (A_Type, Expr) then - Error_Not_Match (Expr, A_Type); - return Null_Iir; - else - Replace_Type (Expr, A_Type); - Sem_String_Literal (Expr); - return Expr; - end if; - - when Iir_Kind_Null_Literal => - Set_Expr_Staticness (Expr, Locally); - -- GHDL: the LRM doesn't explain how the type of NULL is - -- determined. Use the same rule as string or aggregates. - if A_Type = Null_Iir then - return Expr; - end if; - if not Is_Null_Literal_Type (A_Type) then - Error_Msg_Sem (+Expr, "null literal can only be access type"); - return Null_Iir; - else - Set_Type (Expr, A_Type); - return Expr; - end if; - - when Iir_Kind_Aggregate => - -- LRM93 7.3.2 Aggregates - -- The type of an aggregate must be determinable solely from the - -- context in which the aggregate appears, excluding the aggregate - -- itself but [...] - if A_Type = Null_Iir then - return Expr; - else - return Sem_Aggregate (Expr, A_Type, False); - end if; - - when Iir_Kind_Parenthesis_Expression => - declare - Sub_Expr : Iir; - begin - Sub_Expr := Get_Expression (Expr); - Sub_Expr := Sem_Expression_Ov (Sub_Expr, A_Type1); - if Sub_Expr = Null_Iir then - return Null_Iir; - end if; - Set_Expression (Expr, Sub_Expr); - Set_Type (Expr, Get_Type (Sub_Expr)); - Set_Expr_Staticness (Expr, Get_Expr_Staticness (Sub_Expr)); - return Expr; - end; - - when Iir_Kind_Qualified_Expression => - return Sem_Qualified_Expression (Expr, A_Type); - - when Iir_Kind_Allocator_By_Expression - | Iir_Kind_Allocator_By_Subtype => - return Sem_Allocator (Expr, A_Type); - - when Iir_Kind_Procedure_Declaration => - Error_Msg_Sem (+Expr, "%n cannot be used as an expression", +Expr); - return Null_Iir; - - when Iir_Kind_Range_Expression => - -- Can only happen in case of parse error, as a range is not an - -- expression. - pragma Assert (Flags.Flag_Force_Analysis); - declare - Res : Iir; - begin - Res := Sem_Simple_Range_Expression (Expr, A_Type, True); - return Create_Error_Expr (Res, A_Type); - end; - - when Iir_Kind_Error => - -- Always ok. - return Expr; - - when others => - Error_Kind ("sem_expression_ov", Expr); - return Null_Iir; - end case; - end Sem_Expression_Ov; - - function Is_Expr_Not_Analyzed (Expr : Iir) return Boolean is - begin - return Get_Type (Expr) = Null_Iir; - end Is_Expr_Not_Analyzed; - - function Is_Expr_Fully_Analyzed (Expr : Iir) return Boolean is - begin - return Is_Defined_Type (Get_Type (Expr)); - end Is_Expr_Fully_Analyzed; - - function Get_Wildcard_Type (Wildcard : Iir; Atype : Iir) return Iir is - begin - if Atype in Iir_Wildcard_Types then - -- Special wildcard vs wildcard. - case Iir_Wildcard_Types (Wildcard) is - when Wildcard_Any_Type => - return Atype; - when Wildcard_Any_Aggregate_Type => - case Iir_Wildcard_Types (Atype) is - when Wildcard_Any_Type - | Wildcard_Any_Aggregate_Type => - return Wildcard_Any_Aggregate_Type; - when Wildcard_Any_String_Type => - return Wildcard_Any_String_Type; - when Wildcard_Any_Access_Type => - return Null_Iir; - end case; - when Wildcard_Any_String_Type => - case Iir_Wildcard_Types (Atype) is - when Wildcard_Any_Type - | Wildcard_Any_Aggregate_Type - | Wildcard_Any_String_Type => - return Wildcard_Any_String_Type; - when Wildcard_Any_Access_Type => - return Null_Iir; - end case; - when Wildcard_Any_Access_Type => - case Iir_Wildcard_Types (Atype) is - when Wildcard_Any_Type - | Wildcard_Any_Access_Type => - return Wildcard_Any_Access_Type; - when Wildcard_Any_Aggregate_Type - | Wildcard_Any_String_Type => - return Null_Iir; - end case; - end case; - else - case Iir_Wildcard_Types (Wildcard) is - when Wildcard_Any_Type => - -- Match with any type. - return Atype; - when Wildcard_Any_Aggregate_Type => - if Is_Aggregate_Type (Atype) then - return Atype; - end if; - when Wildcard_Any_String_Type => - if Is_String_Type (Atype) then - return Atype; - end if; - when Wildcard_Any_Access_Type => - if Get_Kind (Get_Base_Type (Atype)) - = Iir_Kind_Access_Type_Definition - then - return Atype; - end if; - end case; - return Null_Iir; - end if; - end Get_Wildcard_Type; - - function Compatible_Types_Intersect_Single (T1, T2 : Iir) return Iir is - begin - if T1 = T2 then - return T1; - end if; - if T1 in Iir_Wildcard_Types then - return Get_Wildcard_Type (T1, T2); - elsif T2 in Iir_Wildcard_Types then - return Get_Wildcard_Type (T2, T1); - else - return Get_Common_Basetype (Get_Base_Type (T1), Get_Base_Type (T2)); - end if; - end Compatible_Types_Intersect_Single; - - function Compatible_Types_Intersect_Single_List (A_Type, Types_List : Iir) - return Iir - is - Types_List_List : Iir_List; - It : List_Iterator; - El: Iir; - Com : Iir; - Res : Iir; - begin - if not Is_Overload_List (Types_List) then - return Compatible_Types_Intersect_Single (A_Type, Types_List); - else - Types_List_List := Get_Overload_List (Types_List); - Res := Null_Iir; - It := List_Iterate (Types_List_List); - while Is_Valid (It) loop - El := Get_Element (It); - Com := Compatible_Types_Intersect_Single (El, A_Type); - if Com /= Null_Iir then - Add_Result (Res, Com); - end if; - Next (It); - end loop; - return Res; - end if; - end Compatible_Types_Intersect_Single_List; - - function Compatible_Types_Intersect (List1, List2 : Iir) return Iir - is - List1_List : Iir_List; - It1 : List_Iterator; - Res : Iir; - El : Iir; - Tmp : Iir; - begin - if List1 = Null_Iir or else List2 = Null_Iir then - return Null_Iir; - end if; - - if Is_Overload_List (List1) then - List1_List := Get_Overload_List (List1); - Res := Null_Iir; - It1 := List_Iterate (List1_List); - while Is_Valid (It1) loop - El := Get_Element (It1); - Tmp := Compatible_Types_Intersect_Single_List (El, List2); - if Tmp /= Null_Iir then - Add_Result (Res, Tmp); - end if; - Next (It1); - end loop; - return Res; - else - return Compatible_Types_Intersect_Single_List (List1, List2); - end if; - end Compatible_Types_Intersect; - - function Sem_Expression_Wildcard - (Expr : Iir; Atype : Iir; Force_Constrained : Boolean := False) - return Iir - is - Expr_Type : constant Iir := Get_Type (Expr); - Atype_Defined : constant Boolean := Is_Defined_Type (Atype); - Expr_Type_Defined : constant Boolean := Is_Defined_Type (Expr_Type); - begin - if Expr_Type /= Null_Iir then - -- EXPR is at least partially analyzed. - if Expr_Type_Defined or else not Atype_Defined then - -- Nothing to do if: - -- - Expression is already fully analyzed: caller has to merge - -- types - -- - Expression is partially analyzed but ATYPE is not defined: - -- caller has to merge types. - return Expr; - end if; - end if; - - case Get_Kind (Expr) is - when Iir_Kind_Aggregate => - if Atype_Defined then - return Sem_Aggregate (Expr, Atype, Force_Constrained); - else - pragma Assert (Expr_Type = Null_Iir); - Set_Type (Expr, Wildcard_Any_Aggregate_Type); - end if; - return Expr; - - when Iir_Kind_String_Literal8 => - if Atype_Defined then - if not Is_String_Literal_Type (Atype, Expr) then - Error_Not_Match (Expr, Atype); - Set_Type (Expr, Error_Type); - else - Set_Type (Expr, Atype); - Sem_String_Literal (Expr); - end if; - else - pragma Assert (Expr_Type = Null_Iir); - Set_Type (Expr, Wildcard_Any_String_Type); - end if; - return Expr; - - when Iir_Kind_Null_Literal => - if Atype_Defined then - if not Is_Null_Literal_Type (Atype) then - Error_Not_Match (Expr, Atype); - Set_Type (Expr, Error_Type); - else - Set_Type (Expr, Atype); - Set_Expr_Staticness (Expr, Locally); - end if; - else - pragma Assert (Expr_Type = Null_Iir); - Set_Type (Expr, Wildcard_Any_Access_Type); - end if; - return Expr; - - when Iir_Kind_Allocator_By_Expression - | Iir_Kind_Allocator_By_Subtype => - if Atype_Defined then - if not Is_Null_Literal_Type (Atype) then - Error_Not_Match (Expr, Atype); - Set_Type (Expr, Error_Type); - else - return Sem_Allocator (Expr, Atype); - end if; - else - pragma Assert (Expr_Type = Null_Iir); - Set_Type (Expr, Wildcard_Any_Access_Type); - end if; - return Expr; - - when Iir_Kind_Parenthesis_Expression => - declare - Sub_Expr : Iir; - Ntype : Iir; - begin - Sub_Expr := Get_Expression (Expr); - if Atype_Defined then - -- Very important: loose the subtype due to - -- LRM93 7.3.2.2 Array aggregate. - Ntype := Get_Base_Type (Atype); - else - Ntype := Atype; - end if; - Sub_Expr := Sem_Expression_Wildcard (Sub_Expr, Ntype); - if Sub_Expr /= Null_Iir then - Set_Expression (Expr, Sub_Expr); - Set_Type (Expr, Get_Type (Sub_Expr)); - Set_Expr_Staticness (Expr, Get_Expr_Staticness (Sub_Expr)); - else - Set_Type (Expr, Error_Type); - end if; - end; - return Expr; - - when others => - if Atype_Defined then - return Sem_Expression_Ov (Expr, Get_Base_Type (Atype)); - else - declare - Res : Iir; - Res_Type : Iir; - Prev_Res_Type : Iir; - begin - pragma Assert (Expr_Type = Null_Iir); - if Atype in Iir_Wildcard_Types then - -- Analyze without known type. - Res := Sem_Expression_Ov (Expr, Null_Iir); - if Res = Null_Iir or else Is_Error (Res) then - Set_Type (Expr, Error_Type); - return Expr; - end if; - Prev_Res_Type := Get_Type (Res); - - -- Filter possible type. - Res_Type := Compatible_Types_Intersect_Single_List - (Atype, Prev_Res_Type); - - if Res_Type = Null_Iir then - -- No matching type. This is an error. - Error_Not_Match (Expr, Atype); - Set_Type (Expr, Error_Type); - elsif Is_Defined_Type (Res_Type) then - -- Known and defined matching type. - if Res_Type /= Prev_Res_Type then - -- Need to refine analysis. - Res := Sem_Expression_Ov (Expr, Res_Type); - end if; - else - -- Matching but not defined type (overload). - Set_Type (Expr, Res_Type); - end if; - if Is_Overload_List (Prev_Res_Type) then - Free_Overload_List (Prev_Res_Type); - end if; - return Res; - else - pragma Assert (Atype = Null_Iir); - return Sem_Expression_Ov (Expr, Atype); - end if; - end; - end if; - end case; - end Sem_Expression_Wildcard; - - procedure Merge_Wildcard_Type (Expr : Iir; Atype : in out Iir) - is - Result_Type : Iir; - Expr_Type : Iir; - begin - if Is_Error (Expr) then - return; - end if; - - -- Use the base type; EXPR may define its own subtype (like in - -- qualified expression with forwarding) which must not be referenced - -- above it. In any case, that also makes sense: we need to deal with - -- types, not with subtypes. - Expr_Type := Get_Base_Type (Get_Type (Expr)); - - pragma Assert (Expr_Type /= Null_Iir); - Result_Type := Compatible_Types_Intersect (Atype, Expr_Type); - if Atype /= Null_Iir and then Is_Overload_List (Atype) then - Free_Overload_List (Atype); - end if; - if Result_Type /= Null_Iir then - if Is_Defined_Type (Atype) then - -- If ATYPE was already defined, keep it. So that subtypes - -- are kept (this is needed for aggregates and always helpful). - null; - else - Atype := Result_Type; - end if; - else - Atype := Result_Type; - end if; - end Merge_Wildcard_Type; - - -- If A_TYPE is not null, then EXPR must be of type A_TYPE. - -- Return null in case of error. - function Sem_Expression (Expr: Iir; A_Type: Iir) return Iir - is - A_Type1: Iir; - Res: Iir; - Expr_Type : Iir; - begin - if Check_Is_Expression (Expr, Expr) = Null_Iir then - return Null_Iir; - end if; - - -- Can't try to run sem_expression_ov when a node was already analyzed - Expr_Type := Get_Type (Expr); - if Expr_Type /= Null_Iir and then not Is_Overload_List (Expr_Type) then - -- Checks types. - -- This is necessary when the first call to sem_expression was done - -- with A_TYPE set to NULL_IIR and results in setting the type of - -- EXPR. - if A_Type /= Null_Iir - and then Are_Types_Compatible (Expr_Type, A_Type) = Not_Compatible - then - Error_Not_Match (Expr, A_Type); - return Null_Iir; - end if; - return Expr; - end if; - - -- A_TYPE must be a type definition and not a subtype. - if A_Type /= Null_Iir then - A_Type1 := Get_Base_Type (A_Type); - else - A_Type1 := Null_Iir; - end if; - - case Get_Kind (Expr) is - when Iir_Kind_Aggregate => - Res := Sem_Aggregate (Expr, A_Type, False); - when Iir_Kind_String_Literal8 => - if A_Type = Null_Iir then - Res := Sem_Expression_Ov (Expr, Null_Iir); - else - if not Is_String_Literal_Type (A_Type, Expr) then - Error_Not_Match (Expr, A_Type); - return Null_Iir; - end if; - Set_Type (Expr, A_Type); - Sem_String_Literal (Expr); - return Expr; - end if; - when others => - Res := Sem_Expression_Ov (Expr, A_Type1); - end case; - - if Res /= Null_Iir and then Is_Overloaded (Res) then - -- FIXME: clarify between overload and not determinable from the - -- context. - Error_Overload (Expr); - if Get_Type (Res) /= Null_Iir then - Disp_Overload_List (Get_Overload_List (Get_Type (Res)), Expr); - end if; - return Null_Iir; - end if; - return Res; - end Sem_Expression; - - function Sem_Composite_Expression (Expr : Iir) return Iir - is - Res : Iir; - begin - Res := Sem_Expression_Ov (Expr, Null_Iir); - if Res = Null_Iir or else Get_Type (Res) = Null_Iir then - return Res; - elsif Is_Overload_List (Get_Type (Res)) then - declare - List : constant Iir_List := Get_Overload_List (Get_Type (Res)); - It : List_Iterator; - Res_Type : Iir; - Atype : Iir; - begin - Res_Type := Null_Iir; - It := List_Iterate (List); - while Is_Valid (It) loop - Atype := Get_Element (It); - if Is_Aggregate_Type (Atype) then - Add_Result (Res_Type, Atype); - end if; - Next (It); - end loop; - - if Res_Type = Null_Iir then - Error_Overload (Expr); - return Null_Iir; - elsif Is_Overload_List (Res_Type) then - Error_Overload (Expr); - Disp_Overload_List (Get_Overload_List (Res_Type), Expr); - Free_Overload_List (Res_Type); - return Null_Iir; - else - return Sem_Expression_Ov (Expr, Res_Type); - end if; - end; - else - -- Either an error (already handled) or not overloaded. Type - -- matching will be done later (when the target is analyzed). - return Res; - end if; - end Sem_Composite_Expression; - - -- EXPR must be an expression with type is an overload list. - -- Extract and finish the analysis of the expression that is of universal - -- type, if there is one and if all types are either integer types or - -- floating point types. - -- This is used to get rid of implicit conversions. - function Sem_Favour_Universal_Type (Expr : Iir) return Iir - is - Expr_Type : constant Iir := Get_Type (Expr); - Type_List : constant Iir_List := Get_Overload_List (Expr_Type); - -- Extract kind (from the first element). - First_El : constant Iir := Get_First_Element (Type_List); - Kind : constant Iir_Kind := Get_Kind (Get_Base_Type (First_El)); - Res : Iir; - El : Iir; - - It : List_Iterator; - begin - Res := Null_Iir; - - It := List_Iterate (Type_List); - while Is_Valid (It) loop - El := Get_Element (It); - if Get_Kind (Get_Base_Type (El)) /= Kind then - -- Must be of the same kind. - Res := Null_Iir; - exit; - end if; - if El = Universal_Integer_Type_Definition - or El = Convertible_Integer_Type_Definition - or El = Universal_Real_Type_Definition - or El = Convertible_Real_Type_Definition - then - if Res = Null_Iir then - Res := El; - else - Res := Null_Iir; - exit; - end if; - end if; - Next (It); - end loop; - - if Res = Null_Iir then - Error_Overload (Expr); - Disp_Overload_List (Type_List, Expr); - return Null_Iir; - end if; - - return Sem_Expression_Ov (Expr, Res); - end Sem_Favour_Universal_Type; - - function Sem_Expression_Universal (Expr : Iir) return Iir - is - Expr1 : Iir; - Expr_Type : Iir; - begin - Expr1 := Sem_Expression_Wildcard (Expr, Wildcard_Any_Type); - Expr_Type := Get_Type (Expr1); - if Is_Error (Expr_Type) then - return Null_Iir; - end if; - if not Is_Overload_List (Expr_Type) then - return Expr1; - else - return Sem_Favour_Universal_Type (Expr1); - end if; - end Sem_Expression_Universal; - - function Sem_Case_Expression (Expr : Iir) return Iir - is - Expr1 : Iir; - Expr_Type : Iir; - El : Iir; - Res : Iir; - List : Iir_List; - It : List_Iterator; - begin - Expr1 := Sem_Expression_Ov (Expr, Null_Iir); - if Expr1 = Null_Iir then - return Null_Iir; - end if; - Expr_Type := Get_Type (Expr1); - if Expr_Type = Null_Iir then - -- Possible only if the type cannot be determined without the - -- context (aggregate or string literal). - Error_Msg_Sem - (+Expr, "cannot determine the type of choice expression"); - if Get_Kind (Expr1) = Iir_Kind_Aggregate then - Error_Msg_Sem - (+Expr, "(use a qualified expression of the form T'(xxx).)"); - end if; - return Null_Iir; - end if; - if not Is_Overload_List (Expr_Type) then - return Expr1; - end if; - - -- In case of overload, try to find one match. - -- FIXME: match only character types. - - -- LRM93 8.8 Case statement - -- This type must be determinable independently of the context in which - -- the expression occurs, but using the fact that the expression must be - -- of a discrete type or a one-dimensional character array type. - List := Get_Overload_List (Expr_Type); - Res := Null_Iir; - It := List_Iterate (List); - while Is_Valid (It) loop - El := Get_Element (It); - if Get_Kind (El) in Iir_Kinds_Discrete_Type_Definition - or else Is_One_Dimensional_Array_Type (El) - then - if Res = Null_Iir then - Res := El; - else - Error_Overload (Expr1); - Disp_Overload_List (List, Expr1); - return Null_Iir; - end if; - end if; - Next (It); - end loop; - if Res = Null_Iir then - Error_Overload (Expr1); - Disp_Overload_List (List, Expr1); - return Null_Iir; - end if; - return Sem_Expression_Ov (Expr1, Get_Base_Type (Res)); - end Sem_Case_Expression; - - function Insert_Condition_Operator (Cond : Iir) return Iir - is - Op : Iir; - Res : Iir; - begin - Op := Create_Iir (Iir_Kind_Implicit_Condition_Operator); - Location_Copy (Op, Cond); - Set_Operand (Op, Cond); - - Res := Sem_Operator (Op, Boolean_Type_Definition, 1); - Check_Read (Res); - return Res; - end Insert_Condition_Operator; - - function Sem_Condition (Cond : Iir) return Iir - is - Res : Iir; - begin - -- This function fully analyze COND, so it supposes COND is not yet - -- analyzed. - pragma Assert (Is_Expr_Not_Analyzed (Cond)); - - if Vhdl_Std < Vhdl_08 then - Res := Sem_Expression (Cond, Boolean_Type_Definition); - - Check_Read (Res); - return Res; - else - -- LRM08 9.2.9 - -- If, without overload resolution (see 12.5), the expression is - -- of type BOOLEAN defined in package STANDARD, or if, assuming a - -- rule requiring the expression to be of type BOOLEAN defined in - -- package STANDARD, overload resolution can determine at least one - -- interpretation of each constituent of the innermost complete - -- context including the expression, then the condition operator is - -- not applied. - - Res := Sem_Expression_Ov (Cond, Null_Iir); - - if Res = Null_Iir then - -- Error occurred. - return Res; - end if; - - if not Is_Overloaded (Res) then - -- Only one result. Operator "??" is not applied if the result - -- is of type boolean. - if Are_Types_Compatible (Get_Type (Res), Boolean_Type_Definition) - /= Not_Compatible - then - Check_Read (Res); - return Res; - end if; - elsif Get_Type (Res) /= Null_Iir then - -- Many interpretations. - declare - Res_List : constant Iir_List := - Get_Overload_List (Get_Type (Res)); - It : List_Iterator; - El : Iir; - Nbr_Booleans : Natural; - begin - Nbr_Booleans := 0; - - -- Extract boolean interpretations. - It := List_Iterate (Res_List); - while Is_Valid (It) loop - El := Get_Element (It); - if Are_Types_Compatible (El, Boolean_Type_Definition) - /= Not_Compatible - then - Nbr_Booleans := Nbr_Booleans + 1; - end if; - Next (It); - end loop; - - if Nbr_Booleans >= 1 then - -- There is one or more boolean interpretations: keep them. - -- In case of multiple boolean interpretations, an error - -- message will be generated. - Res := Sem_Expression_Ov (Cond, Boolean_Type_Definition); - Check_Read (Res); - return Res; - end if; - end; - end if; - - -- LRM08 9.2.9 - -- Otherwise, the condition operator is implicitely applied, and the - -- type of the expresion with the implicit application shall be - -- BOOLEAN defined in package STANDARD. - - return Insert_Condition_Operator (Res); - end if; - end Sem_Condition; - -end Sem_Expr; diff --git a/src/vhdl/sem_expr.ads b/src/vhdl/sem_expr.ads deleted file mode 100644 index 1e6ada5ba..000000000 --- a/src/vhdl/sem_expr.ads +++ /dev/null @@ -1,270 +0,0 @@ --- Semantic analysis. --- 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 Ada.Unchecked_Deallocation; -with Types; use Types; -with Iirs; use Iirs; - -package Sem_Expr is - -- Set semantic to EXPR. - -- Replace simple_name with the referenced node, - -- Set type to nodes, - -- Resolve overloading - - Deferred_Constant_Allowed : Boolean := False; - - -- Analyze an expression (other than a range) with a possible overloading. - -- Sem_expression_ov (and therefore sem_expression) must be called *once* - -- for each expression node with A_TYPE1 not null and at most *once* with - -- A_TYPE1 null. - -- - -- When A_TYPE1 is null, sem_expression_ov find all possible types - -- of the expression. If there is only one possible type (ie, overloading - -- is non-existant or solved), then the type of the expression is set, - -- and the node is completly analyzed. Sem_expression_ov must not - -- be called for such a node. - -- If there is several possible types (ie overloaded), then the type is - -- set with a list of overload. To finishes the semantisation, - -- sem_expression_ov must be called again with A_TYPE1 set to the - -- expected type. - -- - -- If A_TYPE1 is set, sem_expression_ov must finishes the analyze of the - -- expression, and set its type, which is not necessary a base type. - -- A_TYPE1 must be a base type. - -- - -- In case of error, it displays a message and return null_iir. - -- In case of success, it returns the analyzed expression, which can - -- be different from EXPR (eg, a character literal is transformed into an - -- enumeration literal). - function Sem_Expression_Ov (Expr: Iir; A_Type1: Iir) return Iir; - - -- If A_TYPE is not null, then EXPR must be of type A_TYPE. - -- Return null in case of error. - function Sem_Expression (Expr: Iir; A_Type: Iir) return Iir; - - -- Same as Sem_Expression, but also implicitly choose an universal type - -- if overloaded. - function Sem_Expression_Universal (Expr : Iir) return Iir; - - -- Same as Sem_Expression but specialized for a case expression. - -- (Handle specific overloading rules). - function Sem_Case_Expression (Expr : Iir) return Iir; - - -- Sem COND as a condition. COND must have not been analyzed. - -- In VHDL08, this follows 9.2.9 Condition operator. - -- In VHDL87 and 93, type of COND must be a boolean. - -- A check is made that COND can be read. - function Sem_Condition (Cond : Iir) return Iir; - - -- Insert a call to condition operator. - function Insert_Condition_Operator (Cond : Iir) return Iir; - - -- Same as Sem_Expression but knowing that the type of EXPR must be a - -- composite type. Used for expressions in assignment statement when the - -- target is an aggregate. - function Sem_Composite_Expression (Expr : Iir) return Iir; - - -- Return True iif INTER is allowed to be read. Follow rules of - -- LRM08 6.5.2 Interface object declarations. - function Can_Interface_Be_Read (Inter : Iir) return Boolean; - - -- Return True iif INTER is allowed to be updated. Follow rules of - -- LRM08 6.5.2 Interface object declarations. - function Can_Interface_Be_Updated (Inter : Iir) return Boolean; - - -- Check EXPR can be read. - procedure Check_Read (Expr : Iir); - - -- Check EXPR can be updated. - procedure Check_Update (Expr : Iir); - - -- For a procedure call, A_TYPE must be null. - function Sem_Subprogram_Call (Expr: Iir; A_Type: Iir) return Iir; - - -- If EXPR is a node for an expression, then return EXPR. - -- Otherwise, emit an error message using LOC as location - -- and return NULL_IIR. - -- If EXPR is NULL_IIR, NULL_IIR is silently returned. - function Check_Is_Expression (Expr : Iir; Loc : Iir) return Iir; - - -- Analyze a procedure_call or a concurrent_procedure_call_statement. - -- A procedure call is not an expression but because most of the code - -- for procedure call is common with function call, procedure calls are - -- handled in this package. - procedure Sem_Procedure_Call (Call : Iir_Procedure_Call; Stmt : Iir); - - -- Analyze a range (ie a range attribute or a range expression). If - -- ANY_DIR is true, the range can't be a null range (slice vs subtype, - -- used in static evaluation). A_TYPE may be Null_Iir. - -- Return Null_Iir in case of error, or EXPR analyzed (and evaluated if - -- possible). - function Sem_Range_Expression (Expr: Iir; A_Type: Iir; Any_Dir : Boolean) - return Iir; - - -- Analyze a discrete range. If ANY_DIR is true, the range can't be a - -- null range (slice vs subtype -- used in static evaluation). A_TYPE may - -- be Null_Iir. Return Null_Iir in case of error. - function Sem_Discrete_Range_Expression - (Expr: Iir; A_Type: Iir; Any_Dir: Boolean) return Iir; - - -- Analyze a discrete range and convert to integer if both bounds are - -- universal integer types, according to rules of LRM 3.2.1.1 - function Sem_Discrete_Range_Integer (Expr: Iir) return Iir; - - -- Transform LIT into a physical_literal. - -- LIT can be either a not analyzed physical literal or - -- a simple name that is a physical unit. In the later case, a physical - -- literal is created. - function Sem_Physical_Literal (Lit: Iir) return Iir; - - type Annex_Array is array (Natural range <>) of Int32; - type Annex_Array_Acc is access Annex_Array; - procedure Free_Annex_Array is new Ada.Unchecked_Deallocation - (Annex_Array, Annex_Array_Acc); - - -- Various info and sorted array for choices. - type Choice_Info_Type is record - -- Number of choices by expression or by range. - Nbr_Choices : Natural; - - -- Number of alternatives - Nbr_Alternatives : Natural; - - -- Set to the others choice is present. - Others_Choice : Iir; - - -- Array of sorted choices. - Arr : Iir_Array_Acc; - - -- Allocated and deallocated by the user. If not null, it will be - -- reordered when ARR is sorted. - Annex_Arr : Annex_Array_Acc; - end record; - - -- Compute the number of locally static choices (excluding others) and - -- set Has_Others. - procedure Count_Choices (Info : out Choice_Info_Type; Choice_Chain : Iir); - - -- Allocate and fill INFO.ARR. - procedure Fill_Choices_Array (Info : in out Choice_Info_Type; - Choice_Chain : Iir); - - -- Sort INFO.ARR. Only for one-dimensional strings. - procedure Sort_String_Choices (Info : in out Choice_Info_Type); - - -- Likewise for discrete choices. - procedure Sort_Discrete_Choices (Info : in out Choice_Info_Type); - - -- CHOICES_CHAIN is a chain of choices (none, expression, range or - -- others). It is an in-out as it may be mutated (from expression to - -- range). - -- If IS_SUB_RANGE is true, then SUB_TYPE may not be fully convered, - -- otherwise, SUB_TYPE must be fully covered. - -- This is used when the subtype of an aggregate must be determined. - -- SUB_TYPE is the discrete subtype. - -- Emit a message if: - -- * the SUB_TYPE is not fully covered by the choices - -- * the choices are not mutually exclusif (an element is present twice) - -- * OTHERS is not the last choice, or is present several times. - -- - -- If there is at least one named choice, LOW and HIGH are set with the - -- lowest and highest index. - -- If LOW and HIGH are set, they are locally static. - -- - -- Unidimensional strings are not handled here but by - -- sem_string_choices_range. - -- - -- TODO: - -- * be smarter if only positional choices (do not create the list). - -- * smarter messages. - procedure Sem_Choices_Range (Choice_Chain : in out Iir; - Choice_Type : Iir; - Low : out Iir; - High : out Iir; - Loc : Location_Type; - Is_Sub_Range : Boolean; - Is_Case_Stmt : Boolean); - - -- Check that the values of CHOICE_CHAIN are a continuous range, and - -- extract the lower LOW and upper HIGH bound (useful to create the - -- corresponding subtype). The values must be of type SUB_TYPE, and if - -- IS_SUB_RANGE True, they must be within SUB_TYPE. - -- The choices must be locally static. - -- If REORDER_CHOICES is true, CHOICE_CHAIN is ordered. - procedure Sem_Check_Continuous_Choices (Choice_Chain : Iir; - Choice_Type : Iir; - Low : out Iir; - High : out Iir; - Loc : Location_Type; - Is_Sub_Range : Boolean); - - -- Analyze CHOICE_LIST when the choice expression SEL is of a - -- one-dimensional character array type. - procedure Sem_String_Choices_Range (Choice_Chain : Iir; Sel : Iir); - - type Compatibility_Level is - (Not_Compatible, Via_Conversion, Fully_Compatible); - - -- LEFT are RIGHT must be really a type (not a subtype). - function Are_Basetypes_Compatible (Left: Iir; Right: Iir) - return Compatibility_Level; - - -- Return TRUE iif types of LEFT and RIGHT are compatible. - function Are_Nodes_Compatible (Left: Iir; Right: Iir) - return Compatibility_Level; - - -- Return TRUE iff the type of EXPR is compatible with A_TYPE - function Is_Expr_Compatible (A_Type : Iir; Expr : Iir) - return Compatibility_Level; - - -- LIST1, LIST2 are either a type node or an overload list of types. - -- Return THE type which is compatible with LIST1 are LIST2. - -- Return null_iir if there is no such type or if there are several types. - function Search_Compatible_Type (List1, List2 : Iir) return Iir; - - -- Return the intersection of LIST1 and LIST2. - -- This function accept wildcard types. - function Compatible_Types_Intersect (List1, List2 : Iir) return Iir; - - -- Return True if an expression is not analyzed (its type is not set). - -- All expressions from the parser are not analyzed. - function Is_Expr_Not_Analyzed (Expr : Iir) return Boolean; - pragma Inline (Is_Expr_Not_Analyzed); - - -- Return True if an expression is fully analyzed: its type is set to - -- either a type definition, or to an error type. - -- Some expressions can be partially analyzed: either set to an overload - -- list or to a wildcard type. - function Is_Expr_Fully_Analyzed (Expr : Iir) return Boolean; - pragma Inline (Is_Expr_Fully_Analyzed); - - -- Analyze EXPR using ATYPE. - -- If EXPR is not analyzed, EXPR is analyzed using type constraints from - -- ATYPE. - -- If ATYPE is a defined type (neither an overload list nor a wildcard - -- type), EXPR will be fully analyzed (possibly with an error). - -- If EXPR is partially or fully analyzed, ATYPE must not be null_iir and - -- it is checked with the types of EXPR. EXPR may become fully analyzed. - function Sem_Expression_Wildcard - (Expr : Iir; Atype : Iir; Force_Constrained : Boolean := False) - return Iir; - - -- To be used after Sem_Expression_Wildcard to update list ATYPE of - -- possible types. - procedure Merge_Wildcard_Type (Expr : Iir; Atype : in out Iir); -end Sem_Expr; diff --git a/src/vhdl/sem_inst.adb b/src/vhdl/sem_inst.adb deleted file mode 100644 index 54f37a2f6..000000000 --- a/src/vhdl/sem_inst.adb +++ /dev/null @@ -1,1217 +0,0 @@ --- Package (and subprograms) instantiations - --- When a package is instantiated, we need to 'duplicate' its declaration. --- This looks useless for analysis but it isn't: a type from a package --- instantiated twice declares two different types. Without duplication, we --- need to attach to each declaration its instance, which looks more expansive --- that duplicating the declaration. --- --- Furthermore, for generic type interface, it looks a good idea to duplicate --- the body (macro expansion). --- --- Duplicating is not trivial: internal links must be kept and external --- links preserved. A table is used to map nodes from the uninstantiated --- package to its duplicated node. Links from instantiated declaration to --- the original declaration are also stored in that table. - -with Tables; -with Nodes; -with Nodes_Meta; -with Types; use Types; -with Files_Map; -with Iirs_Utils; use Iirs_Utils; -with Errorout; use Errorout; -with Sem_Utils; - -package body Sem_Inst is - -- Table of origin. This is an extension of vhdl nodes to track the - -- origin of a node. If a node has a non-null origin, then the node was - -- instantiated for the origin node. - -- - -- Furthermore, during instantiation, we need to keep track of instantiated - -- nodes (ie nodes created by instantiation) used by references. As an - -- instance cannot be uninstantiated, there is no collisions, as soon as - -- such entries are cleaned after instantiation. - -- - -- As an example, here are declarations of an uninstantiated package: - -- type Nat is range 0 to 1023; - -- constant N : Nat := 5; - -- A node Nat1 will be created from node Nat (an integer type definition). - -- The origin of Nat1 is Nat and this is true forever. During - -- instantiation, the instance of Nat is Nat1, so that the type of N will - -- be set to Nat1. - package Origin_Table is new Tables - (Table_Component_Type => Iir, - Table_Index_Type => Iir, - Table_Low_Bound => 2, - Table_Initial => 1024); - - procedure Expand_Origin_Table - is - use Nodes; - Last : constant Iir := Iirs.Get_Last_Node; - El : constant Iir := Origin_Table.Last; - begin - if El < Last then - Origin_Table.Set_Last (Last); - Origin_Table.Table (El + 1 .. Last) := (others => Null_Iir); - end if; - end Expand_Origin_Table; - - -- This is the public function; the table may not have been extended. - function Get_Origin (N : Iir) return Iir - is - -- Make the '<=' operator visible. - use Nodes; - begin - if N <= Origin_Table.Last then - return Origin_Table.Table (N); - else - return Null_Iir; - end if; - end Get_Origin; - - -- This is the private function: the table *must* have been extended. - function Get_Instance (N : Iir) return Iir - is - -- Make '<=' operator visible for the assert. - use Nodes; - begin - pragma Assert (N <= Origin_Table.Last); - return Origin_Table.Table (N); - end Get_Instance; - - procedure Set_Origin (N : Iir; Orig : Iir) is - begin - -- As nodes are created, we need to expand origin table. - Expand_Origin_Table; - - pragma Assert (Orig = Null_Iir - or else Origin_Table.Table (N) = Null_Iir); - Origin_Table.Table (N) := Orig; - end Set_Origin; - - type Instance_Entry_Type is record - -- Node - N : Iir; - - -- Old value in Origin_Table. - Old_Origin : Iir; - end record; - - type Instance_Index_Type is new Natural; - - -- Table of previous values in Origin_Table. The first purpose of this - -- table is to be able to revert the calls to Set_Instance, so that a unit - -- can be instantiated several times. Keeping the nodes that have been - -- instantiated is cheaper than walking the tree a second time. - -- The second purpose of this table is to be able to have uninstantiated - -- packages in instantiated packages. In that case, the slot in - -- Origin_Table cannot be the origin and the instance at the same time and - -- has to be saved. - package Prev_Instance_Table is new Tables - (Table_Component_Type => Instance_Entry_Type, - Table_Index_Type => Instance_Index_Type, - Table_Low_Bound => 1, - Table_Initial => 256); - - -- The instance of ORIG is now N. So during instantiation, a reference - -- to ORIG will be replaced by a reference to N. The previous instance - -- of ORIG is saved. - procedure Set_Instance (Orig : Iir; N : Iir) - is - use Nodes; - begin - pragma Assert (Orig <= Origin_Table.Last); - - -- Save the old entry - Prev_Instance_Table.Append - (Instance_Entry_Type'(N => Orig, - Old_Origin => Origin_Table.Table (Orig))); - - -- Set the entry. - Origin_Table.Table (Orig) := N; - end Set_Instance; - - procedure Restore_Origin (Mark : Instance_Index_Type) is - begin - for I in reverse Mark + 1 .. Prev_Instance_Table.Last loop - declare - El : Instance_Entry_Type renames Prev_Instance_Table.Table (I); - begin - Origin_Table.Table (El.N) := El.Old_Origin; - end; - end loop; - Prev_Instance_Table.Set_Last (Mark); - end Restore_Origin; - - -- The virtual file for the instance. - Instance_File : Source_File_Entry; - - -- True if currently instantiated a shared generic. - Is_Within_Shared_Instance : Boolean := False; - - -- Get the new location. - function Relocate (Loc : Location_Type) return Location_Type is - begin - if Instance_File /= No_Source_File_Entry then - -- For Instantiate. - return Files_Map.Instance_Relocate (Instance_File, Loc); - else - -- For Copy_Tree. - return Loc; - end if; - end Relocate; - - procedure Create_Relocation (Inst : Iir; Orig : Iir) - is - use Files_Map; - Orig_File : Source_File_Entry; - Pos : Source_Ptr; - begin - Location_To_File_Pos (Get_Location (Orig), Orig_File, Pos); - Instance_File := Create_Instance_Source_File - (Orig_File, Get_Location (Inst), Inst); - end Create_Relocation; - - function Instantiate_Iir (N : Iir; Is_Ref : Boolean) return Iir; - - -- Instantiate a list. Simply create a new list and instantiate nodes of - -- that list. - function Instantiate_Iir_List (L : Iir_List; Is_Ref : Boolean) - return Iir_List - is - Res : Iir_List; - It : List_Iterator; - El : Iir; - begin - case L is - when Null_Iir_List - | Iir_List_All => - return L; - when others => - Res := Create_Iir_List; - It := List_Iterate (L); - while Is_Valid (It) loop - El := Get_Element (It); - Append_Element (Res, Instantiate_Iir (El, Is_Ref)); - Next (It); - end loop; - return Res; - end case; - end Instantiate_Iir_List; - - function Instantiate_Iir_Flist (L : Iir_Flist; Is_Ref : Boolean) - return Iir_Flist - is - Res : Iir_Flist; - El : Iir; - begin - case L is - when Null_Iir_Flist - | Iir_Flist_All - | Iir_Flist_Others => - return L; - when others => - Res := Create_Iir_Flist (Get_Nbr_Elements (L)); - for I in Flist_First .. Flist_Last (L) loop - El := Get_Nth_Element (L, I); - Set_Nth_Element (Res, I, Instantiate_Iir (El, Is_Ref)); - end loop; - return Res; - end case; - end Instantiate_Iir_Flist; - - -- Instantiate a chain. This is a special case to reduce stack depth. - function Instantiate_Iir_Chain (N : Iir) return Iir - is - First : Iir; - Last : Iir; - Next_N : Iir; - Next_R : Iir; - begin - if N = Null_Iir then - return Null_Iir; - end if; - - First := Instantiate_Iir (N, False); - Last := First; - Next_N := Get_Chain (N); - while Next_N /= Null_Iir loop - Next_R := Instantiate_Iir (Next_N, False); - Set_Chain (Last, Next_R); - Last := Next_R; - Next_N := Get_Chain (Next_N); - end loop; - - return First; - end Instantiate_Iir_Chain; - - procedure Instantiate_Iir_Field - (Res : Iir; N : Iir; F : Nodes_Meta.Fields_Enum) - is - use Nodes_Meta; - begin - case Get_Field_Type (F) is - when Type_Iir => - declare - S : constant Iir := Get_Iir (N, F); - R : Iir; - begin - case Get_Field_Attribute (F) is - when Attr_None => - R := Instantiate_Iir (S, False); - when Attr_Ref => - R := Instantiate_Iir (S, True); - when Attr_Maybe_Ref => - R := Instantiate_Iir (S, Get_Is_Ref (N)); - when Attr_Forward_Ref => - -- Must be explicitely handled in Instantiate_Iir, as it - -- requires special handling. - raise Internal_Error; - when Attr_Maybe_Forward_Ref => - if Get_Is_Forward_Ref (N) then - -- Likewise: must be explicitely handled. - raise Internal_Error; - else - R := Instantiate_Iir (S, True); - end if; - when Attr_Chain => - R := Instantiate_Iir_Chain (S); - when Attr_Chain_Next => - R := Null_Iir; - when Attr_Of_Ref | Attr_Of_Maybe_Ref => - -- Can only appear in list. - raise Internal_Error; - end case; - Set_Iir (Res, F, R); - end; - when Type_Iir_List => - declare - S : constant Iir_List := Get_Iir_List (N, F); - R : Iir_List; - Ref : Boolean; - begin - case Get_Field_Attribute (F) is - when Attr_None => - Ref := False; - when Attr_Of_Ref => - Ref := True; - when Attr_Of_Maybe_Ref => - Ref := Get_Is_Ref (N); - when others => - -- Ref is specially handled in Instantiate_Iir. - -- Others cannot appear for lists. - raise Internal_Error; - end case; - R := Instantiate_Iir_List (S, Ref); - Set_Iir_List (Res, F, R); - end; - when Type_Iir_Flist => - declare - S : constant Iir_Flist := Get_Iir_Flist (N, F); - R : Iir_Flist; - Ref : Boolean; - begin - case Get_Field_Attribute (F) is - when Attr_None => - Ref := False; - when Attr_Of_Ref => - Ref := True; - when Attr_Of_Maybe_Ref => - Ref := Get_Is_Ref (N); - when others => - -- Ref is specially handled in Instantiate_Iir. - -- Others cannot appear for lists. - raise Internal_Error; - end case; - R := Instantiate_Iir_Flist (S, Ref); - Set_Iir_Flist (Res, F, R); - end; - when Type_PSL_NFA - | Type_PSL_Node => - -- TODO - raise Internal_Error; - when Type_String8_Id => - Set_String8_Id (Res, F, Get_String8_Id (N, F)); - when Type_Source_Ptr => - Set_Source_Ptr (Res, F, Get_Source_Ptr (N, F)); - when Type_Source_File_Entry => - Set_Source_File_Entry (Res, F, Get_Source_File_Entry (N, F)); - when Type_Date_Type - | Type_Date_State_Type - | Type_Time_Stamp_Id - | Type_File_Checksum_Id => - -- Can this happen ? - raise Internal_Error; - when Type_Number_Base_Type => - Set_Number_Base_Type (Res, F, Get_Number_Base_Type (N, F)); - when Type_Iir_Constraint => - Set_Iir_Constraint (Res, F, Get_Iir_Constraint (N, F)); - when Type_Iir_Mode => - Set_Iir_Mode (Res, F, Get_Iir_Mode (N, F)); - when Type_Iir_Index32 => - Set_Iir_Index32 (Res, F, Get_Iir_Index32 (N, F)); - when Type_Iir_Int64 => - Set_Iir_Int64 (Res, F, Get_Iir_Int64 (N, F)); - when Type_Boolean => - Set_Boolean (Res, F, Get_Boolean (N, F)); - when Type_Iir_Staticness => - Set_Iir_Staticness (Res, F, Get_Iir_Staticness (N, F)); - when Type_Iir_All_Sensitized => - Set_Iir_All_Sensitized (Res, F, Get_Iir_All_Sensitized (N, F)); - when Type_Iir_Signal_Kind => - Set_Iir_Signal_Kind (Res, F, Get_Iir_Signal_Kind (N, F)); - when Type_Tri_State_Type => - Set_Tri_State_Type (Res, F, Get_Tri_State_Type (N, F)); - when Type_Iir_Pure_State => - Set_Iir_Pure_State (Res, F, Get_Iir_Pure_State (N, F)); - when Type_Iir_Delay_Mechanism => - Set_Iir_Delay_Mechanism (Res, F, Get_Iir_Delay_Mechanism (N, F)); - when Type_Iir_Predefined_Functions => - Set_Iir_Predefined_Functions - (Res, F, Get_Iir_Predefined_Functions (N, F)); - when Type_Iir_Direction => - Set_Iir_Direction (Res, F, Get_Iir_Direction (N, F)); - when Type_Iir_Int32 => - Set_Iir_Int32 (Res, F, Get_Iir_Int32 (N, F)); - when Type_Int32 => - Set_Int32 (Res, F, Get_Int32 (N, F)); - when Type_Iir_Fp64 => - Set_Iir_Fp64 (Res, F, Get_Iir_Fp64 (N, F)); - when Type_Token_Type => - Set_Token_Type (Res, F, Get_Token_Type (N, F)); - when Type_Name_Id => - Set_Name_Id (Res, F, Get_Name_Id (N, F)); - end case; - end Instantiate_Iir_Field; - - function Instantiate_Iir (N : Iir; Is_Ref : Boolean) return Iir - is - Res : Iir; - begin - -- Nothing to do for null node. - if N = Null_Iir then - return Null_Iir; - end if; - - -- For a reference, do not create a new node. - if Is_Ref then - Res := Get_Instance (N); - if Res /= Null_Iir then - -- There is an instance for N. - return Res; - else - -- Reference outside the instance. - return N; - end if; - end if; - - declare - use Nodes_Meta; - Kind : constant Iir_Kind := Get_Kind (N); - Fields : constant Fields_Array := Get_Fields (Kind); - F : Fields_Enum; - begin - -- In general, Get_Instance (N) is Null_Iir. There are two - -- exceptions: - -- - N is also an instance (instance within an uninstantiated - -- package). As instances and origin share the same table, - -- Get_Instance returns the origin. During instantiation, the old - -- value of Origin is saved so this case is correctly handled. - -- - N is shared, so it was already instantiated. This happends only - -- for interface_constant of implicit operators. In that case, - -- multiple instances are created for the same node, which is not - -- ideal. That's still ok (if no infos are attached to the - -- interface) and is the price to pay for this optimization. - - -- Create a new node. - Res := Create_Iir (Kind); - - -- The origin of this new node is N. - Set_Origin (Res, N); - - -- And the instance of N is RES. - Set_Instance (N, Res); - - Set_Location (Res, Relocate (Get_Location (N))); - - for I in Fields'Range loop - F := Fields (I); - - -- Fields that are handled specially. - case F is - when Field_Index_Subtype_List => - -- Index_Subtype_List is always a reference, so retrieve - -- the instance of the referenced list. This is a special - -- case because there is no origins for list. - declare - List : Iir_Flist; - begin - case Kind is - when Iir_Kind_Array_Type_Definition => - List := Get_Index_Subtype_Definition_List (Res); - when Iir_Kind_Array_Subtype_Definition => - List := Get_Index_Constraint_List (Res); - if List = Null_Iir_Flist then - List := Get_Index_Subtype_List - (Get_Denoted_Type_Mark (Res)); - end if; - when others => - -- All the nodes where Index_Subtype_List appears - -- are handled above. - raise Internal_Error; - end case; - Set_Index_Subtype_List (Res, List); - end; - - when Field_Simple_Aggregate_List => - Set_Simple_Aggregate_List - (Res, Get_Simple_Aggregate_List (N)); - - when Field_Subprogram_Body => - -- This is a forward reference. Not yet solved. - Set_Subprogram_Body (Res, Null_Iir); - - when Field_Subprogram_Specification => - -- Resolve it. - Instantiate_Iir_Field (Res, N, F); - - -- Set body. - pragma Assert (Kind_In (Res, Iir_Kind_Procedure_Body, - Iir_Kind_Function_Body)); - declare - Spec : constant Iir := Get_Subprogram_Specification (Res); - begin - pragma Assert (Get_Subprogram_Body (Spec) = Null_Iir); - Set_Subprogram_Body (Spec, Res); - end; - - when Field_Incomplete_Type_Ref_Chain => - if Get_Kind (Res) = Iir_Kind_Access_Type_Definition then - -- Link - declare - Def : constant Iir := Get_Named_Entity - (Get_Designated_Subtype_Indication (Res)); - begin - if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition - then - Set_Incomplete_Type_Ref_Chain - (Res, Get_Incomplete_Type_Ref_Chain (Def)); - Set_Incomplete_Type_Ref_Chain (Def, Res); - end if; - end; - end if; - - when Field_Designated_Type => - null; - when Field_Designated_Subtype_Indication => - Instantiate_Iir_Field (Res, N, F); - -- The designated type will be patched later if it is an - -- incomplete type definition - Set_Designated_Type - (Res, Get_Type (Get_Designated_Subtype_Indication (Res))); - - when Field_Complete_Type_Definition => - -- Will be set by the declaration of the complete type - null; - when Field_Incomplete_Type_Declaration => - Instantiate_Iir_Field (Res, N, F); - declare - Res_Decl : constant Iir := - Get_Incomplete_Type_Declaration (Res); - N_Decl : constant Iir := - Get_Incomplete_Type_Declaration (N); - Res_Complete : Iir; - N_Def, Res_Def : Iir; - N_El, Next_N_El : Iir; - Res_El, Next_Res_El : Iir; - begin - if Is_Valid (N_Decl) then - -- N/RES completes a type declaration. - N_Def := Get_Type_Definition (N_Decl); - Res_Def := Get_Type_Definition (Res_Decl); - -- Set Complete_Type_Definition - Res_Complete := Get_Type (Res); - Set_Complete_Type_Definition (Res_Def, Res_Complete); - -- Rebuild the list and patch designated types - N_El := N_Def; - Res_El := Res_Def; - loop - Next_N_El := Get_Incomplete_Type_Ref_Chain (N_El); - exit when Is_Null (Next_N_El); - Next_Res_El := Get_Instance (Next_N_El); - Set_Designated_Type (Next_Res_El, Res_Complete); - Set_Incomplete_Type_Ref_Chain (Res_El, Next_Res_El); - N_El := Next_N_El; - end loop; - end if; - end; - - when Field_Deferred_Declaration => - if not Get_Deferred_Declaration_Flag (N) - and then Is_Valid (Get_Deferred_Declaration (N)) - then - -- This is the completion. - declare - Incomplete_Decl_N : constant Iir := - Get_Deferred_Declaration (N); - Incomplete_Decl_Res : constant Iir := - Get_Instance (Incomplete_Decl_N); - begin - pragma Assert (Is_Valid (Incomplete_Decl_Res)); - Set_Deferred_Declaration (Res, Incomplete_Decl_Res); - Set_Deferred_Declaration (Incomplete_Decl_Res, Res); - end; - end if; - - when Field_Protected_Type_Body => - null; - when Field_Protected_Type_Declaration => - Instantiate_Iir_Field (Res, N, F); - Set_Protected_Type_Body - (Get_Protected_Type_Declaration (Res), Res); - - when Field_Package_Body => - null; - when Field_Package => - Instantiate_Iir_Field (Res, N, F); - declare - Pkg : constant Iir := Get_Package (Res); - begin - -- The current node can be the body of a package; in that - -- case set the forward link. - -- Or it can be the body of an instantiated package; in - -- that case there is no forward link. - if Get_Kind (Pkg) = Iir_Kind_Package_Declaration then - Set_Package_Body (Get_Package (Res), Res); - end if; - end; - - when Field_Instance_Package_Body => - -- Do not instantiate the body of a package while - -- instantiating a shared package. - if not Is_Within_Shared_Instance then - Instantiate_Iir_Field (Res, N, F); - end if; - - when Field_Subtype_Definition => - -- TODO - null; - - when Field_Instance_Source_File => - Set_Instance_Source_File - (Res, Files_Map.Create_Instance_Source_File - (Get_Instance_Source_File (N), - Get_Location (Res), Res)); - - when Field_Generic_Chain - | Field_Declaration_Chain => - if Kind = Iir_Kind_Package_Instantiation_Declaration then - declare - Prev_Instance_File : constant Source_File_Entry := - Instance_File; - begin - -- Also relocate the instantiated declarations. - Instance_File := Get_Instance_Source_File (Res); - pragma Assert (Instance_File /= No_Source_File_Entry); - Instantiate_Iir_Field (Res, N, F); - Instance_File := Prev_Instance_File; - end; - else - Instantiate_Iir_Field (Res, N, F); - end if; - - when others => - -- Common case. - Instantiate_Iir_Field (Res, N, F); - end case; - end loop; - - -- TODO: other forward references: - -- incomplete constant - -- incomplete type - -- attribute_value - - return Res; - end; - end Instantiate_Iir; - - -- As the scope generic interfaces extends beyond the immediate scope (see - -- LRM08 12.2 Scope of declarations), they must be instantiated. - function Instantiate_Generic_Chain (Inst : Iir; Inters : Iir) return Iir - is - Inter : Iir; - First : Iir; - Last : Iir; - Res : Iir; - begin - First := Null_Iir; - Last := Null_Iir; - - Inter := Inters; - while Inter /= Null_Iir loop - -- Create a copy of the interface. FIXME: is it really needed ? - Res := Create_Iir (Get_Kind (Inter)); - Set_Location (Res, Relocate (Get_Location (Inter))); - - Set_Parent (Res, Inst); - Set_Identifier (Res, Get_Identifier (Inter)); - Set_Visible_Flag (Res, Get_Visible_Flag (Inter)); - - Set_Origin (Res, Inter); - Set_Instance (Inter, Res); - - case Get_Kind (Res) is - when Iir_Kind_Interface_Constant_Declaration => - Set_Type (Res, Get_Type (Inter)); - Set_Subtype_Indication (Res, Null_Iir); -- Not owner - Set_Mode (Res, Get_Mode (Inter)); - Set_Has_Mode (Res, Get_Has_Mode (Inter)); - Set_Has_Class (Res, Get_Has_Class (Inter)); - Set_Has_Identifier_List (Res, Get_Has_Identifier_List (Inter)); - Set_Expr_Staticness (Res, Get_Expr_Staticness (Inter)); - Set_Name_Staticness (Res, Get_Name_Staticness (Inter)); - Set_Default_Value (Res, Get_Default_Value (Inter)); - Set_Is_Ref (Res, True); - when Iir_Kind_Interface_Package_Declaration => - Set_Uninstantiated_Package_Decl - (Res, Get_Uninstantiated_Package_Decl (Inter)); - Set_Generic_Chain - (Res, - Instantiate_Generic_Chain (Res, Get_Generic_Chain (Inter))); - Set_Declaration_Chain - (Res, Instantiate_Iir_Chain (Get_Declaration_Chain (Inter))); - when Iir_Kind_Interface_Type_Declaration => - Set_Type (Res, Get_Type (Inter)); - when Iir_Kinds_Interface_Subprogram_Declaration => - Sem_Utils.Compute_Subprogram_Hash (Res); - when others => - Error_Kind ("instantiate_generic_chain", Res); - end case; - - -- Append - if First = Null_Iir then - First := Res; - else - Set_Chain (Last, Res); - end if; - Last := Res; - - Inter := Get_Chain (Inter); - end loop; - - return First; - end Instantiate_Generic_Chain; - - procedure Set_Instance_On_Chain (Chain : Iir; Inst_Chain : Iir); - procedure Set_Instance_On_Iir_List (N : Iir_List; Inst : Iir_List); - procedure Set_Instance_On_Iir_Flist (N : Iir_Flist; Inst : Iir_Flist); - - procedure Set_Instance_On_Iir (N : Iir; Inst : Iir) is - begin - if N = Null_Iir then - pragma Assert (Inst = Null_Iir); - return; - end if; - pragma Assert (Inst /= Null_Iir); - - declare - use Nodes_Meta; - Kind : constant Iir_Kind := Get_Kind (N); - Fields : constant Fields_Array := Get_Fields (Kind); - F : Fields_Enum; - begin - pragma Assert (Get_Kind (Inst) = Kind); - - if Kind = Iir_Kind_Interface_Constant_Declaration - and then Get_Identifier (N) = Null_Identifier - then - -- Anonymous constant interface declarations are the only nodes - -- that can be shared. Handle that very special case. - return; - end if; - - -- pragma Assert (Get_Instance (N) = Null_Iir); - Set_Instance (N, Inst); - - for I in Fields'Range loop - F := Fields (I); - - case Get_Field_Type (F) is - when Type_Iir => - declare - S : constant Iir := Get_Iir (N, F); - S_Inst : constant Iir := Get_Iir (Inst, F); - begin - case Get_Field_Attribute (F) is - when Attr_None => - Set_Instance_On_Iir (S, S_Inst); - when Attr_Ref - | Attr_Forward_Ref - | Attr_Maybe_Forward_Ref => - null; - when Attr_Maybe_Ref => - if not Get_Is_Ref (N) then - Set_Instance_On_Iir (S, S_Inst); - end if; - when Attr_Chain => - Set_Instance_On_Chain (S, S_Inst); - when Attr_Chain_Next => - null; - when Attr_Of_Ref | Attr_Of_Maybe_Ref => - -- Can only appear in list. - raise Internal_Error; - end case; - end; - when Type_Iir_List => - declare - S : constant Iir_List := Get_Iir_List (N, F); - S_Inst : constant Iir_List := Get_Iir_List (Inst, F); - begin - case Get_Field_Attribute (F) is - when Attr_None => - Set_Instance_On_Iir_List (S, S_Inst); - when Attr_Of_Maybe_Ref => - if not Get_Is_Ref (N) then - Set_Instance_On_Iir_List (S, S_Inst); - end if; - when Attr_Of_Ref - | Attr_Ref - | Attr_Forward_Ref => - null; - when others => - -- Ref is specially handled in Instantiate_Iir. - -- Others cannot appear for lists. - raise Internal_Error; - end case; - end; - when Type_Iir_Flist => - declare - S : constant Iir_Flist := Get_Iir_Flist (N, F); - S_Inst : constant Iir_Flist := Get_Iir_Flist (Inst, F); - begin - case Get_Field_Attribute (F) is - when Attr_None => - Set_Instance_On_Iir_Flist (S, S_Inst); - when Attr_Of_Maybe_Ref => - if not Get_Is_Ref (N) then - Set_Instance_On_Iir_Flist (S, S_Inst); - end if; - when Attr_Of_Ref - | Attr_Ref - | Attr_Forward_Ref => - null; - when others => - -- Ref is specially handled in Instantiate_Iir. - -- Others cannot appear for lists. - raise Internal_Error; - end case; - end; - when others => - null; - end case; - end loop; - end; - end Set_Instance_On_Iir; - - procedure Set_Instance_On_Iir_List (N : Iir_List; Inst : Iir_List) - is - El : Iir; - El_Inst : Iir; - It, It_Inst : List_Iterator; - begin - case N is - when Null_Iir_List - | Iir_List_All => - pragma Assert (Inst = N); - return; - when others => - It := List_Iterate (N); - It_Inst := List_Iterate (Inst); - while Is_Valid (It) loop - pragma Assert (Is_Valid (It_Inst)); - El := Get_Element (It); - El_Inst := Get_Element (It_Inst); - - Set_Instance_On_Iir (El, El_Inst); - - Next (It); - Next (It_Inst); - end loop; - pragma Assert (not Is_Valid (It_Inst)); - end case; - end Set_Instance_On_Iir_List; - - procedure Set_Instance_On_Iir_Flist (N : Iir_Flist; Inst : Iir_Flist) - is - El : Iir; - El_Inst : Iir; - begin - case N is - when Null_Iir_Flist - | Iir_Flist_All - | Iir_Flist_Others => - pragma Assert (Inst = N); - return; - when others => - pragma Assert (Get_Nbr_Elements (N) = Get_Nbr_Elements (Inst)); - for I in Flist_First .. Flist_Last (N) loop - El := Get_Nth_Element (N, I); - El_Inst := Get_Nth_Element (Inst, I); - - Set_Instance_On_Iir (El, El_Inst); - end loop; - end case; - end Set_Instance_On_Iir_Flist; - - procedure Set_Instance_On_Chain (Chain : Iir; Inst_Chain : Iir) - is - El : Iir; - Inst_El : Iir; - begin - El := Chain; - Inst_El := Inst_Chain; - while El /= Null_Iir loop - pragma Assert (Inst_El /= Null_Iir); - Set_Instance_On_Iir (El, Inst_El); - El := Get_Chain (El); - Inst_El := Get_Chain (Inst_El); - end loop; - pragma Assert (Inst_El = Null_Iir); - end Set_Instance_On_Chain; - - -- In the instance, replace references (and inner references) to interface - -- package declaration to the associated package. - procedure Instantiate_Generic_Map_Chain (Inst : Iir; Pkg : Iir) - is - pragma Unreferenced (Pkg); - Assoc : Iir; - Inter : Iir; - begin - Assoc := Get_Generic_Map_Aspect_Chain (Inst); - Inter := Get_Generic_Chain (Inst); - while Is_Valid (Assoc) loop - -- Replace formal reference to the instance. - -- Cf Get_association_Interface - declare - Formal : Iir; - begin - Formal := Get_Formal (Assoc); - if Is_Valid (Formal) then - loop - case Get_Kind (Formal) is - when Iir_Kind_Simple_Name - | Iir_Kind_Operator_Symbol => - Set_Named_Entity - (Formal, Get_Instance (Get_Named_Entity (Formal))); - exit; - when Iir_Kind_Slice_Name - | Iir_Kind_Indexed_Name - | Iir_Kind_Selected_Element => - Formal := Get_Prefix (Formal); - when others => - Error_Kind ("instantiate_generic_map_chain", Formal); - end case; - end loop; - end if; - end; - - case Get_Kind (Assoc) is - when Iir_Kind_Association_Element_By_Expression - | Iir_Kind_Association_Element_By_Individual - | Iir_Kind_Association_Element_Open => - null; - when Iir_Kind_Association_Element_Package => - declare - Sub_Inst : constant Iir := - Get_Named_Entity (Get_Actual (Assoc)); - Sub_Pkg_Inter : constant Iir := - Get_Association_Interface (Assoc, Inter); - Sub_Pkg : constant Iir := Get_Origin (Sub_Pkg_Inter); - begin - -- Replace references of interface package to references - -- to the actual package. - Set_Instance (Sub_Pkg, Sub_Inst); - Set_Instance_On_Chain (Get_Generic_Chain (Sub_Pkg), - Get_Generic_Chain (Sub_Inst)); - Set_Instance_On_Chain (Get_Declaration_Chain (Sub_Pkg), - Get_Declaration_Chain (Sub_Inst)); - end; - when Iir_Kind_Association_Element_Type => - -- Replace the incomplete interface type by the actual subtype - -- indication. - declare - Inter_Type_Def : constant Iir := - Get_Type (Get_Association_Interface (Assoc, Inter)); - Actual_Type : constant Iir := Get_Actual_Type (Assoc); - begin - Set_Instance (Inter_Type_Def, Actual_Type); - end; - when Iir_Kind_Association_Element_Subprogram => - -- Replace the interface subprogram by the subprogram. - declare - Inter_Subprg : constant Iir := - Get_Association_Interface (Assoc, Inter); - Actual_Subprg : constant Iir := - Get_Named_Entity (Get_Actual (Assoc)); - begin - Set_Instance (Get_Origin (Inter_Subprg), Actual_Subprg); - end; - when others => - Error_Kind ("instantiate_generic_map_chain", Assoc); - end case; - Next_Association_Interface (Assoc, Inter); - end loop; - end Instantiate_Generic_Map_Chain; - - function Copy_Tree (Orig : Iir) return Iir - is - Prev_Instance_File : constant Source_File_Entry := Instance_File; - Mark : constant Instance_Index_Type := Prev_Instance_Table.Last; - Res : Iir; - begin - Instance_File := No_Source_File_Entry; - - -- Be sure Get_Origin_Priv can be called on existing nodes. - Expand_Origin_Table; - - Res := Instantiate_Iir (Orig, False); - - Instance_File := Prev_Instance_File; - Restore_Origin (Mark); - - return Res; - end Copy_Tree; - - procedure Instantiate_Package_Declaration (Inst : Iir; Pkg : Iir) - is - Header : constant Iir := Get_Package_Header (Pkg); - Prev_Instance_File : constant Source_File_Entry := Instance_File; - Mark : constant Instance_Index_Type := Prev_Instance_Table.Last; - Prev_Within_Shared_Instance : constant Boolean := - Is_Within_Shared_Instance; - begin - Create_Relocation (Inst, Pkg); - Set_Instance_Source_File (Inst, Instance_File); - - -- Be sure Get_Origin_Priv can be called on existing nodes. - Expand_Origin_Table; - - -- For Parent: the instance of PKG is INST. - Set_Origin (Pkg, Inst); - - Is_Within_Shared_Instance := not Get_Macro_Expanded_Flag (Pkg); - - Set_Generic_Chain - (Inst, Instantiate_Generic_Chain (Inst, Get_Generic_Chain (Header))); - Instantiate_Generic_Map_Chain (Inst, Pkg); - Set_Declaration_Chain - (Inst, Instantiate_Iir_Chain (Get_Declaration_Chain (Pkg))); - - Set_Origin (Pkg, Null_Iir); - - Instance_File := Prev_Instance_File; - Restore_Origin (Mark); - - Is_Within_Shared_Instance := Prev_Within_Shared_Instance; - end Instantiate_Package_Declaration; - - function Instantiate_Package_Body (Inst : Iir) return Iir - is - Pkg : constant Iir := Get_Uninstantiated_Package_Decl (Inst); - Prev_Instance_File : constant Source_File_Entry := Instance_File; - Mark : constant Instance_Index_Type := Prev_Instance_Table.Last; - Res : Iir; - begin - Create_Relocation (Inst, Pkg); - - -- Be sure Get_Origin_Priv can be called on existing nodes. - Expand_Origin_Table; - - -- References to package specification (and its declarations) will - -- be redirected to the package instantiation. - Set_Instance (Pkg, Inst); - declare - Pkg_Hdr : constant Iir := Get_Package_Header (Pkg); - Pkg_El : Iir; - Inst_El : Iir; - Inter_El : Iir; - Inter : Iir; - begin - -- In the body, references to interface object are redirected to the - -- instantiated interface objects. - Pkg_El := Get_Generic_Chain (Pkg_Hdr); - Inst_El := Get_Generic_Chain (Inst); - while Is_Valid (Pkg_El) loop - if Get_Kind (Pkg_El) in Iir_Kinds_Interface_Object_Declaration then - Set_Instance (Pkg_El, Inst_El); - end if; - Pkg_El := Get_Chain (Pkg_El); - Inst_El := Get_Chain (Inst_El); - end loop; - - -- In the body, references to interface type are substitued to the - -- mapped type. - Inst_El := Get_Generic_Map_Aspect_Chain (Inst); - Inter_El := Get_Generic_Chain (Inst); - while Is_Valid (Inst_El) loop - case Get_Kind (Inst_El) is - when Iir_Kind_Association_Element_Type => - Inter := Get_Association_Interface (Inst_El, Inter_El); - Set_Instance (Get_Type (Get_Origin (Inter)), - Get_Actual_Type (Inst_El)); - -- Implicit operators. - declare - Imp_Inter : Iir; - Imp_Assoc : Iir; - begin - Imp_Assoc := Get_Subprogram_Association_Chain (Inst_El); - Imp_Inter := Get_Interface_Type_Subprograms - (Get_Origin (Inter)); - while Is_Valid (Imp_Inter) and Is_Valid (Imp_Assoc) loop - Set_Instance - (Imp_Inter, - Get_Named_Entity (Get_Actual (Imp_Assoc))); - Imp_Inter := Get_Chain (Imp_Inter); - Imp_Assoc := Get_Chain (Imp_Assoc); - end loop; - end; - - when Iir_Kind_Association_Element_Subprogram => - Inter := Get_Association_Interface (Inst_El, Inter_El); - Set_Instance (Get_Origin (Inter), - Get_Named_Entity (Get_Actual (Inst_El))); - - when Iir_Kind_Association_Element_By_Expression - | Iir_Kind_Association_Element_By_Individual - | Iir_Kind_Association_Element_Open => - null; - when others => - -- TODO. - raise Internal_Error; - end case; - Next_Association_Interface (Inst_El, Inter_El); - end loop; - end; - Set_Instance_On_Chain - (Get_Declaration_Chain (Pkg), Get_Declaration_Chain (Inst)); - - -- Instantiate the body. - Res := Instantiate_Iir (Get_Package_Body (Pkg), False); - Set_Identifier (Res, Get_Identifier (Inst)); - - -- Restore. - Instance_File := Prev_Instance_File; - Restore_Origin (Mark); - - return Res; - end Instantiate_Package_Body; - - procedure Substitute_On_Iir_List (L : Iir_List; E : Iir; Rep : Iir); - - procedure Substitute_On_Iir (N : Iir; E : Iir; Rep : Iir) is - begin - if N = Null_Iir then - return; - end if; - - pragma Assert (N /= E); - - declare - use Nodes_Meta; - Kind : constant Iir_Kind := Get_Kind (N); - Fields : constant Fields_Array := Get_Fields (Kind); - F : Fields_Enum; - begin - for I in Fields'Range loop - F := Fields (I); - - case Get_Field_Type (F) is - when Type_Iir => - declare - S : constant Iir := Get_Iir (N, F); - begin - if S = E then - -- Substitute - Set_Iir (N, F, Rep); - pragma Assert (Get_Field_Attribute (F) = Attr_Ref); - else - case Get_Field_Attribute (F) is - when Attr_None => - Substitute_On_Iir (S, E, Rep); - when Attr_Ref - | Attr_Forward_Ref - | Attr_Maybe_Forward_Ref => - null; - when Attr_Maybe_Ref => - if not Get_Is_Ref (N) then - Substitute_On_Iir (S, E, Rep); - end if; - when Attr_Chain => - Substitute_On_Chain (S, E, Rep); - when Attr_Chain_Next => - null; - when Attr_Of_Ref | Attr_Of_Maybe_Ref => - -- Can only appear in list. - raise Internal_Error; - end case; - end if; - end; - when Type_Iir_List => - declare - S : constant Iir_List := Get_Iir_List (N, F); - begin - case Get_Field_Attribute (F) is - when Attr_None => - Substitute_On_Iir_List (S, E, Rep); - when Attr_Of_Maybe_Ref => - if not Get_Is_Ref (N) then - Substitute_On_Iir_List (S, E, Rep); - end if; - when Attr_Of_Ref - | Attr_Ref - | Attr_Forward_Ref => - null; - when others => - -- Ref is specially handled in Instantiate_Iir. - -- Others cannot appear for lists. - raise Internal_Error; - end case; - end; - when others => - null; - end case; - end loop; - end; - end Substitute_On_Iir; - - procedure Substitute_On_Iir_List (L : Iir_List; E : Iir; Rep : Iir) - is - It : List_Iterator; - begin - case L is - when Null_Iir_List - | Iir_List_All => - return; - when others => - It := List_Iterate (L); - while Is_Valid (It) loop - Substitute_On_Iir (Get_Element (It), E, Rep); - Next (It); - end loop; - end case; - end Substitute_On_Iir_List; - - procedure Substitute_On_Chain (Chain : Iir; E : Iir; Rep : Iir) - is - El : Iir; - begin - El := Chain; - while Is_Valid (El) loop - Substitute_On_Iir (El, E, Rep); - El := Get_Chain (El); - end loop; - end Substitute_On_Chain; - -end Sem_Inst; diff --git a/src/vhdl/sem_inst.ads b/src/vhdl/sem_inst.ads deleted file mode 100644 index 804451272..000000000 --- a/src/vhdl/sem_inst.ads +++ /dev/null @@ -1,36 +0,0 @@ --- Package (and subprograms) instantiations - --- When a package is instantiated, we need to 'duplicate' its declaration. --- This looks useless for analysis but it isn't: a type from a package --- instantiated twice declares two different types. Without duplication, we --- need to attach to each declaration its instance, which looks more expansive --- that duplicating the declaration. --- --- Furthermore, for generic type interface, it looks a good idea to duplicate --- the body (macro expansion). --- --- Duplicating is not trivial: internal links must be kept and external --- links preserved. A table is used to map nodes from the uninstantiated --- package to its duplicated node. Links from instantiated declaration to --- the original declaration are also stored in that table. - -with Iirs; use Iirs; - -package Sem_Inst is - -- Return the origin of node N, the node from which N was instantiated. - -- If N is not an instance, this function returns Null_Iir. - function Get_Origin (N : Iir) return Iir; - - -- Create declaration chain and generic declarations for INST from PKG. - procedure Instantiate_Package_Declaration (Inst : Iir; Pkg : Iir); - - -- Return the instantiation of the body for INST, ie macro-expand the - -- body. INST has the form of a generic-mapped package. - function Instantiate_Package_Body (Inst : Iir) return Iir; - - -- In CHAIN, substitute all references to E by REP. - procedure Substitute_On_Chain (Chain : Iir; E : Iir; Rep : Iir); - - -- Deep copy of ORIG. Doesn't change location. - function Copy_Tree (Orig : Iir) return Iir; -end Sem_Inst; diff --git a/src/vhdl/sem_lib.adb b/src/vhdl/sem_lib.adb deleted file mode 100644 index 7affaaadc..000000000 --- a/src/vhdl/sem_lib.adb +++ /dev/null @@ -1,411 +0,0 @@ --- VHDL libraries handling. --- Copyright (C) 2018 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 Flags; -with Name_Table; -with Files_Map; -with Iirs_Utils; use Iirs_Utils; -with Errorout; use Errorout; -with Libraries; use Libraries; -with Vhdl.Scanner; -with Vhdl.Parse; -with Vhdl.Disp_Tree; -with Vhdl.Disp_Vhdl; -with Sem; -with Post_Sems; -with Vhdl.Canon; -with Nodes_GC; - -package body Sem_Lib is - procedure Error_Lib_Msg (Msg : String; Arg1 : Earg_Type) is - begin - Report_Msg (Msgid_Error, Library, No_Location, Msg, (1 => Arg1)); - end Error_Lib_Msg; - - function Load_File (File : Source_File_Entry) return Iir_Design_File - is - Res : Iir_Design_File; - begin - Vhdl.Scanner.Set_File (File); - if Vhdl.Scanner.Detect_Encoding_Errors then - -- Don't even try to parse such a file. The BOM will be interpreted - -- as an identifier, which is not valid at the beginning of a file. - Res := Null_Iir; - else - Res := Vhdl.Parse.Parse_Design_File; - end if; - Vhdl.Scanner.Close_File; - - if Res /= Null_Iir then - Set_Parent (Res, Work_Library); - Set_Design_File_Filename (Res, Files_Map.Get_File_Name (File)); - Set_Design_File_Source (Res, File); - end if; - return Res; - end Load_File; - - -- parse a file. - -- Return a design_file without putting it into the library - -- (because it was not analyzed). - function Load_File_Name (File_Name: Name_Id) return Iir_Design_File - is - Fe : Source_File_Entry; - begin - Fe := Files_Map.Read_Source_File (Local_Directory, File_Name); - if Fe = No_Source_File_Entry then - Error_Msg_Option ("cannot open " & Name_Table.Image (File_Name)); - return Null_Iir; - end if; - return Load_File (Fe); - end Load_File_Name; - - procedure Finish_Compilation - (Unit : Iir_Design_Unit; Main : Boolean := False) - is - Lib_Unit : Iir; - begin - Lib_Unit := Get_Library_Unit (Unit); - if (Main or Flags.Dump_All) and then Flags.Dump_Parse then - Vhdl.Disp_Tree.Disp_Tree (Unit); - end if; - - if Flags.Check_Ast_Level > 0 then - Nodes_GC.Check_Tree (Unit); - end if; - - if Flags.Verbose then - Report_Msg (Msgid_Note, Semantic, +Lib_Unit, - "analyze %n", (1 => +Lib_Unit)); - end if; - - Sem.Semantic (Unit); - - if (Main or Flags.Dump_All) and then Flags.Dump_Sem then - Vhdl.Disp_Tree.Disp_Tree (Unit); - end if; - - if Errorout.Nbr_Errors > 0 then - return; - end if; - - if (Main or Flags.List_All) and then Flags.List_Sem then - Vhdl.Disp_Vhdl.Disp_Vhdl (Unit); - end if; - - if Flags.Check_Ast_Level > 0 then - Nodes_GC.Check_Tree (Unit); - end if; - - -- Post checks - ---------------- - - Post_Sems.Post_Sem_Checks (Unit); - - if Errorout.Nbr_Errors > 0 then - return; - end if; - - -- Canonalisation. - ------------------ - - if Flags.Verbose then - Report_Msg (Msgid_Note, Semantic, +Lib_Unit, - "canonicalize %n", (1 => +Lib_Unit)); - end if; - - Vhdl.Canon.Canonicalize (Unit); - - if (Main or Flags.Dump_All) and then Flags.Dump_Canon then - Vhdl.Disp_Tree.Disp_Tree (Unit); - end if; - - if Errorout.Nbr_Errors > 0 then - return; - end if; - - if (Main or Flags.List_All) and then Flags.List_Canon then - Vhdl.Disp_Vhdl.Disp_Vhdl (Unit); - end if; - - if Flags.Check_Ast_Level > 0 then - Nodes_GC.Check_Tree (Unit); - end if; - end Finish_Compilation; - - procedure Free_Dependence_List (Design : Iir_Design_Unit) - is - List : Iir_List; - begin - List := Get_Dependence_List (Design); - if List /= Null_Iir_List then - Free_Recursive_List (List); - Destroy_Iir_List (List); - end if; - end Free_Dependence_List; - - procedure Load_Parse_Design_Unit (Design_Unit: Iir_Design_Unit; Loc : Iir) - is - use Vhdl.Scanner; - Design_File : constant Iir_Design_File := Get_Design_File (Design_Unit); - Fe : Source_File_Entry; - Line, Off: Natural; - Pos: Source_Ptr; - Res: Iir; - begin - -- The unit must not be loaded. - pragma Assert (Get_Date_State (Design_Unit) = Date_Disk); - - Fe := Get_Design_File_Source (Design_File); - if Fe = No_Source_File_Entry then - -- Load the file in memory. - Fe := Files_Map.Read_Source_File - (Get_Design_File_Directory (Design_File), - Get_Design_File_Filename (Design_File)); - if Fe = No_Source_File_Entry then - Error_Lib_Msg ("cannot load %n", +Get_Library_Unit (Design_Unit)); - raise Compilation_Error; - end if; - Set_Design_File_Source (Design_File, Fe); - - -- Check if the file has changed. - if not Files_Map.Is_Eq - (Files_Map.Get_File_Checksum (Fe), Get_File_Checksum (Design_File)) - then - Error_Msg_Sem (+Loc, "file %i has changed and must be reanalysed", - +Get_Design_File_Filename (Design_File)); - raise Compilation_Error; - end if; - end if; - - if Get_Date (Design_Unit) = Date_Obsolete then - Error_Msg_Sem (+Loc, "%n has been obsoleted", - +Get_Library_Unit (Design_Unit)); - raise Compilation_Error; - end if; - - -- Set the position of the lexer - Set_File (Fe); - Pos := Get_Design_Unit_Source_Pos (Design_Unit); - Line := Natural (Get_Design_Unit_Source_Line (Design_Unit)); - Off := Natural (Get_Design_Unit_Source_Col (Design_Unit)); - Files_Map.File_Add_Line_Number (Get_Current_Source_File, Line, Pos); - Set_Current_Position (Pos + Source_Ptr (Off)); - - -- Parse - Scan; - Res := Vhdl.Parse.Parse_Design_Unit; - Close_File; - if Res = Null_Iir then - raise Compilation_Error; - end if; - - Set_Date_State (Design_Unit, Date_Parse); - - -- FIXME: check the library unit read is the one expected. - - -- Move the unit in the library: keep the design_unit of the library, - -- but replace the library_unit by the one that has been parsed. Do - -- not forget to relocate parents. - Iirs_Utils.Free_Recursive (Get_Library_Unit (Design_Unit)); - Set_Library_Unit (Design_Unit, Get_Library_Unit (Res)); - Set_Design_Unit (Get_Library_Unit (Res), Design_Unit); - Set_Parent (Get_Library_Unit (Res), Design_Unit); - declare - Item : Iir; - begin - Item := Get_Context_Items (Res); - Set_Context_Items (Design_Unit, Item); - while Is_Valid (Item) loop - Set_Parent (Item, Design_Unit); - Item := Get_Chain (Item); - end loop; - end; - Location_Copy (Design_Unit, Res); - Free_Dependence_List (Design_Unit); - Set_Dependence_List (Design_Unit, Get_Dependence_List (Res)); - Set_Dependence_List (Res, Null_Iir_List); - Free_Iir (Res); - end Load_Parse_Design_Unit; - - procedure Error_Obsolete (Loc : Iir; Msg : String; Args : Earg_Arr) is - begin - if not Flags.Flag_Elaborate_With_Outdated then - if Loc = Null_Iir then - Error_Msg_Sem (Command_Line_Location, Msg, Args); - else - Error_Msg_Sem (+Loc, Msg, Args); - end if; - end if; - end Error_Obsolete; - - -- Check if one of its dependency makes this unit obsolete. - function Check_Obsolete_Dependence (Design_Unit : Iir; Loc : Iir) - return Boolean - is - List : constant Iir_List := Get_Dependence_List (Design_Unit); - Du_Ts : constant Time_Stamp_Id := - Get_Analysis_Time_Stamp (Get_Design_File (Design_Unit)); - U_Ts : Time_Stamp_Id; - El : Iir; - It : List_Iterator; - begin - if List = Null_Iir_List then - return False; - end if; - - It := List_Iterate (List); - while Is_Valid (It) loop - El := Get_Element (It); - if Get_Kind (El) = Iir_Kind_Design_Unit then - U_Ts := Get_Analysis_Time_Stamp (Get_Design_File (El)); - if Files_Map.Is_Gt (U_Ts, Du_Ts) then - Error_Obsolete - (Loc, "%n is obsoleted by %n", (+Design_Unit, +El)); - return True; - end if; - end if; - Next (It); - end loop; - - return False; - end Check_Obsolete_Dependence; - - procedure Explain_Obsolete (Design_Unit : Iir_Design_Unit; Loc : Iir) - is - List : Iir_List; - It : List_Iterator; - El : Iir; - begin - pragma Assert (Get_Date_State (Design_Unit) = Date_Analyze); - pragma Assert (Get_Date (Design_Unit) = Date_Obsolete); - - List := Get_Dependence_List (Design_Unit); - if List = Null_Iir_List then - -- Argh, we don't know why. - Error_Obsolete (Loc, "%n is obsolete", (1 => +Design_Unit)); - return; - end if; - - It := List_Iterate (List); - while Is_Valid (It) loop - El := Get_Element (It); - if Get_Date (El) = Date_Obsolete then - Error_Obsolete (Loc, "%n is obsoleted by %n", (+Design_Unit, +El)); - return; - end if; - Next (It); - end loop; - end Explain_Obsolete; - - -- Load, parse, analyze, back-end a design_unit if necessary. - procedure Load_Design_Unit (Design_Unit : Iir_Design_Unit; Loc : Iir) - is - Warnings : Warnings_Setting; - begin - if Get_Date (Design_Unit) = Date_Replacing then - Error_Msg_Sem (+Loc, "circular reference of %n", +Design_Unit); - return; - end if; - - if Get_Date_State (Design_Unit) = Date_Disk then - Load_Parse_Design_Unit (Design_Unit, Loc); - end if; - - if Get_Date_State (Design_Unit) = Date_Parse then - -- Analyze the design unit. - - if Get_Date (Design_Unit) = Date_Analyzed then - -- Work-around for an internal check in sem. - -- FIXME: to be removed ? - Set_Date (Design_Unit, Date_Parsed); - end if; - - -- Avoid infinite recursion, if the unit is self-referenced. - Set_Date_State (Design_Unit, Date_Analyze); - - -- Disable all warnings. Warnings are emitted only when the unit - -- is analyzed. - Save_Warnings_Setting (Warnings); - Disable_All_Warnings; - - -- Analyze unit. - Finish_Compilation (Design_Unit); - - -- Restore warnings. - Restore_Warnings_Setting (Warnings); - - -- Check if one of its dependency makes this unit obsolete. - -- FIXME: to do when the dependency is added ? - if not Flags.Flag_Elaborate_With_Outdated - and then Check_Obsolete_Dependence (Design_Unit, Loc) - then - Set_Date (Design_Unit, Date_Obsolete); - return; - end if; - end if; - - case Get_Date (Design_Unit) is - when Date_Parsed => - raise Internal_Error; - when Date_Analyzing => - -- Self-referenced unit. - return; - when Date_Analyzed => - -- FIXME: Accept it silently ? - -- Note: this is used when Flag_Elaborate_With_Outdated is set. - -- This is also used by anonymous configuration declaration. - null; - when Date_Uptodate => - return; - when Date_Valid => - null; - when Date_Obsolete => - if not Flags.Flag_Elaborate_With_Outdated then - Explain_Obsolete (Design_Unit, Loc); - end if; - when others => - raise Internal_Error; - end case; - end Load_Design_Unit; - - function Load_Primary_Unit - (Library: Iir_Library_Declaration; Name: Name_Id; Loc : Iir) - return Iir_Design_Unit - is - Design_Unit: Iir_Design_Unit; - begin - Design_Unit := Find_Primary_Unit (Library, Name); - if Design_Unit /= Null_Iir then - Load_Design_Unit (Design_Unit, Loc); - end if; - return Design_Unit; - end Load_Primary_Unit; - - -- Load an secondary unit and analyse it. - function Load_Secondary_Unit - (Primary: Iir_Design_Unit; Name: Name_Id; Loc : Iir) - return Iir_Design_Unit - is - Design_Unit: Iir_Design_Unit; - begin - Design_Unit := Find_Secondary_Unit (Primary, Name); - if Design_Unit /= Null_Iir then - Load_Design_Unit (Design_Unit, Loc); - end if; - return Design_Unit; - end Load_Secondary_Unit; -end Sem_Lib; diff --git a/src/vhdl/sem_lib.ads b/src/vhdl/sem_lib.ads deleted file mode 100644 index 7f57833b5..000000000 --- a/src/vhdl/sem_lib.ads +++ /dev/null @@ -1,58 +0,0 @@ --- VHDL libraries handling. --- Copyright (C) 2018 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 Types; use Types; -with Iirs; use Iirs; - -package Sem_Lib is - -- Start the analyse a file (ie load and parse it). - -- The file is read from the current directory (unless FILE_NAME is an - -- absolute path). - -- Emit an error if the file cannot be opened. - -- Return NULL_IIR in case of parse error. - function Load_File_Name (File_Name: Name_Id) return Iir_Design_File; - function Load_File (File : Source_File_Entry) return Iir_Design_File; - - -- Load, parse, analyze, back-end a design_unit if necessary. - -- Check Design_Unit is not obsolete. - -- LOC is the location where the design unit was needed, in case of error. - procedure Load_Design_Unit (Design_Unit: Iir_Design_Unit; Loc : Iir); - - -- Load and parse DESIGN_UNIT. - -- Contrary to Load_Design_Unit, the design_unit is not analyzed. - -- Also, the design_unit must not have been already loaded. - -- Used almost only by Load_Design_Unit. - procedure Load_Parse_Design_Unit (Design_Unit: Iir_Design_Unit; Loc : Iir); - - -- Load an already analyzed primary unit NAME from library LIBRARY - -- and compile it. - -- Return NULL_IIR if not found (ie, NAME does not correspond to a - -- library unit identifier). - function Load_Primary_Unit - (Library: Iir_Library_Declaration; Name: Name_Id; Loc : Iir) - return Iir_Design_Unit; - - -- Load an secondary unit of primary unit PRIMARY and analyse it. - -- NAME must be set only for an architecture. - function Load_Secondary_Unit - (Primary: Iir_Design_Unit; Name: Name_Id; Loc : Iir) - return Iir_Design_Unit; - - -- Analyze UNIT. - procedure Finish_Compilation - (Unit : Iir_Design_Unit; Main : Boolean := False); -end Sem_Lib; diff --git a/src/vhdl/sem_names.adb b/src/vhdl/sem_names.adb deleted file mode 100644 index 38d372c53..000000000 --- a/src/vhdl/sem_names.adb +++ /dev/null @@ -1,4313 +0,0 @@ --- Semantic analysis. --- 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 Evaluation; use Evaluation; -with Iirs_Utils; use Iirs_Utils; -with Errorout; use Errorout; -with Flags; use Flags; -with Name_Table; -with Std_Package; use Std_Package; -with Types; use Types; -with Iir_Chains; use Iir_Chains; -with Std_Names; -with Sem; -with Sem_Lib; use Sem_Lib; -with Sem_Scopes; use Sem_Scopes; -with Sem_Expr; use Sem_Expr; -with Sem_Stmts; use Sem_Stmts; -with Sem_Decls; use Sem_Decls; -with Sem_Assocs; use Sem_Assocs; -with Sem_Specs; -with Sem_Types; -with Sem_Psl; -with Xrefs; use Xrefs; - -package body Sem_Names is - -- Finish the analyze of NAME using RES as named entity. - -- This is called when the analyze is finished and an uniq - -- interpretation has been determined (RES). - -- - -- Error messages are emitted here. - function Finish_Sem_Name (Name : Iir; Res : Iir) return Iir; - - -- Return the fully analyzed name of NAME. - function Name_To_Analyzed_Name (Name : Iir) return Iir; - - procedure Error_Overload (Expr: Iir) is - begin - if Is_Error (Expr) then - -- Avoid error storm. - return; - end if; - Error_Msg_Sem (+Expr, "can't resolve overload for %n", +Expr); - end Error_Overload; - - procedure Disp_Overload_List (List : Iir_List; Loc : Iir) - is - El : Iir; - It : List_Iterator; - begin - Error_Msg_Sem (+Loc, "possible interpretations are:", Cont => True); - It := List_Iterate (List); - while Is_Valid (It) loop - El := Get_Element (It); - case Get_Kind (El) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - Error_Msg_Sem (+El, Disp_Subprg (El)); - when Iir_Kind_Function_Call => - El := Get_Implementation (El); - Error_Msg_Sem (+El, Disp_Subprg (El)); - when others => - Error_Msg_Sem (+El, "%n", +El); - end case; - Next (It); - end loop; - end Disp_Overload_List; - - -- Create an overload list. - -- must be destroyed with free_iir. - function Get_Overload_List return Iir_Overload_List - is - Res : Iir; - begin - Res := Create_Iir (Iir_Kind_Overload_List); - return Res; - end Get_Overload_List; - - function Create_Overload_List (List : Iir_List) return Iir_Overload_List - is - Res : Iir_Overload_List; - begin - Res := Get_Overload_List; - Set_Overload_List (Res, List); - return Res; - end Create_Overload_List; - - procedure Free_Overload_List (N : in out Iir_Overload_List) - is - List : Iir_List; - begin - List := Get_Overload_List (N); - Destroy_Iir_List (List); - Free_Iir (N); - N := Null_Iir; - end Free_Overload_List; - - function Simplify_Overload_List (List : Iir_List) return Iir - is - Res : Iir; - L1 : Iir_List; - begin - case Get_Nbr_Elements (List) is - when 0 => - L1 := List; - Destroy_Iir_List (L1); - return Null_Iir; - when 1 => - L1 := List; - Res := Get_First_Element (List); - Destroy_Iir_List (L1); - return Res; - when others => - return Create_Overload_List (List); - end case; - end Simplify_Overload_List; - - -- Return true if AN_IIR is an overload list. - function Is_Overload_List (An_Iir: Iir) return Boolean is - begin - return Get_Kind (An_Iir) = Iir_Kind_Overload_List; - end Is_Overload_List; - - function Is_Defined_Type (Atype : Iir) return Boolean is - begin - return Atype /= Null_Iir - and then not Kind_In (Get_Kind (Atype), - Iir_Kind_Overload_List, - Iir_Kind_Wildcard_Type_Definition); - end Is_Defined_Type; - - -- From the list LIST of function or enumeration literal, extract the - -- list of (return) types. - -- If there is only one type, return it. - -- If there is no types, return NULL. - -- Otherwise, return the list as an overload list. - function Create_List_Of_Types (List : Iir_List) - return Iir - is - Res_List : Iir_List; - Decl : Iir; - It : List_Iterator; - begin - -- Create the list of possible return types. - Res_List := Create_Iir_List; - It := List_Iterate (List); - while Is_Valid (It) loop - Decl := Get_Element (It); - case Get_Kind (Decl) is - when Iir_Kind_Function_Declaration => - Add_Element (Res_List, Get_Return_Type (Decl)); - when Iir_Kind_Enumeration_Literal - | Iir_Kind_Function_Call - | Iir_Kind_Indexed_Name - | Iir_Kind_Slice_Name - | Iir_Kind_Selected_Element => - Add_Element (Res_List, Get_Type (Decl)); - when others => - Error_Kind ("create_list_of_types", Decl); - end case; - Next (It); - end loop; - return Simplify_Overload_List (Res_List); - end Create_List_Of_Types; - - procedure Add_Result (Res : in out Iir; Decl : Iir) - is - Nres : Iir; - Nres_List : Iir_List; - begin - if Decl = Null_Iir then - return; - end if; - if Res = Null_Iir then - Res := Decl; - elsif Is_Overload_List (Res) then - Append_Element (Get_Overload_List (Res), Decl); - else - Nres_List := Create_Iir_List; - Nres := Create_Overload_List (Nres_List); - Append_Element (Nres_List, Res); - Append_Element (Nres_List, Decl); - Res := Nres; - end if; - end Add_Result; - - -- Extract from overload list RES the function call without implicit - -- conversion. Return Null_Iir if there is no function call, or if there - -- is an expressions that isn't a function call, or if there is more than - -- one function call without implicit conversion. - -- Cf Sem_Expr.Get_Non_Implicit_Subprogram - function Extract_Call_Without_Implicit_Conversion (Res : Iir) return Iir - is - pragma Assert (Is_Overload_List (Res)); - List : constant Iir_List := Get_Overload_List (Res); - It : List_Iterator; - Call : Iir; - El : Iir; - Imp : Iir; - Inter : Iir; - begin - Call := Null_Iir; - It := List_Iterate (List); - while Is_Valid (It) loop - El := Get_Element (It); - if Get_Kind (El) = Iir_Kind_Function_Call then - Imp := Get_Implementation (El); - Inter := Get_Interface_Declaration_Chain (Imp); - if Get_Type (Inter) = Universal_Integer_Type_Definition - or else Get_Type (Inter) = Universal_Real_Type_Definition - then - -- The type of the first interface is a universal type. So, - -- there were no implicit conversions. Once there is an - -- implicit conversion, the only way to 'convert' to a - -- universal type is through T'Pos, which has to be resolved. - -- Note: there are no interface of convertible types. - -- GHDL: this is not proven... - if Call /= Null_Iir then - -- More than one call without implicit conversion. - return Null_Iir; - else - Call := El; - end if; - end if; - else - return Null_Iir; - end if; - Next (It); - end loop; - - return Call; - end Extract_Call_Without_Implicit_Conversion; - - -- Move elements of result list LIST to result list RES. - -- Destroy LIST if necessary. - procedure Add_Result_List (Res : in out Iir; List : Iir); - pragma Unreferenced (Add_Result_List); - - procedure Add_Result_List (Res : in out Iir; List : Iir) - is - El : Iir; - List_List : Iir_List; - Res_List : Iir_List; - It : List_Iterator; - begin - if Res = Null_Iir then - Res := List; - elsif List = Null_Iir then - null; - elsif not Is_Overload_List (List) then - Add_Result (Res, List); - else - if not Is_Overload_List (Res) then - El := Res; - Res := Get_Overload_List; - Append_Element (Get_Overload_List (Res), El); - end if; - List_List := Get_Overload_List (List); - Res_List := Get_Overload_List (Res); - It := List_Iterate (List_List); - while Is_Valid (It) loop - Append_Element (Res_List, Get_Element (It)); - Next (It); - end loop; - Free_Iir (List); - end if; - end Add_Result_List; - - -- Free interpretations of LIST except KEEP (which can be Null_Iir to free - -- the whole list). - procedure Sem_Name_Free_Result (List : Iir; Keep : Iir) - is - procedure Sem_Name_Free (El : Iir) is - begin - case Get_Kind (El) is - when Iir_Kind_Function_Call - | Iir_Kind_Indexed_Name - | Iir_Kind_Selected_Element => - Sem_Name_Free (Get_Prefix (El)); - Free_Iir (El); - when Iir_Kind_Attribute_Name => - Free_Iir (El); - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration - | Iir_Kind_Enumeration_Literal => - null; - when Iir_Kind_Interface_Function_Declaration - | Iir_Kind_Interface_Procedure_Declaration => - null; - when Iir_Kinds_Denoting_Name => - null; - when others => - Error_Kind ("sem_name_free", El); - end case; - end Sem_Name_Free; - - El : Iir; - List_List : Iir_List; - It : List_Iterator; - begin - if List = Null_Iir then - return; - elsif not Is_Overload_List (List) then - if List /= Keep then - Sem_Name_Free (List); - end if; - else - List_List := Get_Overload_List (List); - It := List_Iterate (List_List); - while Is_Valid (It) loop - El := Get_Element (It); - if El /= Keep then - Sem_Name_Free (El); - end if; - Next (It); - end loop; - Free_Iir (List); - end if; - end Sem_Name_Free_Result; - - procedure Free_Parenthesis_Name (Name : Iir; Res : Iir) - is - Chain, Next_Chain : Iir; - begin - pragma Assert (Get_Kind (Res) /= Iir_Kind_Function_Call); - Chain := Get_Association_Chain (Name); - while Chain /= Null_Iir loop - Next_Chain := Get_Chain (Chain); - Free_Iir (Chain); - Chain := Next_Chain; - end loop; - Free_Iir (Name); - end Free_Parenthesis_Name; - - -- Find all named declaration whose identifier is ID in DECL_LIST and - -- return it. - -- The result can be NULL (if no such declaration exist), - -- a declaration, or an overload_list containing all declarations. - function Find_Declarations_In_List - (Decl: Iir; Name : Iir_Selected_Name; Keep_Alias : Boolean) - return Iir - is - Res: Iir := Null_Iir; - - -- If indentifier of DECL is ID, then add DECL in the result. - procedure Handle_Decl (Decl : Iir; Id : Name_Id) is - begin - -- Use_clauses may appear in a declaration list. - case Get_Kind (Decl) is - when Iir_Kind_Use_Clause - | Iir_Kind_Anonymous_Type_Declaration => - return; - when Iir_Kind_Non_Object_Alias_Declaration => - if Get_Identifier (Decl) = Id then - if Keep_Alias then - Add_Result (Res, Decl); - else - Add_Result (Res, Get_Named_Entity (Get_Name (Decl))); - end if; - end if; - when others => - -- Consider only visible declarations (case of an implicit - -- declaration that is overriden by explicit one). - if Get_Identifier (Decl) = Id and Get_Visible_Flag (Decl) then - Add_Result (Res, Decl); - end if; - end case; - end Handle_Decl; - - procedure Iterator_Decl is new Sem_Scopes.Iterator_Decl - (Arg_Type => Name_Id, Handle_Decl => Handle_Decl); - --procedure Iterator_Decl_List is new Sem_Scopes.Iterator_Decl_List - -- (Arg_Type => Name_Id, Handle_Decl => Iterator_Decl); - procedure Iterator_Decl_Chain is new Sem_Scopes.Iterator_Decl_Chain - (Arg_Type => Name_Id, Handle_Decl => Iterator_Decl); - - Id : constant Name_Id := Get_Identifier (Name); - begin - case Get_Kind (Decl) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - Iterator_Decl_Chain (Get_Interface_Declaration_Chain (Decl), Id); - when Iir_Kind_Entity_Declaration => - Iterator_Decl_Chain (Get_Generic_Chain (Decl), Id); - Iterator_Decl_Chain (Get_Port_Chain (Decl), Id); - when Iir_Kind_Architecture_Body => - null; - when Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement => - null; - when Iir_Kind_Package_Declaration => - declare - Header : constant Iir := Get_Package_Header (Decl); - begin - if Is_Valid (Header) - and then Get_Is_Within_Flag (Decl) - then - Iterator_Decl_Chain (Get_Generic_Chain (Header), Id); - end if; - end; - when Iir_Kind_Package_Instantiation_Declaration - | Iir_Kind_Interface_Package_Declaration => - -- Generics are not visible in selected name. - null; - -- Iterator_Decl_Chain (Get_Generic_Chain (Decl), Id); - when Iir_Kind_Block_Statement => - declare - Header : constant Iir := Get_Block_Header (Decl); - begin - if Header /= Null_Iir then - Iterator_Decl_Chain (Get_Generic_Chain (Header), Id); - Iterator_Decl_Chain (Get_Port_Chain (Header), Id); - end if; - end; - when Iir_Kind_For_Loop_Statement => - Handle_Decl (Get_Parameter_Specification (Decl), Id); - when Iir_Kind_Process_Statement - | Iir_Kind_Sensitized_Process_Statement => - null; - when others => - Error_Kind ("find_declarations_in_list", Decl); - end case; - - case Get_Kind (Decl) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - declare - Decl_Body : constant Iir := Get_Subprogram_Body (Decl); - begin - Iterator_Decl_Chain - (Get_Declaration_Chain (Decl_Body), Id); - Iterator_Decl_Chain - (Get_Sequential_Statement_Chain (Decl_Body), Id); - end; - when Iir_Kind_Architecture_Body - | Iir_Kind_Entity_Declaration - | Iir_Kind_Block_Statement => - Iterator_Decl_Chain (Get_Declaration_Chain (Decl), Id); - Iterator_Decl_Chain (Get_Concurrent_Statement_Chain (Decl), Id); - when Iir_Kind_For_Generate_Statement => - declare - Bod : constant Iir := Get_Generate_Statement_Body (Decl); - begin - Iterator_Decl_Chain (Get_Declaration_Chain (Bod), Id); - Iterator_Decl_Chain (Get_Concurrent_Statement_Chain (Bod), Id); - end; - when Iir_Kind_If_Generate_Statement => - declare - Clause : Iir; - Bod : Iir; - begin - -- Look only in the current generate_statement_body - Clause := Decl; - while Clause /= Null_Iir loop - Bod := Get_Generate_Statement_Body (Clause); - if Get_Is_Within_Flag (Bod) then - Iterator_Decl_Chain - (Get_Declaration_Chain (Bod), Id); - Iterator_Decl_Chain - (Get_Concurrent_Statement_Chain (Bod), Id); - exit; - end if; - Clause := Get_Generate_Else_Clause (Clause); - end loop; - end; - when Iir_Kind_Package_Declaration - | Iir_Kind_Package_Instantiation_Declaration - | Iir_Kind_Interface_Package_Declaration => - Iterator_Decl_Chain (Get_Declaration_Chain (Decl), Id); - when Iir_Kind_Process_Statement - | Iir_Kind_Sensitized_Process_Statement => - Iterator_Decl_Chain (Get_Declaration_Chain (Decl), Id); - Iterator_Decl_Chain (Get_Sequential_Statement_Chain (Decl), Id); - when Iir_Kind_For_Loop_Statement => - null; - when others => - Error_Kind ("find_declarations_in_list", Decl); - end case; - --if Res = Null_Iir then - -- Error_Msg_Sem ("""" & Name_Table.Image (Id) & """ not defined in " - -- & Disp_Node (Decl), Name); - --end if; - return Res; - end Find_Declarations_In_List; - - -- Create an implicit_dereference node if PREFIX is of type access. - -- Return PREFIX otherwise. - -- PARENT is used if an implicit dereference node is created, to copy - -- location from. - function Insert_Implicit_Dereference (Prefix : Iir; Parent : Iir) - return Iir - is - Prefix_Type : Iir; - Res : Iir_Implicit_Dereference; - begin - Prefix_Type := Get_Type (Prefix); - - case Get_Kind (Prefix_Type) is - when Iir_Kind_Access_Type_Definition - | Iir_Kind_Access_Subtype_Definition => - null; - when others => - return Prefix; - end case; - Check_Read (Prefix); - Res := Create_Iir (Iir_Kind_Implicit_Dereference); - Location_Copy (Res, Parent); - Set_Type (Res, Get_Designated_Type (Prefix_Type)); - Set_Prefix (Res, Prefix); - Set_Base_Name (Res, Res); - Set_Expr_Staticness (Res, None); - return Res; - end Insert_Implicit_Dereference; - - -- If PREFIX is a function specification that cannot be converted to a - -- function call (because of lack of association), return FALSE. - function Maybe_Function_Call (Prefix : Iir) return Boolean - is - Inter : Iir; - begin - if Get_Kind (Prefix) /= Iir_Kind_Function_Declaration then - return True; - end if; - Inter := Get_Interface_Declaration_Chain (Prefix); - while Inter /= Null_Iir loop - if Get_Default_Value (Inter) = Null_Iir then - return False; - end if; - Inter := Get_Chain (Inter); - end loop; - return True; - end Maybe_Function_Call; - - procedure Name_To_Method_Object (Call : Iir; Name : Iir) - is - Prefix : Iir; - Obj : Iir; - begin - if Get_Kind (Name) /= Iir_Kind_Selected_Name then - return; - end if; - - Prefix := Get_Prefix (Name); - Obj := Get_Named_Entity (Prefix); - if Obj /= Null_Iir - and then Kind_In (Obj, Iir_Kind_Variable_Declaration, - Iir_Kind_Interface_Variable_Declaration) - and then Get_Type (Obj) /= Null_Iir - then - if Get_Kind (Get_Type (Obj)) /= Iir_Kind_Protected_Type_Declaration - then - Error_Msg_Sem - (+Prefix, "type of the prefix should be a protected type"); - return; - end if; - Set_Method_Object (Call, Obj); - end if; - end Name_To_Method_Object; - - -- NAME is the name of the function (and not the parenthesis name) - function Sem_As_Function_Call (Name : Iir; Spec : Iir; Assoc_Chain : Iir) - return Iir_Function_Call - is - Call : Iir_Function_Call; - begin - -- Check. - pragma Assert (Get_Kind (Name) in Iir_Kinds_Denoting_Name); - - Call := Create_Iir (Iir_Kind_Function_Call); - Location_Copy (Call, Name); - if Get_Kind (Name) = Iir_Kind_Parenthesis_Name then - Set_Prefix (Call, Get_Prefix (Name)); - else - Set_Prefix (Call, Name); - end if; - Name_To_Method_Object (Call, Name); - Set_Implementation (Call, Spec); - Set_Parameter_Association_Chain (Call, Assoc_Chain); - Set_Type (Call, Get_Return_Type (Spec)); - Set_Base_Name (Call, Call); - return Call; - end Sem_As_Function_Call; - - -- If SPEC is a function specification, then return a function call, - -- else return SPEC. - function Maybe_Insert_Function_Call (Name : Iir; Spec : Iir) return Iir - is - begin - if Get_Kind (Spec) = Iir_Kind_Function_Declaration then - return Sem_As_Function_Call (Name, Spec, Null_Iir); - else - return Spec; - end if; - end Maybe_Insert_Function_Call; - - -- If PTR_TYPE is not NULL_IIR, then return an implciti dereference to - -- PREFIX, else return PREFIX. - function Maybe_Insert_Dereference (Prefix : Iir; Ptr_Type : Iir) return Iir - is - Id : Iir; - begin - if Ptr_Type /= Null_Iir then - Id := Create_Iir (Iir_Kind_Implicit_Dereference); - Location_Copy (Id, Prefix); - Set_Type (Id, Get_Designated_Type (Ptr_Type)); - Set_Prefix (Id, Prefix); - Set_Base_Name (Id, Id); - return Id; - else - return Prefix; - end if; - end Maybe_Insert_Dereference; - - procedure Finish_Sem_Indexed_Name (Expr : Iir) - is - Prefix : constant Iir := Get_Prefix (Expr); - Prefix_Type : constant Iir := Get_Type (Prefix); - Index_List : constant Iir_Flist := Get_Index_List (Expr); - Index_Subtype : Iir; - Index : Iir; - Expr_Staticness : Iir_Staticness; - begin - Expr_Staticness := Locally; - - -- LRM93 §6.4: there must be one such expression for each index - -- position of the array and each expression must be of the - -- type of the corresponding index. - -- Loop on the indexes. - for I in Flist_First .. Flist_Last (Index_List) loop - Index := Get_Nth_Element (Index_List, I); - Index_Subtype := Get_Index_Type (Prefix_Type, I); - -- The index_subtype can be an unconstrained index type. - Index := Check_Is_Expression (Index, Index); - if Index /= Null_Iir then - Index := Sem_Expression (Index, Get_Base_Type (Index_Subtype)); - end if; - if Index /= Null_Iir then - if Get_Expr_Staticness (Index) = Locally - and then Get_Type_Staticness (Index_Subtype) = Locally - then - Index := Eval_Expr_Check (Index, Index_Subtype); - end if; - Set_Nth_Element (Index_List, I, Index); - Expr_Staticness := Min (Expr_Staticness, - Get_Expr_Staticness (Index)); - else - Expr_Staticness := None; - end if; - end loop; - - Set_Type (Expr, Get_Element_Subtype (Prefix_Type)); - - -- LRM93 6.1 - -- a name is said to be a static name iff: - -- The name is an indexed name whose prefix is a static name - -- and every expression that appears as part of the name is a - -- static expression. - -- - -- a name is said to be a locally static name iif: - -- The name is an indexed name whose prefix is a locally - -- static name and every expression that appears as part - -- of the name is a locally static expression. - Set_Name_Staticness - (Expr, Min (Expr_Staticness, Get_Name_Staticness (Prefix))); - - -- An indexed name cannot be locally static. - if Flags.Vhdl_Std < Vhdl_08 then - Expr_Staticness := Min (Globally, Expr_Staticness); - end if; - Set_Expr_Staticness - (Expr, Min (Expr_Staticness, Get_Expr_Staticness (Prefix))); - - Set_Base_Name (Expr, Get_Base_Name (Prefix)); - end Finish_Sem_Indexed_Name; - - procedure Finish_Sem_Dereference (Res : Iir) is - begin - Set_Base_Name (Res, Res); - Check_Read (Get_Prefix (Res)); - Set_Expr_Staticness (Res, None); - Set_Name_Staticness (Res, None); - end Finish_Sem_Dereference; - - procedure Finish_Sem_Slice_Name (Name : Iir_Slice_Name) - is - -- The prefix of the slice - Prefix : constant Iir := Get_Prefix (Name); - Prefix_Type : constant Iir := Get_Type (Prefix); - Prefix_Base_Type : Iir; - Prefix_Bt : constant Iir := Get_Base_Type (Prefix_Type); - Index_List: Iir_Flist; - Index_Type: Iir; - Suffix: Iir; - Slice_Type : Iir; - Expr_Type : Iir; - Staticness : Iir_Staticness; - Prefix_Rng : Iir; - begin - Set_Base_Name (Name, Get_Base_Name (Prefix)); - - -- LRM93 §6.5: the prefix of an indexed name must be appropriate - -- for an array type. - if Get_Kind (Prefix_Bt) /= Iir_Kind_Array_Type_Definition then - Error_Msg_Sem (+Name, "slice can only be applied to an array"); - return; - end if; - - -- LRM93 §6.5: - -- The prefix of a slice must be appropriate for a - -- one-dimensionnal array object. - Index_List := Get_Index_Subtype_List (Prefix_Type); - if Get_Nbr_Elements (Index_List) /= 1 then - Error_Msg_Sem - (+Name, "slice prefix must be an one-dimensional array"); - return; - end if; - - Index_Type := Get_Index_Type (Index_List, 0); - Prefix_Rng := Eval_Static_Range (Index_Type); - - -- LRM93 6.5 - -- It is an error if either the bounds of the discrete range does not - -- belong to the index range of the prefixing array, *unless* the slice - -- is a null slice. - -- - -- LRM93 6.5 - -- The slice is a null slice if the discrete range is a null range. - - -- LRM93 §6.5: - -- The bounds of the discrete range [...] must be of the - -- type of the index of the array. - Suffix := Sem_Discrete_Range_Expression - (Get_Suffix (Name), Index_Type, False); - if Suffix = Null_Iir then - return; - end if; - Suffix := Eval_Range_If_Static (Suffix); - Set_Suffix (Name, Suffix); - - -- LRM93 §6.5: - -- It is an error if the direction of the discrete range is not - -- the same as that of the index range of the array denoted - -- by the prefix of the slice name. - - -- Check this only if the type is a constrained type. - if Get_Kind (Prefix_Type) = Iir_Kind_Array_Subtype_Definition - and then Get_Index_Constraint_Flag (Prefix_Type) - and then Get_Expr_Staticness (Suffix) = Locally - and then Prefix_Rng /= Null_Iir - and then Get_Direction (Suffix) /= Get_Direction (Prefix_Rng) - then - if False and then Flags.Vhdl_Std = Vhdl_87 then - -- emit a warning for a null slice. - Warning_Msg_Sem (Warnid_Runtime_Error, +Name, - "direction mismatch results in a null slice"); - - end if; - Error_Msg_Sem (+Name, "direction of the range mismatch"); - end if; - - -- LRM93 §7.4.1 - -- A slice is never a locally static expression. - case Get_Kind (Suffix) is - when Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name => - Suffix := Get_Type (Suffix); - Staticness := Get_Type_Staticness (Suffix); - when Iir_Kind_Range_Expression - | Iir_Kind_Range_Array_Attribute - | Iir_Kind_Reverse_Range_Array_Attribute => - Staticness := Get_Expr_Staticness (Suffix); - when others => - Error_Kind ("finish_sem_slice_name", Suffix); - end case; - Set_Expr_Staticness - (Name, Min (Min (Staticness, Get_Expr_Staticness (Prefix)), Globally)); - Set_Name_Staticness - (Name, Min (Staticness, Get_Name_Staticness (Prefix))); - - -- The type of the slice is a subtype of the base type whose - -- range contraint is the slice itself. - if Get_Kind (Suffix) in Iir_Kinds_Discrete_Type_Definition then - Slice_Type := Suffix; - else - case Get_Kind (Get_Base_Type (Index_Type)) is - when Iir_Kind_Integer_Type_Definition => - Slice_Type := Create_Iir (Iir_Kind_Integer_Subtype_Definition); - when Iir_Kind_Enumeration_Type_Definition => - Slice_Type := - Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); - when others => - Error_Kind ("sem_expr: slice_name", Get_Base_Type (Index_Type)); - end case; - Set_Range_Constraint (Slice_Type, Suffix); - Set_Is_Ref (Slice_Type, True); - Set_Type_Staticness (Slice_Type, Staticness); - Set_Base_Type (Slice_Type, Get_Base_Type (Index_Type)); - Set_Location (Slice_Type, Get_Location (Suffix)); - end if; - - Expr_Type := Create_Iir (Iir_Kind_Array_Subtype_Definition); - Set_Location (Expr_Type, Get_Location (Suffix)); - Set_Index_Subtype_List (Expr_Type, Create_Iir_Flist (1)); - Set_Index_Constraint_List (Expr_Type, - Get_Index_Subtype_List (Expr_Type)); - Prefix_Base_Type := Get_Base_Type (Prefix_Type); - Set_Base_Type (Expr_Type, Prefix_Base_Type); - Set_Signal_Type_Flag (Expr_Type, - Get_Signal_Type_Flag (Prefix_Base_Type)); - Set_Nth_Element (Get_Index_Subtype_List (Expr_Type), 0, Slice_Type); - Set_Element_Subtype (Expr_Type, Get_Element_Subtype (Prefix_Type)); - if Get_Kind (Prefix_Type) = Iir_Kind_Array_Subtype_Definition then - Set_Resolution_Indication - (Expr_Type, Sem_Types.Copy_Resolution_Indication (Prefix_Type)); - else - Set_Resolution_Indication (Expr_Type, Null_Iir); - end if; - Set_Type_Staticness - (Expr_Type, Min (Get_Type_Staticness (Prefix_Type), - Get_Type_Staticness (Slice_Type))); - Set_Type (Name, Expr_Type); - Set_Slice_Subtype (Name, Expr_Type); - Set_Index_Constraint_Flag (Expr_Type, True); - Set_Constraint_State (Expr_Type, Fully_Constrained); - if Is_Signal_Object (Prefix) then - Sem_Types.Set_Type_Has_Signal (Expr_Type); - end if; - end Finish_Sem_Slice_Name; - - -- PREFIX is the name denoting the function declaration, and its analysis - -- is already finished. - procedure Finish_Sem_Function_Call (Call : Iir; Prefix : Iir) - is - Rtype : Iir; - begin - Set_Prefix (Call, Prefix); - Set_Implementation (Call, Get_Named_Entity (Prefix)); - - -- LRM08 8.1 Names - -- The name is a simple name or selected name that does NOT denote a - -- function call [...] - -- - -- GHDL: so function calls are never static names. - Set_Name_Staticness (Call, None); - - -- FIXME: modify sem_subprogram_call to avoid such a type swap. - Rtype := Get_Type (Call); - Set_Type (Call, Null_Iir); - if Sem_Subprogram_Call (Call, Null_Iir) = Null_Iir then - Set_Type (Call, Rtype); - end if; - end Finish_Sem_Function_Call; - - function Function_Declaration_To_Call (Name : Iir) return Iir - is - Expr : Iir; - begin - Expr := Get_Named_Entity (Name); - if Maybe_Function_Call (Expr) then - Expr := Sem_As_Function_Call (Name, Expr, Null_Iir); - pragma Assert (Get_Kind (Expr) = Iir_Kind_Function_Call); - Finish_Sem_Function_Call (Expr, Name); - return Expr; - else - Error_Msg_Sem (+Name, "%n requires parameters", +Expr); - Set_Type (Name, Get_Type (Expr)); - Set_Expr_Staticness (Name, None); - Set_Named_Entity (Name, Create_Error_Expr (Expr, Get_Type (Expr))); - return Name; - end if; - end Function_Declaration_To_Call; - - function Sem_Type_Mark (Name : Iir; Incomplete : Boolean := False) - return Iir - is - Atype : Iir; - Res : Iir; - begin - -- The name must not have been analyzed. - pragma Assert (Get_Type (Name) = Null_Iir); - - if Is_Error (Name) then - Set_Type (Name, Name); - return Name; - end if; - - -- Analyze the name (if not already done). - Res := Get_Named_Entity (Name); - if Res = Null_Iir then - Sem_Name (Name); - Res := Get_Named_Entity (Name); - end if; - if Res /= Null_Iir and then Is_Overload_List (Res) then - Error_Msg_Sem (+Name, "name does not denote a type mark"); - return Create_Error_Type (Name); - end if; - Res := Finish_Sem_Name (Name); - - -- LRM87 14.1 Predefined attributes - if Get_Kind (Res) = Iir_Kind_Base_Attribute then - Error_Msg_Sem - (+Name, "'Base attribute cannot be used as a type mark"); - end if; - - Atype := Name_To_Type_Definition (Res); - - if Is_Error (Atype) then - if Get_Kind (Res) in Iir_Kinds_Denoting_Name then - Set_Named_Entity (Res, Atype); - else - return Create_Error_Type (Name); - end if; - elsif not Incomplete then - if Get_Kind (Atype) = Iir_Kind_Incomplete_Type_Definition then - Error_Msg_Sem - (+Name, "invalid use of an incomplete type definition"); - Atype := Create_Error_Type (Name); - Set_Named_Entity (Res, Atype); - end if; - end if; - - Set_Type (Res, Atype); - - return Res; - end Sem_Type_Mark; - - -- Return Globally if the prefix of NAME is a globally static name. - function Get_Object_Type_Staticness (Name : Iir) return Iir_Staticness - is - Base : constant Iir := Get_Base_Name (Name); - Parent : Iir; - begin - if Get_Kind (Base) in Iir_Kinds_Dereference then - return None; - end if; - - Parent := Get_Parent (Base); - loop - case Get_Kind (Parent) is - when Iir_Kind_Entity_Declaration - | Iir_Kind_Architecture_Body - | Iir_Kind_Block_Statement - | Iir_Kind_Block_Header - | Iir_Kind_Component_Declaration - | Iir_Kinds_Process_Statement - | Iir_Kind_Generate_Statement_Body - | Iir_Kind_Design_Unit => - -- Globally static. - return Globally; - when Iir_Kind_Package_Declaration - | Iir_Kind_Package_Body - | Iir_Kind_Package_Instantiation_Declaration - | Iir_Kind_Protected_Type_Body => - -- Possibly nested construct. - Parent := Get_Parent (Parent); - when Iir_Kinds_Subprogram_Declaration - | Iir_Kinds_Subprogram_Body - | Iir_Kinds_Interface_Subprogram_Declaration => - -- Not globally static. - return None; - when others => - Error_Kind ("get_object_type_staticness", Parent); - end case; - end loop; - end Get_Object_Type_Staticness; - - procedure Finish_Sem_Array_Attribute - (Attr_Name : Iir; Attr : Iir; Param : Iir) - is - Parameter : Iir; - Prefix_Type : Iir; - Index_Type : Iir; - Prefix : Iir; - Prefix_Name : Iir; - Staticness : Iir_Staticness; - begin - -- LRM93 14.1 - -- Parameter: A locally static expression of type universal_integer, the - -- value of which must not exceed the dimensionality of A. If omitted, - -- it defaults to 1. - if Param = Null_Iir then - Parameter := Null_Iir; - else - Parameter := Sem_Expression - (Param, Universal_Integer_Type_Definition); - if Parameter /= Null_Iir then - if Get_Expr_Staticness (Parameter) /= Locally then - Error_Msg_Sem (+Parameter, "parameter must be locally static"); - end if; - else - -- Don't forget there is a parameter, so the attribute cannot - -- be reanalyzed with a default parameter. - Parameter := Error_Mark; - end if; - end if; - - -- See Sem_Array_Attribute_Name for comments about the prefix. - Prefix_Name := Get_Prefix (Attr_Name); - if Is_Type_Name (Prefix_Name) /= Null_Iir then - Prefix := Sem_Type_Mark (Prefix_Name); - else - Prefix := Finish_Sem_Name (Prefix_Name, Get_Prefix (Attr)); - -- Convert function declaration to call. - if Get_Kind (Prefix) in Iir_Kinds_Denoting_Name - and then - (Get_Kind (Get_Named_Entity (Prefix)) - = Iir_Kind_Function_Declaration) - then - Prefix := Function_Declaration_To_Call (Prefix); - end if; - end if; - Set_Prefix (Attr, Prefix); - - Prefix_Type := Get_Type (Prefix); - if Is_Error (Prefix_Type) then - return; - end if; - - declare - Dim : Iir_Int64; - Indexes_List : constant Iir_Flist := - Get_Index_Subtype_List (Prefix_Type); - begin - if Is_Null (Parameter) - or else Get_Expr_Staticness (Parameter) /= Locally - then - Dim := 1; - else - Dim := Get_Value (Parameter); - end if; - if Dim < 1 or else Dim > Iir_Int64 (Get_Nbr_Elements (Indexes_List)) - then - Error_Msg_Sem (+Attr, "parameter value out of bound"); - Dim := 1; - end if; - Index_Type := Get_Index_Type (Indexes_List, Natural (Dim - 1)); - end; - - case Get_Kind (Attr) is - when Iir_Kind_Left_Array_Attribute - | Iir_Kind_Right_Array_Attribute - | Iir_Kind_High_Array_Attribute - | Iir_Kind_Low_Array_Attribute => - Set_Type (Attr, Index_Type); - when Iir_Kind_Range_Array_Attribute - | Iir_Kind_Reverse_Range_Array_Attribute => - Set_Type (Attr, Index_Type); - when Iir_Kind_Length_Array_Attribute => - Set_Type (Attr, Convertible_Integer_Type_Definition); - when Iir_Kind_Ascending_Array_Attribute => - Set_Type (Attr, Boolean_Type_Definition); - when others => - raise Internal_Error; - end case; - - pragma Assert (Get_Parameter (Attr) = Null_Iir); - - Set_Parameter (Attr, Parameter); - - -- If the corresponding type is known, save it so that it is not - -- necessary to extract it from the object. - if Get_Kind (Prefix_Type) = Iir_Kind_Array_Subtype_Definition - and then Get_Constraint_State (Prefix_Type) = Fully_Constrained - then - Set_Index_Subtype (Attr, Index_Type); - end if; - - -- LRM08 9.4.2 Locally static primaries - -- g) A predefined attribute that is a function, [other than ... and - -- other than ...], whose prefix is either a locally static subtype - -- or is an object that is of a locally static subtype, and whose - -- actual parameter (if any) is a locally static expression. - -- - -- LRM08 9.4.3 Globally static primaries - -- l) A predefined attribute that is a function, [other than ... and - -- other than ...], whose prefix is appropriate for a globally - -- static attribute, and whose actual parameter (if any) is a - -- globally static expression. - -- - -- A prefix is appropriate for a globally static attribute if it denotes - -- a signal, a constant, a type or subtype, a globally static function - -- call, a variable that is not of an access type, or a variable of an - -- access type whose designated subtype is fully constrained. - - -- LRM93 7.4.1 - -- A locally static range is either [...], or a range of the first form - -- whose prefix denotes either a locally static subtype or an object - -- that is of a locally static subtype. - - -- LRM93 7.4.2 - -- A globally static range is either [...], or a range of the first form - -- whose prefix denotes either a globally static subtype or an object - -- that is of a globally static subtype. - -- - -- A globally static subtype is either a globally static scalar subtype, - -- a globally static array subtype, [...] - -- - -- A globally static array subtype is a constrained array subtype - -- formed by imposing on an unconstrained array type a globally static - -- index constraint. - - Staticness := Get_Type_Staticness (Prefix_Type); - if Is_Object_Name (Prefix) then - Staticness := Iir_Staticness'Max - (Staticness, Get_Object_Type_Staticness (Prefix)); - end if; - Set_Expr_Staticness (Attr, Staticness); - end Finish_Sem_Array_Attribute; - - procedure Finish_Sem_Scalar_Type_Attribute - (Attr_Name : Iir; Attr : Iir; Param : Iir) - is - Prefix : Iir; - Prefix_Type : Iir; - Prefix_Bt : Iir; - Parameter : Iir; - Param_Type : Iir; - begin - if Param = Null_Iir then - Error_Msg_Sem (+Attr, "%n requires a parameter", +Attr); - return; - end if; - - Prefix := Finish_Sem_Name (Get_Prefix (Attr)); - Free_Iir (Attr_Name); - Set_Prefix (Attr, Prefix); - - Prefix_Type := Get_Type (Prefix); - Prefix_Bt := Get_Base_Type (Prefix_Type); - - case Get_Kind (Attr) is - when Iir_Kind_Pos_Attribute => - -- LRM93 14.1 - -- Parameter: An expression whose type is the base type of T. - Parameter := Sem_Expression (Param, Prefix_Bt); - when Iir_Kind_Val_Attribute => - -- LRM93 14.1 - -- Parameter: An expression of any integer type. - Param_Type := Get_Type (Param); - if Is_Overload_List (Param_Type) then - Parameter := Sem_Expression - (Param, Universal_Integer_Type_Definition); - else - if Get_Kind (Get_Base_Type (Param_Type)) - /= Iir_Kind_Integer_Type_Definition - then - Error_Msg_Sem (+Attr, "parameter must be an integer"); - return; - end if; - Parameter := Param; - end if; - when Iir_Kind_Succ_Attribute - | Iir_Kind_Pred_Attribute - | Iir_Kind_Leftof_Attribute - | Iir_Kind_Rightof_Attribute => - -- LRM93 14.1 - -- Parameter: An expression whose type is the base type of T. - Parameter := Sem_Expression (Param, Prefix_Bt); - when Iir_Kind_Image_Attribute => - -- LRM93 14.1 - -- Parameter: An expression whose type is the base type of T. - Parameter := Sem_Expression (Param, Prefix_Bt); - when Iir_Kind_Value_Attribute => - -- Parameter: An expression of type string. - Parameter := Sem_Expression (Param, String_Type_Definition); - when others => - raise Internal_Error; - end case; - pragma Assert (Get_Parameter (Attr) = Null_Iir); - if Parameter = Null_Iir then - Set_Parameter (Attr, Param); - Set_Expr_Staticness (Attr, None); - return; - end if; - Set_Parameter (Attr, Parameter); - Set_Expr_Staticness (Attr, Min (Get_Type_Staticness (Prefix_Type), - Get_Expr_Staticness (Parameter))); - Set_Name_Staticness (Attr, Get_Expr_Staticness (Attr)); - end Finish_Sem_Scalar_Type_Attribute; - - procedure Finish_Sem_Signal_Attribute - (Attr_Name : Iir; Attr : Iir; Parameter : Iir) - is - Param : Iir; - Prefix : Iir; - Prefix_Name : Iir; - begin - Prefix_Name := Get_Prefix (Attr_Name); - Prefix := Finish_Sem_Name (Prefix_Name, Get_Prefix (Attr)); - Set_Prefix (Attr, Prefix); - Free_Iir (Attr_Name); - - if Parameter = Null_Iir then - return; - end if; - if Get_Kind (Attr) = Iir_Kind_Transaction_Attribute then - Error_Msg_Sem (+Attr, "'transaction does not allow a parameter"); - else - Param := Sem_Expression (Parameter, Time_Subtype_Definition); - if Param /= Null_Iir then - -- LRM93 14.1 - -- Parameter: A static expression of type TIME [that evaluate - -- to a nonnegative value.] - if Get_Expr_Staticness (Param) = None then - Error_Msg_Sem - (+Param, "parameter of signal attribute must be static"); - end if; - Set_Parameter (Attr, Param); - end if; - end if; - end Finish_Sem_Signal_Attribute; - - function Is_Type_Abstract_Numeric (Atype : Iir) return Boolean is - begin - case Get_Kind (Atype) is - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Integer_Type_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Floating_Type_Definition => - return True; - when others => - return False; - end case; - end Is_Type_Abstract_Numeric; - - function Are_Types_Closely_Related (Type1, Type2 : Iir) return Boolean - is - Base_Type1 : constant Iir := Get_Base_Type (Type1); - Base_Type2 : constant Iir := Get_Base_Type (Type2); - Ant1, Ant2 : Boolean; - Index_List1, Index_List2 : Iir_Flist; - El1, El2 : Iir; - begin - -- LRM 7.3.5 - -- In particular, a type is closely related to itself. - if Base_Type1 = Base_Type2 then - return True; - end if; - - -- LRM 7.3.5 - -- a) Abstract Numeric Types: Any abstract numeric type is closely - -- related to any other abstract numeric type. - Ant1 := Is_Type_Abstract_Numeric (Type1); - Ant2 := Is_Type_Abstract_Numeric (Type2); - if Ant1 and Ant2 then - return True; - end if; - if Ant1 or Ant2 then - return False; - end if; - - -- LRM 7.3.5 - -- b) Array Types: Two array types are closely related if and only if - -- The types have the same dimensionality; For each index position, - -- the index types are either the same or are closely related; and - -- The element types are the same. - -- - -- No other types are closely related. - if not (Get_Kind (Base_Type1) = Iir_Kind_Array_Type_Definition - and then Get_Kind (Base_Type2) = Iir_Kind_Array_Type_Definition) - then - return False; - end if; - Index_List1 := Get_Index_Subtype_List (Base_Type1); - Index_List2 := Get_Index_Subtype_List (Base_Type2); - if Get_Nbr_Elements (Index_List1) /= Get_Nbr_Elements (Index_List2) then - return False; - end if; - if Get_Base_Type (Get_Element_Subtype (Base_Type1)) - /= Get_Base_Type (Get_Element_Subtype (Base_Type2)) - then - return False; - end if; - for I in Flist_First .. Flist_Last (Index_List1) loop - El1 := Get_Index_Type (Index_List1, I); - El2 := Get_Index_Type (Index_List2, I); - if not Are_Types_Closely_Related (El1, El2) then - return False; - end if; - end loop; - return True; - end Are_Types_Closely_Related; - - function Sem_Type_Conversion - (Name : Iir; Type_Mark : Iir; Actual : Iir; In_Formal : Boolean) - return Iir - is - Conv_Type : constant Iir := Get_Type (Type_Mark); - Conv : Iir_Type_Conversion; - Expr : Iir; - Staticness : Iir_Staticness; - begin - Conv := Create_Iir (Iir_Kind_Type_Conversion); - Location_Copy (Conv, Name); - Set_Type_Mark (Conv, Type_Mark); - Set_Type (Conv, Conv_Type); - Set_Expression (Conv, Actual); - - -- Default staticness in case of error. - Set_Expr_Staticness (Conv, None); - - -- Bail out if no actual (or invalid one). - if Actual = Null_Iir then - return Conv; - end if; - - -- LRM93 7.3.5 - -- Furthermore, the operand of a type conversion is not allowed to be - -- the literal null, an allocator, an aggregate, or a string literal. - case Get_Kind (Actual) is - when Iir_Kind_Null_Literal - | Iir_Kind_Aggregate - | Iir_Kind_String_Literal8 - | Iir_Kinds_Allocator => - Error_Msg_Sem - (+Actual, "%n cannot be a type conversion operand", +Actual); - return Conv; - when Iir_Kind_Range_Expression => - -- Try to nicely handle expression like NAME (A to B). - Error_Msg_Sem - (+Actual, "subtype indication not allowed in an expression"); - return Conv; - when Iir_Kind_Error => - return Conv; - when others => - null; - end case; - - -- LRM93 7.3.5 - -- The type of the operand of a type conversion must be - -- determinable independent of the context (in particular, - -- independent of the target type). - Expr := Sem_Expression_Universal (Actual); - if Expr = Null_Iir then - return Conv; - end if; - Set_Expression (Conv, Expr); - - -- LRM93 7.4.1 Locally Static Primaries. - -- 9. a type conversion whose expression is a locally static expression. - -- LRM93 7.4.2 Globally Static Primaries. - -- 14. a type conversion whose expression is a globally static - -- expression. - Staticness := Get_Expr_Staticness (Expr); - - -- If the type mark is not locally static, the expression cannot - -- be locally static. This was clarified in VHDL 08, but a type - -- mark that denotes an unconstrained array type, does not prevent - -- the expression from being static. - if Get_Kind (Conv_Type) not in Iir_Kinds_Array_Type_Definition - or else Get_Constraint_State (Conv_Type) = Fully_Constrained - then - Staticness := Min (Staticness, Get_Type_Staticness (Conv_Type)); - end if; - - -- LRM87 7.4 Static Expressions - -- A type conversion is not a locally static expression. - if Flags.Vhdl_Std = Vhdl_87 then - Staticness := Min (Globally, Staticness); - end if; - Set_Expr_Staticness (Conv, Staticness); - - if not Are_Types_Closely_Related (Conv_Type, Get_Type (Expr)) then - -- FIXME: should explain why the types are not closely related. - Error_Msg_Sem - (+Conv, - "conversion not allowed between not closely related types"); - -- Avoid error storm in evaluation. - Set_Expr_Staticness (Conv, None); - else - -- Unless the type conversion appears in the formal part of an - -- association, the expression must be readable. - if not In_Formal then - Check_Read (Expr); - end if; - end if; - return Conv; - end Sem_Type_Conversion; - - -- OBJ is an 'impure' object (variable, signal or file) referenced at - -- location LOC. - -- Check the pure rules (LRM08 4 Subprograms and packages, - -- LRM08 4.3 Subprograms bodies). - procedure Sem_Check_Pure (Loc : Iir; Obj : Iir) - is - procedure Update_Impure_Depth (Subprg_Spec : Iir; Depth : Iir_Int32) - is - Bod : constant Iir := Get_Subprogram_Body (Subprg_Spec); - begin - if Bod = Null_Iir then - return; - end if; - if Depth < Get_Impure_Depth (Bod) then - Set_Impure_Depth (Bod, Depth); - end if; - end Update_Impure_Depth; - - procedure Error_Pure (Subprg : Iir; Obj : Iir) - is - begin - Error_Msg_Sem_Relaxed - (Loc, Warnid_Pure, - "reference to %n violate pure rule for %n", (+Obj, +Subprg)); - end Error_Pure; - - Subprg : constant Iir := Sem_Stmts.Get_Current_Subprogram; - Subprg_Body : Iir; - Parent : Iir; - Decl : Iir; - begin - -- Apply only in subprograms. - if Subprg = Null_Iir then - return; - end if; - case Get_Kind (Subprg) is - when Iir_Kinds_Process_Statement => - return; - when Iir_Kind_Procedure_Declaration => - -- Exit now if already known as impure. - if Get_Purity_State (Subprg) = Impure then - return; - end if; - when Iir_Kind_Function_Declaration => - -- Exit now if impure. - if Get_Pure_Flag (Subprg) = False then - return; - end if; - when others => - Error_Kind ("sem_check_pure", Subprg); - end case; - - -- Follow aliases. - if Get_Kind (Obj) = Iir_Kind_Object_Alias_Declaration then - Decl := Get_Object_Prefix (Get_Name (Obj)); - else - Decl := Obj; - end if; - - -- Not all objects are impure. - case Get_Kind (Decl) is - when Iir_Kind_Object_Alias_Declaration => - raise Program_Error; - when Iir_Kind_Guard_Signal_Declaration - | Iir_Kind_Signal_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_Interface_File_Declaration => - null; - when Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Interface_Signal_Declaration => - -- When referenced as a formal name (FIXME: this is an - -- approximation), the rules don't apply. - if not Get_Is_Within_Flag (Get_Parent (Decl)) then - return; - end if; - when Iir_Kind_File_Declaration => - -- LRM 93 2.2 - -- If a pure function is the parent of a given procedure, then - -- that procedure must not contain a reference to an explicitly - -- declared file object [...] - -- - -- A pure function must not contain a reference to an explicitly - -- declared file. - if Get_Kind (Subprg) = Iir_Kind_Function_Declaration then - Error_Pure (Subprg, Obj); - else - Set_Purity_State (Subprg, Impure); - Set_Impure_Depth (Get_Subprogram_Body (Subprg), - Iir_Depth_Impure); - end if; - return; - when others => - return; - end case; - - -- DECL is declared in the immediate declarative part of the subprogram. - Parent := Get_Parent (Decl); - Subprg_Body := Get_Subprogram_Body (Subprg); - if Parent = Subprg or else Parent = Subprg_Body then - return; - end if; - - -- Function. - if Get_Kind (Subprg) = Iir_Kind_Function_Declaration then - Error_Pure (Subprg, Obj); - return; - end if; - - case Get_Kind (Parent) is - when Iir_Kind_Entity_Declaration - | Iir_Kind_Architecture_Body - | Iir_Kind_Package_Declaration - | Iir_Kind_Package_Body - | Iir_Kind_Block_Statement - | Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement - | Iir_Kind_Generate_Statement_Body - | Iir_Kinds_Process_Statement - | Iir_Kind_Protected_Type_Body => - -- The procedure is impure. - Set_Purity_State (Subprg, Impure); - Set_Impure_Depth (Subprg_Body, Iir_Depth_Impure); - return; - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body => - Update_Impure_Depth - (Subprg, - Get_Subprogram_Depth (Get_Subprogram_Specification (Parent))); - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - Update_Impure_Depth (Subprg, Get_Subprogram_Depth (Parent)); - when others => - Error_Kind ("sem_check_pure(2)", Parent); - end case; - end Sem_Check_Pure; - - -- Set All_Sensitized_State to False iff OBJ is a signal declaration - -- and the current subprogram is in a package body. - procedure Sem_Check_All_Sensitized (Obj : Iir) - is - Subprg : Iir; - begin - -- We cares only of signals. - if Get_Kind (Obj) /= Iir_Kind_Signal_Declaration then - return; - end if; - -- We cares only of subprograms. Give up if we are in a process. - Subprg := Sem_Stmts.Get_Current_Subprogram; - if Subprg = Null_Iir - or else Get_Kind (Subprg) not in Iir_Kinds_Subprogram_Declaration - then - return; - end if; - if Get_Kind (Get_Library_Unit (Sem.Get_Current_Design_Unit)) - = Iir_Kind_Package_Body - then - Set_All_Sensitized_State (Subprg, Invalid_Signal); - else - Set_All_Sensitized_State (Subprg, Read_Signal); - end if; - end Sem_Check_All_Sensitized; - - -- Free overload list of NAME but keep RES interpretation. - procedure Free_Old_Entity_Name (Name : Iir; Res : Iir) - is - Old_Res : constant Iir := Get_Named_Entity (Name); - begin - if Old_Res /= Null_Iir and then Old_Res /= Res then - pragma Assert (Is_Overload_List (Old_Res)); - Sem_Name_Free_Result (Old_Res, Res); - end if; - Set_Named_Entity (Name, Res); - end Free_Old_Entity_Name; - - function Finish_Sem_Denoting_Name (Name : Iir; Res : Iir) return Iir is - begin - case Iir_Kinds_Denoting_Name (Get_Kind (Name)) is - when Iir_Kind_Simple_Name - | Iir_Kind_Character_Literal - | Iir_Kind_Operator_Symbol => - Set_Base_Name (Name, Res); - Xref_Ref (Name, Res); - return Name; - when Iir_Kind_Selected_Name => - declare - Prefix, Res_Prefix : Iir; - Old_Res : Iir; - begin - Xref_Ref (Name, Res); - Prefix := Name; - Res_Prefix := Res; - loop - Prefix := Get_Prefix (Prefix); - Res_Prefix := Get_Parent (Res_Prefix); - - -- Get the parent for expanded_name, may skip some parents. - case Get_Kind (Res_Prefix) is - when Iir_Kind_Design_Unit => - Res_Prefix := - Get_Library (Get_Design_File (Res_Prefix)); - when others => - null; - end case; - - pragma Assert (Get_Kind (Prefix) in Iir_Kinds_Denoting_Name); - Xref_Ref (Prefix, Res_Prefix); - - -- Cannot use Free_Old_Entity_Name as a prefix may not be - -- the parent (for protected subprogram calls). - Old_Res := Get_Named_Entity (Prefix); - if Is_Overload_List (Old_Res) then - Free_Iir (Old_Res); - Set_Named_Entity (Prefix, Res_Prefix); - end if; - - exit when Get_Kind (Prefix) /= Iir_Kind_Selected_Name; - end loop; - end; - return Name; - when Iir_Kind_Reference_Name => - -- Not in the sources. - raise Internal_Error; - end case; - end Finish_Sem_Denoting_Name; - - function Finish_Sem_Name_1 (Name : Iir; Res : Iir) return Iir - is - Prefix : Iir; - Name_Prefix : Iir; - Name_Res : Iir; - begin - case Get_Kind (Res) is - when Iir_Kinds_Library_Unit => - return Finish_Sem_Denoting_Name (Name, Res); - when Iir_Kinds_Sequential_Statement - | Iir_Kinds_Concurrent_Statement => - -- Label or part of an expanded name (for process, block - -- and generate). - return Finish_Sem_Denoting_Name (Name, Res); - when Iir_Kinds_Object_Declaration - | Iir_Kinds_Quantity_Declaration - | Iir_Kind_Enumeration_Literal - | Iir_Kind_Unit_Declaration - | Iir_Kind_Psl_Endpoint_Declaration => - Name_Res := Finish_Sem_Denoting_Name (Name, Res); - Set_Base_Name (Name_Res, Res); - Set_Name_Staticness (Name_Res, Get_Name_Staticness (Res)); - Set_Expr_Staticness (Name_Res, Get_Expr_Staticness (Res)); - Sem_Check_Pure (Name_Res, Res); - Sem_Check_All_Sensitized (Res); - Set_Type (Name_Res, Get_Type (Res)); - return Name_Res; - when Iir_Kind_Attribute_Value => - pragma Assert (Get_Kind (Name) = Iir_Kind_Attribute_Name); - Prefix := Finish_Sem_Name (Get_Prefix (Name)); - Set_Prefix (Name, Prefix); - if Get_Is_Forward_Ref (Prefix) then - Set_Base_Name (Prefix, Null_Iir); - end if; - Set_Base_Name (Name, Res); - Set_Type (Name, Get_Type (Res)); - Set_Name_Staticness (Name, Get_Name_Staticness (Res)); - Set_Expr_Staticness (Name, Get_Expr_Staticness (Res)); - return Name; - when Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration - | Iir_Kind_Component_Declaration - | Iir_Kind_Group_Template_Declaration - | Iir_Kind_Group_Declaration - | Iir_Kind_Attribute_Declaration - | Iir_Kind_Non_Object_Alias_Declaration - | Iir_Kind_Library_Declaration - | Iir_Kind_Interface_Package_Declaration - | Iir_Kind_Interface_Type_Declaration => - Name_Res := Finish_Sem_Denoting_Name (Name, Res); - Set_Base_Name (Name_Res, Res); - return Name_Res; - when Iir_Kind_Function_Declaration - | Iir_Kind_Interface_Function_Declaration => - Name_Res := Finish_Sem_Denoting_Name (Name, Res); - Set_Type (Name_Res, Get_Return_Type (Res)); - return Name_Res; - when Iir_Kind_Procedure_Declaration - | Iir_Kind_Interface_Procedure_Declaration => - return Finish_Sem_Denoting_Name (Name, Res); - when Iir_Kind_Type_Conversion => - pragma Assert (Get_Kind (Name) = Iir_Kind_Parenthesis_Name); - Set_Type_Mark (Res, Sem_Type_Mark (Get_Prefix (Name))); - Free_Parenthesis_Name (Name, Res); - return Res; - when Iir_Kind_Indexed_Name - | Iir_Kind_Selected_Element - | Iir_Kind_Slice_Name - | Iir_Kind_Dereference => - -- Fall through. - null; - when Iir_Kind_Implicit_Dereference => - -- The name may not have a prefix. - Prefix := Finish_Sem_Name_1 (Name, Get_Prefix (Res)); - Set_Prefix (Res, Prefix); - Finish_Sem_Dereference (Res); - return Res; - when Iir_Kind_Function_Call => - case Get_Kind (Name) is - when Iir_Kind_Parenthesis_Name => - -- Usual case. - Prefix := Finish_Sem_Name - (Get_Prefix (Name), Get_Implementation (Res)); - Finish_Sem_Function_Call (Res, Prefix); - Free_Iir (Name); - when Iir_Kinds_Denoting_Name => - -- Call without association list. - Prefix := Finish_Sem_Name (Name, Get_Implementation (Res)); - Finish_Sem_Function_Call (Res, Prefix); - when others => - Error_Kind ("Finish_Sem_Name(function call)", Name); - end case; - return Res; - when Iir_Kinds_Array_Attribute => - if Get_Parameter (Res) = Null_Iir then - Finish_Sem_Array_Attribute (Name, Res, Null_Iir); - end if; - if Get_Kind (Name) = Iir_Kind_Attribute_Name then - Free_Iir (Name); - else - Free_Iir (Get_Prefix (Name)); - Free_Parenthesis_Name (Name, Res); - end if; - return Res; - when Iir_Kinds_Scalar_Type_Attribute - | Iir_Kind_Image_Attribute - | Iir_Kind_Value_Attribute => - if Get_Parameter (Res) = Null_Iir then - Finish_Sem_Scalar_Type_Attribute (Name, Res, Null_Iir); - else - Free_Parenthesis_Name (Name, Res); - end if; - return Res; - when Iir_Kind_Subtype_Attribute => - null; - when Iir_Kinds_Signal_Value_Attribute => - null; - when Iir_Kinds_Signal_Attribute => - if Get_Parameter (Res) = Null_Iir then - Finish_Sem_Signal_Attribute (Name, Res, Null_Iir); - else - Free_Parenthesis_Name (Name, Res); - end if; - return Res; - when Iir_Kinds_Type_Attribute - | Iir_Kind_Base_Attribute => - pragma Assert (Get_Kind (Name) = Iir_Kind_Attribute_Name); - Free_Iir (Name); - return Res; - when Iir_Kind_Simple_Name_Attribute - | Iir_Kind_Path_Name_Attribute - | Iir_Kind_Instance_Name_Attribute => - Free_Iir (Name); - return Res; - when Iir_Kinds_External_Name => - pragma Assert (Name = Res); - return Res; - when Iir_Kind_Psl_Expression => - return Res; - when Iir_Kind_Psl_Declaration => - return Name; - when Iir_Kind_Element_Declaration => - -- Certainly an error! - return Name; - when Iir_Kind_Error => - return Name; - when others => - Error_Kind ("finish_sem_name_1", Res); - end case; - - -- The name has a prefix, finish it. - Prefix := Get_Prefix (Res); - Name_Prefix := Get_Prefix (Name); - Prefix := Finish_Sem_Name_1 (Name_Prefix, Prefix); - Set_Prefix (Res, Prefix); - - case Get_Kind (Res) is - when Iir_Kind_Indexed_Name => - Finish_Sem_Indexed_Name (Res); - Free_Parenthesis_Name (Name, Res); - when Iir_Kind_Slice_Name => - Finish_Sem_Slice_Name (Res); - Free_Parenthesis_Name (Name, Res); - when Iir_Kind_Selected_Element => - pragma Assert (Get_Kind (Name) = Iir_Kind_Selected_Name); - Xref_Ref (Res, Get_Named_Entity (Res)); - Set_Name_Staticness (Res, Get_Name_Staticness (Prefix)); - Set_Expr_Staticness (Res, Get_Expr_Staticness (Prefix)); - Set_Base_Name (Res, Get_Base_Name (Prefix)); - Free_Iir (Name); - when Iir_Kind_Dereference => - pragma Assert (Get_Kind (Name) = Iir_Kind_Selected_By_All_Name); - Finish_Sem_Dereference (Res); - Free_Iir (Name); - when Iir_Kinds_Signal_Value_Attribute - | Iir_Kind_Subtype_Attribute => - Sem_Name_Free_Result (Name, Res); - when others => - Error_Kind ("finish_sem_name_1(2)", Res); - end case; - return Res; - end Finish_Sem_Name_1; - - function Finish_Sem_Name (Name : Iir; Res : Iir) return Iir is - begin - if Get_Kind (Res) /= Iir_Kind_Implicit_Dereference then - -- There is no corresponding name for implicit_dereference (because - -- it is implicit). - -- Free overload list (but keep RES interpretation) for other cases. - Free_Old_Entity_Name (Name, Res); - end if; - - return Finish_Sem_Name_1 (Name, Res); - end Finish_Sem_Name; - - function Finish_Sem_Name (Name : Iir) return Iir is - begin - return Finish_Sem_Name_1 (Name, Get_Named_Entity (Name)); - end Finish_Sem_Name; - - -- LRM93 6.2 - -- The evaluation of a simple name has no other effect than to determine - -- the named entity denoted by the name. - -- - -- NAME may be a simple name, a strig literal or a character literal. - -- GHDL: set interpretation of NAME (possibly an overload list) or - -- error_mark for unknown names. - -- If SOFT is TRUE, then no error message is reported in case of failure. - procedure Sem_Simple_Name (Name : Iir; Keep_Alias : Boolean; Soft : Boolean) - is - Id : constant Name_Id := Get_Identifier (Name); - Interpretation: Name_Interpretation_Type; - Res: Iir; - Res_List : Iir_List; - Res_It : List_Iterator; - N : Natural; - begin - Interpretation := Get_Interpretation (Id); - - if not Valid_Interpretation (Interpretation) then - -- Unknown name. - if not Soft then - Interpretation := Get_Interpretation_Raw (Id); - if Valid_Interpretation (Interpretation) - and then Is_Conflict_Declaration (Interpretation) - then - Error_Msg_Sem - (+Name, "no declaration for %i (due to conflicts)", +Name); - else - Error_Msg_Sem (+Name, "no declaration for %i", +Name); - end if; - end if; - Res := Error_Mark; - elsif not Valid_Interpretation (Get_Next_Interpretation (Interpretation)) - then - -- One simple interpretation. - Res := Get_Declaration (Interpretation); - - -- For a design unit, return the library unit - if Get_Kind (Res) = Iir_Kind_Design_Unit then - -- FIXME: should replace interpretation ? - Load_Design_Unit (Res, Name); - Sem.Add_Dependence (Res); - Res := Get_Library_Unit (Res); - end if; - - -- Check visibility. - if not Get_Visible_Flag (Res) then - if Flag_Relaxed_Rules - and then Get_Kind (Res) in Iir_Kinds_Object_Declaration - and then Valid_Interpretation (Get_Under_Interpretation (Id)) - then - Res := Get_Declaration (Get_Under_Interpretation (Id)); - else - if not Soft then - Error_Msg_Sem (+Name, "%n is not visible here", +Res); - end if; - -- Even if a named entity was found, return an error_mark. - -- Indeed, the named entity found is certainly the one being - -- analyzed, and the analyze may be uncomplete. - Res := Error_Mark; - end if; - end if; - - if not Keep_Alias - and then Get_Kind (Res) = Iir_Kind_Non_Object_Alias_Declaration - then - Set_Alias_Declaration (Name, Res); - Res := Get_Named_Entity (Get_Name (Res)); - end if; - else - -- Name is overloaded. - Res_List := Create_Iir_List; - N := 0; - -- The SEEN_FLAG is used to get only one meaning which can be reached - -- through several paths (such as aliases). - while Valid_Interpretation (Interpretation) loop - if Keep_Alias then - Res := Get_Declaration (Interpretation); - else - Res := Get_Non_Alias_Declaration (Interpretation); - end if; - if not Get_Seen_Flag (Res) then - Set_Seen_Flag (Res, True); - N := N + 1; - Append_Element (Res_List, Res); - end if; - Interpretation := Get_Next_Interpretation (Interpretation); - end loop; - - -- FIXME: there can be only one element (a function and its alias!). - - -- Clear SEEN_FLAG. - Res_It := List_Iterate (Res_List); - while Is_Valid (Res_It) loop - Set_Seen_Flag (Get_Element (Res_It), False); - Next (Res_It); - end loop; - - Res := Create_Overload_List (Res_List); - end if; - - Set_Named_Entity (Name, Res); - end Sem_Simple_Name; - - -- LRM93 §6.3 - -- Selected Names. - procedure Sem_Selected_Name - (Name: Iir; Keep_Alias : Boolean := False; Soft : Boolean := False) - is - Suffix : constant Name_Id := Get_Identifier (Name); - Prefix_Name : constant Iir := Get_Prefix (Name); - Prefix_Loc : constant Location_Type := Get_Location (Prefix_Name); - - Prefix: Iir; - Res : Iir; - - -- Analyze SUB_NAME.NAME as an expanded name (ie, NAME is declared - -- within SUB_NAME). This is possible only if the expanded name is - -- analyzed within the context of SUB_NAME. - procedure Sem_As_Expanded_Name (Sub_Name : Iir) - is - Sub_Res : Iir; - begin - if Get_Is_Within_Flag (Sub_Name) then - Sub_Res := Find_Declarations_In_List (Sub_Name, Name, Keep_Alias); - if Sub_Res /= Null_Iir then - Add_Result (Res, Sub_Res); - end if; - end if; - end Sem_As_Expanded_Name; - - -- LRM93 6.3 - -- For a selected name that is used to denote a record element, - -- the suffix must be a simple name denoting an element of a - -- record object or value. The prefix must be appropriate for the - -- type of this object or value. - -- - -- Analyze SUB_NAME.NAME as a selected element. - procedure Sem_As_Selected_Element (Sub_Name : Iir) - is - Name_Type : Iir; - Ptr_Type : Iir; - Rec_El : Iir; - R : Iir; - Se : Iir; - begin - Name_Type := Get_Type (Sub_Name); - if Kind_In (Name_Type, Iir_Kind_Access_Type_Definition, - Iir_Kind_Access_Subtype_Definition) - then - Ptr_Type := Name_Type; - Name_Type := Get_Designated_Type (Name_Type); - else - Ptr_Type := Null_Iir; - end if; - - -- Only records have elements. - if not Kind_In (Name_Type, Iir_Kind_Record_Type_Definition, - Iir_Kind_Record_Subtype_Definition) - then - return; - end if; - - Rec_El := Find_Name_In_Flist - (Get_Elements_Declaration_List (Name_Type), Suffix); - if Rec_El = Null_Iir then - -- No such element in the record type. - return; - end if; - - if not Maybe_Function_Call (Sub_Name) then - return; - end if; - - R := Maybe_Insert_Function_Call (Prefix_Name, Sub_Name); - R := Maybe_Insert_Dereference (R, Ptr_Type); - - Se := Create_Iir (Iir_Kind_Selected_Element); - Location_Copy (Se, Name); - Set_Prefix (Se, R); - Set_Type (Se, Get_Type (Rec_El)); - Set_Identifier (Se, Suffix); - Set_Named_Entity (Se, Rec_El); - Set_Base_Name (Se, Get_Object_Prefix (R, False)); - Add_Result (Res, Se); - end Sem_As_Selected_Element; - - procedure Error_Selected_Element (Prefix_Type : Iir) - is - Base_Type : Iir; - begin - Base_Type := Get_Base_Type (Prefix_Type); - if Get_Kind (Base_Type) = Iir_Kind_Access_Type_Definition then - Base_Type := Get_Base_Type (Get_Designated_Type (Base_Type)); - end if; - if Get_Kind (Base_Type) /= Iir_Kind_Record_Type_Definition then - Error_Msg_Sem - (+Name, "%n does not designate a record", +Prefix); - else - Error_Msg_Sem - (+Name, "no element %i in %n", (+Suffix, +Base_Type)); - end if; - end Error_Selected_Element; - - procedure Sem_As_Protected_Item (Sub_Name : Iir) - is - Prot_Type : constant Iir := Get_Type (Sub_Name); - Method : Iir; - begin - -- LRM98 12.3 Visibility - -- s) For a subprogram declared immediately within a given protected - -- type declaration: at the place of the suffix in a selected - -- name whose prefix denotes an object of the protected type. - Method := Get_Declaration_Chain (Prot_Type); - while Method /= Null_Iir loop - case Get_Kind (Method) is - when Iir_Kind_Function_Declaration | - Iir_Kind_Procedure_Declaration => - if Get_Identifier (Method) = Suffix then - Add_Result (Res, Method); - end if; - when Iir_Kind_Attribute_Specification - | Iir_Kind_Use_Clause => - null; - when others => - -- Declarations not allowed in protected types. - -- Just ignore them. - null; - end case; - Method := Get_Chain (Method); - end loop; - end Sem_As_Protected_Item; - - procedure Error_Protected_Item (Prot_Type : Iir) is - begin - Error_Msg_Sem (+Name, "no method %i in %n", (+Suffix, +Prot_Type)); - end Error_Protected_Item; - - -- Emit an error message if unit is not found in library LIB. - procedure Error_Unit_Not_Found (Lib : Iir) - is - use Std_Names; - begin - Error_Msg_Sem (+Name, "unit %i not found in %n", (+Suffix, +Lib)); - - -- Give an advice for common synopsys packages. - if Get_Identifier (Lib) = Name_Ieee then - if Suffix = Name_Std_Logic_Arith - or else Suffix = Name_Std_Logic_Signed - or else Suffix = Name_Std_Logic_Unsigned - then - Error_Msg_Sem - (+Name, - " (use --ieee=synopsys for non-standard synopsys packages)"); - elsif Suffix = Name_Std_Logic_Textio then - Error_Msg_Sem - (+Name, " (use --ieee=synopsys or --std=08 for " - & "this non-standard synopsys package)"); - end if; - end if; - end Error_Unit_Not_Found; - begin - -- Analyze prefix. - if Soft then - Sem_Name_Soft (Prefix_Name); - else - Sem_Name (Prefix_Name); - end if; - Prefix := Get_Named_Entity (Prefix_Name); - if Is_Error (Prefix) then - Set_Named_Entity (Name, Prefix); - return; - end if; - - Res := Null_Iir; - - case Get_Kind (Prefix) is - when Iir_Kind_Overload_List => - -- LRM93 6.3 - -- If, according to the visibility rules, there is at - -- least one possible interpretation of the prefix of a - -- selected name as the name of an enclosing entity - -- interface, architecture, subprogram, block statement, - -- process statement, generate statement, or loop - -- statement, then the only interpretations considered are - -- those of the immediately preceding paragraph. - -- - -- In this case, the selected name is always interpreted - -- as an expanded name. In particular, no interpretations - -- of the prefix as a function call are considered. - declare - Prefix_List : Iir_List; - It : List_Iterator; - El : Iir; - begin - -- So, first try as expanded name. - Prefix_List := Get_Overload_List (Prefix); - It := List_Iterate (Prefix_List); - while Is_Valid (It) loop - El := Get_Element (It); - case Get_Kind (El) is - when Iir_Kind_Function_Call - | Iir_Kind_Selected_Element => - -- Not an expanded name. - null; - when others => - Sem_As_Expanded_Name (El); - end case; - Next (It); - end loop; - - -- If no expanded name are found, try as selected element. - if Res = Null_Iir then - It := List_Iterate (Prefix_List); - while Is_Valid (It) loop - El := Get_Element (It); - case Get_Kind (El) is - when Iir_Kind_Procedure_Declaration => - -- A procedure cannot be the prefix of a selected - -- element. - null; - when others => - Sem_As_Selected_Element (El); - end case; - Next (It); - end loop; - end if; - end; - if Res = Null_Iir and then not Soft then - Error_Msg_Sem - (+Name, "no suffix %i for overloaded selected name", +Suffix); - end if; - when Iir_Kind_Library_Declaration => - -- LRM93 6.3 - -- An expanded name denotes a primary unit constained in a design - -- library if the prefix denotes the library and the suffix is the - -- simple name if a primary unit whose declaration is contained - -- in that library. - -- An expanded name is not allowed for a secondary unit, - -- particularly for an architecture body. - -- GHDL: FIXME: error message more explicit - Res := Load_Primary_Unit (Prefix, Suffix, Name); - if Res /= Null_Iir then - Sem.Add_Dependence (Res); - Res := Get_Library_Unit (Res); - elsif not Soft then - Error_Unit_Not_Found (Prefix); - end if; - when Iir_Kind_Process_Statement - | Iir_Kind_Procedure_Declaration - | Iir_Kind_Sensitized_Process_Statement - | Iir_Kind_Architecture_Body - | Iir_Kind_Entity_Declaration - | Iir_Kind_Package_Declaration - | Iir_Kind_Package_Instantiation_Declaration - | Iir_Kind_Interface_Package_Declaration - | Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement - | Iir_Kind_Block_Statement - | Iir_Kind_For_Loop_Statement => - -- LRM93 §6.3 - -- An expanded name denotes a named entity declared immediatly - -- within a named construct if the prefix that is an entity - -- interface, an architecture, a subprogram, a block statement, - -- a process statement, a generate statement, or a loop - -- statement, and the suffix is the simple name, character - -- literal, or operator symbol of an named entity whose - -- declaration occurs immediatly within that construct. - if Get_Kind (Prefix) = Iir_Kind_Design_Unit then - Load_Design_Unit (Prefix, Name); - Sem.Add_Dependence (Prefix); - Prefix := Get_Library_Unit (Prefix); - -- Modified only for xrefs, since a design_unit points to - -- the first context clause, while a library unit points to - -- the identifier. - Set_Named_Entity (Get_Prefix (Name), Prefix); - end if; - - Res := Find_Declarations_In_List (Prefix, Name, Keep_Alias); - - if Res = Null_Iir then - if not Soft then - Error_Msg_Sem - (+Name, "no declaration for %i in %n", (+Suffix, +Prefix)); - end if; - else - -- LRM93 6.3 - -- This form of expanded name is only allowed within the - -- construct itself. - -- FIXME: LRM08 12.3 Visibility h) - if not Kind_In (Prefix, - Iir_Kind_Package_Declaration, - Iir_Kind_Package_Instantiation_Declaration) - and then not Get_Is_Within_Flag (Prefix) - then - if not Soft then - Error_Msg_Sem - (+Prefix_Loc, - "an expanded name is only allowed " - & "within the construct"); - end if; - -- Hum, keep res. - elsif Get_Kind (Prefix) = Iir_Kind_Package_Declaration - and then not Get_Is_Within_Flag (Prefix) - and then Is_Uninstantiated_Package (Prefix) - then - -- LRM08 12.3 f) Visibility - -- For a declaration given in a package declaration, other - -- than in a package declaration that defines an - -- uninstantiated package: [...] - if not Soft then - Error_Msg_Sem - (+Prefix_Loc, - "cannot refer a declaration in an " - & "uninstantiated package"); - end if; - end if; - end if; - when Iir_Kind_Function_Declaration => - Sem_As_Expanded_Name (Prefix); - if Res = Null_Iir then - Sem_As_Selected_Element (Prefix); - end if; - if Res = Null_Iir and then not Soft then - Error_Selected_Element (Get_Return_Type (Prefix)); - end if; - when Iir_Kinds_Object_Declaration - | Iir_Kind_Indexed_Name - | Iir_Kind_Selected_Element - | Iir_Kind_Dereference - | Iir_Kind_Implicit_Dereference - | Iir_Kind_Attribute_Value - | Iir_Kind_Function_Call => - if Get_Kind (Get_Type (Prefix)) - = Iir_Kind_Protected_Type_Declaration - then - Sem_As_Protected_Item (Prefix); - if Res = Null_Iir and then not Soft then - Error_Protected_Item (Prefix); - end if; - else - Sem_As_Selected_Element (Prefix); - if Res = Null_Iir and then not Soft then - Error_Selected_Element (Get_Type (Prefix)); - end if; - end if; - when Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration - | Iir_Kind_Concurrent_Procedure_Call_Statement - | Iir_Kind_Component_Instantiation_Statement - | Iir_Kind_Slice_Name - | Iir_Kind_Procedure_Call_Statement - | Iir_Kind_Attribute_Declaration - | Iir_Kind_Type_Conversion => - if not Soft then - Error_Msg_Sem - (+Prefix_Loc, "%n cannot be selected by name", +Prefix); - end if; - - when Iir_Kind_Error => - -- Let's propagate the error. - null; - - when others => - Error_Kind ("sem_selected_name(2)", Prefix); - end case; - if Res = Null_Iir then - Res := Error_Mark; - end if; - Set_Named_Entity (Name, Res); - end Sem_Selected_Name; - - -- If ASSOC_LIST has one element, which is an expression without formal, - -- return the actual, else return NULL_IIR. - function Get_One_Actual (Assoc_Chain : Iir) return Iir - is - Assoc : Iir; - begin - -- Only one actual ? - if Assoc_Chain = Null_Iir or else Get_Chain (Assoc_Chain) /= Null_Iir - then - return Null_Iir; - end if; - - -- Not 'open' association element ? - Assoc := Assoc_Chain; - if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Expression then - return Null_Iir; - end if; - - -- Not an association (ie no formal) ? - if Get_Formal (Assoc) /= Null_Iir then - return Null_Iir; - end if; - - return Get_Actual (Assoc); - end Get_One_Actual; - - function Slice_Or_Index (Actual : Iir) return Iir_Kind is - begin - -- But it may be a slice name. - case Get_Kind (Actual) is - when Iir_Kind_Range_Array_Attribute - | Iir_Kind_Reverse_Range_Array_Attribute - | Iir_Kind_Subtype_Declaration - | Iir_Kind_Type_Declaration - | Iir_Kind_Range_Expression => - return Iir_Kind_Slice_Name; - when others => - if Is_Range_Attribute_Name (Actual) then - return Iir_Kind_Slice_Name; - end if; - end case; - -- By default, this is an indexed name. - return Iir_Kind_Indexed_Name; - end Slice_Or_Index; - - -- Check whether association chain ASSOCS may be interpreted as indexes. - function Index_Or_Not (Assocs : Iir) return Iir_Kind - is - El : Iir; - begin - El := Assocs; - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Association_Element_By_Expression => - if Get_Formal (El) /= Null_Iir then - return Iir_Kind_Error; - end if; - when others => - -- Only expression are allowed. - return Iir_Kind_Error; - end case; - El := Get_Chain (El); - end loop; - return Iir_Kind_Indexed_Name; - end Index_Or_Not; - - function Sem_Index_Specification (Name : Iir_Parenthesis_Name; Itype : Iir) - return Iir - is - Actual : Iir; - Kind : Iir_Kind; - Res : Iir; - begin - -- FIXME: reuse Sem_Name for the whole analysis ? - - Actual := Get_One_Actual (Get_Association_Chain (Name)); - if Actual = Null_Iir then - Error_Msg_Sem (+Name, "only one index specification is allowed"); - return Null_Iir; - end if; - case Get_Kind (Actual) is - when Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name => - Sem_Name (Actual); - Kind := Slice_Or_Index (Get_Named_Entity (Actual)); - -- FIXME: analyze to be finished. - --Maybe_Finish_Sem_Name (Actual); - when others => - Kind := Slice_Or_Index (Actual); - end case; - - Res := Create_Iir (Kind); - Location_Copy (Res, Name); - case Kind is - when Iir_Kind_Indexed_Name => - Actual := Sem_Expression (Actual, Itype); - if Actual = Null_Iir then - return Null_Iir; - end if; - Check_Read (Actual); - if Get_Expr_Staticness (Actual) < Globally then - Error_Msg_Sem (+Name, "index must be a static expression"); - end if; - Set_Index_List (Res, Create_Iir_Flist (1)); - Set_Nth_Element (Get_Index_List (Res), 0, Actual); - when Iir_Kind_Slice_Name => - Actual := Sem_Discrete_Range_Expression (Actual, Itype, False); - if Actual = Null_Iir then - return Null_Iir; - end if; - if Get_Expr_Staticness (Actual) < Globally then - Error_Msg_Sem (+Name, "index must be a static expression"); - end if; - Set_Suffix (Res, Actual); - when others => - raise Internal_Error; - end case; - Free_Parenthesis_Name (Name, Res); - return Res; - end Sem_Index_Specification; - - procedure Sem_Parenthesis_Name (Name : Iir_Parenthesis_Name) - is - Prefix_Name : constant Iir := Get_Prefix (Name); - Prefix: Iir; - Res : Iir; - Res_Prefix : Iir; - Assoc_Chain : Iir; - - Slice_Index_Kind : Iir_Kind; - - -- If FINISH is TRUE, then display error message in case of error. - function Sem_As_Indexed_Or_Slice_Name (Sub_Name : Iir; Finish : Boolean) - return Iir - is - Base_Type : Iir; - Ptr_Type : Iir; - P : Iir; - R : Iir; - begin - if Slice_Index_Kind = Iir_Kind_Error then - if Finish then - Error_Msg_Sem (+Name, "prefix is not a function name"); - end if; - -- No way. - return Null_Iir; - end if; - - -- Only values can be indexed or sliced. - -- Catch errors such as slice of a type conversion. - if Name_To_Value (Sub_Name) = Null_Iir - and then not Is_Function_Declaration (Sub_Name) - then - if Finish then - Error_Msg_Sem - (+Name, "prefix is not an array value (found %n)", +Sub_Name); - end if; - return Null_Iir; - end if; - - -- Extract type of prefix, handle possible implicit deference. - Base_Type := Get_Base_Type (Get_Type (Sub_Name)); - if Get_Kind (Base_Type) = Iir_Kind_Access_Type_Definition then - Ptr_Type := Base_Type; - Base_Type := Get_Base_Type (Get_Designated_Type (Base_Type)); - else - Ptr_Type := Null_Iir; - end if; - - if Get_Kind (Base_Type) /= Iir_Kind_Array_Type_Definition then - if Finish and then not Is_Error (Base_Type) then - Error_Msg_Sem (+Name, "type of prefix is not an array"); - end if; - return Null_Iir; - end if; - if Get_Nbr_Elements (Get_Index_Subtype_List (Base_Type)) /= - Get_Chain_Length (Assoc_Chain) - then - if Finish then - Error_Msg_Sem - (+Name, "number of indexes mismatches array dimension"); - end if; - return Null_Iir; - end if; - - -- For indexed names, discard type incompatibilities between indexes - -- and array type indexes. - -- The FINISH = True case will be handled by Finish_Sem_Indexed_Name. - if Slice_Index_Kind = Iir_Kind_Indexed_Name and then not Finish then - declare - Type_Index_List : constant Iir_Flist := - Get_Index_Subtype_List (Base_Type); - Type_Index : Iir; - Assoc : Iir; - begin - Assoc := Assoc_Chain; - for I in Natural loop - -- Assoc and Type_Index_List have the same length as this - -- was checked just above. - exit when Assoc = Null_Iir; - if Get_Kind (Assoc) - /= Iir_Kind_Association_Element_By_Expression - then - return Null_Iir; - end if; - Type_Index := Get_Index_Type (Type_Index_List, I); - if Is_Expr_Compatible (Type_Index, Get_Actual (Assoc)) - = Not_Compatible - then - return Null_Iir; - end if; - Assoc := Get_Chain (Assoc); - end loop; - end; - end if; - - if not Maybe_Function_Call (Sub_Name) then - if Finish then - Error_Msg_Sem (+Name, "missing parameters for function call"); - end if; - return Null_Iir; - end if; - - P := Maybe_Insert_Function_Call (Prefix_Name, Sub_Name); - P := Maybe_Insert_Dereference (P, Ptr_Type); - - R := Create_Iir (Slice_Index_Kind); - Location_Copy (R, Name); - Set_Prefix (R, P); - Set_Base_Name (R, Get_Object_Prefix (P)); - - case Slice_Index_Kind is - when Iir_Kind_Slice_Name => - Set_Suffix (R, Get_Actual (Assoc_Chain)); - Set_Type (R, Get_Base_Type (Get_Type (P))); - when Iir_Kind_Indexed_Name => - declare - Idx_El : Iir; - Idx_List : Iir_List; - begin - Idx_List := Create_Iir_List; - Idx_El := Assoc_Chain; - while Idx_El /= Null_Iir loop - Append_Element (Idx_List, Get_Actual (Idx_El)); - Idx_El := Get_Chain (Idx_El); - end loop; - Set_Index_List (R, List_To_Flist (Idx_List)); - end; - Set_Type (R, Get_Element_Subtype (Base_Type)); - when others => - raise Internal_Error; - end case; - - return R; - end Sem_As_Indexed_Or_Slice_Name; - - -- Sem parenthesis name when the prefix is a function declaration. - -- Can be either a function call (and the expression is the actual) or - -- a slice/index of the result of a call without actual. - procedure Sem_Parenthesis_Function (Sub_Name : Iir) - is - Used : Boolean; - R : Iir; - Match : Compatibility_Level; - Call : Iir; - begin - Used := False; - - -- A function call. - if Is_Function_Declaration (Sub_Name) then - Sem_Association_Chain - (Get_Interface_Declaration_Chain (Sub_Name), - Assoc_Chain, False, Missing_Parameter, Name, Match); - if Match /= Not_Compatible then - Call := Sem_As_Function_Call - (Prefix_Name, Sub_Name, Assoc_Chain); - Add_Result (Res, Call); - Add_Result (Res_Prefix, Sub_Name); - Used := True; - end if; - end if; - - -- A slice/index of a call (without parameters). - if not Is_Procedure_Declaration (Sub_Name) then - R := Sem_As_Indexed_Or_Slice_Name (Sub_Name, False); - if R /= Null_Iir then - Add_Result (Res, R); - Add_Result (Res_Prefix, Sub_Name); - Used := True; - end if; - end if; - - if not Used then - Sem_Name_Free_Result (Sub_Name, Null_Iir); - end if; - end Sem_Parenthesis_Function; - - procedure Error_Parenthesis_Function (Spec : Iir) - is - Match : Compatibility_Level; - begin - Error_Msg_Sem (+Name, "cannot match %n with actuals", +Prefix); - -- Display error message. - Sem_Association_Chain - (Get_Interface_Declaration_Chain (Spec), - Assoc_Chain, True, Missing_Parameter, Name, Match); - end Error_Parenthesis_Function; - - Actual : Iir; - Actual_Expr : Iir; - begin - -- The prefix is a function name, a type mark or an array. - Sem_Name (Prefix_Name); - Prefix := Get_Named_Entity (Prefix_Name); - if Prefix = Error_Mark then - Set_Named_Entity (Name, Error_Mark); - return; - end if; - Res := Null_Iir; - - Assoc_Chain := Get_Association_Chain (Name); - Actual := Get_One_Actual (Assoc_Chain); - - if Kind_In (Prefix, - Iir_Kind_Type_Declaration, Iir_Kind_Subtype_Declaration) - then - -- A type conversion. The prefix is a type mark. - declare - In_Formal : Boolean; - begin - if Actual = Null_Iir then - -- More than one actual. Keep only the first. - Error_Msg_Sem - (+Name, "type conversion allows only one expression"); - In_Formal := False; - else - In_Formal := Get_In_Formal_Flag (Assoc_Chain); - end if; - - -- This is certainly the easiest case: the prefix is not - -- overloaded, so the result can be computed. - Set_Named_Entity - (Name, Sem_Type_Conversion (Name, Prefix, Actual, In_Formal)); - end; - return; - end if; - - -- Select between slice or indexed name. - Actual_Expr := Null_Iir; - if Actual /= Null_Iir then - -- Only one actual: can be a slice or an index - if Get_Kind (Actual) in Iir_Kinds_Name - or else Get_Kind (Actual) = Iir_Kind_Attribute_Name - then - -- Maybe a discrete range name. - Sem_Name (Actual); - Actual_Expr := Get_Named_Entity (Actual); - if Actual_Expr = Error_Mark then - Set_Named_Entity (Name, Actual_Expr); - return; - end if; - -- Decides between sliced or indexed name to actual. - Slice_Index_Kind := Slice_Or_Index (Actual_Expr); - elsif Get_Kind (Actual) = Iir_Kind_Range_Expression then - -- This can only be a slice. - Slice_Index_Kind := Iir_Kind_Slice_Name; - -- Actual_Expr := - -- Sem_Discrete_Range_Expression (Actual, Null_Iir, False); - -- Set_Actual (Assoc_Chain, Actual_Expr); - else - -- Any other expression: an indexed name. - Slice_Index_Kind := Iir_Kind_Indexed_Name; - end if; - else - -- More than one actual: an indexed name. - - -- FIXME: improve error message for multi-dim slice ? - Slice_Index_Kind := Index_Or_Not (Assoc_Chain); - end if; - - -- Analyze actuals if not already done (done for slices). - if Slice_Index_Kind /= Iir_Kind_Slice_Name then - if Sem_Actual_Of_Association_Chain (Assoc_Chain) = False then - Actual := Null_Iir; - else - Actual := Get_One_Actual (Assoc_Chain); - end if; - end if; - - Res_Prefix := Null_Iir; - - case Get_Kind (Prefix) is - when Iir_Kind_Overload_List => - declare - El : Iir; - Prefix_List : Iir_List; - It : List_Iterator; - begin - Prefix_List := Get_Overload_List (Prefix); - It := List_Iterate (Prefix_List); - while Is_Valid (It) loop - El := Get_Element (It); - Sem_Parenthesis_Function (El); - Next (It); - end loop; - -- Some prefixes may have been removed, replace with the - -- rebuilt prefix list. - Free_Overload_List (Prefix); - Set_Named_Entity (Prefix_Name, Res_Prefix); - end; - if Res = Null_Iir then - Error_Msg_Sem - (+Name, "no overloaded function found matching %n", - +Prefix_Name); - end if; - when Iir_Kind_Function_Declaration - | Iir_Kind_Interface_Function_Declaration => - Sem_Parenthesis_Function (Prefix); - Set_Named_Entity (Prefix_Name, Res_Prefix); - if Res = Null_Iir then - Error_Parenthesis_Function (Prefix); - end if; - - when Iir_Kinds_Object_Declaration - | Iir_Kind_Indexed_Name - | Iir_Kind_Slice_Name - | Iir_Kind_Dereference - | Iir_Kind_Implicit_Dereference - | Iir_Kind_Selected_Element - | Iir_Kind_Attribute_Value - | Iir_Kind_Simple_Name_Attribute - | Iir_Kind_Function_Call => - Add_Result (Res, Sem_As_Indexed_Or_Slice_Name (Prefix, True)); - - when Iir_Kinds_Array_Attribute => - if Actual /= Null_Iir then - Finish_Sem_Array_Attribute (Prefix_Name, Prefix, Actual); - Set_Named_Entity (Name, Prefix); - else - Error_Msg_Sem (+Name, "bad attribute parameter"); - Set_Named_Entity (Name, Error_Mark); - end if; - return; - - when Iir_Kinds_Scalar_Type_Attribute - | Iir_Kind_Image_Attribute - | Iir_Kind_Value_Attribute => - if Get_Parameter (Prefix) /= Null_Iir then - -- Attribute already has a parameter, the expression - -- is either a slice or an index. - Add_Result - (Res, Sem_As_Indexed_Or_Slice_Name (Prefix, True)); - elsif Actual /= Null_Iir then - Finish_Sem_Scalar_Type_Attribute (Prefix_Name, Prefix, Actual); - Set_Named_Entity (Name, Prefix); - return; - else - Error_Msg_Sem (+Name, "bad attribute parameter"); - Set_Named_Entity (Name, Error_Mark); - return; - end if; - - when Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration => - Error_Msg_Sem - (+Name, "subprogram name is a type mark (missing apostrophe)"); - - when Iir_Kind_Stable_Attribute - | Iir_Kind_Quiet_Attribute - | Iir_Kind_Delayed_Attribute => - if Actual /= Null_Iir then - Finish_Sem_Signal_Attribute (Prefix_Name, Prefix, Actual); - Set_Named_Entity (Name, Prefix); - else - Error_Msg_Sem (+Name, "bad attribute parameter"); - Set_Named_Entity (Name, Error_Mark); - end if; - return; - - when Iir_Kind_Procedure_Declaration - | Iir_Kind_Interface_Procedure_Declaration => - Error_Msg_Sem (+Name, "cannot call %n in an expression", - +Prefix); - - when Iir_Kinds_Process_Statement - | Iir_Kind_Component_Declaration - | Iir_Kind_Type_Conversion - | Iir_Kind_Unit_Declaration - | Iir_Kind_Enumeration_Literal - | Iir_Kind_Attribute_Declaration => - Error_Msg_Sem (+Name, "%n cannot be indexed or sliced", +Prefix); - Res := Null_Iir; - - when Iir_Kind_Psl_Declaration - | Iir_Kind_Psl_Endpoint_Declaration => - Res := Sem_Psl.Sem_Psl_Name (Name); - - when Iir_Kinds_Library_Unit => - Error_Msg_Sem (+Name, "function name is a design unit"); - - when Iir_Kind_Error => - -- Continue with the error. - Res := Prefix; - - when others => - Error_Kind ("sem_parenthesis_name", Prefix); - end case; - - if Res = Null_Iir then - Res := Error_Mark; - end if; - Set_Named_Entity (Name, Res); - end Sem_Parenthesis_Name; - - procedure Sem_Selected_By_All_Name (Name : Iir_Selected_By_All_Name) - is - Prefix : Iir; - Prefix_Name : Iir; - Res : Iir; - - procedure Sem_As_Selected_By_All_Name (Sub_Name : Iir) - is - Base_Type : Iir; - R, R1 : Iir; - begin - -- Only accept prefix of access type. - Base_Type := Get_Base_Type (Get_Type (Sub_Name)); - if Get_Kind (Base_Type) /= Iir_Kind_Access_Type_Definition then - return; - end if; - - if not Maybe_Function_Call (Sub_Name) then - return; - end if; - - R1 := Maybe_Insert_Function_Call (Get_Prefix (Name), Sub_Name); - - R := Create_Iir (Iir_Kind_Dereference); - Location_Copy (R, Name); - Set_Prefix (R, R1); - -- FIXME: access subtype. - Set_Type (R, Get_Designated_Type (Base_Type)); - Add_Result (Res, R); - end Sem_As_Selected_By_All_Name; - begin - Prefix := Get_Prefix (Name); - Sem_Name (Prefix); - Prefix_Name := Prefix; - Prefix := Get_Named_Entity (Prefix); - if Prefix = Null_Iir then - return; - end if; - Res := Null_Iir; - - case Get_Kind (Prefix) is - when Iir_Kind_Overload_List => - declare - Prefix_List : constant Iir_List := Get_Overload_List (Prefix); - It : List_Iterator; - begin - It := List_Iterate (Prefix_List); - while Is_Valid (It) loop - Sem_As_Selected_By_All_Name (Get_Element (It)); - Next (It); - end loop; - end; - when Iir_Kinds_Object_Declaration - | Iir_Kind_Selected_Element - | Iir_Kind_Dereference - | Iir_Kind_Indexed_Name - | Iir_Kind_Function_Call => - Sem_As_Selected_By_All_Name (Prefix); - when Iir_Kind_Function_Declaration => - Prefix := Sem_As_Function_Call (Name => Prefix_Name, - Spec => Prefix, - Assoc_Chain => Null_Iir); - Sem_As_Selected_By_All_Name (Prefix); - when Iir_Kind_Error => - Set_Named_Entity (Name, Error_Mark); - return; - when others => - Error_Kind ("sem_selected_by_all_name", Prefix); - end case; - if Res = Null_Iir then - Error_Msg_Sem (+Name, "prefix type is not an access type"); - Res := Error_Mark; - end if; - Set_Named_Entity (Name, Res); - end Sem_Selected_By_All_Name; - - function Sem_Base_Attribute (Attr : Iir_Attribute_Name) return Iir - is - Prefix_Name : Iir; - Prefix_Type : Iir; - Res : Iir; - Base_Type : Iir; - Type_Decl : Iir; - begin - Prefix_Name := Finish_Sem_Name (Get_Prefix (Attr)); - Prefix_Type := Name_To_Type_Definition (Prefix_Name); - if not Is_Error (Prefix_Type) then - Base_Type := Get_Base_Type (Prefix_Type); - -- Get the first subtype. FIXME: ref? - Type_Decl := Get_Type_Declarator (Base_Type); - if Get_Kind (Type_Decl) = Iir_Kind_Anonymous_Type_Declaration then - Base_Type := Get_Subtype_Definition (Type_Decl); - end if; - else - Base_Type := Prefix_Type; - end if; - Res := Create_Iir (Iir_Kind_Base_Attribute); - Location_Copy (Res, Attr); - Set_Prefix (Res, Prefix_Name); - Set_Type (Res, Base_Type); - return Res; - end Sem_Base_Attribute; - - function Sem_User_Attribute (Attr : Iir_Attribute_Name) return Iir - is - Prefix_Name : constant Iir := Get_Prefix (Attr); - Prefix : Iir; - Value : Iir; - Attr_Id : Name_Id; - begin - Prefix := Get_Named_Entity (Prefix_Name); - - -- LRM93 6.6 - -- If the attribute name denotes an alias, then the attribute name - -- denotes an attribute of the aliased name and not the alias itself, - -- except when the attribute designator denotes any of the predefined - -- attributes 'simple_name, 'path_name, or 'instance_name. - if Get_Kind (Prefix) = Iir_Kind_Object_Alias_Declaration then - -- GHDL: according to 4.3.3, the name cannot be an alias. - Prefix := Strip_Denoting_Name (Get_Name (Prefix)); - end if; - - -- LRM93 6.6 - -- If the attribute designator denotes a user-defined attribute, the - -- prefix cannot denote a subelement or a slice of an object. - case Get_Kind (Prefix) is - when Iir_Kind_Selected_By_All_Name - | Iir_Kind_Selected_Name - | Iir_Kind_Indexed_Name - | Iir_Kind_Slice_Name => - Error_Msg_Sem (+Attr, "prefix of user defined attribute cannot be " - & "an object subelement"); - return Error_Mark; - when Iir_Kind_Dereference => - Error_Msg_Sem (+Attr, "prefix of user defined attribute cannot be " - & "an anonymous object"); - return Error_Mark; - when Iir_Kind_Attribute_Declaration => - Error_Msg_Sem (+Attr, "prefix of user defined attribute cannot be " - & "an attribute"); - return Error_Mark; - when Iir_Kind_Function_Call => - Error_Msg_Sem (+Attr, "invalid prefix or user defined attribute"); - return Error_Mark; - when Iir_Kinds_Object_Declaration - | Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration - | Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration - | Iir_Kind_Enumeration_Literal - | Iir_Kind_Unit_Declaration - | Iir_Kind_Component_Declaration - | Iir_Kinds_Library_Unit => - -- FIXME: to complete - null; - when Iir_Kinds_Sequential_Statement - | Iir_Kinds_Concurrent_Statement => - -- May appear textually before the statement. - Set_Is_Forward_Ref (Prefix_Name, True); - when others => - Error_Kind ("sem_user_attribute", Prefix); - end case; - - Attr_Id := Get_Identifier (Attr); - Value := Sem_Specs.Find_Attribute_Value (Prefix, Attr_Id); - if Value = Null_Iir then - Error_Msg_Sem (+Attr, "%n was not annotated with attribute %i", - (+Prefix, +Attr_Id)); - if Attr_Id = Std_Names.Name_First or Attr_Id = Std_Names.Name_Last - then - -- Nice (?) message for Ada users. - Error_Msg_Sem - (+Attr, "(you may use 'high, 'low, 'left or 'right attribute)"); - end if; - return Error_Mark; - end if; - - Xref_Ref (Attr, Value); - - return Value; - end Sem_User_Attribute; - - -- The prefix of scalar type attributes is a type name (or 'base), and - -- therefore isn't overloadable. So at the end of the function, the - -- analyze is finished. - function Sem_Scalar_Type_Attribute (Attr : Iir_Attribute_Name) - return Iir - is - use Std_Names; - Prefix_Name : constant Iir := Get_Prefix (Attr); - Id : constant Name_Id := Get_Identifier (Attr); - Prefix_Type : Iir; - Res : Iir; - begin - -- LRM93 14.1 - -- Prefix: Any discrete or physical type of subtype T. - Prefix_Type := - Name_To_Type_Definition (Name_To_Analyzed_Name (Prefix_Name)); - Set_Type (Prefix_Name, Prefix_Type); - if Is_Error (Prefix_Type) then - --Error_Msg_Sem - --(+Attr, "prefix of %i attribute must be a type", +Id); - return Error_Mark; - end if; - - case Id is - when Name_Image - | Name_Value => - if Get_Kind (Prefix_Type) - not in Iir_Kinds_Scalar_Type_And_Subtype_Definition - then - Error_Msg_Sem - (+Attr, "prefix of %i attribute must be a scalar type", - (1 => +Id), Cont => True); - Error_Msg_Sem - (+Attr, "found %n defined at %l", - (+Prefix_Type, +Prefix_Type)); - return Error_Mark; - end if; - when others => - case Get_Kind (Prefix_Type) is - when Iir_Kinds_Discrete_Type_Definition - | Iir_Kind_Physical_Subtype_Definition - | Iir_Kind_Physical_Type_Definition => - null; - when others => - Error_Msg_Sem - (+Attr, "prefix of %i" - & " attribute must be discrete or physical type", - (1 => +Id), Cont => True); - Error_Msg_Sem - (+Attr, "found %n defined at %l", - (+Prefix_Type, +Prefix_Type)); - return Error_Mark; - end case; - end case; - - -- Create the resulting node. - case Get_Identifier (Attr) is - when Name_Pos => - Res := Create_Iir (Iir_Kind_Pos_Attribute); - when Name_Val => - Res := Create_Iir (Iir_Kind_Val_Attribute); - when Name_Succ => - Res := Create_Iir (Iir_Kind_Succ_Attribute); - when Name_Pred => - Res := Create_Iir (Iir_Kind_Pred_Attribute); - when Name_Leftof => - Res := Create_Iir (Iir_Kind_Leftof_Attribute); - when Name_Rightof => - Res := Create_Iir (Iir_Kind_Rightof_Attribute); - when Name_Image => - Res := Create_Iir (Iir_Kind_Image_Attribute); - when Name_Value => - Res := Create_Iir (Iir_Kind_Value_Attribute); - when others => - raise Internal_Error; - end case; - Location_Copy (Res, Attr); - Set_Prefix (Res, Prefix_Name); - Set_Base_Name (Res, Res); - - case Get_Identifier (Attr) is - when Name_Pos => - -- LRM93 14.1 - -- Result type: universal_integer. - Set_Type (Res, Convertible_Integer_Type_Definition); - when Name_Val => - -- LRM93 14.1 - -- Result type: the base type of T - Set_Type (Res, Get_Base_Type (Prefix_Type)); - when Name_Succ - | Name_Pred - | Name_Leftof - | Name_Rightof => - -- LRM93 14.1 - -- Result type: the base type of T. - Set_Type (Res, Get_Base_Type (Prefix_Type)); - when Name_Image => - -- LRM93 14.1 - -- Result type: type string - Set_Type (Res, String_Type_Definition); - when Name_Value => - -- LRM93 14.1 - -- Result type: the base type of T. - Set_Type (Res, Get_Base_Type (Prefix_Type)); - when others => - raise Internal_Error; - end case; - return Res; - end Sem_Scalar_Type_Attribute; - - -- Analyze attributes whose prefix is a type or a subtype and result is - -- a value (not a function). - function Sem_Predefined_Type_Attribute (Attr : Iir_Attribute_Name) - return Iir - is - use Std_Names; - Prefix_Name : constant Iir := Get_Prefix (Attr); - Id : constant Name_Id := Get_Identifier (Attr); - Res : Iir; - Prefix : Iir; - Prefix_Type : Iir; - begin - case Id is - when Name_Left => - Res := Create_Iir (Iir_Kind_Left_Type_Attribute); - when Name_Right => - Res := Create_Iir (Iir_Kind_Right_Type_Attribute); - when Name_High => - Res := Create_Iir (Iir_Kind_High_Type_Attribute); - when Name_Low => - Res := Create_Iir (Iir_Kind_Low_Type_Attribute); - when Name_Ascending => - Res := Create_Iir (Iir_Kind_Ascending_Type_Attribute); - when Name_Range - | Name_Reverse_Range => - Error_Msg_Sem - (+Attr, - "prefix of range attribute must be an array type or object"); - return Error_Mark; - when others => - Error_Msg_Sem (+Attr, "attribute %i not valid on this type", +Id); - return Error_Mark; - end case; - Location_Copy (Res, Attr); - Set_Base_Name (Res, Res); - - Prefix := Get_Named_Entity (Prefix_Name); - case Get_Kind (Prefix) is - when Iir_Kind_Range_Array_Attribute - | Iir_Kind_Reverse_Range_Array_Attribute => - Prefix := Finish_Sem_Name (Prefix_Name, Prefix); - Prefix_Type := Get_Type (Prefix); - Set_Expr_Staticness (Res, Get_Expr_Staticness (Prefix)); - when Iir_Kind_Base_Attribute => - -- Base_Attribute is already finished. - pragma Assert (Get_Kind (Prefix_Name) = Iir_Kind_Attribute_Name); - Free_Iir (Prefix_Name); - Prefix_Type := Get_Type (Prefix); - Set_Expr_Staticness (Res, Get_Type_Staticness (Prefix_Type)); - when others => - Prefix := Sem_Type_Mark (Prefix_Name); - Prefix_Type := Get_Type (Prefix); - Set_Expr_Staticness (Res, Get_Type_Staticness (Prefix_Type)); - end case; - Set_Prefix (Res, Prefix); - - case Get_Identifier (Attr) is - when Name_Ascending => - -- LRM93 14.1 - -- Result Type: type boolean. - Set_Type (Res, Boolean_Type_Definition); - when others => - -- LRM 14.1 - -- Result Type: Same type as T. - Set_Type (Res, Prefix_Type); - end case; - return Res; - end Sem_Predefined_Type_Attribute; - - -- Called for attributes Length, Left, Right, High, Low, Range, - -- Reverse_Range, Ascending. - -- FIXME: handle overload - function Sem_Array_Attribute_Name (Attr : Iir_Attribute_Name) return Iir - is - use Std_Names; - Prefix_Name : constant Iir := Get_Prefix (Attr); - Prefix_Type : Iir; - Prefix : Iir; - Res : Iir; - Res_Type : Iir; - begin - Prefix := Get_Named_Entity (Prefix_Name); - - -- LRM93 14.1 - -- Prefix: Any prefix A that is appropriate for an array object, or an - -- alias thereof, or that denotes a constrained array subtype. - -- - -- LRM08 16.2 Predefined attributes. - -- Prefix of A'Left[(N)], A'Right[(N)]... : - -- Any prefix A that is appropriate for an array object, or an alias - -- thereof, or that denotes a constrained an array subtype whose index - -- ranges are defined by a constraint. - -- - -- GHDL: the prefix cannot be a function call, as the result is not - -- an object and it doesn't denote a subtype. References are: - -- - -- LRM08 6.4 Objects: - -- An object is a named entity [...] - -- In addition the following are objects, but are not named - -- entities[...] - -- - -- LRM08 6 Declarations - -- the name is said to denote the associated entity. - case Get_Kind (Prefix) is - when Iir_Kind_Dereference - | Iir_Kinds_Object_Declaration - | Iir_Kind_Function_Call - | Iir_Kind_Function_Declaration - | Iir_Kind_Selected_Element - | Iir_Kind_Indexed_Name - | Iir_Kind_Slice_Name - | Iir_Kind_Attribute_Value - | Iir_Kind_Image_Attribute => - -- FIXME: list of expr. - Prefix_Type := Get_Type (Prefix); - case Get_Kind (Prefix_Type) is - when Iir_Kind_Access_Type_Definition - | Iir_Kind_Access_Subtype_Definition => - declare - Designated_Type : Iir; - begin - Designated_Type := - Get_Designated_Type (Get_Base_Type (Prefix_Type)); - Prefix := Insert_Implicit_Dereference (Prefix, Attr); - Prefix_Type := Designated_Type; - end; - when Iir_Kinds_Array_Type_Definition => - null; - when others => - Error_Msg_Sem (+Attr, "object prefix must be an array"); - return Error_Mark; - end case; - when Iir_Kind_Subtype_Declaration - | Iir_Kind_Type_Declaration - | Iir_Kind_Base_Attribute - | Iir_Kind_Subtype_Attribute - | Iir_Kind_Element_Attribute => - Prefix_Type := Get_Type (Prefix); - if not Is_Fully_Constrained_Type (Prefix_Type) then - Error_Msg_Sem (+Attr, "prefix type is not constrained"); - -- We continue using the unconstrained array type. - -- At least, this type is valid; and even if the array was - -- constrained, the base type would be the same. - end if; - when Iir_Kind_Range_Array_Attribute - | Iir_Kind_Reverse_Range_Array_Attribute => - -- For names such as pfx'Range'Left. - -- Finish_Sem_Array_Attribute (Prefix_Name, Prefix, Null_Iir); - Prefix_Type := Get_Type (Prefix); - when Iir_Kind_Process_Statement => - Error_Msg_Sem - (+Attr, "%n is not an appropriate prefix for %i attribute", - (+Prefix, +Attr)); - return Error_Mark; - when others => - Error_Msg_Sem - (+Attr, "prefix must denote an array object or type"); - return Error_Mark; - end case; - - case Get_Kind (Prefix_Type) is - when Iir_Kinds_Scalar_Type_And_Subtype_Definition => - -- Note: prefix is a scalar type or subtype. - return Sem_Predefined_Type_Attribute (Attr); - when Iir_Kinds_Array_Type_Definition => - null; - when others => - Error_Msg_Sem (+Attr, "prefix of %i attribute must denote a " - & "constrained array subtype", +Attr); - return Error_Mark; - end case; - - -- Type of the attribute. This is correct unless there is a parameter, - -- and furthermore 'range and 'reverse_range has to be handled - -- specially because the result is a range and not a value. - Res_Type := Get_Index_Type (Get_Index_Subtype_List (Prefix_Type), 0); - - -- Create the node for the attribute. - case Get_Identifier (Attr) is - when Name_Left => - Res := Create_Iir (Iir_Kind_Left_Array_Attribute); - when Name_Right => - Res := Create_Iir (Iir_Kind_Right_Array_Attribute); - when Name_High => - Res := Create_Iir (Iir_Kind_High_Array_Attribute); - when Name_Low => - Res := Create_Iir (Iir_Kind_Low_Array_Attribute); - when Name_Range => - Res := Create_Iir (Iir_Kind_Range_Array_Attribute); - when Name_Reverse_Range => - Res := Create_Iir (Iir_Kind_Reverse_Range_Array_Attribute); - when Name_Length => - Res := Create_Iir (Iir_Kind_Length_Array_Attribute); - -- FIXME: Error if ambiguous - Res_Type := Convertible_Integer_Type_Definition; - when Name_Ascending => - Res := Create_Iir (Iir_Kind_Ascending_Array_Attribute); - -- FIXME: Error if ambiguous - Res_Type := Boolean_Type_Definition; - when others => - raise Internal_Error; - end case; - Location_Copy (Res, Attr); - Set_Prefix (Res, Prefix); - Set_Type (Res, Res_Type); - return Res; - end Sem_Array_Attribute_Name; - - -- For 'Subtype - function Sem_Subtype_Attribute (Attr : Iir_Attribute_Name) return Iir - is - Prefix_Name : constant Iir := Get_Prefix (Attr); - Prefix : Iir; - Prefix_Type : Iir; - Res : Iir; - begin - Prefix := Get_Named_Entity (Prefix_Name); - - -- LRM08 16.2 Predefined attributes - -- Prefix: Any prefix O that is appropriate for an object, or an alias - -- thereof - if Get_Kind (Prefix) not in Iir_Kinds_Object_Declaration then - Error_Msg_Sem (+Attr, "prefix must denote an object"); - return Error_Mark; - end if; - - Prefix_Type := Get_Type (Prefix); - - Res := Create_Iir (Iir_Kind_Subtype_Attribute); - Location_Copy (Res, Attr); - Set_Prefix (Res, Prefix); - Set_Type (Res, Prefix_Type); - - Set_Base_Name (Res, Get_Base_Name (Prefix_Name)); - Set_Name_Staticness (Res, Get_Name_Staticness (Prefix)); - Set_Type_Staticness (Res, Get_Type_Staticness (Prefix_Type)); - - return Res; - end Sem_Subtype_Attribute; - - function Sem_Signal_Signal_Attribute - (Attr : Iir_Attribute_Name; Kind : Iir_Kind) - return Iir - is - Res : Iir; - Prefix : Iir; - begin - Prefix := Get_Named_Entity (Get_Prefix (Attr)); - Res := Create_Iir (Kind); - Location_Copy (Res, Attr); - if Kind = Iir_Kind_Delayed_Attribute then - Set_Type (Res, Get_Type (Prefix)); - elsif Kind = Iir_Kind_Transaction_Attribute then - Set_Type (Res, Bit_Type_Definition); - else - Set_Type (Res, Boolean_Type_Definition); - end if; - Set_Base_Name (Res, Res); - - if Get_Kind (Prefix) = Iir_Kind_Interface_Signal_Declaration then - -- LRM93 2.1.1.2 / LRM08 4.2.2.3 - -- - -- It is an error if signal-valued attributes 'STABLE , 'QUIET, - -- 'TRANSACTION, and 'DELAYED of formal signal paramaters of any - -- mode are read within a subprogram. - case Get_Kind (Get_Parent (Prefix)) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - Error_Msg_Sem - (+Attr, "%i is not allowed for a signal parameter", +Attr); - when others => - null; - end case; - end if; - Sem_Decls.Add_Declaration_For_Implicit_Signal (Res); - return Res; - end Sem_Signal_Signal_Attribute; - - function Sem_Signal_Attribute (Attr : Iir_Attribute_Name) return Iir - is - use Std_Names; - Prefix: Iir; - Res : Iir; - Base : Iir; - begin - Prefix := Get_Named_Entity (Get_Prefix (Attr)); - Base := Get_Object_Prefix (Prefix); - case Get_Kind (Base) is - when Iir_Kind_Signal_Declaration - | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Guard_Signal_Declaration - | Iir_Kinds_Signal_Attribute => - null; - when others => - Error_Msg_Sem - (+Attr, "prefix of %i attribute must denote a signal", +Attr); - return Error_Mark; - end case; - case Get_Identifier (Attr) is - when Name_Stable => - Res := Sem_Signal_Signal_Attribute - (Attr, Iir_Kind_Stable_Attribute); - when Name_Quiet => - Res := Sem_Signal_Signal_Attribute - (Attr, Iir_Kind_Quiet_Attribute); - when Name_Delayed => - Res := Sem_Signal_Signal_Attribute - (Attr, Iir_Kind_Delayed_Attribute); - when Name_Transaction => - Res := Sem_Signal_Signal_Attribute - (Attr, Iir_Kind_Transaction_Attribute); - when Name_Event => - Res := Create_Iir (Iir_Kind_Event_Attribute); - Set_Type (Res, Boolean_Type_Definition); - when Name_Active => - Res := Create_Iir (Iir_Kind_Active_Attribute); - Set_Type (Res, Boolean_Type_Definition); - when Name_Last_Value => - Res := Create_Iir (Iir_Kind_Last_Value_Attribute); - Set_Type (Res, Get_Type (Prefix)); - when Name_Last_Event => - Res := Create_Iir (Iir_Kind_Last_Event_Attribute); - Set_Type (Res, Time_Type_Definition); - when Name_Last_Active => - Res := Create_Iir (Iir_Kind_Last_Active_Attribute); - Set_Type (Res, Time_Type_Definition); - when Name_Driving_Value => - Res := Create_Iir (Iir_Kind_Driving_Value_Attribute); - Set_Type (Res, Get_Type (Prefix)); - -- FIXME: check restrictions. - when Name_Driving => - Res := Create_Iir (Iir_Kind_Driving_Attribute); - Set_Type (Res, Boolean_Type_Definition); - -- FIXME: check restrictions. - when others => - -- Not yet implemented attribute, or really an internal error. - raise Internal_Error; - end case; - Location_Copy (Res, Attr); - - -- LRM 4.3.2 - -- The value of an object is said to be read when one of the following - -- conditions is satisfied: - -- [...] - -- * When the object is a signal and the value of any of its predefined - -- attributes 'STABLE, 'QUIET, 'DELAYED, 'TRANSACTION, 'EVENT, - -- 'ACTIVE, 'LAST_EVENT, 'LAST_ACTIVE, or 'LAST_VALUE is read. - - -- LRM 14.1 - -- S'Driving Restrictions: - -- S'Driving_Value Restrictions: - -- This attribute is available only from within a process, a - -- concurrent statement with an equivalent process, or a subprogram. - -- If the prefix denotes a port, it is an error if the port does not - -- have a mode of INOUT, OUT or BUFFER. It is also an error if the - -- attribute name appears in a subprogram body that is not a declarative - -- item contained within a process statement and the prefix is not a - -- formal parameter of the given subprogram or of a parent of that - -- subprogram. Finally, it is an error if the prefix denotes a - -- subprogram formal parameter whose mode is not INOUT or OUT, or if - -- S'Driving is False at the time of the evaluation of S'Driving_Value. - case Get_Kind (Res) is - when Iir_Kind_Stable_Attribute - | Iir_Kind_Quiet_Attribute - | Iir_Kind_Delayed_Attribute - | Iir_Kind_Transaction_Attribute - | Iir_Kind_Event_Attribute - | Iir_Kind_Active_Attribute - | Iir_Kind_Last_Event_Attribute - | Iir_Kind_Last_Active_Attribute - | Iir_Kind_Last_Value_Attribute => - Check_Read (Prefix); - when Iir_Kind_Driving_Attribute - | Iir_Kind_Driving_Value_Attribute => - -- FIXME: complete checks. - if Get_Current_Concurrent_Statement = Null_Iir then - Error_Msg_Sem - (+Attr, "'driving or 'driving_value is available only " - & "within a concurrent statement"); - else - case Get_Kind (Get_Current_Concurrent_Statement) is - when Iir_Kinds_Process_Statement - | Iir_Kind_Concurrent_Conditional_Signal_Assignment - | Iir_Kind_Concurrent_Selected_Signal_Assignment - | Iir_Kind_Concurrent_Procedure_Call_Statement => - null; - when others => - Error_Msg_Sem - (+Attr, "'driving or 'driving_value not available " - & "within this concurrent statement"); - end case; - end if; - - case Get_Kind (Base) is - when Iir_Kind_Signal_Declaration => - null; - when Iir_Kind_Interface_Signal_Declaration => - case Get_Mode (Base) is - when Iir_Buffer_Mode - | Iir_Inout_Mode - | Iir_Out_Mode => - null; - when others => - Error_Msg_Sem - (+Attr, "mode of 'driving or 'driving_value prefix " - & "must be out, inout or buffer"); - end case; - when others => - Error_Msg_Sem - (+Attr, "bad prefix for 'driving or 'driving_value"); - end case; - when others => - null; - end case; - - -- According to LRM 7.4, signal attributes are not static expressions - -- since the prefix (a signal) is not a static expression. - Set_Expr_Staticness (Res, None); - - -- LRM02 6.1 / LRM08 8.1 - -- A name is said to be a static name if and only if at least one of - -- the following conditions holds: - -- [...] - -- - The name is a attribute name whose prefix is a static signal name - -- and whose suffix is one of the predefined attributes 'DELAYED, - -- 'STABLE, 'QUIET or 'TRANSACTION. - -- According to LRM 6.1, attributes are not static names. - if Flags.Vhdl_Std = Vhdl_93c or Flag_Relaxed_Rules - or Flags.Vhdl_Std >= Vhdl_02 - then - case Get_Kind (Res) is - when Iir_Kind_Stable_Attribute - | Iir_Kind_Quiet_Attribute - | Iir_Kind_Delayed_Attribute - | Iir_Kind_Transaction_Attribute => - Set_Name_Staticness (Res, Get_Name_Staticness (Prefix)); - when others => - Set_Name_Staticness (Res, None); - end case; - else - Set_Name_Staticness (Res, None); - end if; - - Set_Prefix (Res, Prefix); - - -- Set has_active_flag when activity is read. - case Get_Kind (Res) is - when Iir_Kind_Quiet_Attribute - | Iir_Kind_Transaction_Attribute - | Iir_Kind_Active_Attribute - | Iir_Kind_Last_Active_Attribute => - Set_Has_Active_Flag (Base, True); - when others => - null; - end case; - - return Res; - end Sem_Signal_Attribute; - - -- 'Simple_name, 'instance_name and 'path_name. - function Sem_Name_Attribute (Attr : Iir_Attribute_Name) return Iir - is - use Std_Names; - Prefix_Name : constant Iir := Get_Prefix (Attr); - Prefix: Iir; - Res : Iir; - Attr_Type : Iir; - begin - Prefix := Get_Named_Entity (Prefix_Name); - Set_Prefix (Attr, Finish_Sem_Name (Prefix_Name, Prefix)); - - -- LRM 14.1 Predefined attributes - -- E'SIMPLE_NAME - -- Prefix: Any named entity as defined in 5.1 - -- E'INSTANCE_NAME - -- Prefix: Any named entity other than the local ports and generics - -- of a component declaration. - -- E'PATH_NAME - -- Prefix: Any named entity other than the local ports and generics - -- of a component declaration. - case Get_Kind (Prefix) is - when Iir_Kind_Procedure_Declaration - | Iir_Kind_Function_Declaration - | Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration - | Iir_Kind_Constant_Declaration - | Iir_Kind_Signal_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Iterator_Declaration - | Iir_Kind_Component_Declaration - | Iir_Kinds_Concurrent_Statement - | Iir_Kinds_Sequential_Statement - | Iir_Kind_Enumeration_Literal - | Iir_Kind_Group_Declaration - | Iir_Kind_Group_Template_Declaration - | Iir_Kind_File_Declaration - | Iir_Kinds_Library_Unit - | Iir_Kind_Non_Object_Alias_Declaration => - null; - - when Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Interface_Constant_Declaration => - if Get_Identifier (Attr) /= Name_Simple_Name - and then Get_Kind (Get_Parent (Prefix)) - = Iir_Kind_Component_Declaration - then - Error_Msg_Sem - (+Attr, - "local ports or generics of a component cannot be a prefix"); - end if; - - when Iir_Kind_Subtype_Attribute - | Iir_Kind_Base_Attribute => - declare - Atype : constant Iir := Get_Type (Prefix); - begin - if Is_Anonymous_Type_Definition (Atype) then - Error_Msg_Sem (+Attr, "%n is not a named entity", +Prefix); - return Create_Error_Expr (Attr, String_Type_Definition); - end if; - Prefix := Get_Type_Declarator (Atype); - end; - when others => - Error_Msg_Sem (+Attr, "%n is not a named entity", +Prefix); - return Create_Error_Expr (Attr, String_Type_Definition); - end case; - - case Get_Identifier (Attr) is - when Name_Simple_Name => - declare - Id : constant Name_Id := Name_Table.Get_Identifier - (Eval_Simple_Name (Get_Identifier (Prefix))); - begin - Res := Create_Iir (Iir_Kind_Simple_Name_Attribute); - Set_Simple_Name_Identifier (Res, Id); - Attr_Type := Create_Unidim_Array_By_Length - (String_Type_Definition, - Iir_Int64 (Name_Table.Get_Name_Length (Id)), - Attr); - Set_Simple_Name_Subtype (Res, Attr_Type); - Set_Expr_Staticness (Res, Locally); - end; - - when Name_Path_Name => - Res := Create_Iir (Iir_Kind_Path_Name_Attribute); - Set_Expr_Staticness (Res, Globally); - Attr_Type := String_Type_Definition; - - when Name_Instance_Name => - Res := Create_Iir (Iir_Kind_Instance_Name_Attribute); - Set_Expr_Staticness (Res, Globally); - Attr_Type := String_Type_Definition; - - when others => - raise Internal_Error; - end case; - - Location_Copy (Res, Attr); - Set_Prefix (Res, Prefix_Name); - Set_Type (Res, Attr_Type); - return Res; - end Sem_Name_Attribute; - - procedure Sem_Attribute_Name (Attr : Iir_Attribute_Name) - is - use Std_Names; - Prefix : Iir; - Res : Iir; - Sig : Iir_Signature; - begin - -- LRM93 6.6 Attribute names - -- The meaning of the prefix of an attribute name must be determinable - -- independently of the attribute designator and independently of the - -- fact that it is the prefix of an attribute. - Prefix := Get_Prefix (Attr); - - -- LRM93 6.6 - -- If the prefix of an attribute name denotes an alias, then the - -- attribute name denotes an attribute of the aliased name and not the - -- alias itself, except when the attribute designator denotes any of - -- the predefined attributes 'Simple_Name, 'Path_Name or 'Instance_Name. - -- If the prefix of an attribute name denotes an alias and the - -- attribute designator denotes any of the predefined attributes - -- 'Simple_Name, 'Path_Name or 'Instance_Name, then the attribute name - -- denotes the attribute of the alias and not of the aliased name. - if Flags.Vhdl_Std > Vhdl_87 - and then Get_Identifier (Attr) in Name_Id_Name_Attributes - then - Sem_Name (Prefix, True); - else - Sem_Name (Prefix, False); - end if; - Prefix := Get_Named_Entity (Prefix); - - if Prefix = Error_Mark then - Set_Named_Entity (Attr, Prefix); - return; - end if; - - -- LRM93 6.6 - -- A signature may follow the prefix if and only if the prefix denotes - -- a subprogram or enumeration literal, or an alias thereof. - -- In this case, the signature is required to match (see Section 2.3.2) - -- the parameter and result type profile of exactly one visible - -- subprogram or enumeration literal, as is appropriate to the prefix. - -- GHDL: this is done by Sem_Signature. - Sig := Get_Attribute_Signature (Attr); - if Sig /= Null_Iir then - Prefix := Sem_Signature (Prefix, Sig); - if Prefix = Null_Iir then - Set_Named_Entity (Attr, Error_Mark); - return; - end if; - Set_Named_Entity (Get_Prefix (Attr), Prefix); - end if; - - if Get_Kind (Prefix) = Iir_Kind_Overload_List then - -- FIXME: this should be allowed. - Error_Msg_Sem (+Attr, "prefix of attribute is overloaded"); - Set_Named_Entity (Attr, Error_Mark); - return; - end if; - - -- Set_Prefix (Attr, Finish_Sem_Name (Get_Prefix (Attr), Prefix)); - - case Get_Identifier (Attr) is - when Name_Base => - Res := Sem_Base_Attribute (Attr); - when Name_Image - | Name_Value => - if Flags.Vhdl_Std > Vhdl_87 then - Res := Sem_Scalar_Type_Attribute (Attr); - else - Res := Sem_User_Attribute (Attr); - end if; - - when Name_Pos - | Name_Val - | Name_Succ - | Name_Pred - | Name_Rightof - | Name_Leftof => - Res := Sem_Scalar_Type_Attribute (Attr); - - when Name_Length - | Name_Left - | Name_Right - | Name_High - | Name_Low - | Name_Range - | Name_Reverse_Range => - Res := Sem_Array_Attribute_Name (Attr); - - when Name_Ascending => - if Flags.Vhdl_Std > Vhdl_87 then - Res := Sem_Array_Attribute_Name (Attr); - else - Res := Sem_User_Attribute (Attr); - end if; - - when Name_Stable - | Name_Event - | Name_Last_Value - | Name_Delayed - | Name_Quiet - | Name_Transaction - | Name_Active - | Name_Last_Active - | Name_Last_Event => - Res := Sem_Signal_Attribute (Attr); - - when Name_Driving - | Name_Driving_Value => - if Flags.Vhdl_Std > Vhdl_87 then - Res := Sem_Signal_Attribute (Attr); - else - Res := Sem_User_Attribute (Attr); - end if; - - when Name_Simple_Name - | Name_Path_Name - | Name_Instance_Name => - if Flags.Vhdl_Std > Vhdl_87 then - Res := Sem_Name_Attribute (Attr); - else - Res := Sem_User_Attribute (Attr); - end if; - - when Name_Subtype => - if Flags.Vhdl_Std >= Vhdl_08 then - Res := Sem_Subtype_Attribute (Attr); - else - Res := Sem_User_Attribute (Attr); - end if; - - when others => - Res := Sem_User_Attribute (Attr); - end case; - - if Res = Null_Iir then - Error_Kind ("sem_attribute_name", Attr); - end if; - Set_Named_Entity (Attr, Res); - end Sem_Attribute_Name; - - -- LRM93 §6 - procedure Sem_Name (Name : Iir; Keep_Alias : Boolean := False) is - begin - -- Exit now if NAME was already analyzed. - if Get_Named_Entity (Name) /= Null_Iir then - return; - end if; - - case Get_Kind (Name) is - when Iir_Kind_Simple_Name - | Iir_Kind_Character_Literal - | Iir_Kind_Operator_Symbol => - -- String_Literal may be a operator_symbol. - Sem_Simple_Name (Name, Keep_Alias, Soft => False); - when Iir_Kind_Selected_Name => - Sem_Selected_Name (Name, Keep_Alias); - when Iir_Kind_Parenthesis_Name => - Sem_Parenthesis_Name (Name); - when Iir_Kind_Selected_By_All_Name => - Sem_Selected_By_All_Name (Name); - when Iir_Kind_Attribute_Name => - Sem_Attribute_Name (Name); - when Iir_Kinds_External_Name => - Sem_External_Name (Name); - when others => - Error_Kind ("sem_name", Name); - end case; - end Sem_Name; - - procedure Sem_Name_Soft (Name : Iir) - is - begin - -- Exit now if NAME was already analyzed. - if Get_Named_Entity (Name) /= Null_Iir then - return; - end if; - - case Get_Kind (Name) is - when Iir_Kind_Simple_Name - | Iir_Kind_Operator_Symbol => - -- String_Literal may be a operator_symbol. - Sem_Simple_Name (Name, False, Soft => True); - when Iir_Kind_Selected_Name => - Sem_Selected_Name (Name, Keep_Alias => False, Soft => True); - when Iir_Kind_Parenthesis_Name => - -- FIXME: SOFT!! - Sem_Parenthesis_Name (Name); - when others => - Error_Kind ("sem_name_soft", Name); - end case; - end Sem_Name_Soft; - - procedure Sem_Name_Clean_1 (Name : Iir) - is - Named_Entity : Iir; - Atype : Iir; - begin - if Name = Null_Iir then - return; - end if; - - -- Clear and free overload lists of Named_entity and type. - Named_Entity := Get_Named_Entity (Name); - Set_Named_Entity (Name, Null_Iir); - if Named_Entity /= Null_Iir - and then Is_Overload_List (Named_Entity) - then - Free_Iir (Named_Entity); - end if; - - Atype := Get_Type (Name); - Set_Type (Name, Null_Iir); - if Atype /= Null_Iir - and then Is_Overload_List (Atype) - then - Free_Iir (Atype); - end if; - end Sem_Name_Clean_1; - - procedure Sem_Name_Clean (Name : Iir) is - begin - case Get_Kind (Name) is - when Iir_Kind_Simple_Name - | Iir_Kind_Operator_Symbol => - Sem_Name_Clean_1 (Name); - when Iir_Kind_Parenthesis_Name - | Iir_Kind_Selected_Name => - Sem_Name_Clean_1 (Get_Prefix (Name)); - Sem_Name_Clean_1 (Name); - when others => - Error_Kind ("sem_name_clean", Name); - end case; - end Sem_Name_Clean; - - -- Remove procedure specification from LIST. - function Remove_Procedures_From_List (Expr : Iir) return Iir - is - El : Iir; - List : Iir_List; - It : List_Iterator; - New_List : Iir_List; - begin - if not Is_Overload_List (Expr) then - return Expr; - end if; - List := Get_Overload_List (Expr); - New_List := Create_Iir_List; - It := List_Iterate (List); - while Is_Valid (It) loop - El := Get_Element (It); - case Get_Kind (El) is - when Iir_Kind_Procedure_Declaration => - null; - when Iir_Kind_Function_Declaration => - if Maybe_Function_Call (El) then - Append_Element (New_List, El); - end if; - when others => - Append_Element (New_List, El); - end case; - Next (It); - end loop; - case Get_Nbr_Elements (New_List) is - when 0 => - Free_Iir (Expr); - Destroy_Iir_List (New_List); - return Null_Iir; - when 1 => - Free_Iir (Expr); - El := Get_First_Element (New_List); - Destroy_Iir_List (New_List); - return El; - when others => - Set_Overload_List (Expr, New_List); - Destroy_Iir_List (List); - return Expr; - end case; - end Remove_Procedures_From_List; - - -- Return the fully analyzed name of NAME. - function Name_To_Analyzed_Name (Name : Iir) return Iir is - begin - case Get_Kind (Name) is - when Iir_Kind_Attribute_Name - | Iir_Kind_Parenthesis_Name => - return Get_Named_Entity (Name); - when others => - return Name; - end case; - end Name_To_Analyzed_Name; - - -- Convert name EXPR to an expression (ie, create function call). - -- A_TYPE is the expected type of the expression. - -- Returns an Error node in case of error. - function Name_To_Expression (Name : Iir; A_Type : Iir) return Iir - is - Ret_Type : Iir; - Res_Type : Iir; - Expr : Iir; - Expr_List : Iir_List; - Expr_It : List_Iterator; - Res : Iir; - Res1 : Iir; - El : Iir; - begin - Expr := Get_Named_Entity (Name); - if Get_Kind (Expr) = Iir_Kind_Error then - return Expr; - end if; - if Check_Is_Expression (Expr, Name) = Null_Iir then - return Create_Error_Expr (Name, A_Type); - end if; - - -- Note: EXPR may contain procedure names... - Expr := Remove_Procedures_From_List (Expr); - Set_Named_Entity (Name, Expr); - if Expr = Null_Iir then - Error_Msg_Sem (+Name, "%n cannot be used as expression", +Name); - return Create_Error_Expr (Name, A_Type); - end if; - - if not Is_Overload_List (Expr) then - Res := Finish_Sem_Name (Name); - pragma Assert (Res /= Null_Iir); - if A_Type /= Null_Iir then - Res_Type := Get_Type (Res); - if Res_Type = Null_Iir then - return Create_Error_Expr (Res, A_Type); - end if; - if Are_Basetypes_Compatible (Get_Base_Type (Res_Type), A_Type) - = Not_Compatible - then - Error_Not_Match (Res, A_Type); - return Create_Error_Expr (Res, A_Type); - end if; - -- Fall through. - end if; - else - -- EXPR is an overloaded name. - Expr_List := Get_Overload_List (Expr); - - if A_Type /= Null_Iir then - -- Find the name returning A_TYPE. - Res := Null_Iir; - Expr_It := List_Iterate (Expr_List); - while Is_Valid (Expr_It) loop - El := Get_Element (Expr_It); - if Are_Basetypes_Compatible (Get_Base_Type (Get_Type (El)), - A_Type) - /= Not_Compatible - then - Add_Result (Res, El); - end if; - Next (Expr_It); - end loop; - if Res = Null_Iir then - -- Specific error message for a non-visible enumeration - -- literal. - if (Get_Kind (Get_Base_Type (A_Type)) - = Iir_Kind_Enumeration_Type_Definition) - and then Kind_In (Name, Iir_Kind_Simple_Name, - Iir_Kind_Character_Literal) - then - Res := Find_Name_In_Flist (Get_Enumeration_Literal_List - (Get_Base_Type (A_Type)), - Get_Identifier (Name)); - if Res /= Null_Iir then - Error_Msg_Sem - (+Name, "enumeration literal %i is not visible " - & "(add a use clause)", +Name); - -- Keep the literal as result. - end if; - end if; - end if; - - if Res = Null_Iir then - Error_Not_Match (Name, A_Type); - return Create_Error_Expr (Name, A_Type); - elsif Is_Overload_List (Res) then - Res1 := Extract_Call_Without_Implicit_Conversion (Res); - if Res1 /= Null_Iir then - Free_Iir (Res); - Res := Res1; - else - Error_Overload (Name); - Disp_Overload_List (Get_Overload_List (Res), Name); - Free_Iir (Res); - return Create_Error_Expr (Name, A_Type); - end if; - end if; - - -- Free results - Sem_Name_Free_Result (Expr, Res); - - Ret_Type := Get_Type (Name); - if Ret_Type /= Null_Iir then - pragma Assert (Is_Overload_List (Ret_Type)); - Free_Overload_List (Ret_Type); - end if; - -- Fall through. - else - -- Create a list of type. - Ret_Type := Create_List_Of_Types (Expr_List); - if Ret_Type = Null_Iir or else not Is_Overload_List (Ret_Type) then - Res1 := Extract_Call_Without_Implicit_Conversion (Expr); - if Res1 /= Null_Iir then - -- Found it. - Res := Res1; - -- Fall through - else - -- There is either no types or one type for - -- several meanings. - Error_Overload (Name); - Disp_Overload_List (Expr_List, Name); - --Free_Iir (Ret_Type); - return Create_Error_Expr (Name, A_Type); - end if; - else - Set_Type (Name, Ret_Type); - return Name; - end if; - end if; - - Set_Named_Entity (Name, Res); - Res := Finish_Sem_Name (Name); - end if; - - -- NAME has only one meaning, which is RES. - case Get_Kind (Res) is - when Iir_Kind_Simple_Name - | Iir_Kind_Character_Literal - | Iir_Kind_Selected_Name => - Expr := Get_Named_Entity (Res); - if Get_Kind (Expr) = Iir_Kind_Function_Declaration then - return Function_Declaration_To_Call (Res); - else - Set_Type (Res, Get_Type (Expr)); - Set_Expr_Staticness (Res, Get_Expr_Staticness (Expr)); - --Set_Name_Staticness (Name, Get_Name_Staticness (Expr)); - --Set_Base_Name (Name, Get_Base_Name (Expr)); - return Res; - end if; - when Iir_Kind_Function_Call - | Iir_Kind_Selected_Element - | Iir_Kind_Indexed_Name - | Iir_Kind_Slice_Name - | Iir_Kind_Type_Conversion - | Iir_Kind_Attribute_Name => - return Eval_Expr_If_Static (Res); - when Iir_Kind_Dereference => - -- Never static. - return Res; - when Iir_Kinds_Array_Attribute => - -- FIXME: exclude range and reverse_range. - return Eval_Expr_If_Static (Res); - when Iir_Kinds_Signal_Attribute - | Iir_Kinds_Signal_Value_Attribute => - -- Never static - return Res; - when Iir_Kinds_Type_Attribute - | Iir_Kinds_Scalar_Type_Attribute - | Iir_Kind_Image_Attribute - | Iir_Kind_Value_Attribute - | Iir_Kind_Simple_Name_Attribute - | Iir_Kind_Path_Name_Attribute - | Iir_Kind_Instance_Name_Attribute => - return Eval_Expr_If_Static (Res); - when Iir_Kind_Parenthesis_Name - | Iir_Kind_Selected_By_All_Name => - raise Internal_Error; - when others => - Error_Kind ("name_to_expression", Res); - end case; - end Name_To_Expression; - - function Name_To_Range (Name : Iir) return Iir - is - Expr : Iir; - begin - Expr := Get_Named_Entity (Name); - if Get_Kind (Expr) = Iir_Kind_Error then - return Error_Mark; - end if; - - case Get_Kind (Expr) is - when Iir_Kind_Subtype_Declaration - | Iir_Kind_Type_Declaration => - Expr := Sem_Type_Mark (Name); - Set_Expr_Staticness - (Expr, Get_Type_Staticness (Get_Type (Expr))); - return Expr; - when Iir_Kind_Range_Array_Attribute - | Iir_Kind_Reverse_Range_Array_Attribute => - if Get_Parameter (Expr) = Null_Iir then - Finish_Sem_Array_Attribute (Name, Expr, Null_Iir); - end if; - if Get_Kind (Name) = Iir_Kind_Attribute_Name then - Free_Iir (Name); - else - Free_Iir (Get_Prefix (Name)); - Free_Parenthesis_Name (Name, Expr); - end if; - return Expr; - when others => - Error_Msg_Sem (+Name, "%n doesn't denote a range", +Name); - return Error_Mark; - end case; - end Name_To_Range; - - function Name_To_Type_Definition (Name : Iir) return Iir - is - Atype : Iir; - begin - case Get_Kind (Name) is - when Iir_Kinds_Denoting_Name => - -- Common correct case. - Atype := Get_Named_Entity (Name); - case Get_Kind (Atype) is - when Iir_Kind_Type_Declaration => - return Get_Type_Definition (Atype); - when Iir_Kind_Subtype_Declaration - | Iir_Kind_Interface_Type_Declaration => - return Get_Type (Atype); - when Iir_Kind_Error => - return Atype; - when others => - Error_Msg_Sem - (+Name, "a type mark must denote a type or a subtype", - Cont => True); - Error_Msg_Sem - (+Name, "(type mark denotes %n)", +Atype); - return Create_Error_Type (Atype); - end case; - when Iir_Kind_Subtype_Attribute - | Iir_Kind_Element_Attribute - | Iir_Kind_Base_Attribute => - return Get_Type (Name); - when Iir_Kinds_Expression_Attribute => - Error_Msg_Sem (+Name, "%n is not a valid type mark", +Name); - return Create_Error_Type (Name); - when others => - if not Is_Error (Name) then - Error_Msg_Sem - (+Name, "a type mark must be a simple or expanded name"); - end if; - return Create_Error_Type (Name); - end case; - end Name_To_Type_Definition; - - function Sem_Denoting_Name (Name: Iir) return Iir - is - Res: Iir; - begin - pragma Assert (Get_Kind (Name) in Iir_Kinds_Denoting_Name); - - Sem_Name (Name); - Res := Get_Named_Entity (Name); - - case Get_Kind (Res) is - when Iir_Kind_Error => - -- A message must have been displayed. - return Name; - when Iir_Kind_Overload_List => - Error_Overload (Res); - Set_Named_Entity (Name, Create_Error_Name (Name)); - return Name; - when Iir_Kinds_Concurrent_Statement - | Iir_Kinds_Sequential_Statement - | Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration - | Iir_Kind_Enumeration_Literal - | Iir_Kind_Unit_Declaration - | Iir_Kind_Group_Template_Declaration - | Iir_Kind_Group_Declaration - | Iir_Kind_Attribute_Declaration - | Iir_Kinds_Object_Declaration - | Iir_Kind_Entity_Declaration - | Iir_Kind_Configuration_Declaration - | Iir_Kind_Package_Declaration - | Iir_Kind_Context_Declaration - | Iir_Kind_Package_Instantiation_Declaration - | Iir_Kind_Interface_Package_Declaration - | Iir_Kind_Library_Declaration - | Iir_Kinds_Subprogram_Declaration - | Iir_Kind_Component_Declaration => - Res := Finish_Sem_Name (Name, Res); - pragma Assert (Get_Kind (Res) in Iir_Kinds_Denoting_Name); - return Res; - when Iir_Kind_Selected_Element => - -- An error (to be diagnosticed by the caller). - return Name; - when others => - Error_Kind ("sem_denoting_name", Res); - end case; - end Sem_Denoting_Name; - - procedure Sem_External_Name (Name : Iir) - is - Atype : Iir; - begin - pragma Assert (Get_Type (Name) = Null_Iir); - - Atype := Get_Subtype_Indication (Name); - - Atype := Sem_Types.Sem_Subtype_Indication (Atype); - Set_Subtype_Indication (Name, Atype); - Atype := Get_Type_Of_Subtype_Indication (Atype); - if Atype = Null_Iir then - Atype := Create_Error_Type (Null_Iir); - end if; - - Set_Type (Name, Atype); - - -- LRM08 8.1 Names - -- A name is said to be a static name if and only if one of the - -- following condition holds: - -- - The name is an external name. - Set_Name_Staticness (Name, Globally); - - Set_Expr_Staticness (Name, None); - - -- Consider the node as analyzed. - Set_Named_Entity (Name, Name); - end Sem_External_Name; - - function Sem_Terminal_Name (Name : Iir) return Iir - is - Res : Iir; - Ent : Iir; - begin - Res := Sem_Denoting_Name (Name); - Ent := Get_Named_Entity (Res); - if Get_Kind (Ent) /= Iir_Kind_Terminal_Declaration then - Error_Class_Match (Name, "terminal"); - Set_Named_Entity (Res, Create_Error_Name (Name)); - end if; - return Res; - end Sem_Terminal_Name; - - procedure Error_Class_Match (Name : Iir; Class_Name : String) - is - Ent : constant Iir := Get_Named_Entity (Name); - begin - if Is_Error (Ent) then - Error_Msg_Sem (+Name, Class_Name & " name expected"); - else - Error_Msg_Sem (+Name, Class_Name & " name expected, found %n", - +Get_Named_Entity (Name)); - end if; - end Error_Class_Match; -end Sem_Names; diff --git a/src/vhdl/sem_names.ads b/src/vhdl/sem_names.ads deleted file mode 100644 index 542ed4d07..000000000 --- a/src/vhdl/sem_names.ads +++ /dev/null @@ -1,159 +0,0 @@ --- Semantic analysis. --- 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 Iirs; use Iirs; - -package Sem_Names is - -- In VHDL, most of name notations are ambiguous: - -- P.N is either - -- an expanded name or - -- a selected name for an element (with a possible implicit dereference) - -- P (A1, A2, ...) can be - -- an indexed name (with a possible implicit dereference) - -- a slice name (with a possible implicit dereference) - -- a subprogram call - -- a type conversion - - -- The name analysis resolves two ambiguities: notation and overload. - -- In a first pass, all possible meaning are collected as an overload - -- list in the Named_Entity field of the name. Prefixes in that list - -- are always declarations and not simple or expanded names. This is done - -- to avoid creating nodes for simple or expanded names, as they cannot be - -- shared in the prefixes because they can have several meanings. - -- - -- In a second pass, when the caller has resolved the overloading (using - -- the context), the name is rewritten: parenthesis and selected names are - -- replaced (by slice, index, call, element selection...). Prefixes are - -- simple or expanded names (and never declarations). Checks are also - -- performed on the result (pure, all sensitized). - -- - -- The result of the name analysis may not be a name: a function_call or - -- a type conversion are not names. - - -- Analyze NAME: perform the first pass only. In case of error, a message - -- is displayed and the named entity is error_mark. - procedure Sem_Name (Name : Iir; Keep_Alias : Boolean := False); - - -- Finish analysis of NAME, if necessary. The named entity must not - -- be an overload list (ie the overload resolution must have been done). - -- Do remaining checks, transform function names into calls... - function Finish_Sem_Name (Name : Iir) return Iir; - - -- Analyze NAME as a type mark. NAME must be either a simple name or an - -- expanded name, and the denoted entity must be either a type or a subtype - -- declaration. Return the name (possibly modified) and set named_entity - -- and type. In case of error, the type is error_mark. NAME may have - -- already been analyzed by Sem_Name. - -- Incomplete types are allowed only if INCOMPLETE is True. - function Sem_Type_Mark (Name : Iir; Incomplete : Boolean := False) - return Iir; - - -- Same as Sem_Name but without any side-effect: - -- * do not report error - -- * do not set xrefs - -- Currently, only simple names (and expanded names) are handled. - -- This is to be used during sem of associations. Because there is no side - -- effect, NAME is not modified (but is decorated with Named_Entity) - procedure Sem_Name_Soft (Name : Iir); - - -- Remove every named_entity of NAME. - -- If NAME is Null_Iir then this is no op. - -- To be used only for names (weakly) analyzed by sem_name_soft. - procedure Sem_Name_Clean (Name : Iir); - - -- If NAME is a selected name whose prefix is a protected variable, set - -- method_object of CALL. - procedure Name_To_Method_Object (Call : Iir; Name : Iir); - - -- Convert name NAME to an expression (ie, can create function call). - -- A_TYPE is the expected type of the expression. - -- FIXME: it is unclear whether the result must be an expression or not - -- (ie, it *must* have a type, but may be a range). - function Name_To_Expression (Name : Iir; A_Type : Iir) return Iir; - - -- Finish analyze of NAME and expect a range (either a type or subtype - -- declaration or a range attribute). Return Error_Mark in case of error. - function Name_To_Range (Name : Iir) return Iir; - - -- Convert name NAME to a type definition. Return an error if NAME does - -- not designate a type (and emit an error message). NAME must be a fully - -- analyzed name (cannot be an Iir_Kind_Attribute_Name). - function Name_To_Type_Definition (Name : Iir) return Iir; - - -- Return true if AN_IIR is an overload list. - function Is_Overload_List (An_Iir: Iir) return Boolean; - pragma Inline (Is_Overload_List); - - -- Create an overload list, that must be destroyed by Destroy_Overload_List. - function Get_Overload_List return Iir_Overload_List; - pragma Inline (Get_Overload_List); - - function Create_Overload_List (List : Iir_List) return Iir_Overload_List; - pragma Inline (Create_Overload_List); - - -- Free the list node (and the list itself). - procedure Free_Overload_List (N : in out Iir_Overload_List); - - -- Display an error message if the overload resolution for EXPR find more - -- than one interpretation. - procedure Error_Overload (Expr: Iir); - - -- Disp the overload list LIST. - procedure Disp_Overload_List (List : Iir_List; Loc : Iir); - - -- Convert a list to either Null_Iir, an element or an overload list. - function Simplify_Overload_List (List : Iir_List) return Iir; - - -- Add new interpretation DECL to RES. - -- Create an overload_list if necessary. - -- Before the first call, RES should be set to NULL_IIR. - procedure Add_Result (Res : in out Iir; Decl : Iir); - - -- Return TRUE if ATYPE is defined: not Null_Iir, not an overload list and - -- not a wildcard. - function Is_Defined_Type (Atype : Iir) return Boolean; - - -- Free a Parenthesis_Name. This is a special case as in general the - -- Association_Chain field must be freed too. - procedure Free_Parenthesis_Name (Name : Iir; Res : Iir); - - -- Return TRUE iff TYPE1 and TYPE2 are closely related. - function Are_Types_Closely_Related (Type1, Type2 : Iir) return Boolean; - - -- From the list LIST of function or enumeration literal, extract the - -- list of (return) types. - -- If there is only one type, return it. - -- If there is no types, return NULL. - -- Otherwise, return the list as an overload list. - function Create_List_Of_Types (List : Iir_List) return Iir; - - function Sem_Index_Specification (Name : Iir_Parenthesis_Name; Itype : Iir) - return Iir; - - -- Analyze denoting name NAME. NAME must be either a simple name or an - -- expanded name and so is the result. - function Sem_Denoting_Name (Name: Iir) return Iir; - - -- Like Sem_Denoting_Name but expect a terminal name. - function Sem_Terminal_Name (Name : Iir) return Iir; - - -- Analyze an external name. - procedure Sem_External_Name (Name : Iir); - - -- Emit an error for NAME that doesn't match its class CLASS_NAME. - procedure Error_Class_Match (Name : Iir; Class_Name : String); -end Sem_Names; diff --git a/src/vhdl/sem_psl.adb b/src/vhdl/sem_psl.adb deleted file mode 100644 index 346802944..000000000 --- a/src/vhdl/sem_psl.adb +++ /dev/null @@ -1,808 +0,0 @@ --- Semantic analysis pass for PSL. --- Copyright (C) 2009 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 Types; use Types; -with PSL.Nodes; use PSL.Nodes; -with PSL.Subsets; -with PSL.Hash; - -with Sem_Expr; -with Sem_Stmts; use Sem_Stmts; -with Sem_Scopes; -with Sem_Names; -with Std_Names; -with Iirs_Utils; use Iirs_Utils; -with Evaluation; use Evaluation; -with Std_Package; -with Ieee.Std_Logic_1164; -with Errorout; use Errorout; -with Xrefs; use Xrefs; - -package body Sem_Psl is - procedure Sem_Psl_Directive_Clock (Stmt : Iir; Prop : in out Node); - - -- Return TRUE iff Atype is a PSL boolean type. - -- See PSL1.1 5.1.2 Boolean expressions - function Is_Psl_Bool_Type (Atype : Iir) return Boolean - is - Btype : Iir; - begin - if Atype = Null_Iir then - return False; - end if; - Btype := Get_Base_Type (Atype); - return Btype = Std_Package.Boolean_Type_Definition - or else Btype = Std_Package.Bit_Type_Definition - or else Btype = Ieee.Std_Logic_1164.Std_Ulogic_Type; - end Is_Psl_Bool_Type; - - -- Return TRUE if EXPR type is a PSL boolean type. - function Is_Psl_Bool_Expr (Expr : Iir) return Boolean is - begin - return Is_Psl_Bool_Type (Get_Type (Expr)); - end Is_Psl_Bool_Expr; - - -- Convert VHDL and/or/not nodes to PSL nodes. - function Convert_Bool (Expr : Iir) return Node - is - use Std_Names; - Impl : Iir; - begin - case Get_Kind (Expr) is - when Iir_Kinds_Dyadic_Operator => - declare - Left : Iir; - Right : Iir; - - function Build_Op (Kind : Nkind) return Node - is - N : Node; - begin - N := Create_Node (Kind); - Set_Location (N, Get_Location (Expr)); - Set_Left (N, Convert_Bool (Left)); - Set_Right (N, Convert_Bool (Right)); - Free_Iir (Expr); - return N; - end Build_Op; - begin - Impl := Get_Implementation (Expr); - Left := Get_Left (Expr); - Right := Get_Right (Expr); - if Impl /= Null_Iir - and then Is_Psl_Bool_Expr (Left) - and then Is_Psl_Bool_Expr (Right) - then - if Get_Identifier (Impl) = Name_And then - return Build_Op (N_And_Bool); - elsif Get_Identifier (Impl) = Name_Or then - return Build_Op (N_Or_Bool); - end if; - end if; - end; - when Iir_Kinds_Monadic_Operator => - declare - Operand : Iir; - - function Build_Op (Kind : Nkind) return Node - is - N : Node; - begin - N := Create_Node (Kind); - Set_Location (N, Get_Location (Expr)); - Set_Boolean (N, Convert_Bool (Operand)); - Free_Iir (Expr); - return N; - end Build_Op; - begin - Impl := Get_Implementation (Expr); - Operand := Get_Operand (Expr); - if Impl /= Null_Iir - and then Is_Psl_Bool_Expr (Operand) - then - if Get_Identifier (Impl) = Name_Not then - return Build_Op (N_Not_Bool); - end if; - end if; - end; - when Iir_Kinds_Name => - -- Get the named entity for names in order to hash it. - declare - Name : Iir; - begin - Name := Get_Named_Entity (Expr); - if Name /= Null_Iir then - return PSL.Hash.Get_PSL_Node (HDL_Node (Name)); - end if; - end; - when others => - null; - end case; - return PSL.Hash.Get_PSL_Node (HDL_Node (Expr)); - end Convert_Bool; - - -- Analyze an HDL expression. This may mostly a wrapper except in the - -- case when the expression is in fact a PSL expression. - function Sem_Hdl_Expr (N : Node) return Node - is - use Sem_Names; - - Expr : Iir; - Name : Iir; - Decl : Node; - Res : Node; - begin - Expr := Get_HDL_Node (N); - if Get_Kind (Expr) in Iir_Kinds_Name then - Sem_Name (Expr); - Expr := Finish_Sem_Name (Expr); - Set_HDL_Node (N, Expr); - - Name := Strip_Denoting_Name (Expr); - - case Get_Kind (Name) is - when Iir_Kind_Error => - return N; - when Iir_Kind_Overload_List => - -- FIXME: todo. - raise Internal_Error; - when Iir_Kind_Psl_Declaration => - Decl := Get_Psl_Declaration (Name); - case Get_Kind (Decl) is - when N_Sequence_Declaration => - Res := Create_Node (N_Sequence_Instance); - when N_Property_Declaration => - Res := Create_Node (N_Property_Instance); - when N_Boolean_Parameter - | N_Sequence_Parameter - | N_Const_Parameter - | N_Property_Parameter => - -- FIXME: create a n_name - Free_Node (N); - Free_Iir (Expr); - return Decl; - when others => - Error_Kind ("sem_hdl_expr(2)", Decl); - end case; - Set_Location (Res, Get_Location (N)); - Set_Declaration (Res, Decl); - if Get_Parameter_List (Decl) /= Null_Node then - Error_Msg_Sem (+Res, "no actual for instantiation"); - end if; - Free_Node (N); - Free_Iir (Expr); - return Res; - when Iir_Kind_Psl_Expression => - -- Remove the two bridge nodes: from PSL to HDL and from - -- HDL to PSL. - Free_Node (N); - Res := Get_Psl_Expression (Name); - Free_Iir (Expr); - if Name /= Expr then - Free_Iir (Name); - end if; - return Res; - when Iir_Kind_Function_Call - | Iir_Kind_Indexed_Name - | Iir_Kind_Selected_Element => - Expr := Name; - when others => - Expr := Name_To_Expression (Expr, Null_Iir); - end case; - else - Expr := Sem_Expr.Sem_Expression (Expr, Null_Iir); - end if; - - if Expr = Null_Iir then - return N; - end if; - Free_Node (N); - if not Is_Psl_Bool_Expr (Expr) then - Error_Msg_Sem (+Expr, "type of expression must be boolean"); - return PSL.Hash.Get_PSL_Node (HDL_Node (Expr)); - else - return Convert_Bool (Expr); - end if; - end Sem_Hdl_Expr; - - -- Sem a boolean node. - function Sem_Boolean (Bool : Node) return Node is - begin - case Get_Kind (Bool) is - when N_HDL_Expr => - return Sem_Hdl_Expr (Bool); - when N_And_Bool - | N_Or_Bool => - Set_Left (Bool, Sem_Boolean (Get_Left (Bool))); - Set_Right (Bool, Sem_Boolean (Get_Right (Bool))); - return Bool; - when others => - Error_Kind ("psl.sem_boolean", Bool); - end case; - end Sem_Boolean; - - procedure Sem_Boolean (N : Node) - is - Bool : Node; - begin - Bool := Get_Boolean (N); - Bool := Sem_Boolean (Bool); - Set_Boolean (N, Bool); - end Sem_Boolean; - - -- Used by Sem_Property to rewrite a property logical operator to a - -- boolean logical operator. - function Reduce_Logic_Node (Prop : Node; Bool_Kind : Nkind) return Node - is - Res : Node; - begin - Res := Create_Node (Bool_Kind); - Set_Location (Res, Get_Location (Prop)); - Set_Left (Res, Get_Left (Prop)); - Set_Right (Res, Get_Right (Prop)); - Free_Node (Prop); - return Res; - end Reduce_Logic_Node; - - function Sem_Sequence (Seq : Node) return Node - is - Res : Node; - L, R : Node; - begin - case Get_Kind (Seq) is - when N_Braced_SERE => - Res := Sem_Sequence (Get_SERE (Seq)); - Set_SERE (Seq, Res); - return Seq; - when N_Clocked_SERE => - Res := Sem_Sequence (Get_SERE (Seq)); - Set_SERE (Seq, Res); - Sem_Boolean (Seq); - return Seq; - when N_Concat_SERE - | N_Fusion_SERE - | N_Within_SERE - | N_Or_Seq - | N_And_Seq - | N_Match_And_Seq => - L := Sem_Sequence (Get_Left (Seq)); - Set_Left (Seq, L); - R := Sem_Sequence (Get_Right (Seq)); - Set_Right (Seq, R); - return Seq; - when N_Star_Repeat_Seq => - Res := Get_Sequence (Seq); - if Res /= Null_Node then - Res := Sem_Sequence (Get_Sequence (Seq)); - Set_Sequence (Seq, Res); - end if; - -- FIXME: range. - return Seq; - when N_Plus_Repeat_Seq => - Res := Get_Sequence (Seq); - if Res /= Null_Node then - Res := Sem_Sequence (Get_Sequence (Seq)); - Set_Sequence (Seq, Res); - end if; - return Seq; - when N_And_Bool - | N_Or_Bool - | N_Not_Bool => - return Sem_Boolean (Seq); - when N_HDL_Expr => - Res := Sem_Hdl_Expr (Seq); - case Get_Kind (Res) is - when N_Sequence_Instance - | N_Endpoint_Instance - | N_Boolean_Parameter - | N_Booleans => - null; - when N_Property_Instance => - Error_Msg_Sem - (+Res, "property instance not allowed in PSL sequence"); - when others => - Error_Kind ("psl.sem_sequence.hdl", Res); - end case; - return Res; - when others => - Error_Kind ("psl.sem_sequence", Seq); - end case; - end Sem_Sequence; - - function Sem_Property (Prop : Node; Top : Boolean := False) return Node; - - procedure Sem_Property (N : Node; Top : Boolean := False) - is - Prop : Node; - begin - Prop := Get_Property (N); - Prop := Sem_Property (Prop, Top); - Set_Property (N, Prop); - end Sem_Property; - - procedure Sem_Number (N : Node) - is - Num : Node; - begin - Num := Get_Number (N); - -- FIXME: todo - null; - Set_Number (N, Num); - end Sem_Number; - - function Sem_Property (Prop : Node; Top : Boolean := False) return Node - is - Res : Node; - L, R : Node; - begin - case Get_Kind (Prop) is - when N_Braced_SERE => - return Sem_Sequence (Prop); - when N_Always - | N_Never => - -- By extension, clock_event is allowed within outermost - -- always/never. - Sem_Property (Prop, Top); - return Prop; - when N_Eventually => - Sem_Property (Prop); - return Prop; - when N_Clock_Event => - Sem_Property (Prop); - Sem_Boolean (Prop); - if not Top then - Error_Msg_Sem (+Prop, "inner clock event not supported"); - end if; - return Prop; - when N_Abort => - Sem_Property (Prop); - Sem_Boolean (Prop); - return Prop; - when N_Until - | N_Before => - Res := Sem_Property (Get_Left (Prop)); - Set_Left (Prop, Res); - Res := Sem_Property (Get_Right (Prop)); - Set_Right (Prop, Res); - return Prop; - when N_Log_Imp_Prop - | N_And_Prop - | N_Or_Prop => - L := Sem_Property (Get_Left (Prop)); - Set_Left (Prop, L); - R := Sem_Property (Get_Right (Prop)); - Set_Right (Prop, R); - if Get_Psl_Type (L) = Type_Boolean - and then Get_Psl_Type (R) = Type_Boolean - then - case Get_Kind (Prop) is - when N_And_Prop => - return Reduce_Logic_Node (Prop, N_And_Bool); - when N_Or_Prop => - return Reduce_Logic_Node (Prop, N_Or_Bool); - when N_Log_Imp_Prop => - return Reduce_Logic_Node (Prop, N_Imp_Bool); - when others => - Error_Kind ("psl.sem_property(log)", Prop); - end case; - end if; - return Prop; - when N_Overlap_Imp_Seq - | N_Imp_Seq => - Res := Sem_Sequence (Get_Sequence (Prop)); - Set_Sequence (Prop, Res); - Sem_Property (Prop); - return Prop; - when N_Next => - Sem_Number (Prop); - Sem_Property (Prop); - return Prop; - when N_Next_A => - -- FIXME: range. - Sem_Property (Prop); - return Prop; - when N_Next_Event => - Sem_Number (Prop); - Sem_Boolean (Prop); - Sem_Property (Prop); - return Prop; - when N_HDL_Expr => - Res := Sem_Hdl_Expr (Prop); - if not Top and then Get_Kind (Res) = N_Property_Instance then - declare - Decl : constant Node := Get_Declaration (Res); - begin - if Decl /= Null_Node - and then Get_Global_Clock (Decl) /= Null_Node - then - Error_Msg_Sem - (+Prop, "property instance already has a clock"); - end if; - end; - end if; - return Res; - when others => - Error_Kind ("psl.sem_property", Prop); - end case; - end Sem_Property; - - -- Extract the clock from PROP. - procedure Extract_Clock (Prop : in out Node; Clk : out Node) - is - Child : Node; - begin - Clk := Null_Node; - case Get_Kind (Prop) is - when N_Clock_Event => - Clk := Get_Boolean (Prop); - Prop := Get_Property (Prop); - when N_Clocked_SERE => - Clk := Get_Boolean (Prop); - Prop := Get_SERE (Prop); - when N_Always - | N_Never => - Child := Get_Property (Prop); - if Get_Kind (Child) = N_Clock_Event then - Set_Property (Prop, Get_Property (Child)); - Clk := Get_Boolean (Child); - end if; - when N_Property_Instance => - Child := Get_Declaration (Prop); - Clk := Get_Global_Clock (Child); - when others => - null; - end case; - end Extract_Clock; - - -- Sem a property/sequence/endpoint declaration. - procedure Sem_Psl_Declaration (Stmt : Iir) - is - use Sem_Scopes; - Decl : constant Node := Get_Psl_Declaration (Stmt); - Prop : Node; - Clk : Node; - Formal : Node; - El : Iir; - begin - Sem_Scopes.Add_Name (Stmt); - Xref_Decl (Stmt); - - Open_Declarative_Region; - - -- Make formal parameters visible. - Formal := Get_Parameter_List (Decl); - while Formal /= Null_Node loop - El := Create_Iir (Iir_Kind_Psl_Declaration); - Set_Location (El, Get_Location (Formal)); - Set_Identifier (El, Get_Identifier (Formal)); - Set_Psl_Declaration (El, Formal); - - Sem_Scopes.Add_Name (El); - Xref_Decl (El); - Set_Visible_Flag (El, True); - - Formal := Get_Chain (Formal); - end loop; - - case Get_Kind (Decl) is - when N_Property_Declaration => - -- FIXME: sem formal list - Prop := Get_Property (Decl); - Prop := Sem_Property (Prop, True); - Extract_Clock (Prop, Clk); - Set_Property (Decl, Prop); - Set_Global_Clock (Decl, Clk); - -- Check simple subset restrictions. - PSL.Subsets.Check_Simple (Prop); - when N_Sequence_Declaration - | N_Endpoint_Declaration => - -- FIXME: sem formal list, do not allow property parameter. - Prop := Get_Sequence (Decl); - Prop := Sem_Sequence (Prop); - Set_Sequence (Decl, Prop); - PSL.Subsets.Check_Simple (Prop); - when others => - Error_Kind ("sem_psl_declaration", Decl); - end case; - Set_Visible_Flag (Stmt, True); - - Close_Declarative_Region; - end Sem_Psl_Declaration; - - procedure Sem_Psl_Endpoint_Declaration (Stmt : Iir) - is - Decl : constant Node := Get_Psl_Declaration (Stmt); - Prop : Node; - begin - Sem_Scopes.Add_Name (Stmt); - Xref_Decl (Stmt); - - pragma Assert (Get_Parameter_List (Decl) = Null_Node); - pragma Assert (Get_Kind (Decl) = N_Endpoint_Declaration); - - Prop := Get_Sequence (Decl); - Prop := Sem_Sequence (Prop); - Sem_Psl_Directive_Clock (Stmt, Prop); - Set_Sequence (Decl, Prop); - - PSL.Subsets.Check_Simple (Prop); - - -- Endpoints are considered as an HDL declaration and must have a - -- type. - Set_Type (Stmt, Std_Package.Boolean_Type_Definition); - Set_Expr_Staticness (Stmt, None); - - Set_Visible_Flag (Stmt, True); - end Sem_Psl_Endpoint_Declaration; - - function Rewrite_As_Boolean_Expression (Prop : Node) return Iir - is - function Rewrite_Dyadic_Operator - (Expr : Node; Kind : Iir_Kind) return Iir - is - Res : Iir; - begin - Res := Create_Iir (Kind); - Set_Location (Res, Get_Location (Expr)); - Set_Left (Res, Rewrite_As_Boolean_Expression (Get_Left (Expr))); - Set_Right (Res, Rewrite_As_Boolean_Expression (Get_Right (Expr))); - return Res; - end Rewrite_Dyadic_Operator; - - function Rewrite_Monadic_Operator - (Expr : Node; Kind : Iir_Kind) return Iir - is - Res : Iir; - begin - Res := Create_Iir (Kind); - Set_Location (Res, Get_Location (Expr)); - Set_Operand (Res, Rewrite_As_Boolean_Expression (Get_Boolean (Expr))); - return Res; - end Rewrite_Monadic_Operator; - begin - case Get_Kind (Prop) is - when N_HDL_Expr => - return Get_HDL_Node (Prop); - when N_And_Bool => - return Rewrite_Dyadic_Operator (Prop, Iir_Kind_And_Operator); - when N_Or_Bool => - return Rewrite_Dyadic_Operator (Prop, Iir_Kind_Or_Operator); - when N_Not_Bool => - return Rewrite_Monadic_Operator (Prop, Iir_Kind_Not_Operator); - when others => - Error_Kind ("rewrite_as_boolean_expression", Prop); - end case; - end Rewrite_As_Boolean_Expression; - - function Rewrite_As_Concurrent_Assertion (Stmt : Iir) return Iir - is - Res : Iir; - Cond : Iir; - begin - Res := Create_Iir (Iir_Kind_Concurrent_Assertion_Statement); - Set_Location (Res, Get_Location (Stmt)); - Cond := Rewrite_As_Boolean_Expression (Get_Psl_Property (Stmt)); - if Get_Type (Cond) = Null_Iir then - Cond := Sem_Expr.Sem_Condition (Cond); - elsif Get_Base_Type (Get_Type (Cond)) - /= Std_Package.Boolean_Type_Definition - then - Cond := Sem_Expr.Insert_Condition_Operator (Cond); - end if; - Cond := Eval_Expr_If_Static (Cond); - Set_Assertion_Condition (Res, Cond); - Set_Label (Res, Get_Label (Stmt)); - Set_Severity_Expression (Res, Get_Severity_Expression (Stmt)); - Set_Report_Expression (Res, Get_Report_Expression (Stmt)); - Set_Postponed_Flag (Res, Get_Postponed_Flag (Stmt)); - return Res; - end Rewrite_As_Concurrent_Assertion; - - -- Return True iff EXPR is a boolean expression. - function Is_Boolean_Assertion (Expr : Node) return Boolean is - begin - case Get_Kind (Expr) is - when N_HDL_Expr => - return True; - when N_And_Bool | N_Or_Bool | N_Not_Bool => - return True; - when others => - return False; - end case; - end Is_Boolean_Assertion; - - procedure Sem_Psl_Directive_Clock (Stmt : Iir; Prop : in out Node) - is - Clk : Node; - begin - Extract_Clock (Prop, Clk); - if Clk = Null_Node then - if Current_Psl_Default_Clock = Null_Iir then - Error_Msg_Sem (+Stmt, "no clock for PSL directive"); - Clk := Null_Node; - else - Clk := Get_Psl_Boolean (Current_Psl_Default_Clock); - end if; - end if; - Set_PSL_Clock (Stmt, Clk); - end Sem_Psl_Directive_Clock; - - function Sem_Psl_Assert_Statement (Stmt : Iir) return Iir - is - Prop : Node; - Res : Iir; - begin - pragma Assert (Get_Kind (Stmt) = Iir_Kind_Psl_Assert_Statement); - - -- Sem report and severity expressions. - Sem_Report_Statement (Stmt); - - Prop := Get_Psl_Property (Stmt); - Prop := Sem_Property (Prop, True); - Set_Psl_Property (Stmt, Prop); - - if Is_Boolean_Assertion (Prop) then - -- This is a simple assertion. Convert to a non-PSL statement, as - -- the handling is simpler (and the assertion doesn't need a clock). - Res := Rewrite_As_Concurrent_Assertion (Stmt); - Free_Iir (Stmt); - return Res; - end if; - - if Get_Postponed_Flag (Stmt) then - Error_Msg_Sem (+Stmt, "PSL assertions cannot be postponed"); - Set_Postponed_Flag (Stmt, False); - end if; - - -- Properties must be clocked. - Sem_Psl_Directive_Clock (Stmt, Prop); - Set_Psl_Property (Stmt, Prop); - - -- Check simple subset restrictions. - PSL.Subsets.Check_Simple (Prop); - - return Stmt; - end Sem_Psl_Assert_Statement; - - procedure Sem_Psl_Cover_Statement (Stmt : Iir) - is - Seq : Node; - begin - -- Sem report and severity expressions. - Sem_Report_Statement (Stmt); - - Seq := Get_Psl_Sequence (Stmt); - Seq := Sem_Sequence (Seq); - - -- Properties must be clocked. - Sem_Psl_Directive_Clock (Stmt, Seq); - Set_Psl_Sequence (Stmt, Seq); - - -- Check simple subset restrictions. - PSL.Subsets.Check_Simple (Seq); - end Sem_Psl_Cover_Statement; - - procedure Sem_Psl_Default_Clock (Stmt : Iir) - is - Expr : Node; - begin - if Current_Psl_Default_Clock /= Null_Iir - and then Get_Parent (Current_Psl_Default_Clock) = Get_Parent (Stmt) - then - Error_Msg_Sem - (+Stmt, "redeclaration of PSL default clock in the same region", - Cont => True); - Error_Msg_Sem - (+Current_Psl_Default_Clock, - " (previous default clock declaration)"); - end if; - Expr := Sem_Boolean (Get_Psl_Boolean (Stmt)); - Set_Psl_Boolean (Stmt, Expr); - Current_Psl_Default_Clock := Stmt; - end Sem_Psl_Default_Clock; - - function Sem_Psl_Instance_Name (Name : Iir) return Iir - is - Prefix : constant Iir := Get_Prefix (Name); - Ent : constant Iir := Get_Named_Entity (Prefix); - Decl : constant Node := Get_Psl_Declaration (Ent); - Formal : Node; - Assoc : Iir; - Res : Node; - Last_Assoc : Node; - Assoc2 : Node; - Actual : Iir; - Psl_Actual : Node; - Res2 : Iir; - begin - pragma Assert (Get_Kind (Ent) = Iir_Kind_Psl_Declaration - or Get_Kind (Ent) = Iir_Kind_Psl_Endpoint_Declaration); - case Get_Kind (Decl) is - when N_Property_Declaration => - Res := Create_Node (N_Property_Instance); - when N_Sequence_Declaration => - Res := Create_Node (N_Sequence_Instance); - when N_Endpoint_Declaration => - Res := Create_Node (N_Endpoint_Instance); - when others => - Error_Msg_Sem (+Name, "can only instantiate a psl declaration"); - return Null_Iir; - end case; - Set_Declaration (Res, Decl); - Set_Location (Res, Get_Location (Name)); - Formal := Get_Parameter_List (Decl); - Assoc := Get_Association_Chain (Name); - Last_Assoc := Null_Node; - - while Formal /= Null_Node loop - if Assoc = Null_Iir then - Error_Msg_Sem (+Name, "not enough association"); - exit; - end if; - if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Expression then - Error_Msg_Sem - (+Assoc, "open or individual association not allowed"); - elsif Get_Formal (Assoc) /= Null_Iir then - Error_Msg_Sem (+Assoc, "named association not allowed in psl"); - else - Actual := Get_Actual (Assoc); - -- FIXME: currently only boolean are parsed. - Actual := Sem_Expr.Sem_Expression (Actual, Null_Iir); - if Get_Kind (Actual) in Iir_Kinds_Name then - Actual := Get_Named_Entity (Actual); - end if; - Psl_Actual := PSL.Hash.Get_PSL_Node (HDL_Node (Actual)); - end if; - - Assoc2 := Create_Node (N_Actual); - Set_Location (Assoc2, Get_Location (Assoc)); - Set_Formal (Assoc2, Formal); - Set_Actual (Assoc2, Psl_Actual); - if Last_Assoc = Null_Node then - Set_Association_Chain (Res, Assoc2); - else - Set_Chain (Last_Assoc, Assoc2); - end if; - Last_Assoc := Assoc2; - - Formal := Get_Chain (Formal); - Assoc := Get_Chain (Assoc); - end loop; - if Assoc /= Null_Iir then - Error_Msg_Sem (+Name, "too many association"); - end if; - - Res2 := Create_Iir (Iir_Kind_Psl_Expression); - Set_Psl_Expression (Res2, Res); - Location_Copy (Res2, Name); - return Res2; - end Sem_Psl_Instance_Name; - - -- Called by sem_names to analyze a psl name. - function Sem_Psl_Name (Name : Iir) return Iir is - begin - case Get_Kind (Name) is - when Iir_Kind_Parenthesis_Name => - return Sem_Psl_Instance_Name (Name); - when others => - Error_Kind ("sem_psl_name", Name); - end case; - return Null_Iir; - end Sem_Psl_Name; - -end Sem_Psl; diff --git a/src/vhdl/sem_psl.ads b/src/vhdl/sem_psl.ads deleted file mode 100644 index 6d2bf75ea..000000000 --- a/src/vhdl/sem_psl.ads +++ /dev/null @@ -1,31 +0,0 @@ --- Semantic analysis pass for PSL. --- Copyright (C) 2009 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 Iirs; use Iirs; - -package Sem_Psl is - procedure Sem_Psl_Declaration (Stmt : Iir); - procedure Sem_Psl_Endpoint_Declaration (Stmt : Iir); - - -- May return a non-psl concurrent assertion statement. - function Sem_Psl_Assert_Statement (Stmt : Iir) return Iir; - - procedure Sem_Psl_Cover_Statement (Stmt : Iir); - procedure Sem_Psl_Default_Clock (Stmt : Iir); - function Sem_Psl_Name (Name : Iir) return Iir; -end Sem_Psl; diff --git a/src/vhdl/sem_scopes.adb b/src/vhdl/sem_scopes.adb deleted file mode 100644 index e4f780961..000000000 --- a/src/vhdl/sem_scopes.adb +++ /dev/null @@ -1,1672 +0,0 @@ --- Semantic analysis. --- 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 Logging; use Logging; -with Tables; -with Flags; use Flags; -with Name_Table; -- use Name_Table; -with Files_Map; use Files_Map; -with Errorout; use Errorout; -with Iirs_Utils; use Iirs_Utils; - -package body Sem_Scopes is - -- An interpretation cell is the element of the simply linked list - -- of interpretation for an identifier. - -- Interpretation cells are stored in table Interpretations. - type Interpretation_Cell is record - -- The declaration for this interpretation. - Decl: Iir; - - -- If True, the declaration is potentially visible (ie visible via a - -- use clause). - Is_Potential : Boolean; - - -- If True, previous declarations in PREV chain are hidden and shouldn't - -- be considered. - Prev_Hidden : Boolean; - - -- Previous interpretation for this identifier. - -- If No_Name_Interpretation, this (not PREV) interpretation is the last - -- one. If Prev_Hidden is True, PREV must be ignored. If Prev_Hidden is - -- false, the identifier is overloaded. - Prev: Name_Interpretation_Type; - - -- Previous added identifier in the declarative region. This forms a - -- linked list used to remove interpretations when a declarative - -- region is closed. - Prev_In_Region : Name_Id; - end record; - pragma Pack (Interpretation_Cell); - - package Interpretations is new Tables - (Table_Component_Type => Interpretation_Cell, - Table_Index_Type => Name_Interpretation_Type, - Table_Low_Bound => First_Valid_Interpretation, - Table_Initial => 1024); - - -- Cached value of Prev_In_Region of current region. - Last_In_Region : Name_Id := Null_Identifier; - - -- First interpretation in the current declarative region. - Current_Region_Start : Name_Interpretation_Type := - First_Valid_Interpretation; - - -- First valid interpretation. All interpretations smaller than this - -- value are part of a previous (and nested) analysis and must not be - -- considered. - First_Interpretation : Name_Interpretation_Type := - First_Valid_Interpretation; - - -- List of non-local hidden declarations. - type Hide_Index is new Nat32; - No_Hide_Index : constant Hide_Index := 0; - - package Hidden_Decls is new Tables - (Table_Component_Type => Name_Interpretation_Type, - Table_Index_Type => Hide_Index, - Table_Low_Bound => No_Hide_Index + 1, - Table_Initial => 32); - - -- First non-local hidden declarations. In VHDL, it is possible to hide - -- an overloaded declaration (by declaring a subprogram with the same - -- profile). If the overloaded declaration is local, the interpretation - -- can simply be modified. But if it is not local, the interpretation is - -- removed from the chain and saved in the Hidden_Decls table. - First_Hide_Index : Hide_Index := No_Hide_Index; - - -- To manage the list of interpretation and to add informations to this - -- list, a stack is used. - -- Elements of stack can be of kind: - -- Save_Cell: - -- the element contains the interpretation INTER for the indentifier ID - -- for the outer declarative region. - -- A save cell is always created each time a declaration is added to save - -- the previous interpretation. - -- Region_Start: - -- A new declarative region start at interpretation INTER. Here, INTER - -- is used as an index in the interpretations stack (table). - -- ID is used as an index into the unidim_array stack. - -- Barrier_start, Barrier_end: - -- All currents interpretations are saved between both INTER, and - -- are cleared. This is used to call semantic during another semantic. - - type Scope_Cell_Kind_Type is (Scope_Start, Scope_Region); - - type Scope_Cell is record - Kind: Scope_Cell_Kind_Type; - - -- Values for the previous scope. - Saved_Last_In_Region : Name_Id; - Saved_Region_Start : Name_Interpretation_Type; - Saved_First_Hide_Index : Hide_Index; - Saved_First_Interpretation : Name_Interpretation_Type; - end record; - - package Scopes is new Tables - (Table_Component_Type => Scope_Cell, - Table_Index_Type => Natural, - Table_Low_Bound => 1, - Table_Initial => 64); - - function Valid_Interpretation (Inter : Name_Interpretation_Type) - return Boolean is - begin - return Inter >= First_Interpretation; - end Valid_Interpretation; - - -- Return True iff NI means there is a conflict for the identifier: no - -- valid interpretation due to potentially visible homoraph. - function Is_Conflict_Declaration (Ni : Name_Interpretation_Type) - return Boolean is - begin - pragma Assert (Valid_Interpretation (Ni)); - return Interpretations.Table (Ni).Decl = Null_Iir; - end Is_Conflict_Declaration; - - -- Get the current interpretation for ID. The result is raw: it may not - -- be valid. - function Get_Interpretation_Raw (Id : Name_Id) - return Name_Interpretation_Type is - begin - return Name_Interpretation_Type (Name_Table.Get_Name_Info (Id)); - end Get_Interpretation_Raw; - - procedure Set_Interpretation - (Id : Name_Id; Inter : Name_Interpretation_Type) is - begin - Name_Table.Set_Name_Info (Id, Int32 (Inter)); - end Set_Interpretation; - - function Get_Interpretation_From_Raw (Inter : Name_Interpretation_Type) - return Name_Interpretation_Type is - begin - if Valid_Interpretation (Inter) - and then not Is_Conflict_Declaration (Inter) - then - -- In the current scopes set and not a conflict. - return Inter; - else - return No_Name_Interpretation; - end if; - end Get_Interpretation_From_Raw; - - function Get_Interpretation (Id : Name_Id) - return Name_Interpretation_Type is - begin - return Get_Interpretation_From_Raw (Get_Interpretation_Raw (Id)); - end Get_Interpretation; - - procedure Check_Interpretations; - pragma Unreferenced (Check_Interpretations); - - procedure Check_Interpretations - is - Inter: Name_Interpretation_Type; - Last : constant Name_Interpretation_Type := Interpretations.Last; - Err : Boolean; - begin - Err := False; - for I in 0 .. Name_Table.Last_Name_Id loop - Inter := Get_Interpretation (I); - if Inter > Last then - Log_Line ("bad interpretation for " & Name_Table.Image (I)); - Err := True; - end if; - end loop; - if Err then - raise Internal_Error; - end if; - end Check_Interpretations; - - procedure Push_Interpretations is - begin - Scopes.Append ((Kind => Scope_Start, - Saved_Last_In_Region => Last_In_Region, - Saved_Region_Start => Current_Region_Start, - Saved_First_Hide_Index => First_Hide_Index, - Saved_First_Interpretation => First_Interpretation)); - Last_In_Region := Null_Identifier; - Current_Region_Start := Interpretations.Last + 1; - First_Hide_Index := Hidden_Decls.Last + 1; - First_Interpretation := Interpretations.Last + 1; - end Push_Interpretations; - - procedure Pop_Interpretations - is - Cell : Scope_Cell renames Scopes.Table (Scopes.Last); - begin - pragma Assert (Scopes.Table (Scopes.Last).Kind = Scope_Start); - - -- All the declarative regions must have been removed. - pragma Assert (Last_In_Region = Null_Identifier); - pragma Assert (Current_Region_Start = Interpretations.Last + 1); - pragma Assert (First_Hide_Index = Hidden_Decls.Last + 1); - pragma Assert (First_Interpretation = Interpretations.Last + 1); - - Last_In_Region := Cell.Saved_Last_In_Region; - Current_Region_Start := Cell.Saved_Region_Start; - First_Hide_Index := Cell.Saved_First_Hide_Index; - First_Interpretation := Cell.Saved_First_Interpretation; - - Scopes.Decrement_Last; - end Pop_Interpretations; - - -- Create a new declarative region. - -- Simply push a region_start cell and update current_scope_start. - procedure Open_Declarative_Region is - begin - Scopes.Append ((Kind => Scope_Region, - Saved_Last_In_Region => Last_In_Region, - Saved_Region_Start => Current_Region_Start, - Saved_First_Hide_Index => First_Hide_Index, - Saved_First_Interpretation => No_Name_Interpretation)); - Last_In_Region := Null_Identifier; - Current_Region_Start := Interpretations.Last + 1; - First_Hide_Index := Hidden_Decls.Last + 1; - end Open_Declarative_Region; - - -- Close a declarative region. - -- Update interpretation of identifiers. - procedure Close_Declarative_Region - is - Cell : Scope_Cell renames Scopes.Table (Scopes.Last); - Id : Name_Id; - begin - pragma Assert (Cell.Kind = Scope_Region); - - -- Restore hidden declarations. - for I in reverse First_Hide_Index .. Hidden_Decls.Last loop - declare - Inter : constant Name_Interpretation_Type := - Hidden_Decls.Table (I); - Prev_Inter, Next_Inter : Name_Interpretation_Type; - begin - Prev_Inter := Interpretations.Table (Inter).Prev; - Next_Inter := Interpretations.Table (Prev_Inter).Prev; - Interpretations.Table (Inter).Prev := Next_Inter; - Interpretations.Table (Prev_Inter).Prev := Inter; - end; - end loop; - Hidden_Decls.Set_Last (First_Hide_Index - 1); - - -- Remove interpretations of that region. - Id := Last_In_Region; - if Id /= Null_Identifier then - declare - Inter : Name_Interpretation_Type; - begin - loop - Inter := Get_Interpretation_Raw (Id); - pragma Assert (Inter >= Current_Region_Start); - Set_Interpretation (Id, Interpretations.Table (Inter).Prev); - Id := Interpretations.Table (Inter).Prev_In_Region; - exit when Id = Null_Identifier; - end loop; - pragma Assert (Inter = Current_Region_Start); - end; - Interpretations.Set_Last (Current_Region_Start - 1); - end if; - - Last_In_Region := Cell.Saved_Last_In_Region; - Current_Region_Start := Cell.Saved_Region_Start; - First_Hide_Index := Cell.Saved_First_Hide_Index; - - Scopes.Decrement_Last; - end Close_Declarative_Region; - - procedure Open_Scope_Extension renames Open_Declarative_Region; - procedure Close_Scope_Extension renames Close_Declarative_Region; - - function Get_Next_Interpretation (Ni : Name_Interpretation_Type) - return Name_Interpretation_Type - is - pragma Assert (Valid_Interpretation (Ni)); - Cell : Interpretation_Cell renames Interpretations.Table (Ni); - begin - if Cell.Prev_Hidden - or else not Valid_Interpretation (Cell.Prev) - then - return No_Name_Interpretation; - else - return Cell.Prev; - end if; - end Get_Next_Interpretation; - - function Get_Declaration (Ni : Name_Interpretation_Type) return Iir is - begin - pragma Assert (Valid_Interpretation (Ni)); - return Interpretations.Table (Ni).Decl; - end Get_Declaration; - - function Get_Under_Interpretation (Id : Name_Id) - return Name_Interpretation_Type - is - Inter : constant Name_Interpretation_Type := Get_Interpretation (Id); - begin - -- ID has no interpretation. - -- So, there is no 'under' interpretation (FIXME: prove it). - pragma Assert (Valid_Interpretation (Inter)); - - declare - Cell : Interpretation_Cell renames Interpretations.Table (Inter); - Prev : constant Name_Interpretation_Type := Cell.Prev; - begin - -- Get_Under_Interpretation can be used only to get a hidden - -- interpretation. - pragma Assert (Cell.Prev_Hidden); - - if Valid_Interpretation (Prev) - -- Not a conflict one (use clauses). - and then Get_Declaration (Prev) /= Null_Iir - then - return Prev; - else - return No_Name_Interpretation; - end if; - end; - end Get_Under_Interpretation; - - function Strip_Non_Object_Alias (Decl : Iir) return Iir - is - Res : Iir; - begin - Res := Decl; - if Get_Kind (Res) = Iir_Kind_Non_Object_Alias_Declaration then - Res := Get_Named_Entity (Get_Name (Res)); - end if; - return Res; - end Strip_Non_Object_Alias; - - function Get_Non_Alias_Declaration (Ni : Name_Interpretation_Type) - return Iir is - begin - return Strip_Non_Object_Alias (Get_Declaration (Ni)); - end Get_Non_Alias_Declaration; - - -- Return TRUE if INTER was made directly visible via a use clause. - function Is_Potentially_Visible (Inter : Name_Interpretation_Type) - return Boolean is - begin - return Interpretations.Table (Inter).Is_Potential; - end Is_Potentially_Visible; - - -- Return TRUE iif DECL can be overloaded. - function Is_Overloadable (Decl : Iir) return Boolean is - begin - -- LRM93 10.3: - -- The overloaded declarations considered in this chapter are those for - -- subprograms and enumeration literals. - case Get_Kind (Decl) is - when Iir_Kind_Enumeration_Literal - | Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration - | Iir_Kind_Interface_Function_Declaration - | Iir_Kind_Interface_Procedure_Declaration => - return True; - when Iir_Kind_Non_Object_Alias_Declaration => - case Get_Kind (Get_Named_Entity (Get_Name (Decl))) is - when Iir_Kind_Enumeration_Literal - | Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration - | Iir_Kind_Interface_Function_Declaration - | Iir_Kind_Interface_Procedure_Declaration => - return True; - when Iir_Kind_Non_Object_Alias_Declaration => - raise Internal_Error; - when others => - return False; - end case; - when others => - return False; - end case; - end Is_Overloadable; - - -- Return TRUE if INTER was made direclty visible in the current - -- declarative region. - function Is_In_Current_Declarative_Region (Inter : Name_Interpretation_Type) - return Boolean is - begin - return Inter >= Current_Region_Start; - end Is_In_Current_Declarative_Region; - - -- Emit a warning when DECL hides PREV_DECL. - procedure Warning_Hide (Decl : Iir; Prev_Decl : Iir) - is - begin - if Get_Kind (Decl) in Iir_Kinds_Interface_Declaration - and then Get_Kind (Get_Parent (Decl)) = Iir_Kind_Component_Declaration - then - -- Do not warn when an interface in a component hides a declaration. - -- This is a common case (eg: in testbenches), and there is no real - -- hiding. - return; - end if; - - if Get_Kind (Decl) = Iir_Kind_Element_Declaration then - -- Do not warn for record elements. They are used by selection. - return; - end if; - - if Decl = Prev_Decl then - -- Can happen in configuration. No real hidding. - return; - end if; - - Warning_Msg_Sem (Warnid_Hide, +Decl, - "declaration of %i hides %n", (+Decl, +Prev_Decl)); - end Warning_Hide; - - -- Add interpretation DECL to the identifier of DECL. - -- POTENTIALLY is true if the identifier comes from a use clause. - procedure Add_Name (Decl : Iir; Ident : Name_Id; Potentially : Boolean) - is - -- Current interpretation of ID. This is the one before DECL is - -- added (if so). - Raw_Inter : constant Name_Interpretation_Type := - Get_Interpretation_Raw (Ident); - Current_Inter : constant Name_Interpretation_Type := - Get_Interpretation_From_Raw (Raw_Inter); - Current_Decl : Iir; - - -- Add DECL in the chain of interpretation for the identifier. - procedure Add_New_Interpretation (Hid_Prev : Boolean; D : Iir := Decl) is - begin - Interpretations.Append ((Decl => D, - Prev => Raw_Inter, - Is_Potential => Potentially, - Prev_Hidden => Hid_Prev, - Prev_In_Region => Last_In_Region)); - Set_Interpretation (Ident, Interpretations.Last); - Last_In_Region := Ident; - end Add_New_Interpretation; - begin - if Ident = Null_Identifier then - -- Missing identifier can happen only in case of parse error. - pragma Assert (Flags.Flag_Force_Analysis); - return; - end if; - - if not Valid_Interpretation (Raw_Inter) then - -- Very simple: no hidding, no overloading. - Add_New_Interpretation (True); - return; - end if; - - if Is_Conflict_Declaration (Raw_Inter) then - if Potentially then - -- Yet another conflicting interpretation. - return; - else - -- Very simple: no hidding, no overloading. - -- (current interpretation is Conflict_Interpretation if there is - -- only potentially visible declarations that are not made - -- directly visible). - -- Note: in case of conflict interpretation, it may be unnecessary - -- to keep the current interpretation (but it is simpler as is). - Add_New_Interpretation (True); - return; - end if; - end if; - - if Potentially then - -- Do not re-add a potential decl. This handles cases like: - -- 'use p.all; use p.all;'. - -- FIXME: add a flag (or reuse Visible_Flag) to avoid walking all - -- the interpretations. - declare - Inter : Name_Interpretation_Type := Current_Inter; - begin - while Valid_Interpretation (Inter) loop - if Get_Declaration (Inter) = Decl then - return; - end if; - Inter := Get_Next_Interpretation (Inter); - end loop; - end; - end if; - - -- LRM 10.3 Visibility - -- Each of two declarations is said to be a homograph of the other if - -- both declarations have the same identifier, operator symbol, or - -- character literal, and overloading is allowed for at most one - -- of the two. - -- - -- GHDL: the condition 'overloading is allowed for at most one of the - -- two' is false iff overloading is allowed for both; this is a nand. - - -- Note: at this stage, current_inter is valid. - Current_Decl := Get_Declaration (Current_Inter); - - if Is_Overloadable (Current_Decl) and then Is_Overloadable (Decl) then - -- Current_Inter and Decl overloads (well, they have the same - -- designator). - - -- LRM 10.3 Visibility - -- If overloading is allowed for both declarations, then each of the - -- two is a homograph of the other if they have the same identifier, - -- operator symbol or character literal, as well as the same - -- parameter and result profile. - - declare - Homograph : Name_Interpretation_Type; - Prev_Homograph : Name_Interpretation_Type; - - -- Hide HOMOGRAPH (ie unlink it from the chain of interpretation). - procedure Hide_Homograph - is - S : Name_Interpretation_Type; - begin - if Prev_Homograph = No_Name_Interpretation then - Prev_Homograph := Interpretations.Last; - end if; - - -- PREV_HOMOGRAPH must be the interpretation just before - -- HOMOGRAPH. - pragma Assert - (Interpretations.Table (Prev_Homograph).Prev = Homograph); - - -- Hide previous interpretation. - Hidden_Decls.Append (Homograph); - - S := Interpretations.Table (Homograph).Prev; - Interpretations.Table (Homograph).Prev := Prev_Homograph; - Interpretations.Table (Prev_Homograph).Prev := S; - end Hide_Homograph; - - function Get_Hash_Non_Alias (D : Iir) return Iir_Int32 is - begin - return Get_Subprogram_Hash (Strip_Non_Object_Alias (D)); - end Get_Hash_Non_Alias; - - -- Return True iff D is an implicit declaration (either a - -- subprogram or an implicit alias). - function Is_Implicit_Declaration (D : Iir) return Boolean is - begin - case Get_Kind (D) is - when Iir_Kind_Non_Object_Alias_Declaration => - return Get_Implicit_Alias_Flag (D); - when Iir_Kind_Enumeration_Literal => - return False; - when Iir_Kind_Procedure_Declaration - | Iir_Kind_Function_Declaration => - return Is_Implicit_Subprogram (D); - when others => - Error_Kind ("is_implicit_declaration", D); - end case; - end Is_Implicit_Declaration; - - -- Return TRUE iff D is an implicit alias of an implicit - -- subprogram. - function Is_Implicit_Alias (D : Iir) return Boolean is - begin - -- FIXME: Is it possible to have an implicit alias of an - -- explicit subprogram ? Yes for enumeration literal and - -- physical units. - return Get_Kind (D) = Iir_Kind_Non_Object_Alias_Declaration - and then Get_Implicit_Alias_Flag (D) - and then Is_Implicit_Subprogram (Get_Named_Entity - (Get_Name (D))); - end Is_Implicit_Alias; - - -- Replace the homograph of DECL by DECL. - procedure Replace_Homograph is - begin - Interpretations.Table (Homograph).Decl := Decl; - end Replace_Homograph; - - Decl_Hash : Iir_Int32; - Hash : Iir_Int32; - begin - Decl_Hash := Get_Hash_Non_Alias (Decl); - -- The hash must have been computed. - pragma Assert (Decl_Hash /= 0); - - -- LRM02 10.3 Visibility - -- Each of two declarations is said to be a /homograph/ of the - -- other if both declarations have the same identifier, operator - -- symbol, or character literal, and if overloading is allowed for - -- at most one of the two. - -- - -- LRM08 12.3 Visibility - -- Each of two declarations is said to be a /homograph/ of the - -- other if and only if both declarations have the same - -- designator, and they denote different named entities, and - -- either overloading is allows for at most one of the two, or - -- overloading is allowed for both declarations and they have the - -- same parameter and result type profile. - - -- GHDL: here we are in the case when both declarations are - -- overloadable. Also, always follow the LRM08 rules as they fix - -- issues. - -- GHDL: Special case for a second declaration with the same - -- designator and that denotes the same named entity than a - -- previous one (that would be an alias): according to the LRM, - -- they are both visible and there are no ambiguity as they - -- denotes the same named entity. In GHDL, the new one hides the - -- previous one. The behaviour should be the same. - - -- Find an homograph of this declaration (and also keep the - -- interpretation just before it in the chain). - Homograph := Current_Inter; - Prev_Homograph := No_Name_Interpretation; - while Homograph /= No_Name_Interpretation loop - Current_Decl := Get_Declaration (Homograph); - Hash := Get_Hash_Non_Alias (Current_Decl); - exit when Decl_Hash = Hash - and then Is_Same_Profile (Decl, Current_Decl); - Prev_Homograph := Homograph; - Homograph := Get_Next_Interpretation (Homograph); - end loop; - - if Homograph = No_Name_Interpretation then - -- Simple case: no homograph. - Add_New_Interpretation (False); - return; - end if; - - -- There is an homograph (or the named entity is the same). - if Potentially then - -- Added DECL would be made potentially visible. - - -- LRM93 10.4 1) / LRM08 12.4 a) Use Clauses - -- 1. A potentially visible declaration is not made - -- directly visible if the place considered is within the - -- immediate scope of a homograph of the declaration. - if not Is_Potentially_Visible (Homograph) then - return; - end if; - - -- LRM08 12.4 Use Clauses - -- b) If two potentially visible declarations are homograph - -- and one is explicitly declared and the other is - -- implicitly declared, then the implicit declaration is - -- not made directly visible. - if (Flags.Flag_Explicit or else Flags.Vhdl_Std >= Vhdl_08) - and then Is_Potentially_Visible (Homograph) - then - declare - Implicit_Current_Decl : constant Boolean := - Is_Implicit_Declaration (Current_Decl); - Implicit_Decl : constant Boolean := - Is_Implicit_Declaration (Decl); - begin - if Implicit_Current_Decl and then not Implicit_Decl then - if Is_In_Current_Declarative_Region (Homograph) then - Replace_Homograph; - else - -- Insert DECL and hide homograph. - Add_New_Interpretation (False); - Hide_Homograph; - end if; - return; - elsif not Implicit_Current_Decl and then Implicit_Decl - then - -- Discard decl. - return; - elsif Strip_Non_Object_Alias (Decl) - = Strip_Non_Object_Alias (Current_Decl) - then - -- This rule is not written clearly in the LRM, but - -- if two designators denote the same named entity, - -- no need to make both visible. - return; - end if; - end; - end if; - - -- GHDL: if the homograph is in the same declarative - -- region than DECL, it must be an implicit declaration - -- to be hidden. - -- FIXME: this rule is not in the LRM93, but it is necessary - -- so that explicit declaration hides the implicit one. - if Flags.Vhdl_Std < Vhdl_08 - and then not Flags.Flag_Explicit - and then Get_Parent (Decl) = Get_Parent (Current_Decl) - then - declare - Implicit_Current_Decl : constant Boolean := - Is_Implicit_Subprogram (Current_Decl); - Implicit_Decl : constant Boolean := - Is_Implicit_Subprogram (Decl); - begin - if Implicit_Current_Decl and not Implicit_Decl then - -- Note: no need to save previous interpretation, as - -- it is in the same declarative region. - -- Replace the previous homograph with DECL. - Replace_Homograph; - return; - elsif not Implicit_Current_Decl and Implicit_Decl then - -- As we have replaced the homograph, it is possible - -- than the implicit declaration is re-added (by - -- a new use clause). Discard it. - return; - end if; - end; - end if; - - -- The homograph was made visible in an outer declarative - -- region. Therefore, it must not be hidden. - Add_New_Interpretation (False); - - return; - else - -- Added DECL would be made directly visible. - - if not Is_Potentially_Visible (Homograph) then - -- The homograph was also declared in that declarative - -- region or in an inner one. - if Is_In_Current_Declarative_Region (Homograph) then - -- ... and was declared in the same region - - -- To sum up: at this point both DECL and CURRENT_DECL - -- are overloadable, have the same profile (but may be - -- aliases) and are declared in the same declarative - -- region. - - -- LRM08 12.3 Visibility - -- LRM93 10.3 Visibility - -- Two declarations that occur immediately within - -- the same declarative regions [...] shall not be - -- homograph, unless exactely one of them is the - -- implicit declaration of a predefined operation, - - -- LRM08 12.3 Visibility - -- or is an implicit alias of such implicit declaration. - -- - -- GHDL: FIXME: 'implicit alias' - - -- LRM08 12.3 Visibility - -- LRM93 10.3 Visibility - -- Each of two declarations is said to be a - -- homograph of the other if and only if both - -- declarations have the same designator, [...] - -- - -- LRM08 12.3 Visibility - -- [...] and they denote different named entities, - -- and [...] - declare - Is_Decl_Implicit : Boolean; - Is_Current_Decl_Implicit : Boolean; - begin - if Flags.Vhdl_Std >= Vhdl_08 then - Is_Current_Decl_Implicit := - Is_Implicit_Subprogram (Current_Decl) - or else Is_Implicit_Alias (Current_Decl); - Is_Decl_Implicit := Is_Implicit_Subprogram (Decl) - or else Is_Implicit_Alias (Decl); - - -- If they denote the same entity, they aren't - -- homograph. - if Strip_Non_Object_Alias (Decl) - = Strip_Non_Object_Alias (Current_Decl) - then - if Is_Current_Decl_Implicit - and then not Is_Decl_Implicit - then - -- They aren't homograph but DECL is stronger - -- (at it is not an implicit declaration) - -- than CURRENT_DECL - Replace_Homograph; - end if; - - return; - end if; - - if Is_Decl_Implicit - and then not Is_Current_Decl_Implicit - then - -- Re-declaration of an implicit subprogram via - -- an implicit alias is simply discarded. - return; - end if; - else - -- Can an implicit subprogram declaration appears - -- after an explicit one in vhdl 93? I don't - -- think so. - Is_Decl_Implicit := Is_Implicit_Subprogram (Decl); - Is_Current_Decl_Implicit := - Is_Implicit_Subprogram (Current_Decl); - end if; - - if not (Is_Decl_Implicit xor Is_Current_Decl_Implicit) - then - Error_Msg_Sem - (+Decl, "redeclaration of %n defined at %l", - (+Current_Decl, +Current_Decl)); - return; - end if; - - if not Is_Decl_Implicit and Is_Current_Decl_Implicit - then - -- DECL 'overrides' the predefined current - -- declaration. - - -- LRM93 10.3 Visibility - -- In such cases, a predefined operation is always - -- hidden by the other homograph. Where hidden in - -- this manner, an implicit declaration is hidden - -- within the entire scope of the other declaration - -- (regardless of which declaration occurs first); - -- the implicit declaration is visible neither by - -- selection nor directly. - Set_Visible_Flag (Current_Decl, False); - if Get_Kind (Decl) - in Iir_Kinds_Subprogram_Declaration - then - Set_Hide_Implicit_Flag (Decl, True); - end if; - end if; - end; - else - -- GHDL: hide directly visible declaration declared in - -- an outer region. - null; - end if; - else - -- LRM 10.4 Use Clauses - -- 1. A potentially visible declaration is not made - -- directly visible if the place considered is within the - -- immediate scope of a homograph of the declaration. - - -- GHDL: hide the potentially visible declaration. - null; - end if; - Add_New_Interpretation (False); - - Hide_Homograph; - return; - end if; - end; - end if; - - -- The current interpretation and the new one aren't overloadable, ie - -- they are homograph (well almost). - - if Is_Potentially_Visible (Current_Inter) then - if Potentially then - -- LRM93 10.4 2) / LRM08 12.4 c) Use clauses - -- Potentially visible declarations that have the same - -- designator are not made directly visible unless each of - -- them is either an enumeration literal specification or - -- the declaration of a subprogram. - if Decl = Get_Declaration (Current_Inter) then - -- The rule applies only for distinct declaration. - -- This handles 'use p.all; use P.all;'. - -- FIXME: this should have been handled at the start of - -- this subprogram. - raise Internal_Error; - return; - end if; - - -- LRM08 12.3 Visibility - -- Each of two declarations is said to be a homograph of the - -- other if and only if both declarations have the same - -- designator; and they denote different named entities, [...] - if Flags.Vhdl_Std >= Vhdl_08 then - if Strip_Non_Object_Alias (Decl) - = Strip_Non_Object_Alias (Current_Decl) - then - return; - end if; - end if; - - -- Conflict. - Add_New_Interpretation (True, Null_Iir); - return; - else - -- LRM93 10.4 item #1 - -- A potentially visible declaration is not made directly - -- visible if the place considered is within the immediate - -- scope of a homograph of the declaration. - -- GHDL: Could directly replace the previous interpretation - -- (added in same scope), but don't do that for entity - -- declarations, since it is used to find default binding. - Add_New_Interpretation (True); - return; - end if; - else - -- There is already a declaration in the current scope. - if Potentially then - -- LRM93 §10.4 item #1 - -- Discard the new and potentially visible declaration. - -- However, add the type. - -- FIXME: Add_In_Visible_List (Ident, Decl); - return; - else - if Is_In_Current_Declarative_Region (Current_Inter) then - -- They are perhaps visible in the same declarative region. - - -- LRM93 11.2 - -- If two or more logical names having the same - -- identifier appear in library clauses in the same - -- context, the second and subsequent occurences of the - -- logical name have no effect. The same is true of - -- logical names appearing both in the context clause - -- of a primary unit and in the context clause of a - -- corresponding secondary unit. - -- GHDL: we apply this rule with VHDL-87, because of implicits - -- library clauses STD and WORK. - if Get_Kind (Decl) = Iir_Kind_Library_Declaration - and then - Get_Kind (Current_Decl) = Iir_Kind_Library_Declaration - then - return; - end if; - - -- None of the two declarations are potentially visible, ie - -- both are visible. - -- LRM §10.3: - -- Two declarations that occur immediately within the same - -- declarative region must not be homographs, - -- FIXME: unless one of them is the implicit declaration of a - -- predefined operation. - Error_Msg_Sem - (+Decl, "identifier %i already used for a declaration", - (1 => +Ident), Cont => True); - Error_Msg_Sem - (+Current_Decl, "previous declaration: %n", +Current_Decl); - return; - else - -- Homograph, not in the same scope. - -- LRM §10.3: - -- A declaration is said to be hidden within (part of) an inner - -- declarative region if the inner region contains an homograph - -- of this declaration; the outer declaration is the hidden - -- within the immediate scope of the inner homograph. - if Is_Warning_Enabled (Warnid_Hide) - and then not Is_Potentially_Visible (Current_Inter) - then - Warning_Hide (Decl, Current_Decl); - end if; - - Add_New_Interpretation (True); - return; - end if; - end if; - end if; - end Add_Name; - - procedure Add_Name (Decl: Iir) is - begin - Add_Name (Decl, Get_Identifier (Decl), False); - end Add_Name; - - procedure Replace_Name (Id: Name_Id; Old : Iir; Decl: Iir) - is - Inter : Name_Interpretation_Type; - begin - Inter := Get_Interpretation (Id); - loop - exit when Get_Declaration (Inter) = Old; - Inter := Get_Next_Interpretation (Inter); - pragma Assert (Valid_Interpretation (Inter)); - end loop; - Interpretations.Table (Inter).Decl := Decl; - pragma Assert (Get_Next_Interpretation (Inter) = No_Name_Interpretation); - end Replace_Name; - - procedure Name_Visible (Decl : Iir) is - begin - -- A name can be made visible only once. - pragma Assert (not Get_Visible_Flag (Decl)); - Set_Visible_Flag (Decl, True); - end Name_Visible; - - procedure Iterator_Decl (Decl : Iir; Arg : Arg_Type) - is - begin - case Get_Kind (Decl) is - when Iir_Kind_Subtype_Declaration - | Iir_Kind_Enumeration_Literal -- By use clause - | Iir_Kind_Constant_Declaration - | Iir_Kind_Signal_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_File_Declaration - | Iir_Kind_Object_Alias_Declaration - | Iir_Kind_Non_Object_Alias_Declaration - | Iir_Kinds_Interface_Object_Declaration - | Iir_Kind_Interface_Package_Declaration - | Iir_Kinds_Interface_Subprogram_Declaration - | Iir_Kind_Component_Declaration - | Iir_Kind_Attribute_Declaration - | Iir_Kind_Group_Template_Declaration - | Iir_Kind_Group_Declaration - | Iir_Kind_Nature_Declaration - | Iir_Kind_Free_Quantity_Declaration - | Iir_Kind_Through_Quantity_Declaration - | Iir_Kind_Across_Quantity_Declaration - | Iir_Kind_Terminal_Declaration - | Iir_Kind_Entity_Declaration - | Iir_Kind_Package_Declaration - | Iir_Kind_Package_Instantiation_Declaration - | Iir_Kind_Configuration_Declaration - | Iir_Kind_Context_Declaration - | Iir_Kinds_Concurrent_Statement - | Iir_Kinds_Sequential_Statement => - Handle_Decl (Decl, Arg); - when Iir_Kind_Procedure_Declaration - | Iir_Kind_Function_Declaration => - if not Is_Second_Subprogram_Specification (Decl) then - Handle_Decl (Decl, Arg); - end if; - when Iir_Kind_Type_Declaration => - declare - Def : constant Iir := Get_Type_Definition (Decl); - List : Iir_Flist; - El : Iir; - begin - -- Handle incomplete type declaration. - if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then - return; - end if; - - Handle_Decl (Decl, Arg); - - if Get_Kind (Def) = Iir_Kind_Enumeration_Type_Definition then - List := Get_Enumeration_Literal_List (Def); - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - Handle_Decl (El, Arg); - end loop; - end if; - end; - when Iir_Kind_Anonymous_Type_Declaration => - Handle_Decl (Decl, Arg); - - declare - Def : constant Iir := Get_Type_Definition (Decl); - El : Iir; - begin - if Get_Kind (Def) = Iir_Kind_Physical_Type_Definition then - El := Get_Unit_Chain (Def); - while El /= Null_Iir loop - Handle_Decl (El, Arg); - El := Get_Chain (El); - end loop; - end if; - end; - when Iir_Kind_Interface_Type_Declaration => - Handle_Decl (Decl, Arg); - declare - El : Iir; - begin - El := Get_Interface_Type_Subprograms (Decl); - while El /= Null_Iir loop - Handle_Decl (El, Arg); - El := Get_Chain (El); - end loop; - end; - when Iir_Kind_Use_Clause - | Iir_Kind_Context_Reference => - Handle_Decl (Decl, Arg); - when Iir_Kind_Library_Clause => - Handle_Decl (Decl, Arg); --- El := Get_Library_Declaration (Decl); --- if El /= Null_Iir then --- -- May be empty. --- Handle_Decl (El, Arg); --- end if; - - when Iir_Kind_Procedure_Body - | Iir_Kind_Function_Body => - null; - - when Iir_Kind_Package_Body => - null; - - when Iir_Kind_Attribute_Specification - | Iir_Kind_Configuration_Specification - | Iir_Kind_Disconnection_Specification => - null; - when Iir_Kinds_Signal_Attribute - | Iir_Kind_Signal_Attribute_Declaration => - null; - - when Iir_Kind_Protected_Type_Body => - -- FIXME: allowed only in debugger (if the current scope is - -- within a package body) ? - null; - - when others => - Error_Kind ("iterator_decl", Decl); - end case; - end Iterator_Decl; - - -- Handle context_clause of context reference CTXT. - procedure Add_One_Context_Reference (Ctxt : Iir) - is - Name : constant Iir := Get_Selected_Name (Ctxt); - Ent : constant Iir := Get_Named_Entity (Name); - Item : Iir; - begin - if Ent = Null_Iir or else Is_Error (Ent) then - -- Stop now in case of error. - return; - end if; - pragma Assert (Get_Kind (Ent) = Iir_Kind_Context_Declaration); - - Item := Get_Context_Items (Ent); - while Item /= Null_Iir loop - case Get_Kind (Item) is - when Iir_Kind_Use_Clause => - Add_Use_Clause (Item); - when Iir_Kind_Library_Clause => - Add_Name (Get_Library_Declaration (Item), - Get_Identifier (Item), False); - when Iir_Kind_Context_Reference => - Add_Context_Reference (Item); - when others => - Error_Kind ("add_context_reference", Item); - end case; - Item := Get_Chain (Item); - end loop; - end Add_One_Context_Reference; - - procedure Add_Context_Reference (Ref : Iir) - is - Ctxt : Iir; - begin - Ctxt := Ref; - loop - Add_One_Context_Reference (Ctxt); - Ctxt := Get_Context_Reference_Chain (Ctxt); - exit when Ctxt = Null_Iir; - end loop; - end Add_Context_Reference; - - -- Make POTENTIALLY (or not) visible DECL. - procedure Add_Name_Decl (Decl : Iir; Potentially : Boolean) is - begin - case Get_Kind (Decl) is - when Iir_Kind_Use_Clause => - if not Potentially then - Add_Use_Clause (Decl); - end if; - when Iir_Kind_Context_Reference => - pragma Assert (not Potentially); - Add_Context_Reference (Decl); - when Iir_Kind_Library_Clause => - Add_Name (Get_Library_Declaration (Decl), - Get_Identifier (Decl), Potentially); - when Iir_Kind_Anonymous_Type_Declaration => - null; - when others => - Add_Name (Decl, Get_Identifier (Decl), Potentially); - end case; - end Add_Name_Decl; - - procedure Add_Declaration is - new Iterator_Decl (Arg_Type => Boolean, Handle_Decl => Add_Name_Decl); - - procedure Iterator_Decl_List (Decl_List : Iir_List; Arg : Arg_Type) - is - Decl : Iir; - It : List_Iterator; - begin - if Decl_List = Null_Iir_List then - return; - end if; - It := List_Iterate (Decl_List); - while Is_Valid (It) loop - Decl := Get_Element (It); - Handle_Decl (Decl, Arg); - Next (It); - end loop; - end Iterator_Decl_List; - - procedure Iterator_Decl_Chain (Chain_First : Iir; Arg : Arg_Type) - is - Decl: Iir; - begin - Decl := Chain_First; - while Decl /= Null_Iir loop - Handle_Decl (Decl, Arg); - Decl := Get_Chain (Decl); - end loop; - end Iterator_Decl_Chain; - - procedure Add_Declarations_1 is new Iterator_Decl_Chain - (Arg_Type => Boolean, Handle_Decl => Add_Declaration); - - procedure Add_Declarations (Chain : Iir; Potentially : Boolean := False) - renames Add_Declarations_1; - - procedure Add_Declarations_List is new Iterator_Decl_List - (Arg_Type => Boolean, Handle_Decl => Add_Declaration); - - procedure Add_Declarations_From_Interface_Chain (Chain : Iir) - is - El : Iir; - Id : Name_Id; - begin - El := Chain; - while El /= Null_Iir loop - Id := Get_Identifier (El); - - -- The chain may be from an implicitely declared subprograms, with - -- anonymous identifiers. In that case, all interfaces are - -- anonymous and there is no need to iterate. - exit when Id = Null_Identifier; - - Add_Name (El, Id, False); - El := Get_Chain (El); - end loop; - end Add_Declarations_From_Interface_Chain; - - procedure Add_Declarations_Of_Concurrent_Statement (Parent : Iir) - is - El: Iir; - Label: Name_Id; - begin - El := Get_Concurrent_Statement_Chain (Parent); - while El /= Null_Iir loop - Label := Get_Label (El); - if Label /= Null_Identifier then - Add_Name (El, Get_Identifier (El), False); - end if; - El := Get_Chain (El); - end loop; - end Add_Declarations_Of_Concurrent_Statement; - - procedure Add_Context_Clauses (Unit : Iir_Design_Unit) is - begin - Add_Declarations (Get_Context_Items (Unit), False); - end Add_Context_Clauses; - - -- Add declarations from an entity into the current declarative region. - -- This is needed when an architecture is analysed. - procedure Add_Entity_Declarations (Entity : Iir_Entity_Declaration) - is - begin - Add_Declarations_From_Interface_Chain (Get_Generic_Chain (Entity)); - Add_Declarations_From_Interface_Chain (Get_Port_Chain (Entity)); - Add_Declarations (Get_Declaration_Chain (Entity), False); - Add_Declarations_Of_Concurrent_Statement (Entity); - end Add_Entity_Declarations; - - -- Add declarations from a package into the current declarative region. - -- (for a use clause or when a package body is analyzed) - procedure Add_Package_Declarations - (Decl: Iir_Package_Declaration; Potentially : Boolean) - is - Header : constant Iir := Get_Package_Header (Decl); - begin - -- LRM08 12.1 Declarative region - -- d) A package declaration together with the corresponding body - -- - -- GHDL: the formal generic declarations are considered to be in the - -- same declarative region as the package declarations (and therefore - -- in the same scope), even if they don't occur immediately within a - -- package declaration. - if Header /= Null_Iir then - Add_Declarations (Get_Generic_Chain (Header), Potentially); - end if; - - Add_Declarations (Get_Declaration_Chain (Decl), Potentially); - end Add_Package_Declarations; - - procedure Add_Package_Instantiation_Declarations - (Decl: Iir; Potentially : Boolean) is - begin - -- LRM08 4.9 Package instantiation declarations - -- The package instantiation declaration is equivalent to declaration of - -- a generic-mapped package, consisting of a package declaration [...] - Add_Declarations (Get_Generic_Chain (Decl), Potentially); - Add_Declarations (Get_Declaration_Chain (Decl), Potentially); - end Add_Package_Instantiation_Declarations; - - -- Add declarations from a package into the current declarative region. - -- This is needed when a package body is analysed. - procedure Add_Package_Declarations (Decl: Iir_Package_Declaration) is - begin - Add_Package_Declarations (Decl, False); - end Add_Package_Declarations; - - procedure Add_Component_Declarations (Component: Iir_Component_Declaration) - is - begin - Add_Declarations_From_Interface_Chain (Get_Generic_Chain (Component)); - Add_Declarations_From_Interface_Chain (Get_Port_Chain (Component)); - end Add_Component_Declarations; - - procedure Add_Protected_Type_Declarations - (Decl : Iir_Protected_Type_Declaration) is - begin - Add_Declarations (Get_Declaration_Chain (Decl), False); - end Add_Protected_Type_Declarations; - - procedure Extend_Scope_Of_Block_Declarations (Decl : Iir) is - begin - case Get_Kind (Decl) is - when Iir_Kind_Architecture_Body => - Add_Context_Clauses (Get_Design_Unit (Decl)); - when Iir_Kind_Block_Statement - | Iir_Kind_Generate_Statement_Body => - -- FIXME: formal, iterator ? - null; - when others => - Error_Kind ("extend_scope_of_block_declarations", Decl); - end case; - Add_Declarations (Get_Declaration_Chain (Decl), False); - Add_Declarations_Of_Concurrent_Statement (Decl); - end Extend_Scope_Of_Block_Declarations; - - procedure Use_Library_All (Library : Iir_Library_Declaration) - is - Design_File : Iir_Design_File; - Design_Unit : Iir_Design_Unit; - Library_Unit : Iir; - begin - Design_File := Get_Design_File_Chain (Library); - while Design_File /= Null_Iir loop - Design_Unit := Get_First_Design_Unit (Design_File); - while Design_Unit /= Null_Iir loop - Library_Unit := Get_Library_Unit (Design_Unit); - if Get_Kind (Library_Unit) /= Iir_Kind_Package_Body then - Add_Name (Design_Unit, Get_Identifier (Design_Unit), True); - end if; - Design_Unit := Get_Chain (Design_Unit); - end loop; - Design_File := Get_Chain (Design_File); - end loop; - end Use_Library_All; - - procedure Potentially_Add_Name (Name : Iir) is - begin - Add_Name (Name, Get_Identifier (Name), True); - end Potentially_Add_Name; - - -- LRM08 12.4 Use clauses - -- Moreover, the following declarations, if any, that occurs immediately - -- within the package denoted by the prefix of the selected name, are also - -- identifier: - procedure Use_Selected_Type_Name (Name : Iir) - is - Type_Def : constant Iir := Get_Type (Name); - Base_Type : constant Iir := Get_Base_Type (Type_Def); - begin - case Get_Kind (Base_Type) is - when Iir_Kind_Enumeration_Type_Definition => - -- LRM08 12.4 Use clauses - -- - If the type mark denotes an enumeration type of a subtype of - -- an enumeration type, the enumeration literals of the base - -- type - declare - List : constant Iir_Flist := - Get_Enumeration_Literal_List (Base_Type); - El : Iir; - begin - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - Potentially_Add_Name (El); - end loop; - end; - when Iir_Kind_Physical_Type_Definition => - -- LRM08 12.4 Use clauses - -- - If the type mark denotes a subtype of a physical type, the - -- units of the base type - declare - El : Iir; - begin - El := Get_Unit_Chain (Base_Type); - while El /= Null_Iir loop - Potentially_Add_Name (El); - El := Get_Chain (El); - end loop; - end; - when others => - null; - end case; - - -- LRM08 12.4 Use clauses - -- - The implicit declarations of predefined operations for the type - -- that are not hidden by homographs explicitely declared immediately - -- within the package denoted by the prefix of the selected name - -- - The declarations of homographs, explicitely declared immediately - -- within the package denotes by the prefix of the selected name, - -- that hide implicit declarations of predefined operations for the - -- type - declare - Type_Decl : constant Iir := Get_Type_Declarator (Base_Type); - El : Iir; - Has_Override : Boolean; - begin - Has_Override := False; - El := Get_Chain (Type_Decl); - while El /= Null_Iir loop - if Is_Implicit_Subprogram (El) - and then Is_Operation_For_Type (El, Base_Type) - then - if Get_Visible_Flag (El) then - -- Implicit declaration EL was overriden by a user - -- declaration. Don't make it visible. - Potentially_Add_Name (El); - else - Has_Override := True; - end if; - El := Get_Chain (El); - else - exit; - end if; - end loop; - - -- Explicitely declared homograph. - if Has_Override then - while El /= Null_Iir loop - if Get_Kind (El) in Iir_Kinds_Subprogram_Declaration - and then Get_Hide_Implicit_Flag (El) - and then Is_Operation_For_Type (El, Base_Type) - then - Potentially_Add_Name (El); - end if; - El := Get_Chain (El); - end loop; - end if; - end; - end Use_Selected_Type_Name; - - -- LRM02 10.4 Use clauses - -- Each selected name in a use clause identifiers one or more declarations - -- that will potentially become directly visible. If the suffix of the - -- selected name is a simple name, a character literal, or operator - -- symbol, then the selected name identifiers only the declarations(s) of - -- that simple name, character literal, or operator symbol contained - -- within the package or library denoted by the prefix of the selected - -- name. - procedure Use_Selected_Name (Name : Iir) is - begin - case Get_Kind (Name) is - when Iir_Kind_Overload_List => - Add_Declarations_List (Get_Overload_List (Name), True); - when Iir_Kind_Error => - null; - when others => - Potentially_Add_Name (Name); - - -- LRM08 12.4 Use clauses - -- If the suffix of the selected name is a type mark, then the - -- declaration of the type or subtype denoted by the type mark - -- is identified. Moreover [...] - if (Vhdl_Std >= Vhdl_08 or else Flag_Relaxed_Rules) - and then Get_Kind (Name) in Iir_Kinds_Type_Declaration - then - Use_Selected_Type_Name (Name); - end if; - end case; - end Use_Selected_Name; - - -- LRM93 10.4 Use clauses - -- If the suffix is the reserved word ALL, then all the selected name - -- identifies all declaration that are contained within the package or - -- library denotes by te prefix of the selected name. - procedure Use_All_Names (Name: Iir) is - begin - case Get_Kind (Name) is - when Iir_Kind_Library_Declaration => - Use_Library_All (Name); - when Iir_Kind_Package_Declaration => - Add_Package_Declarations (Name, True); - when Iir_Kind_Package_Instantiation_Declaration => - Add_Package_Instantiation_Declarations (Name, True); - when Iir_Kind_Interface_Package_Declaration => - -- LRM08 6.5.5 Interface package declarations - -- Within an entity declaration, an architecture body, a - -- component declaration, or an uninstantiated subprogram or - -- package declaration that declares a given interface package, - -- the name of the given interface package denotes an undefined - -- instance of the uninstantiated package. - Add_Package_Instantiation_Declarations (Name, True); - when Iir_Kind_Error => - null; - when others => - raise Internal_Error; - end case; - end Use_All_Names; - - procedure Add_Use_Clause (Clause : Iir_Use_Clause) - is - Name : Iir; - Cl : Iir_Use_Clause; - begin - Cl := Clause; - loop - Name := Get_Selected_Name (Cl); - if Name = Null_Iir then - pragma Assert (Flags.Flag_Force_Analysis); - null; - else - if Get_Kind (Name) = Iir_Kind_Selected_By_All_Name then - Name := Get_Prefix (Name); - if not Is_Error (Name) then - Use_All_Names (Get_Named_Entity (Name)); - end if; - else - if not Is_Error (Name) then - Use_Selected_Name (Get_Named_Entity (Name)); - end if; - end if; - end if; - Cl := Get_Use_Clause_Chain (Cl); - exit when Cl = Null_Iir; - end loop; - end Add_Use_Clause; - - -- Debugging subprograms. - procedure Disp_All_Names; - pragma Unreferenced (Disp_All_Names); - - procedure Disp_Scopes; - pragma Unreferenced (Disp_Scopes); - - procedure Disp_Detailed_Interpretations (Ident : Name_Id); - pragma Unreferenced (Disp_Detailed_Interpretations); - - procedure Dump_Current_Scope; - pragma Unreferenced (Dump_Current_Scope); - - procedure Disp_Detailed_Interpretations (Ident : Name_Id) - is - Inter: Name_Interpretation_Type; - Decl : Iir; - begin - Log (Name_Table.Image (Ident)); - Log_Line (":"); - - Inter := Get_Interpretation (Ident); - while Valid_Interpretation (Inter) loop - Log (Name_Interpretation_Type'Image (Inter)); - if Is_Potentially_Visible (Inter) then - Log (" (use)"); - end if; - Log (":"); - Decl := Get_Declaration (Inter); - Log (Iir'Image (Decl)); - Log (":"); - Log (Iir_Kind'Image (Get_Kind (Decl))); - Log_Line (", loc: " & Image (Get_Location (Decl))); - if Get_Kind (Decl) in Iir_Kinds_Subprogram_Declaration then - Log_Line (" " & Disp_Subprg (Decl)); - end if; - Inter := Get_Next_Interpretation (Inter); - end loop; - end Disp_Detailed_Interpretations; - - procedure Disp_All_Interpretations - (Interpretation : Name_Interpretation_Type) - is - Inter: Name_Interpretation_Type; - begin - Inter := Interpretation; - while Valid_Interpretation (Inter) loop - Log (Name_Interpretation_Type'Image (Inter)); - Log ("."); - Log (Iir_Kind'Image (Get_Kind (Get_Declaration (Inter)))); - Inter := Get_Next_Interpretation (Inter); - end loop; - Log_Line; - end Disp_All_Interpretations; - - procedure Disp_All_Names - is - Inter: Name_Interpretation_Type; - begin - for I in 0 .. Name_Table.Last_Name_Id loop - Inter := Get_Interpretation (I); - if Valid_Interpretation (Inter) then - Log (Name_Table.Image (I)); - Log (Name_Id'Image (I)); - Log (":"); - Disp_All_Interpretations (Inter); - end if; - end loop; - Log_Line ("interprations.last = " - & Name_Interpretation_Type'Image (Interpretations.Last)); - Log_Line ("current_region_start =" - & Name_Interpretation_Type'Image (Current_Region_Start)); - end Disp_All_Names; - - procedure Dump_Interpretation (Inter : Name_Interpretation_Type) - is - Decl : Iir; - begin - Log (Name_Interpretation_Type'Image (Inter)); - if Is_Potentially_Visible (Inter) then - Log (" (use)"); - end if; - Log (": "); - Decl := Get_Declaration (Inter); - if Decl = Null_Iir then - Log_Line ("null: conflict"); - else - Log (Iir_Kind'Image (Get_Kind (Decl))); - Log_Line (", loc: " & Image (Get_Location (Decl))); - if Get_Kind (Decl) in Iir_Kinds_Subprogram_Declaration then - Log_Line (" " & Disp_Subprg (Decl)); - end if; - end if; - end Dump_Interpretation; - - procedure Dump_A_Scope (First, Last : Name_Interpretation_Type) is - begin - if First > Last then - Log_Line ("scope is empty"); - return; - end if; - - for Inter in reverse First .. Last loop - declare - Cell : Interpretation_Cell renames Interpretations.Table (Inter); - begin - Dump_Interpretation (Inter); - if Cell.Prev_Hidden then - Log (" [prev:"); - Log (Name_Interpretation_Type'Image (Cell.Prev)); - if Cell.Prev_Hidden then - Log (" hidden"); - end if; - Log_Line ("]"); - else - if Cell.Prev < First then - Log_Line (" [last in scope]"); - end if; - end if; - end; - end loop; - end Dump_A_Scope; - - procedure Dump_Current_Scope is - begin - Dump_A_Scope (Current_Region_Start, Interpretations.Last); - end Dump_Current_Scope; - - procedure Disp_Scopes is - begin - for I in reverse Scopes.First .. Scopes.Last loop - declare - S : Scope_Cell renames Scopes.Table (I); - begin - case S.Kind is - when Scope_Start => - Log ("scope_start at"); - when Scope_Region => - Log ("scope_region at"); - end case; - Log_Line (Name_Interpretation_Type'Image (S.Saved_Region_Start)); - end; - end loop; - end Disp_Scopes; -end Sem_Scopes; diff --git a/src/vhdl/sem_scopes.ads b/src/vhdl/sem_scopes.ads deleted file mode 100644 index 3503d4fb6..000000000 --- a/src/vhdl/sem_scopes.ads +++ /dev/null @@ -1,220 +0,0 @@ --- Semantic analysis. --- 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 Iirs; use Iirs; -with Types; use Types; - -package Sem_Scopes is - - -- The purpose of SEM_NAME package is to handle association between - -- identifiers and declarations. - -- Roughly speacking, it implements ch10 of LRM: scope and visibility. - -- - -- Basic elements are: declarations and declarative region. - -- Declaration should be understood in the large meaning: any textual - -- construction declaring an identifier, which can be a label. - -- A declarative region contains declarations and possibly other - -- declarative regions. - -- - -- Rules are scope, visibility and overloading. - -- - - -- Create and close a declarative region. - -- By closing a declarative region, all declarations made in this region - -- are discarded. - procedure Open_Declarative_Region; - procedure Close_Declarative_Region; - - -- Add meaning DECL for its identifier to the current declarative region. - procedure Add_Name (Decl: Iir); - pragma Inline (Add_Name); - - -- Add meaning DECL to the identifier IDENT. - -- POTENTIALLY is true if the identifier comes from a use clause. - procedure Add_Name (Decl: Iir; Ident : Name_Id; Potentially: Boolean); - - -- Set the visible_flag of DECL to true. - procedure Name_Visible (Decl : Iir); - - -- Replace the interpretation OLD of ID by DECL. - -- ID must have a uniq interpretation OLD (ie, it must not be overloaded). - -- The interpretation must have been done in the current scope. - -- - -- This procedure is used when the meaning of a name is changed due to its - -- analysis, eg: when a concurrent_procedure_call_statement becomes - -- a component_instantiation_statement. - procedure Replace_Name (Id: Name_Id; Old : Iir; Decl: Iir); - - -- Interpretation is a simply linked list of what an identifier means. - -- In LRM08 12.3 Visibility, the sentence is 'the declaration defines a - -- possible meaning of this occurrence'. - -- FIXME: replace Interpretation by Meaning. - type Name_Interpretation_Type is private; - - -- Return true if INTER is a valid interpretation, ie has a corresponding - -- declaration. There are only two invalids interpretations, which - -- are declared just below as constants. - function Valid_Interpretation (Inter : Name_Interpretation_Type) - return Boolean; - pragma Inline (Valid_Interpretation); - - -- Get the first interpretation of identifier ID. - function Get_Interpretation (Id: Name_Id) return Name_Interpretation_Type; - - -- Get the next interpretation from an interpretation. - function Get_Next_Interpretation (Ni: Name_Interpretation_Type) - return Name_Interpretation_Type; - - -- Get a declaration associated with an interpretation. - function Get_Declaration (Ni: Name_Interpretation_Type) return Iir; - pragma Inline (Get_Declaration); - - -- Same as Get_Declaration, but get the name of non-object alias. - -- (ie, can never returns an object alias). - function Get_Non_Alias_Declaration (Ni: Name_Interpretation_Type) - return Iir; - - -- Get the previous interpretation of identifier ID, ie the interpretation - -- for ID before the current interpretation of ID. - function Get_Under_Interpretation (Id : Name_Id) - return Name_Interpretation_Type; - - -- Return TRUE if INTER was made directly visible via a use clause. - function Is_Potentially_Visible (Inter: Name_Interpretation_Type) - return Boolean; - pragma Inline (Is_Potentially_Visible); - - -- Return TRUE if INTER was made direclty visible in the current - -- declarative region. Note this is different from being declared in the - -- current declarative region because of use clauses. - function Is_In_Current_Declarative_Region (Inter: Name_Interpretation_Type) - return Boolean; - pragma Inline (Is_In_Current_Declarative_Region); - - -- Return the raw interpretation of ID. To be used only in case of - -- invalid interpretation to clarify the issue: this may be due to - -- conflicting declarations. - function Get_Interpretation_Raw (Id : Name_Id) - return Name_Interpretation_Type; - - -- Return True iff NI is a conflicting declaration. - function Is_Conflict_Declaration (Ni : Name_Interpretation_Type) - return Boolean; - - -- Push and pop all interpretations. - -- This can be used to suspend name interpretation, in case of recursive - -- semantics. - -- After a push, all names have no_name_interpretation. - -- Pop restore the previous state. - procedure Pop_Interpretations; - procedure Push_Interpretations; - - -- Execute a use clause on NAME. - -- Make potentially directly visible declarations of NAMES. - --procedure Use_Selected_Name (Name : Iir); - procedure Use_All_Names (Name: Iir); - - -- Achieves visibility of the selected_name of use clause CLAUSE. - procedure Add_Use_Clause (Clause : Iir_Use_Clause); - - -- Add declarations for context clause in REF. - procedure Add_Context_Reference (Ref : Iir); - - -- Add declarations for a context clause into the current declarative - -- regions. - procedure Add_Context_Clauses (Unit : Iir_Design_Unit); - - -- Add declarations from an entity into the current declarative region. - -- This is needed when an architecture is analysed. - procedure Add_Entity_Declarations (Entity : Iir_Entity_Declaration); - - -- Add declarations from a package into the current declarative region. - -- This is needed when a package body is analysed. - -- FIXME: this must be done as if the declarative region was extended. - procedure Add_Package_Declarations (Decl: Iir_Package_Declaration); - - -- Add interfaces declaration of a component into the current declarative - -- region. - procedure Add_Component_Declarations - (Component : Iir_Component_Declaration); - - -- Add declarations from a protected type declaration into the current - -- declaration region (which is expected to be the region of the protected - -- type body). - procedure Add_Protected_Type_Declarations - (Decl : Iir_Protected_Type_Declaration); - - -- Add declarations of interface chain CHAIN into the current - -- declarative region. - procedure Add_Declarations_From_Interface_Chain (Chain : Iir); - - -- Add all declarations for concurrent statements declared in PARENT. - procedure Add_Declarations_Of_Concurrent_Statement (Parent : Iir); - - -- Add declarations of a declaration chain CHAIN. - procedure Add_Declarations (Chain : Iir; Potentially : Boolean := False); - - -- Scope extension area contains declarations from another declarative - -- region. These area are abstract and only used to be able to add - -- and remove declarations. - procedure Open_Scope_Extension; - procedure Close_Scope_Extension; - - -- Add any declarations that include the end of the declarative part of - -- the given block BLOCK. This follow rules of LRM93 10.2 - -- FIXME: BLOCK must be an architecture at first, then blocks declared - -- inside this architecture, then a block declared inside this block... - -- This procedure must be called after an Open_Scope_Extension and - -- declarations added can be removed with Close_Scope_Extension. - procedure Extend_Scope_Of_Block_Declarations (Decl : Iir); - - -- Call HANDLE_DECL for each declaration found in DECL. - -- This will generally call HANDLE_DECL with DECL. - -- For types, HANDLE_DECL is first called with the type declaration, then - -- with implicit functions, with element literals for enumeration type, - -- and units for physical type. - generic - type Arg_Type is private; - with procedure Handle_Decl (Decl : Iir; Arg : Arg_Type); - procedure Iterator_Decl (Decl : Iir; Arg : Arg_Type); - - -- Call HANDLE_DECL for each declaration found in DECL_LIST. - -- Generally, HANDLE_DECL must be an ITERATOR_DECL; this is not - -- automatically done, since the user might be interested in using the - -- ITERATOR_DECL. - generic - type Arg_Type is private; - with procedure Handle_Decl (Decl : Iir; Arg : Arg_Type); - procedure Iterator_Decl_List (Decl_List : Iir_List; Arg : Arg_Type); - - generic - type Arg_Type is private; - with procedure Handle_Decl (Decl : Iir; Arg : Arg_Type); - procedure Iterator_Decl_Chain (Chain_First : Iir; Arg : Arg_Type); - -private - type Name_Interpretation_Type is new Int32 range 0 .. (2 ** 30) - 1; - - -- This pseudo interpretation marks the end of the interpretation chain, - -- and means there is no (more) interpretations for the name. - -- Unless you need to discriminate between an absence of declaration and - -- a conflict between potential declarations, you should use the - -- VALID_INTERPRETATION function. - No_Name_Interpretation : constant Name_Interpretation_Type := 0; - - First_Valid_Interpretation : constant Name_Interpretation_Type := 1; -end Sem_Scopes; diff --git a/src/vhdl/sem_specs.adb b/src/vhdl/sem_specs.adb deleted file mode 100644 index 429431539..000000000 --- a/src/vhdl/sem_specs.adb +++ /dev/null @@ -1,1928 +0,0 @@ --- Semantic analysis. --- 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 Iirs_Utils; use Iirs_Utils; -with Sem_Expr; use Sem_Expr; -with Sem_Names; use Sem_Names; -with Evaluation; use Evaluation; -with Std_Package; use Std_Package; -with Errorout; use Errorout; -with Sem; use Sem; -with Sem_Lib; use Sem_Lib; -with Sem_Scopes; use Sem_Scopes; -with Sem_Assocs; use Sem_Assocs; -with Libraries; -with Iir_Chains; use Iir_Chains; -with Flags; use Flags; -with Std_Names; -with Sem_Decls; -with Xrefs; use Xrefs; -with Back_End; - -package body Sem_Specs is - function Get_Entity_Class_Kind (Decl : Iir) return Vhdl.Tokens.Token_Type - is - use Vhdl.Tokens; - begin - case Get_Kind (Decl) is - when Iir_Kind_Entity_Declaration => - return Tok_Entity; - when Iir_Kind_Architecture_Body => - return Tok_Architecture; - when Iir_Kind_Configuration_Declaration => - return Tok_Configuration; - when Iir_Kind_Package_Declaration => - return Tok_Package; - when Iir_Kind_Procedure_Declaration => - return Tok_Procedure; - when Iir_Kind_Function_Declaration => - return Tok_Function; - when Iir_Kind_Type_Declaration => - return Tok_Type; - when Iir_Kind_Subtype_Declaration => - return Tok_Subtype; - when Iir_Kind_Constant_Declaration - | Iir_Kind_Interface_Constant_Declaration => - return Tok_Constant; - when Iir_Kind_Signal_Declaration - | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Guard_Signal_Declaration => - return Tok_Signal; - when Iir_Kind_Variable_Declaration - | Iir_Kind_Interface_Variable_Declaration => - return Tok_Variable; - when Iir_Kind_Component_Declaration => - return Tok_Component; - when Iir_Kind_Concurrent_Conditional_Signal_Assignment - | Iir_Kind_Concurrent_Selected_Signal_Assignment - | Iir_Kind_Sensitized_Process_Statement - | Iir_Kind_Process_Statement - | Iir_Kind_Concurrent_Assertion_Statement - | Iir_Kind_Component_Instantiation_Statement - | Iir_Kind_Block_Statement - | Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement - | Iir_Kind_Concurrent_Procedure_Call_Statement - | Iir_Kinds_Sequential_Statement => - return Tok_Label; - when Iir_Kind_Enumeration_Literal => - return Tok_Literal; - when Iir_Kind_Unit_Declaration => - return Tok_Units; - when Iir_Kind_Group_Declaration => - return Tok_Group; - when Iir_Kind_File_Declaration - | Iir_Kind_Interface_File_Declaration => - return Tok_File; - when Iir_Kind_Attribute_Declaration => - -- Even if an attribute can't have a attribute... - -- Because an attribute declaration can appear in a declaration - -- region. - return Tok_Attribute; - when others => - Error_Kind ("get_entity_class_kind", Decl); - end case; - return Tok_Invalid; - end Get_Entity_Class_Kind; - - -- Return the node containing the attribute_value_chain field for DECL. - -- This is the parent of the attribute specification, so in general this - -- is also the parent of the declaration, but there are exceptions... - function Get_Attribute_Value_Chain_Parent (Decl : Iir) return Iir - is - Parent : Iir; - begin - case Get_Kind (Decl) is - when Iir_Kind_Entity_Declaration - | Iir_Kind_Package_Declaration - | Iir_Kind_Package_Instantiation_Declaration - | Iir_Kind_Architecture_Body - | Iir_Kind_Configuration_Declaration => - -- LRM93 5.1 - -- An attribute specification for an attribute of a design unit - -- [...] must appear immediately within the declarative part of - -- that design unit. - return Decl; - when Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Interface_File_Declaration => - -- LRM93 5.1 - -- Similarly, an attribute specification for an attribute of an - -- interface object of a design unit, subprogram, block statement - -- or package must appear immediately within the declarative part - -- of that design unit, subprogram, block statement, or package. - Parent := Get_Parent (Decl); - case Get_Kind (Parent) is - when Iir_Kind_Entity_Declaration - | Iir_Kind_Block_Statement - | Iir_Kind_Package_Declaration - | Iir_Kind_Package_Instantiation_Declaration => - return Parent; - when Iir_Kind_Procedure_Declaration - | Iir_Kind_Function_Declaration => - return Get_Subprogram_Body (Parent); - when others => - raise Internal_Error; - end case; - when Iir_Kinds_Sequential_Statement => - -- Sequential statements can be nested. - Parent := Get_Parent (Decl); - loop - if Get_Kind (Parent) not in Iir_Kinds_Sequential_Statement then - return Parent; - end if; - Parent := Get_Parent (Parent); - end loop; - when others => - -- This is also true for enumeration literals and physical units. - return Get_Parent (Decl); - end case; - end Get_Attribute_Value_Chain_Parent; - - function Find_Attribute_Value (Ent : Iir; Id : Name_Id) return Iir - is - Attr_Value_Parent : constant Iir := - Get_Attribute_Value_Chain_Parent (Ent); - Value : Iir; - Spec : Iir; - Attr_Decl : Iir; - begin - Value := Get_Attribute_Value_Chain (Attr_Value_Parent); - while Value /= Null_Iir loop - if Get_Designated_Entity (Value) = Ent then - Spec := Get_Attribute_Specification (Value); - Attr_Decl := Get_Attribute_Designator (Spec); - if Get_Identifier (Attr_Decl) = Id then - return Value; - end if; - end if; - Value := Get_Value_Chain (Value); - end loop; - return Null_Iir; - end Find_Attribute_Value; - - -- Decorate DECL with attribute ATTR. - -- If CHECK_CLASS is true, class of DECL must be class of ATTR, otherwise - -- returns silently. - -- If CHECK_DEFINED is true, DECL must not have been decorated, otherwise - -- returns silently. - procedure Attribute_A_Decl (Decl : Iir; - Attr : Iir_Attribute_Specification; - Check_Class : Boolean; - Check_Defined : Boolean) - is - use Vhdl.Tokens; - Attr_Expr : constant Iir := Get_Expression (Attr); - - El : Iir_Attribute_Value; - - -- Attribute declaration corresponding to ATTR. - -- Due to possible error, it is not required to be an attribute decl, - -- it may be a simple name. - Attr_Decl : Iir; - - Attr_Chain_Parent : Iir; - begin - -- LRM93 5.1 - -- It is an error if the class of those names is not the same as that - -- denoted by the entity class. - if Get_Entity_Class_Kind (Decl) /= Get_Entity_Class (Attr) then - if Check_Class then - Error_Msg_Sem (+Attr, "%n is not of class %t", - (+Decl, +Get_Entity_Class (Attr))); - if Get_Kind (Decl) = Iir_Kind_Subtype_Declaration - and then Get_Entity_Class (Attr) = Tok_Type - and then Get_Type (Decl) /= Null_Iir - and then Get_Base_Type (Get_Type (Decl)) /= Null_Iir - and then Get_Kind - (Get_Type_Declarator (Get_Base_Type (Get_Type (Decl)))) - = Iir_Kind_Anonymous_Type_Declaration - then - -- The type declaration declares an anonymous type - -- and a named subtype. - Error_Msg_Sem - (+Decl, - "%i declares both an anonymous type and a named subtype", - +Decl); - end if; - end if; - return; - end if; - - -- LRM93 5.1 - -- An attribute specification for an attribute of a design unit - -- (ie an entity declaration, an architecture, a configuration, or a - -- package) must appear immediately within the declarative part of - -- that design unit. - case Get_Entity_Class (Attr) is - when Tok_Entity - | Tok_Architecture - | Tok_Configuration - | Tok_Package => - if Get_Design_Unit (Decl) /= Get_Current_Design_Unit then - Error_Msg_Sem (+Attr, "%n must appear immediatly within %n", - (+Attr, +Decl)); - return; - end if; - when others => - null; - end case; - - Attr_Decl := Get_Named_Entity (Get_Attribute_Designator (Attr)); - - -- LRM93 5.1 - -- It is an error if a given attribute is associated more than once with - -- a given named entity. - -- LRM 5.1 - -- Similarly, it is an error if two different attributes with the - -- same simple name (whether predefined or user-defined) are both - -- associated with a given named entity. - Attr_Chain_Parent := Get_Attribute_Value_Chain_Parent (Decl); - El := Get_Attribute_Value_Chain (Attr_Chain_Parent); - while El /= Null_Iir loop - if Get_Designated_Entity (El) = Decl then - declare - El_Attr : constant Iir_Attribute_Declaration := - Get_Named_Entity (Get_Attribute_Designator - (Get_Attribute_Specification (El))); - begin - if El_Attr = Attr_Decl then - if Get_Attribute_Specification (El) = Attr then - -- Was already specified with the same attribute value. - -- This is possible only in one case: - -- - -- signal S1 : real; - -- alias S1_too : real is S1; - -- attribute ATTR : T1; - -- attribute ATTR of ALL : signal is '1'; - return; - end if; - if Check_Defined then - Error_Msg_Sem - (+Attr, "%n has already %n", (+Decl, +Attr), - Cont => True); - Error_Msg_Sem - (+Attr, "previous attribute specification at %l", +El); - end if; - return; - elsif Get_Identifier (El_Attr) = Get_Identifier (Attr_Decl) then - Error_Msg_Sem (+Attr, "%n is already decorated with an %n", - (+Decl, +El_Attr), Cont => True); - Error_Msg_Sem - (+El, "(previous attribute specification was here)"); - return; - end if; - end; - end if; - El := Get_Value_Chain (El); - end loop; - - El := Create_Iir (Iir_Kind_Attribute_Value); - Location_Copy (El, Attr); - Set_Name_Staticness (El, None); - Set_Attribute_Specification (El, Attr); - -- FIXME: create an expr_error node? - if Is_Error (Attr_Expr) then - Set_Expr_Staticness (El, Locally); - else - Set_Expr_Staticness (El, Get_Expr_Staticness (Attr_Expr)); - end if; - Set_Designated_Entity (El, Decl); - Set_Type (El, Get_Type (Attr_Expr)); - Set_Base_Name (El, El); - - -- Put the attribute value in the attribute_value_chain. - Set_Value_Chain (El, Get_Attribute_Value_Chain (Attr_Chain_Parent)); - Set_Attribute_Value_Chain (Attr_Chain_Parent, El); - - -- Put the attribute value in the chain of the attribute specification. - -- This is prepended, so in reverse order. Will be reversed later. - Set_Spec_Chain (El, Get_Attribute_Value_Spec_Chain (Attr)); - Set_Attribute_Value_Spec_Chain (Attr, El); - - -- Special handling for 'Foreign. - if (Flags.Vhdl_Std >= Vhdl_93c - and then Attr_Decl = Foreign_Attribute) - or else - (Flags.Vhdl_Std <= Vhdl_93c - and then Get_Identifier (Attr_Decl) = Std_Names.Name_Foreign) - then - -- LRM93 12.4 - -- The 'FOREIGN attribute may be associated only with - -- architectures or with subprograms. - case Get_Entity_Class (Attr) is - when Tok_Architecture => - null; - - when Tok_Function - | Tok_Procedure => - -- LRM93 12.4 - -- In the latter case, the attribute specification must - -- appear in the declarative part in which the subprogram - -- is declared. - -- GHDL: huh, this is the case for any attributes. - null; - - when others => - Error_Msg_Sem - (+Attr, - "'FOREIGN allowed only for architectures and subprograms"); - return; - end case; - - Set_Foreign_Flag (Decl, True); - - -- Use 'standard' convention call for foreign procedures, so as a - -- consequence they cannot be suspended. - if Get_Kind (Decl) = Iir_Kind_Procedure_Declaration then - Set_Suspend_Flag (Decl, False); - end if; - - declare - use Back_End; - begin - if Sem_Foreign /= null then - Sem_Foreign.all (Decl); - end if; - end; - end if; - end Attribute_A_Decl; - - -- Return TRUE if a named entity was attributed. - function Sem_Named_Entities (Scope : Iir; - Name : Iir; - Attr : Iir_Attribute_Specification; - Check_Defined : Boolean) - return Boolean - is - -- Name is set (ie neither ALL nor OTHERS). - Is_Designator : constant Boolean := Name /= Null_Iir; - - Res : Boolean; - - -- If declaration DECL matches then named entity ENT, apply attribute - -- specification and returns TRUE. Otherwise, return FALSE. - -- Note: ENT and DECL are different for aliases. - function Sem_Named_Entity1 (Ent : Iir; Decl : Iir) return Boolean - is - use Vhdl.Tokens; - Ent_Id : constant Name_Id := Get_Identifier (Ent); - begin - if (not Is_Designator or else Ent_Id = Get_Identifier (Name)) - and then Ent_Id /= Null_Identifier - then - if Is_Designator then - -- The designator is neither ALL nor OTHERS. - Set_Named_Entity (Name, Ent); - Xref_Ref (Name, Ent); - - if Get_Entity_Class (Attr) = Tok_Label then - -- Concurrent or sequential statements appear later in the - -- AST, but their label are considered to appear before - -- other items in the declarative part. - Set_Is_Forward_Ref (Name, True); - end if; - end if; - if Get_Visible_Flag (Ent) = False then - Error_Msg_Sem (+Attr, "%n is not yet visible", +Ent); - else - Attribute_A_Decl (Decl, Attr, Is_Designator, Check_Defined); - return True; - end if; - end if; - return False; - end Sem_Named_Entity1; - - procedure Sem_Named_Entity (Ent : Iir) is - begin - case Get_Kind (Ent) is - when Iir_Kinds_Library_Unit - | Iir_Kinds_Concurrent_Statement - | Iir_Kinds_Sequential_Statement - | Iir_Kinds_Non_Alias_Object_Declaration - | Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration - | Iir_Kind_Component_Declaration - | Iir_Kind_Enumeration_Literal - | Iir_Kind_Unit_Declaration - | Iir_Kind_Group_Template_Declaration - | Iir_Kind_Group_Declaration => - Res := Res or Sem_Named_Entity1 (Ent, Ent); - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - if not Is_Second_Subprogram_Specification (Ent) then - Res := Res or Sem_Named_Entity1 (Ent, Ent); - end if; - when Iir_Kind_Object_Alias_Declaration => - -- LRM93 5.1 - -- An entity designator that denotes an alias of an object is - -- required to denote the entire object, and not a subelement - -- or slice thereof. - declare - Decl : constant Iir := Get_Name (Ent); - Base : constant Iir := Get_Object_Prefix (Decl, False); - Applied : Boolean; - begin - Applied := Sem_Named_Entity1 (Ent, Base); - -- FIXME: check the alias denotes a local entity... - if Applied - and then Base /= Strip_Denoting_Name (Decl) - then - Error_Msg_Sem - (+Attr, "%n does not denote the entire object", +Ent); - end if; - Res := Res or Applied; - end; - when Iir_Kind_Non_Object_Alias_Declaration => - Res := Res - or Sem_Named_Entity1 (Ent, Get_Named_Entity (Get_Name (Ent))); - when Iir_Kind_Attribute_Declaration - | Iir_Kind_Attribute_Specification - | Iir_Kind_Configuration_Specification - | Iir_Kind_Use_Clause => - null; - when Iir_Kind_Procedure_Body - | Iir_Kind_Function_Body => - null; - when Iir_Kind_Anonymous_Type_Declaration => - null; - when others => - Error_Kind ("sem_named_entity", Ent); - end case; - end Sem_Named_Entity; - - procedure Sem_Named_Entity_Chain (Chain_First : Iir) - is - El : Iir; - Def : Iir; - begin - El := Chain_First; - while El /= Null_Iir loop - exit when El = Attr; - Sem_Named_Entity (El); - case Get_Kind (El) is - when Iir_Kind_Type_Declaration => - Def := Get_Type_Definition (El); - if Get_Kind (Def) = Iir_Kind_Enumeration_Type_Definition then - declare - List : constant Iir_Flist := - Get_Enumeration_Literal_List (Def); - El1 : Iir; - begin - for I in Flist_First .. Flist_Last (List) loop - El1 := Get_Nth_Element (List, I); - Sem_Named_Entity (El1); - end loop; - end; - end if; - when Iir_Kind_Anonymous_Type_Declaration => - Def := Get_Type_Definition (El); - if Get_Kind (Def) = Iir_Kind_Physical_Type_Definition then - declare - El1 : Iir; - begin - El1 := Get_Unit_Chain (Def); - while El1 /= Null_Iir loop - Sem_Named_Entity (El1); - El1 := Get_Chain (El1); - end loop; - end; - end if; - when Iir_Kind_For_Loop_Statement - | Iir_Kind_While_Loop_Statement => - Sem_Named_Entity_Chain (Get_Sequential_Statement_Chain (El)); - when Iir_Kind_If_Statement => - declare - Clause : Iir; - begin - Clause := El; - while Clause /= Null_Iir loop - Sem_Named_Entity_Chain - (Get_Sequential_Statement_Chain (Clause)); - Clause := Get_Else_Clause (Clause); - end loop; - end; - when Iir_Kind_Case_Statement => - declare - El1 : Iir; - begin - El1 := Get_Case_Statement_Alternative_Chain (El); - while El1 /= Null_Iir loop - Sem_Named_Entity_Chain (Get_Associated_Chain (El1)); - El1 := Get_Chain (El1); - end loop; - end; - - when Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement => - -- INT-1991/issue 27 - -- Generate statements represent declarative region and - -- have implicit declarative parts. - -- Was: There is no declarative part in generate statement - -- for VHDL 87. - if False and then Flags.Vhdl_Std = Vhdl_87 then - Sem_Named_Entity_Chain - (Get_Concurrent_Statement_Chain (El)); - end if; - - when others => - null; - end case; - El := Get_Chain (El); - end loop; - end Sem_Named_Entity_Chain; - begin - -- The attribute specification was not yet applied. - Res := False; - - -- LRM 5.1 Attribute specification - -- o If a list of entity designators is supplied, then the - -- attribute specification applies to the named entities denoted - -- by those designators. - -- - -- o If the reserved word OTHERS is supplied, then the attribute - -- specification applies to named entities of the specified class - -- that are declared in the immediately enclosing declarative - -- part [...] - -- - -- o If the reserved word ALL is supplied, then the attribute - -- specification applies to all named entities of the specified - -- class that are declared in the immediatly enclosing - -- declarative part. - - -- NOTE: therefore, ALL/OTHERS do not apply to named entities declared - -- beyond the immediate declarative part, such as design unit or - -- interfaces. - if Is_Designator then - if Is_Error (Name) then - pragma Assert (Flags.Flag_Force_Analysis); - return True; - end if; - - -- LRM 5.1 Attribute specification - -- An attribute specification for an attribute of a design unit - -- (i.e. an entity declaration, an architecture, a configuration - -- or a package) must appear immediatly within the declarative part - -- of that design unit. - case Get_Kind (Scope) is - when Iir_Kind_Entity_Declaration - | Iir_Kind_Architecture_Body - | Iir_Kind_Configuration_Declaration - | Iir_Kind_Package_Declaration => - Sem_Named_Entity (Scope); - when others => - null; - end case; - - -- LRM 5.1 Attribute specification - -- Similarly, an attribute specification for an attribute of an - -- interface object of a design unit, subprogram or block statement - -- must appear immediatly within the declarative part of that design - -- unit, subprogram, or block statement. - case Get_Kind (Scope) is - when Iir_Kind_Entity_Declaration => - Sem_Named_Entity_Chain (Get_Generic_Chain (Scope)); - Sem_Named_Entity_Chain (Get_Port_Chain (Scope)); - when Iir_Kind_Block_Statement => - declare - Header : constant Iir := Get_Block_Header (Scope); - begin - if Header /= Null_Iir then - Sem_Named_Entity_Chain (Get_Generic_Chain (Header)); - Sem_Named_Entity_Chain (Get_Port_Chain (Header)); - end if; - end; - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body => - declare - Spec : Iir; - begin - Spec := Get_Subprogram_Specification (Scope); - Sem_Named_Entity_Chain - (Get_Interface_Declaration_Chain (Spec)); - end; - when others => - null; - end case; - end if; - - case Get_Kind (Scope) is - when Iir_Kind_Entity_Declaration - | Iir_Kind_Architecture_Body - | Iir_Kind_Generate_Statement_Body => - Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); - Sem_Named_Entity_Chain (Get_Concurrent_Statement_Chain (Scope)); - when Iir_Kind_Block_Statement => - declare - Guard : constant Iir := Get_Guard_Decl (Scope); - begin - if Guard /= Null_Iir then - Sem_Named_Entity (Guard); - end if; - end; - Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); - Sem_Named_Entity_Chain (Get_Concurrent_Statement_Chain (Scope)); - when Iir_Kind_Configuration_Declaration => - null; - when Iir_Kind_Package_Declaration => - Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); - when Iir_Kinds_Process_Statement => - Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); - Sem_Named_Entity_Chain (Get_Sequential_Statement_Chain (Scope)); - when Iir_Kind_Package_Body => - Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body => - Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); - Sem_Named_Entity_Chain (Get_Sequential_Statement_Chain (Scope)); - when others => - Error_Kind ("sem_named_entities", Scope); - end case; - return Res; - end Sem_Named_Entities; - - procedure Sem_Signature_Entity_Designator - (Sig : Iir_Signature; Attr : Iir_Attribute_Specification) - is - Prefix : Iir; - Inter : Name_Interpretation_Type; - List : Iir_List; - Name : Iir; - begin - List := Create_Iir_List; - - -- Sem_Name cannot be used here (at least not directly) because only - -- the declarations of the current scope are considered. - Prefix := Get_Signature_Prefix (Sig); - Inter := Get_Interpretation (Get_Identifier (Prefix)); - while Valid_Interpretation (Inter) loop - exit when not Is_In_Current_Declarative_Region (Inter); - if not Is_Potentially_Visible (Inter) then - Name := Get_Declaration (Inter); - -- LRM 5.1 Attribute Specification - -- The entity tag of an entity designator containing a signature - -- must denote the name of one or more subprograms or enumeration - -- literals. - case Get_Kind (Name) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration - | Iir_Kind_Enumeration_Literal => - Append_Element (List, Name); - when others => - Error_Msg_Sem - (+Sig, "entity tag must denote a subprogram or a literal"); - end case; - end if; - Inter := Get_Next_Interpretation (Inter); - end loop; - - Name := Sem_Decls.Sem_Signature (Create_Overload_List (List), Sig); - if Name = Null_Iir then - return; - end if; - - Set_Named_Entity (Prefix, Name); - Prefix := Finish_Sem_Name (Prefix); - Set_Signature_Prefix (Sig, Prefix); - - Attribute_A_Decl (Name, Attr, True, True); - end Sem_Signature_Entity_Designator; - - procedure Sem_Attribute_Specification - (Spec : Iir_Attribute_Specification; Scope : Iir) - is - -- Emit an error message when NAME is not found. - procedure Error_Attribute_Specification (Name : Iir) - is - Inter : Name_Interpretation_Type; - Decl : Iir; - begin - if Flag_Relaxed_Rules or Vhdl_Std = Vhdl_93c then - -- Some (clueless ?) vendors put attribute specifications in - -- architectures for ports (declared in entities). This is not - -- valid according to the LRM (eg: LRM02 5.1 Attribute - -- specification). Be tolerant. - Inter := Get_Interpretation (Get_Identifier (Name)); - if Valid_Interpretation (Inter) then - Decl := Get_Declaration (Inter); - if Get_Kind (Decl) = Iir_Kind_Interface_Signal_Declaration - and then (Get_Kind (Get_Parent (Decl)) - = Iir_Kind_Entity_Declaration) - and then Get_Kind (Scope) = Iir_Kind_Architecture_Body - then - Warning_Msg_Sem - (Warnid_Specs, +Name, - "attribute for port %i must be specified in the entity", - (1 => +Name)); - return; - end if; - end if; - end if; - - Error_Msg_Sem - (+Name, "no %i for attribute specification", (1 => +Name)); - end Error_Attribute_Specification; - - use Vhdl.Tokens; - - Name : Iir; - Attr : Iir_Attribute_Declaration; - Attr_Type : Iir; - List : Iir_Flist; - Expr : Iir; - Res : Boolean; - begin - -- LRM93 5.1 - -- The attribute designator must denote an attribute. - Name := Sem_Denoting_Name (Get_Attribute_Designator (Spec)); - Set_Attribute_Designator (Spec, Name); - - Attr := Get_Named_Entity (Name); - if Get_Kind (Attr) /= Iir_Kind_Attribute_Declaration then - Error_Class_Match (Name, "attribute"); - return; - end if; - - -- LRM 5.1 - -- The type of the expression in the attribute specification must be - -- the same as (or implicitly convertible to) the type mark in the - -- corresponding attribute declaration. - Attr_Type := Get_Type (Attr); - Expr := Sem_Expression (Get_Expression (Spec), Attr_Type); - if Expr /= Null_Iir then - Check_Read (Expr); - Expr := Eval_Expr_If_Static (Expr); - Set_Expression (Spec, Expr); - - -- LRM 5.1 - -- If the entity name list denotes an entity declaration, - -- architecture body or configuration declaration, then the - -- expression is required to be locally static. - -- GHDL: test based on the entity_class. - case Get_Entity_Class (Spec) is - when Tok_Entity - | Tok_Architecture - | Tok_Configuration => - if Get_Expr_Staticness (Expr) /= Locally then - Error_Msg_Sem - (+Spec, - "attribute expression for %t must be locally static", - +Get_Entity_Class (Spec)); - end if; - when others => - null; - end case; - else - Set_Expression - (Spec, Create_Error_Expr (Get_Expression (Spec), Attr_Type)); - end if; - - -- LRM93 3.2.1.1 Index constraints and discrete ranges - -- - For an attribute whose value is specified by an attribute - -- specification, the index ranges are defined by the expression - -- given in the specification, if the subtype of the attribute is - -- unconstrained [...] - -- GHDL: For attribute value. - - -- LRM 5.1 - -- The entity name list identifies those named entities, both - -- implicitly and explicitly defined, that inherit the attribute, as - -- defined below: - List := Get_Entity_Name_List (Spec); - if List = Iir_Flist_All then - -- o If the reserved word ALL is supplied, then the attribute - -- specification applies to all named entities of the specified - -- class that are declared in the immediatly enclosing - -- declarative part. - Res := Sem_Named_Entities (Scope, Null_Iir, Spec, True); - if Res = False and then Is_Warning_Enabled (Warnid_Specs) then - Warning_Msg_Sem - (Warnid_Specs, +Spec, - "attribute specification apply to no named entity"); - end if; - elsif List = Iir_Flist_Others then - -- o If the reserved word OTHERS is supplied, then the attribute - -- specification applies to named entities of the specified class - -- that are declared in the immediately enclosing declarative - -- part, provided that each such entity is not explicitly named - -- in the entity name list of a previous attribute specification - -- for the given attribute. - Res := Sem_Named_Entities (Scope, Null_Iir, Spec, False); - if Res = False and then Is_Warning_Enabled (Warnid_Specs) then - Warning_Msg_Sem - (Warnid_Specs, +Spec, - "attribute specification apply to no named entity"); - end if; - elsif List = Null_Iir_Flist then - pragma Assert (Flags.Flag_Force_Analysis); - null; - else - -- o If a list of entity designators is supplied, then the - -- attribute specification applies to the named entities denoted - -- by those designators. - declare - El : Iir; - begin - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - if Get_Kind (El) = Iir_Kind_Signature then - Sem_Signature_Entity_Designator (El, Spec); - else - -- LRM 5.1 - -- It is an error if the class of those names is not the - -- same as that denoted by entity class. - if not Sem_Named_Entities (Scope, El, Spec, True) then - Error_Attribute_Specification (El); - end if; - end if; - end loop; - end; - end if; - - -- Reverse the chain of attribute value in specification, so that they - -- are in textual order. This is important if the expression is not - -- static. - declare - El : Iir; - New_El : Iir; - Tmp : Iir; - begin - El := Get_Attribute_Value_Spec_Chain (Spec); - New_El := Null_Iir; - while Is_Valid (El) loop - Tmp := Get_Spec_Chain (El); - Set_Spec_Chain (El, New_El); - New_El := El; - El := Tmp; - end loop; - Set_Attribute_Value_Spec_Chain (Spec, New_El); - end; - end Sem_Attribute_Specification; - - procedure Check_Post_Attribute_Specification - (Attr_Spec_Chain : Iir; Decl : Iir) - is - use Vhdl.Tokens; - - Has_Error : Boolean; - Spec : Iir; - Decl_Class : Token_Type; - Decl_Class2 : Token_Type; - Ent_Class : Token_Type; - begin - -- Some declaration items can never be attributed. - Decl_Class2 := Tok_Eof; - case Get_Kind (Decl) is - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body - | Iir_Kind_Use_Clause - | Iir_Kind_Attribute_Declaration - | Iir_Kinds_Signal_Attribute - | Iir_Kind_Disconnection_Specification => - return; - when Iir_Kind_Anonymous_Type_Declaration => - -- A physical type definition declares units. - if Get_Kind (Get_Type_Definition (Decl)) - = Iir_Kind_Physical_Type_Definition - then - Decl_Class := Tok_Units; - else - return; - end if; - when Iir_Kind_Attribute_Specification => - Decl_Class := Get_Entity_Class (Decl); - when Iir_Kind_Type_Declaration => - Decl_Class := Tok_Type; - -- An enumeration type declares literals. - if Get_Kind (Get_Type_Definition (Decl)) - = Iir_Kind_Enumeration_Type_Definition - then - Decl_Class2 := Tok_Literal; - end if; - when Iir_Kind_Non_Object_Alias_Declaration - | Iir_Kind_Object_Alias_Declaration => - Decl_Class := Get_Entity_Class_Kind (Get_Name (Decl)); - -- NOTE: for non-object alias that declares an enumeration type - -- or a physical type, no need to set decl_class2, since - -- all implicit aliases are checked. - when others => - Decl_Class := Get_Entity_Class_Kind (Decl); - end case; - - Spec := Attr_Spec_Chain; - -- Skip itself (newly added, therefore first of the chain). - if Spec = Decl then - Spec := Get_Attribute_Specification_Chain (Spec); - end if; - while Spec /= Null_Iir loop - pragma Assert (Get_Entity_Name_List (Spec) in Iir_Flists_All_Others); - Ent_Class := Get_Entity_Class (Spec); - if Ent_Class = Decl_Class or Ent_Class = Decl_Class2 then - Has_Error := False; - - if Get_Kind (Decl) = Iir_Kind_Attribute_Specification then - -- LRM 5.1 Attribute specifications - -- An attribute specification with the entity name list OTHERS - -- or ALL for a given entity class that appears in a - -- declarative part must be the last such specification for the - -- given attribute for the given entity class in that - -- declarative part. - if Get_Identifier (Get_Attribute_Designator (Decl)) - = Get_Identifier (Get_Attribute_Designator (Spec)) - then - Error_Msg_Sem - (+Decl, "no attribute specification may follow an " - & "all/others spec", Cont => True); - Has_Error := True; - end if; - else - -- LRM 5.1 Attribute specifications - -- It is an error if a named entity in the specificied entity - -- class is declared in a given declarative part following such - -- an attribute specification. - Error_Msg_Sem - (+Decl, "no named entity may follow an all/others attribute " - & "specification", Cont => True); - Has_Error := True; - end if; - if Has_Error then - Error_Msg_Sem - (+Spec, "(previous all/others specification for the given " - &"entity class)"); - end if; - end if; - Spec := Get_Attribute_Specification_Chain (Spec); - end loop; - end Check_Post_Attribute_Specification; - - -- Compare ATYPE and TYPE_MARK. - -- ATYPE is a type definition, which can be anonymous. - -- TYPE_MARK is a subtype definition, established from a type mark. - -- Therefore, it is the name of a type or a subtype. - -- Return TRUE iff the type mark of ATYPE is TYPE_MARK. - function Is_Same_Type_Mark (Atype : Iir; Type_Mark : Iir) - return Boolean is - begin - if Get_Kind (Atype) in Iir_Kinds_Subtype_Definition - and then Is_Anonymous_Type_Definition (Atype) - then - -- FIXME: to be removed; used to catch uninitialized type_mark. - if Get_Subtype_Type_Mark (Atype) = Null_Iir then - raise Internal_Error; - end if; - return Get_Type (Get_Subtype_Type_Mark (Atype)) = Type_Mark; - else - return Atype = Type_Mark; - end if; - end Is_Same_Type_Mark; - - procedure Sem_Disconnection_Specification - (Dis : Iir_Disconnection_Specification) - is - Type_Mark : Iir; - Atype : Iir; - Time_Expr : Iir; - List : Iir_Flist; - El : Iir; - Sig : Iir; - Prefix : Iir; - begin - -- Sem type mark. - Type_Mark := Get_Type_Mark (Dis); - Type_Mark := Sem_Type_Mark (Type_Mark); - Set_Type_Mark (Dis, Type_Mark); - Atype := Get_Type (Type_Mark); - - -- LRM93 5.3 - -- The time expression in a disconnection specification must be static - -- and must evaluate to a non-negative value. - Time_Expr := Sem_Expression - (Get_Expression (Dis), Time_Subtype_Definition); - if Time_Expr /= Null_Iir then - Check_Read (Time_Expr); - Set_Expression (Dis, Time_Expr); - if Get_Expr_Staticness (Time_Expr) < Globally then - Error_Msg_Sem (+Time_Expr, "time expression must be static"); - end if; - end if; - - List := Get_Signal_List (Dis); - if List in Iir_Flists_All_Others then - -- FIXME: checks todo - null; - else - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - - if Is_Error (El) then - Sig := Null_Iir; - else - Sem_Name (El); - El := Finish_Sem_Name (El); - Set_Nth_Element (List, I, El); - - Sig := Get_Named_Entity (El); - Sig := Name_To_Object (Sig); - end if; - - if Sig /= Null_Iir then - Set_Type (El, Get_Type (Sig)); - Prefix := Get_Object_Prefix (Sig); - -- LRM93 5.3 - -- Each signal name in a signal list in a guarded signal - -- specification must be a locally static name that - -- denotes a guarded signal. - case Get_Kind (Prefix) is - when Iir_Kind_Signal_Declaration - | Iir_Kind_Interface_Signal_Declaration => - null; - when others => - Error_Msg_Sem (+El, "object must be a signal"); - return; - end case; - if Get_Name_Staticness (Sig) /= Locally then - Error_Msg_Sem (+El, "signal name must be locally static"); - end if; - if not Get_Guarded_Signal_Flag (Prefix) then - Error_Msg_Sem (+El, "signal must be a guarded signal"); - end if; - Set_Has_Disconnect_Flag (Prefix, True); - - -- LRM93 5.3 - -- If the guarded signal is a declared signal or a slice of - -- thereof, the type mark must be the same as the type mark - -- indicated in the guarded signal specification. - -- If the guarded signal is an array element of an explicitly - -- declared signal, the type mark must be the same as the - -- element subtype indication in the (explicit or implicit) - -- array type declaration that declares the base type of the - -- explicitly declared signal. - -- If the guarded signal is a record element of an explicitly - -- declared signal, then the type mark must be the same as - -- the type mark in the element subtype definition of the - -- record type declaration that declares the type of the - -- explicitly declared signal. - -- FIXME: to be checked: the expression type (as set by - -- sem_expression) may be a base type instead of a type mark. - if not Is_Same_Type_Mark (Get_Type (Sig), Atype) then - Error_Msg_Sem (+El, "type mark and signal type mismatch"); - end if; - - -- LRM93 5.3 - -- Each signal must be declared in the declarative part - -- enclosing the disconnection specification. - -- FIXME: todo. - elsif not Is_Error (El) - and then Get_Designated_Entity (El) /= Error_Mark - then - Error_Msg_Sem (+El, "name must designate a signal"); - end if; - end loop; - end if; - end Sem_Disconnection_Specification; - - -- Analyze entity aspect ASPECT and return the entity declaration. - -- Return NULL_IIR if not found. - function Sem_Entity_Aspect (Aspect : Iir) return Iir is - begin - case Get_Kind (Aspect) is - when Iir_Kind_Entity_Aspect_Entity => - declare - Entity_Name : Iir; - Entity : Iir; - Arch_Name : Iir; - Arch_Unit : Iir; - begin - -- The entity. - Entity_Name := Sem_Denoting_Name (Get_Entity_Name (Aspect)); - Set_Entity_Name (Aspect, Entity_Name); - Entity := Get_Named_Entity (Entity_Name); - if Entity = Error_Mark then - return Null_Iir; - end if; - if Get_Kind (Entity) /= Iir_Kind_Entity_Declaration then - Error_Class_Match (Entity_Name, "entity"); - return Null_Iir; - end if; - -- Note: dependency is added by Sem_Denoting_Name. - - -- Check architecture. - Arch_Name := Get_Architecture (Aspect); - if Arch_Name /= Null_Iir then - Arch_Unit := Libraries.Find_Secondary_Unit - (Get_Design_Unit (Entity), Get_Identifier (Arch_Name)); - if Arch_Unit /= Null_Iir then - -- The architecture is known. - if Get_Date_State (Arch_Unit) >= Date_Parse then - -- And loaded! - Arch_Unit := Get_Library_Unit (Arch_Unit); - end if; - Set_Named_Entity (Arch_Name, Arch_Unit); - Xref_Ref (Arch_Name, Arch_Unit); - end if; - - -- FIXME: may emit a warning if the architecture does not - -- exist. - -- Note: the design needs the architecture. - Add_Dependence (Aspect); - end if; - return Entity; - end; - - when Iir_Kind_Entity_Aspect_Configuration => - declare - Conf_Name : Iir; - Conf : Iir; - begin - Conf_Name := - Sem_Denoting_Name (Get_Configuration_Name (Aspect)); - Set_Configuration_Name (Aspect, Conf_Name); - Conf := Get_Named_Entity (Conf_Name); - if Is_Error (Conf) then - return Null_Iir; - elsif Get_Kind (Conf) /= Iir_Kind_Configuration_Declaration then - Error_Class_Match (Conf, "configuration"); - return Null_Iir; - end if; - - return Get_Entity (Conf); - end; - - when Iir_Kind_Entity_Aspect_Open => - return Null_Iir; - - when others => - Error_Kind ("sem_entity_aspect", Aspect); - end case; - end Sem_Entity_Aspect; - - procedure Sem_Binding_Indication (Bind : Iir_Binding_Indication; - Parent : Iir; - Primary_Entity_Aspect : Iir) - is - Entity_Aspect : Iir; - Entity : Iir_Entity_Declaration; - begin - if Bind = Null_Iir then - raise Internal_Error; - end if; - - Entity_Aspect := Get_Entity_Aspect (Bind); - if Entity_Aspect /= Null_Iir then - Entity := Sem_Entity_Aspect (Entity_Aspect); - - -- LRM93 5.2.1 Binding Indication - -- An incremental binding indication must not have an entity aspect. - if Primary_Entity_Aspect /= Null_Iir then - Error_Msg_Sem - (+Bind, "entity aspect not allowed for incremental binding"); - end if; - - -- Return now in case of error. - if Entity = Null_Iir then - return; - end if; - else - -- LRM93 5.2.1 - -- When a binding indication is used in an explicit configuration - -- specification, it is an error if the entity aspect is absent. - case Get_Kind (Parent) is - when Iir_Kind_Component_Configuration => - if Primary_Entity_Aspect = Null_Iir then - Entity := Null_Iir; - else - case Get_Kind (Primary_Entity_Aspect) is - when Iir_Kind_Entity_Aspect_Entity => - Entity := Get_Entity (Primary_Entity_Aspect); - when others => - Error_Kind - ("sem_binding_indication", Primary_Entity_Aspect); - end case; - end if; - when Iir_Kind_Configuration_Specification => - Error_Msg_Sem - (+Bind, - "entity aspect required in a configuration specification"); - return; - when others => - raise Internal_Error; - end case; - end if; - if Entity = Null_Iir - or else Get_Kind (Entity) = Iir_Kind_Entity_Aspect_Open - then - -- LRM 5.2.1.1 Entity aspect - -- The third form of entity aspect is used to specify that the - -- indiciation of the design entity is to be defined. In this case, - -- the immediatly enclosing binding indication is said to not - -- imply any design entity. Furthermore, the immediatly enclosing - -- binding indication must not include a generic map aspect or a - -- port map aspect. - if Get_Generic_Map_Aspect_Chain (Bind) /= Null_Iir - or else Get_Port_Map_Aspect_Chain (Bind) /= Null_Iir - then - Error_Msg_Sem - (+Bind, "map aspect not allowed for open entity aspect"); - return; - end if; - else - Sem_Generic_Port_Association_Chain (Entity, Bind); - - -- LRM 5.2.1 Binding Indication - -- If the generic map aspect or port map aspect of a binding - -- indication is not present, then the default rules as described - -- in 5.2.2 apply. - -- GHDL: done in canon - end if; - end Sem_Binding_Indication; - - -- Set configuration_specification or component_configuration SPEC to - -- component instantiation COMP. - procedure Apply_Configuration_Specification - (Comp : Iir_Component_Instantiation_Statement; - Spec : Iir; - Primary_Entity_Aspect : in out Iir) - is - Prev_Spec : Iir; - Prev_Conf : Iir; - - procedure Prev_Spec_Error is - begin - Error_Msg_Sem - (+Spec, "%n is alreay bound by a configuration specification", - (1 => +Comp), Cont => True); - Error_Msg_Sem (+Prev_Spec, "(previous is %n)", +Prev_Spec); - end Prev_Spec_Error; - - Prev_Binding : Iir_Binding_Indication; - Prev_Entity_Aspect : Iir; - begin - Prev_Spec := Get_Configuration_Specification (Comp); - if Prev_Spec /= Null_Iir then - case Get_Kind (Spec) is - when Iir_Kind_Configuration_Specification => - Prev_Spec_Error; - return; - when Iir_Kind_Component_Configuration => - if Flags.Vhdl_Std = Vhdl_87 then - Prev_Spec_Error; - Error_Msg_Sem - (+Spec, "(incremental binding is not allowed in vhdl87)"); - return; - end if; - -- Incremental binding. - Prev_Binding := Get_Binding_Indication (Prev_Spec); - if Prev_Binding /= Null_Iir then - Prev_Entity_Aspect := Get_Entity_Aspect (Prev_Binding); - if Primary_Entity_Aspect = Null_Iir then - Primary_Entity_Aspect := Prev_Entity_Aspect; - else - -- FIXME: checks to do ? - null; - end if; - end if; - when others => - Error_Kind ("apply_configuration_specification", Spec); - end case; - end if; - Prev_Conf := Get_Component_Configuration (Comp); - if Prev_Conf /= Null_Iir then - case Get_Kind (Spec) is - when Iir_Kind_Configuration_Specification => - -- How can this happen ? - raise Internal_Error; - when Iir_Kind_Component_Configuration => - Error_Msg_Sem - (+Spec, "%n is already bound by a component configuration", - (1 => +Comp), Cont => True); - Error_Msg_Sem (+Prev_Conf, "(previous is %n)", +Prev_Conf); - return; - when others => - Error_Kind ("apply_configuration_specification(2)", Spec); - end case; - end if; - if Get_Kind (Spec) = Iir_Kind_Configuration_Specification then - Set_Configuration_Specification (Comp, Spec); - end if; - Set_Component_Configuration (Comp, Spec); - end Apply_Configuration_Specification; - - -- Analyze component_configuration or configuration_specification SPEC. - -- STMTS is the concurrent statement list related to SPEC. - procedure Sem_Component_Specification - (Parent_Stmts : Iir; Spec : Iir; Primary_Entity_Aspect : out Iir) - is - function Apply_Component_Specification - (Chain : Iir; Check_Applied : Boolean) return Boolean - is - Comp : constant Iir := Get_Named_Entity (Get_Component_Name (Spec)); - El : Iir; - Res : Boolean; - begin - if Chain = Null_Iir then - return False; - end if; - - El := Get_Concurrent_Statement_Chain (Chain); - Res := False; - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Component_Instantiation_Statement => - if Is_Component_Instantiation (El) - and then - Get_Named_Entity (Get_Instantiated_Unit (El)) = Comp - and then - (not Check_Applied - or else Get_Component_Configuration (El) = Null_Iir) - then - Apply_Configuration_Specification - (El, Spec, Primary_Entity_Aspect); - Res := True; - end if; - when Iir_Kind_For_Generate_Statement - | Iir_Kind_If_Generate_Statement => - if False and then Flags.Vhdl_Std = Vhdl_87 then - Res := Res - or Apply_Component_Specification (El, Check_Applied); - end if; - when others => - null; - end case; - El := Get_Chain (El); - end loop; - return Res; - end Apply_Component_Specification; - - List : Iir_Flist; - El : Iir; - Inter : Sem_Scopes.Name_Interpretation_Type; - Comp : Iir; - Comp_Name : Iir; - Inst : Iir; - Inst_Unit : Iir; - begin - Primary_Entity_Aspect := Null_Iir; - Comp_Name := Get_Component_Name (Spec); - if Is_Error (Comp_Name) then - pragma Assert (Flags.Flag_Force_Analysis); - return; - end if; - Comp_Name := Sem_Denoting_Name (Comp_Name); - Set_Component_Name (Spec, Comp_Name); - Comp := Get_Named_Entity (Comp_Name); - if Get_Kind (Comp) /= Iir_Kind_Component_Declaration then - Error_Class_Match (Comp_Name, "component"); - return; - end if; - - List := Get_Instantiation_List (Spec); - if List = Iir_Flist_All then - -- LRM93 5.2 - -- * If the reserved word ALL is supplied, then the configuration - -- specification applies to all instances of the specified - -- component declaration whose labels are (implicitly) declared - -- in the immediately enclosing declarative region part. - -- This rule applies only to those component instantiation - -- statements whose corresponding instantiated units name - -- component. - if not Apply_Component_Specification (Parent_Stmts, False) - and then Is_Warning_Enabled (Warnid_Specs) - then - Warning_Msg_Sem (Warnid_Specs, +Spec, - "component specification applies to no instance"); - end if; - elsif List = Iir_Flist_Others then - -- LRM93 5.2 - -- * If the reserved word OTHERS is supplied, then the - -- configuration specification applies to instances of the - -- specified component declaration whoce labels are (implicitly) - -- declared in the immediatly enclosing declarative part, - -- provided that each such component instance is not explicitly - -- names in the instantiation list of a previous configuration - -- specification. - -- This rule applies only to those component instantiation - -- statements whose corresponding instantiated units name - -- components. - if not Apply_Component_Specification (Parent_Stmts, True) - and then Is_Warning_Enabled (Warnid_Specs) - then - Warning_Msg_Sem (Warnid_Specs, +Spec, - "component specification applies to no instance"); - end if; - else - -- LRM93 5.2 - -- * If a list of instantiation labels is supplied, then the - -- configuration specification applies to the corresponding - -- component instances. - -- Such labels must be (implicitly) declared within the - -- immediatly enclosing declarative part. - -- It is an error if these component instances are not instances - -- of the component declaration named in the component - -- specification. - -- It is also an error if any of the labels denote a component - -- instantiation statement whose corresponding instantiated unit - -- does not name a component. - -- FIXME: error message are *really* cryptic. - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - Inter := Sem_Scopes.Get_Interpretation (Get_Identifier (El)); - if not Valid_Interpretation (Inter) then - Error_Msg_Sem - (+El, "no component instantation with label %i", +El); - elsif not Is_In_Current_Declarative_Region (Inter) then - -- FIXME. - Error_Msg_Sem (+El, "label not in block declarative part"); - else - Inst := Get_Declaration (Inter); - if Get_Kind (Inst) /= Iir_Kind_Component_Instantiation_Statement - then - Error_Msg_Sem - (+El, "label does not denote an instantiation"); - else - Inst_Unit := Get_Instantiated_Unit (Inst); - if Is_Entity_Instantiation (Inst) - or else (Get_Kind (Get_Named_Entity (Inst_Unit)) - /= Iir_Kind_Component_Declaration) - then - Error_Msg_Sem - (+El, "specification does not apply to " - & "direct instantiation"); - elsif Get_Named_Entity (Inst_Unit) /= Comp then - Error_Msg_Sem (+El, "component names mismatch"); - else - Apply_Configuration_Specification - (Inst, Spec, Primary_Entity_Aspect); - Xref_Ref (El, Inst); - Set_Named_Entity (El, Inst); - Set_Is_Forward_Ref (El, True); - end if; - end if; - end if; - end loop; - end if; - end Sem_Component_Specification; - - procedure Sem_Configuration_Specification - (Parent_Stmts : Iir; Conf : Iir_Configuration_Specification) - is - Primary_Entity_Aspect : Iir; - Component : Iir; - begin - Sem_Component_Specification (Parent_Stmts, Conf, Primary_Entity_Aspect); - Component := Get_Component_Name (Conf); - if Is_Error (Component) then - pragma Assert (Flags.Flag_Force_Analysis); - return; - end if; - Component := Get_Named_Entity (Component); - - -- Return now in case of error. - if Get_Kind (Component) /= Iir_Kind_Component_Declaration then - return; - end if; - -- Extend scope of component interface declaration. - Sem_Scopes.Open_Scope_Extension; - Sem_Scopes.Add_Component_Declarations (Component); - Sem_Binding_Indication - (Get_Binding_Indication (Conf), Conf, Primary_Entity_Aspect); - -- FIXME: check default port and generic association. - Sem_Scopes.Close_Scope_Extension; - end Sem_Configuration_Specification; - - function Sem_Create_Default_Binding_Indication - (Comp : Iir_Component_Declaration; - Entity_Unit : Iir_Design_Unit; - Parent : Iir; - Force : Boolean; - Create_Map_Aspect : Boolean) - return Iir_Binding_Indication - is - Entity : Iir_Entity_Declaration; - Entity_Name : Iir; - Aspect : Iir; - Res : Iir; - Design_Unit : Iir_Design_Unit; - begin - -- LRM 5.2.2 - -- The default binding indication consists of a default entity aspect, - -- together with a default generic map aspect and a default port map - -- aspect, as appropriate. - - if Entity_Unit = Null_Iir then - if not Force then - return Null_Iir; - end if; - - -- LRM 5.2.2 - -- If no visible entity declaration has the same simple name as that - -- of the instantiated component, then the default entity aspect is - -- OPEN. - Aspect := Create_Iir (Iir_Kind_Entity_Aspect_Open); - Location_Copy (Aspect, Comp); - Res := Create_Iir (Iir_Kind_Binding_Indication); - Set_Entity_Aspect (Res, Aspect); - return Res; - else - -- LRM 5.2.2 - -- Otherwise, the default entity aspect is of the form: - -- ENTITY entity_name ( architecture_identifier) - -- where the entity name is the simple name of the instantiated - -- component and the architecture identifier is the same as the - -- simple name of the most recently analyzed architecture body - -- associated with the entity declaration. - -- - -- If this rule is applied either to a binding indication contained - -- within a configuration specification or to a component - -- configuration that does not contain an explicit inner block - -- configuration, then the architecture identifier is determined - -- during elaboration of the design hierarchy containing the binding - -- indication. - -- - -- Likewise, if a component instantiation statement contains an - -- instantiated unit containing the reserved word ENTITY, but does - -- not contain an explicitly specified architecture identifier, this - -- rule is applied during the elaboration of the design hierarchy - -- containing a component instantiation statement. - -- - -- In all other cases, this rule is applied during analysis of the - -- binding indication. - -- - -- It is an error if there is no architecture body associated with - -- the entity declaration denoted by an entity name that is the - -- simple name of the instantiated component. - null; - end if; - - Design_Unit := Load_Primary_Unit - (Get_Library (Get_Design_File (Entity_Unit)), - Get_Identifier (Get_Library_Unit (Entity_Unit)), - Parent); - if Design_Unit = Null_Iir then - -- Found an entity which is not in the library. - raise Internal_Error; - end if; - - Entity := Get_Library_Unit (Design_Unit); - - Res := Create_Iir (Iir_Kind_Binding_Indication); - Aspect := Create_Iir (Iir_Kind_Entity_Aspect_Entity); - Location_Copy (Aspect, Parent); - - -- Create a name for the entity. As this is a default binding - -- indication, the design unit does *NOT* depend on the entity, so the - -- reference is a forward reference. - Entity_Name := Build_Simple_Name (Entity, Parent); - Set_Is_Forward_Ref (Entity_Name, True); - - Set_Entity_Name (Aspect, Entity_Name); - Set_Entity_Aspect (Res, Aspect); - - if Create_Map_Aspect then - -- LRM 5.2.2 - -- The default binding indication includes a default generic map - -- aspect if the design entity implied by the entity aspect contains - -- formal generics. - Set_Generic_Map_Aspect_Chain - (Res, - Create_Default_Map_Aspect (Comp, Entity, Map_Generic, Parent)); - - -- LRM 5.2.2 - -- The default binding indication includes a default port map aspect - -- if the design entity implied by the entity aspect contains formal - -- ports. - Set_Port_Map_Aspect_Chain - (Res, Create_Default_Map_Aspect (Comp, Entity, Map_Port, Parent)); - end if; - - return Res; - end Sem_Create_Default_Binding_Indication; - - -- LRM 5.2.2 - -- The default binding indication includes a default generic map aspect - -- if the design entity implied by the entity aspect contains formal - -- generics. - -- - -- The default generic map aspect associates each local generic in - -- the corresponding component instantiation (if any) with a formal - -- of the same simple name. - -- It is an error if such a formal does not exist, or if its mode and - -- type are not appropriate for such an association. - -- Any remaining unassociated formals are associated with the actual - -- designator OPEN. - - -- LRM 5.2.2 - -- The default binding indication includes a default port map aspect - -- if the design entity implied by the entity aspect contains formal - -- ports. - -- - -- The default port map aspect associates each local port in the - -- corresponding component instantiation (if any) with a formal of - -- the same simple name. - -- It is an error if such a formal does not exist, or if its mode - -- and type are not appropriate for such an association. - -- Any remaining unassociated formals are associated with the actual - -- designator OPEN. - function Create_Default_Map_Aspect - (Comp : Iir; Entity : Iir; Kind : Map_Kind_Type; Parent : Iir) - return Iir - is - Error : Boolean; - - procedure Error_Header is - begin - if Error then - return; - end if; - Error_Msg_Sem - (+Parent, "for default port binding of %n:", - (1 => +Parent), Cont => True); - Error := True; - end Error_Header; - - Res, Last : Iir; - Comp_El, Ent_El : Iir; - Assoc : Iir; - Name : Iir; - Found : Natural; - Comp_Chain : Iir; - Ent_Chain : Iir; - begin - case Kind is - when Map_Generic => - Ent_Chain := Get_Generic_Chain (Entity); - Comp_Chain := Get_Generic_Chain (Comp); - when Map_Port => - Ent_Chain := Get_Port_Chain (Entity); - Comp_Chain := Get_Port_Chain (Comp); - end case; - - -- No error found yet. - Error := False; - - Sub_Chain_Init (Res, Last); - Found := 0; - Ent_El := Ent_Chain; - while Ent_El /= Null_Iir loop - -- Find the component generic/port with the same name. - Comp_El := Find_Name_In_Chain (Comp_Chain, Get_Identifier (Ent_El)); - if Comp_El = Null_Iir then - Assoc := Create_Iir (Iir_Kind_Association_Element_Open); - Location_Copy (Assoc, Parent); - else - if Are_Nodes_Compatible (Comp_El, Ent_El) = Not_Compatible then - Error_Header; - Error_Msg_Sem - (+Parent, "type of %n declared at %l", - (+Comp_El, +Comp_El), Cont => True); - Error_Msg_Sem - (+Parent, "not compatible with type of %n declared at %l", - (+Ent_El, +Ent_El)); - elsif Kind = Map_Port - and then not Check_Port_Association_Mode_Restrictions - (Ent_El, Comp_El, Null_Iir) - then - Error_Header; - Error_Msg_Sem (+Parent, "cannot associate " - & Get_Mode_Name (Get_Mode (Ent_El)) - & " %n declared at %l", - (+Ent_El, +Ent_El), Cont => True); - Error_Msg_Sem (+Parent, "with actual port of mode " - & Get_Mode_Name (Get_Mode (Comp_El)) - & " declared at %l", +Comp_El); - end if; - Assoc := Create_Iir (Iir_Kind_Association_Element_By_Expression); - Location_Copy (Assoc, Parent); - Name := Build_Simple_Name (Comp_El, Parent); - Set_Type (Name, Get_Type (Comp_El)); - Set_Actual (Assoc, Name); - if Kind = Map_Port and then not Error then - Check_Port_Association_Bounds_Restrictions - (Ent_El, Comp_El, Assoc); - end if; - Found := Found + 1; - end if; - Set_Whole_Association_Flag (Assoc, True); - - -- Create the formal name. This is a forward reference as the - -- current design unit does not depend on the entity. - Name := Build_Simple_Name (Ent_El, Parent); - Set_Is_Forward_Ref (Name, True); - Set_Type (Name, Get_Type (Ent_El)); - Set_Formal (Assoc, Name); - - if Kind = Map_Port - and then not Error - and then Comp_El /= Null_Iir - then - Set_Collapse_Signal_Flag - (Assoc, Can_Collapse_Signals (Assoc, Ent_El)); - end if; - Sub_Chain_Append (Res, Last, Assoc); - Ent_El := Get_Chain (Ent_El); - end loop; - if Iir_Chains.Get_Chain_Length (Comp_Chain) /= Found then - -- At least one component generic/port cannot be associated with - -- the entity one. - - -- Disp unassociated interfaces. - Comp_El := Comp_Chain; - while Comp_El /= Null_Iir loop - Ent_El := Find_Name_In_Chain (Ent_Chain, Get_Identifier (Comp_El)); - if Ent_El = Null_Iir then - Error_Header; - Error_Msg_Sem (+Parent, "%n has no association in %n", - (+Comp_El, +Entity)); - end if; - Comp_El := Get_Chain (Comp_El); - end loop; - end if; - if Error then - return Null_Iir; - else - return Res; - end if; - end Create_Default_Map_Aspect; - - -- LRM93 §5.2.2 - function Get_Visible_Entity_Declaration (Comp: Iir_Component_Declaration) - return Iir_Design_Unit - is - -- Return the design_unit if DECL is an entity declaration or the - -- design unit of an entity declaration. Otherwise return Null_Iir. - -- This double check is needed as the interpretation may be both. - function Is_Entity_Declaration (Decl : Iir) return Iir is - begin - if Get_Kind (Decl) = Iir_Kind_Entity_Declaration then - return Get_Design_Unit (Decl); - elsif Get_Kind (Decl) = Iir_Kind_Design_Unit - and then - Get_Kind (Get_Library_Unit (Decl)) = Iir_Kind_Entity_Declaration - then - return Decl; - else - return Null_Iir; - end if; - end Is_Entity_Declaration; - - Name : constant Name_Id := Get_Identifier (Comp); - Inter : Name_Interpretation_Type; - Decl : Iir; - Res : Iir; - Target_Lib : Iir; - begin - Inter := Get_Interpretation (Name); - - if Valid_Interpretation (Inter) then - -- LRM93 5.2.2 Default binding indication - -- A visible entity declaration is either: - -- - -- a) An entity declaration that has the same simple name as that of - -- the instantiated component and that is directly visible - -- (see 10.3), - Decl := Get_Declaration (Inter); - Res := Is_Entity_Declaration (Decl); - if Res /= Null_Iir then - return Res; - end if; - - -- b) An entity declaration that has the same simple name that of - -- the instantiated component and that would be directly - -- visible in the absence of a directly visible (see 10.3) - -- component declaration with the same simple name as that - -- of the entity declaration, or - if Get_Kind (Decl) = Iir_Kind_Component_Declaration then - Inter := Get_Under_Interpretation (Name); - if Valid_Interpretation (Inter) then - Decl := Get_Declaration (Inter); - Res := Is_Entity_Declaration (Decl); - if Res /= Null_Iir then - return Res; - end if; - end if; - end if; - end if; - - -- VHDL02: - -- c) An entity declaration denoted by "L.C", where L is the target - -- library and C is the simple name of the instantiated component. - -- The target library is the library logical name of the library - -- containing the design unit in which the component C is - -- declared. - if Flags.Flag_Syn_Binding - or Flags.Vhdl_Std >= Vhdl_02 - or Flags.Vhdl_Std = Vhdl_93c - then - -- Find target library. - Target_Lib := Comp; - while Get_Kind (Target_Lib) /= Iir_Kind_Library_Declaration loop - Target_Lib := Get_Parent (Target_Lib); - end loop; - - Decl := Libraries.Find_Primary_Unit (Target_Lib, Name); - if Decl /= Null_Iir then - Res := Is_Entity_Declaration (Decl); - if Res /= Null_Iir then - return Res; - end if; - end if; - end if; - - -- --syn-binding - -- Search for any entity. - if Flags.Flag_Syn_Binding then - Decl := Libraries.Find_Entity_For_Component (Name); - if Decl /= Null_Iir then - return Decl; - end if; - end if; - - return Null_Iir; - end Get_Visible_Entity_Declaration; - - -- Explain why there is no default binding for COMP. - procedure Explain_No_Visible_Entity (Comp: Iir_Component_Declaration) - is - Inter : Name_Interpretation_Type; - Name : Name_Id; - Decl : Iir; - begin - Name := Get_Identifier (Comp); - Inter := Get_Interpretation (Name); - - if Valid_Interpretation (Inter) then - -- LRM93 5.2.2 Default binding indication - -- A visible entity declaration is either: - -- - -- a) An entity declaration that has the same simple name as that of - -- the instantiated component and that is directly visible - -- (see 10.3), - Decl := Get_Declaration (Inter); - Warning_Msg_Elab - (Warnid_Default_Binding, Decl, "visible declaration for %i", +Name); - - -- b) An entity declaration that has the same simple name that of - -- the instantiated component and that would be directly - -- visible in the absence of a directly visible (see 10.3) - -- component declaration with the same simple name as that - -- of the entity declaration, or - if Get_Kind (Decl) = Iir_Kind_Component_Declaration then - Inter := Get_Under_Interpretation (Name); - if Valid_Interpretation (Inter) then - Decl := Get_Declaration (Inter); - Warning_Msg_Elab (Warnid_Default_Binding, Comp, - "interpretation behind the component is %n", - +Decl); - end if; - end if; - end if; - - -- VHDL02: - -- c) An entity declaration denoted by "L.C", where L is the target - -- library and C is the simple name of the instantiated component. - -- The target library is the library logical name of the library - -- containing the design unit in which the component C is - -- declared. - if Flags.Vhdl_Std >= Vhdl_02 - or else Flags.Vhdl_Std = Vhdl_93c - then - Decl := Comp; - while Get_Kind (Decl) /= Iir_Kind_Library_Declaration loop - Decl := Get_Parent (Decl); - end loop; - - Warning_Msg_Elab (Warnid_Default_Binding, Comp, - "no entity %i in %n", (+Name, +Decl)); - end if; - end Explain_No_Visible_Entity; - - procedure Sem_Specification_Chain (Decls_Parent : Iir; Parent_Stmts: Iir) - is - Decl: Iir; - begin - Decl := Get_Declaration_Chain (Decls_Parent); - while Decl /= Null_Iir loop - case Get_Kind (Decl) is - when Iir_Kind_Configuration_Specification => - Sem_Configuration_Specification (Parent_Stmts, Decl); - when others => - null; - end case; - Decl := Get_Chain (Decl); - end loop; - end Sem_Specification_Chain; -end Sem_Specs; diff --git a/src/vhdl/sem_specs.ads b/src/vhdl/sem_specs.ads deleted file mode 100644 index 170df72fb..000000000 --- a/src/vhdl/sem_specs.ads +++ /dev/null @@ -1,99 +0,0 @@ --- Semantic analysis. --- 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 Types; use Types; -with Iirs; use Iirs; -with Vhdl.Tokens; - -package Sem_Specs is - -- Return the attribute_value for named entity ENT and attribute identifier - -- ID. Return Null_Iir if ENT was not decorated with attribute ID. - function Find_Attribute_Value (Ent : Iir; Id : Name_Id) return Iir; - - -- Return the node containing the attribute_value_chain field for DECL. - -- This is the parent of the attribute specification, so in general this - -- is also the parent of the declaration, but there are exceptions... - function Get_Attribute_Value_Chain_Parent (Decl : Iir) return Iir; - - function Get_Entity_Class_Kind (Decl : Iir) return Vhdl.Tokens.Token_Type; - - procedure Sem_Attribute_Specification - (Spec : Iir_Attribute_Specification; Scope : Iir); - - -- Check declarations following an ALL/OTHERS attribute specification. - -- ATTR_SPEC_CHAIN is the linked list of all attribute specifications whith - -- the entity name list ALL or OTHERS until the current declaration DECL. - -- So no specification in the chain must match the declaration. - procedure Check_Post_Attribute_Specification - (Attr_Spec_Chain : Iir; Decl : Iir); - - procedure Sem_Disconnection_Specification - (Dis : Iir_Disconnection_Specification); - - procedure Sem_Configuration_Specification - (Parent_Stmts : Iir; Conf : Iir_Configuration_Specification); - - -- Analyze binding indication BIND of configuration specification or - -- component configuration PARENT. - -- PRIMARY_ENTITY_ASPECT is not Null_Iir for an incremental binding. - procedure Sem_Binding_Indication (Bind : Iir_Binding_Indication; - Parent : Iir; - Primary_Entity_Aspect : Iir); - - -- Analyze entity aspect ASPECT and return the entity declaration. - -- Return NULL_IIR if not found. - function Sem_Entity_Aspect (Aspect : Iir) return Iir; - - -- Analyze component_configuration or configuration_specification SPEC. - -- STMTS is the concurrent statement list related to SPEC. - procedure Sem_Component_Specification - (Parent_Stmts : Iir; Spec : Iir; Primary_Entity_Aspect : out Iir); - - -- Create a default binding indication for component COMP which will be - -- bound with entity ENTITY_UNIT. - -- If ENTITY_UNIT is NULL_IIR, the component is not bound. - -- If FORCE is True, a binding indication will be created even if the - -- component is not bound (this is an open binding indication). - -- If CREATE_MAP_ASPECT is true, port and generic map aspect are created. - -- PARENT is used to report error. - function Sem_Create_Default_Binding_Indication - (Comp : Iir_Component_Declaration; - Entity_Unit : Iir_Design_Unit; - Parent : Iir; - Force : Boolean; - Create_Map_Aspect : Boolean) - return Iir_Binding_Indication; - - -- Create a default generic or port map aspect that associates all elements - -- of ENTITY (if any) to elements of COMP with the same name or to - -- an open association. - -- If KIND is GENERIC_MAP, apply this on generics, if KIND is PORT_MAP, - -- apply this on ports. - -- PARENT is used to report errors. - type Map_Kind_Type is (Map_Generic, Map_Port); - function Create_Default_Map_Aspect - (Comp : Iir; Entity : Iir; Kind : Map_Kind_Type; Parent : Iir) - return Iir; - - -- Explain why there is no default binding for COMP. - procedure Explain_No_Visible_Entity (Comp: Iir_Component_Declaration); - - function Get_Visible_Entity_Declaration (Comp: Iir_Component_Declaration) - return Iir_Design_Unit; - - procedure Sem_Specification_Chain (Decls_Parent : Iir; Parent_Stmts: Iir); -end Sem_Specs; diff --git a/src/vhdl/sem_stmts.adb b/src/vhdl/sem_stmts.adb deleted file mode 100644 index 30c0de209..000000000 --- a/src/vhdl/sem_stmts.adb +++ /dev/null @@ -1,2183 +0,0 @@ --- Semantic analysis. --- 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 Errorout; use Errorout; -with Types; use Types; -with Flags; use Flags; -with Sem_Specs; use Sem_Specs; -with Std_Package; use Std_Package; -with Sem; use Sem; -with Sem_Decls; use Sem_Decls; -with Sem_Expr; use Sem_Expr; -with Sem_Names; use Sem_Names; -with Sem_Scopes; use Sem_Scopes; -with Sem_Types; -with Sem_Psl; -with Std_Names; -with Evaluation; use Evaluation; -with Iirs_Utils; use Iirs_Utils; -with Xrefs; use Xrefs; - -package body Sem_Stmts is - -- Process is the scope, this is also the process for which drivers can - -- be created. - -- Note: FIRST_STMT is the first statement, which can be get by: - -- get_sequential_statement_chain (usual) - -- get_associated_chain (for case statement). - procedure Sem_Sequential_Statements_Internal (First_Stmt : Iir); - - -- Access to the current subprogram or process. - Current_Subprogram: Iir := Null_Iir; - - function Get_Current_Subprogram return Iir is - begin - return Current_Subprogram; - end Get_Current_Subprogram; - - -- Access to the current concurrent statement. - -- Null_iir if no one. - Current_Concurrent_Statement : Iir := Null_Iir; - - function Get_Current_Concurrent_Statement return Iir is - begin - return Current_Concurrent_Statement; - end Get_Current_Concurrent_Statement; - - -- LRM 8 Sequential statements. - -- All statements may be labeled. - -- Such labels are implicitly declared at the beginning of the declarative - -- part of the innermost enclosing process statement of subprogram body. - procedure Sem_Sequential_Labels (First_Stmt : Iir) - is - Stmt: Iir; - Label: Name_Id; - begin - Stmt := First_Stmt; - while Stmt /= Null_Iir loop - Label := Get_Label (Stmt); - if Label /= Null_Identifier then - Sem_Scopes.Add_Name (Stmt); - Name_Visible (Stmt); - Xref_Decl (Stmt); - end if; - - -- Some statements have sub-lists of statements. - case Get_Kind (Stmt) is - when Iir_Kind_For_Loop_Statement - | Iir_Kind_While_Loop_Statement => - Sem_Sequential_Labels (Get_Sequential_Statement_Chain (Stmt)); - when Iir_Kind_If_Statement => - declare - Clause : Iir; - begin - Clause := Stmt; - while Clause /= Null_Iir loop - Sem_Sequential_Labels - (Get_Sequential_Statement_Chain (Clause)); - Clause := Get_Else_Clause (Clause); - end loop; - end; - when Iir_Kind_Case_Statement => - declare - El : Iir; - begin - El := Get_Case_Statement_Alternative_Chain (Stmt); - while El /= Null_Iir loop - Sem_Sequential_Labels (Get_Associated_Chain (El)); - El := Get_Chain (El); - end loop; - end; - when others => - null; - end case; - Stmt := Get_Chain (Stmt); - end loop; - end Sem_Sequential_Labels; - - procedure Fill_Array_From_Aggregate_Associated - (Chain : Iir; Nbr : in out Natural; Arr : in out Iir_Array) - is - El : Iir; - Ass : Iir; - begin - El := Chain; - while El /= Null_Iir loop - Ass := Get_Associated_Expr (El); - if Get_Kind (Ass) = Iir_Kind_Aggregate then - Fill_Array_From_Aggregate_Associated - (Get_Association_Choices_Chain (Ass), Nbr, Arr); - else - Arr (Nbr) := Ass; - Nbr := Nbr + 1; - end if; - El := Get_Chain (El); - end loop; - end Fill_Array_From_Aggregate_Associated; - - -- Return TRUE iff there is no common elements designed by N1 and N2. - -- N1 and N2 are static names. - -- FIXME: The current implementation is completly wrong; should check from - -- prefix to suffix. - function Is_Disjoint (N1, N2: Iir) return Boolean - is - List1, List2 : Iir_Flist; - El1, El2 : Iir; - begin - if N1 = N2 then - return False; - end if; - if Get_Kind (N1) = Iir_Kind_Indexed_Name - and then Get_Kind (N2) = Iir_Kind_Indexed_Name - then - if Is_Disjoint (Get_Prefix (N1), Get_Prefix (N2)) then - return True; - end if; - -- Check indexes. - List1 := Get_Index_List (N1); - List2 := Get_Index_List (N2); - for I in Flist_First .. Flist_Last (List1) loop - El1 := Get_Nth_Element (List1, I); - El2 := Get_Nth_Element (List2, I); - El1 := Eval_Expr (El1); - Set_Nth_Element (List1, I, El1); - El2 := Eval_Expr (El2); - Set_Nth_Element (List2, I, El2); - -- EL are of discrete type. - if Get_Value (El1) /= Get_Value (El2) then - return True; - end if; - end loop; - return False; - elsif Get_Kind (N1) in Iir_Kinds_Denoting_Name - and then Get_Kind (N2) in Iir_Kinds_Denoting_Name - then - return Get_Named_Entity (N1) /= Get_Named_Entity (N2); - else - return True; - end if; - end Is_Disjoint; - - procedure Check_Uniq_Aggregate_Associated - (Aggr : Iir_Aggregate; Nbr : Natural) - is - Chain : constant Iir := Get_Association_Choices_Chain (Aggr); - subtype El_Array_Type is Iir_Array (0 .. Nbr - 1); - Name_Arr, Obj_Arr : El_Array_Type; - Index : Natural; - El : Iir; - begin - -- Fill the array. - Index := 0; - Fill_Array_From_Aggregate_Associated (Chain, Index, Name_Arr); - -- Should be the same. - pragma Assert (Index = Nbr); - - -- Replace name with object. Return now in case of error (not an - -- object or not a static name). - for I in Name_Arr'Range loop - El := Name_To_Object (Name_Arr (I)); - if El = Null_Iir - or else Get_Name_Staticness (El) /= Locally - then - -- Error... - return; - end if; - Obj_Arr (I) := El; - end loop; - - -- Check each element is uniq. - for I in Name_Arr'Range loop - for J in 0 .. I - 1 loop - if not Is_Disjoint (Obj_Arr (I), Obj_Arr (J)) then - Error_Msg_Sem - (+Name_Arr (I), "target is assigned more than once", - Cont => True); - Error_Msg_Sem - (+Name_Arr (J), " (previous assignment is here)"); - return; - end if; - end loop; - end loop; - end Check_Uniq_Aggregate_Associated; - - -- Do checks for the target of an assignment. - procedure Check_Simple_Signal_Target - (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness); - -- STMT is used to localize the error (if any). - procedure Check_Simple_Variable_Target - (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness); - - -- Semantic associed with signal mode. - -- See LRM93 4.3.3 (or LRM08 6.5.2) - type Boolean_Array_Of_Iir_Mode is array (Iir_Mode) of Boolean; - Iir_Mode_Readable : constant Boolean_Array_Of_Iir_Mode := - (Iir_Unknown_Mode => False, - Iir_In_Mode => True, - Iir_Out_Mode => False, - Iir_Inout_Mode => True, - Iir_Buffer_Mode => True, - Iir_Linkage_Mode => False); - Iir_Mode_Writable : constant Boolean_Array_Of_Iir_Mode := - (Iir_Unknown_Mode => False, - Iir_In_Mode => False, - Iir_Out_Mode => True, - Iir_Inout_Mode => True, - Iir_Buffer_Mode => True, - Iir_Linkage_Mode => False); - - -- Return True iff signal interface INTER is readable. - function Is_Interface_Signal_Readable (Inter : Iir) return Boolean - is - pragma Assert (Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration); - Mode : constant Iir_Mode := Get_Mode (Inter); - begin - if Mode = Iir_Out_Mode and then Flags.Vhdl_Std >= Vhdl_08 then - -- LRM08 6.5.2 Interface object declarations - -- OUT. The value of the inerface object is allowed [...] and - -- provided it is not a signal parameter, read. - return not Is_Parameter (Inter); - else - return Iir_Mode_Readable (Mode); - end if; - end Is_Interface_Signal_Readable; - - procedure Check_Aggregate_Target - (Stmt : Iir; Target : Iir; Nbr : in out Natural) - is - Choice : Iir; - Ass : Iir; - begin - Choice := Get_Association_Choices_Chain (Target); - while Choice /= Null_Iir loop - case Get_Kind (Choice) is - when Iir_Kind_Choice_By_Range => - -- LRM93 8.4 - -- It is an error if an element association in such an - -- aggregate contains an OTHERS choice or a choice that is - -- a discrete range. - Error_Msg_Sem - (+Choice, "discrete range choice not allowed for target"); - when Iir_Kind_Choice_By_Others => - -- LRM93 8.4 - -- It is an error if an element association in such an - -- aggregate contains an OTHERS choice or a choice that is - -- a discrete range. - Error_Msg_Sem - (+Choice, "others choice not allowed for target"); - when Iir_Kind_Choice_By_Expression - | Iir_Kind_Choice_By_Name - | Iir_Kind_Choice_By_None => - -- LRM93 9.4 - -- Such a target may not only contain locally static signal - -- names [...] - Ass := Get_Associated_Expr (Choice); - if Get_Kind (Ass) = Iir_Kind_Aggregate then - Check_Aggregate_Target (Stmt, Ass, Nbr); - else - if Get_Kind (Stmt) in - Iir_Kinds_Variable_Assignment_Statement - then - Check_Simple_Variable_Target (Stmt, Ass, Locally); - else - Check_Simple_Signal_Target (Stmt, Ass, Locally); - end if; - Nbr := Nbr + 1; - end if; - when others => - Error_Kind ("check_aggregate_target", Choice); - end case; - Choice := Get_Chain (Choice); - end loop; - end Check_Aggregate_Target; - - procedure Check_Simple_Signal_Target - (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness) - is - Target_Object : Iir; - Target_Prefix : Iir; - Guarded_Target : Tri_State_Type; - Targ_Obj_Kind : Iir_Kind; - begin - Target_Object := Name_To_Object (Target); - if Target_Object = Null_Iir then - Error_Msg_Sem (+Target, "target is not a signal name"); - return; - end if; - - Target_Prefix := Get_Object_Prefix (Target_Object); - Targ_Obj_Kind := Get_Kind (Target_Prefix); - case Targ_Obj_Kind is - when Iir_Kind_Interface_Signal_Declaration => - if not Iir_Mode_Writable (Get_Mode (Target_Prefix)) then - Error_Msg_Sem - (+Target, "%n can't be assigned", +Target_Prefix); - else - Sem_Add_Driver (Target_Object, Stmt); - end if; - when Iir_Kind_Signal_Declaration => - Sem_Add_Driver (Target_Object, Stmt); - when Iir_Kind_Guard_Signal_Declaration => - Error_Msg_Sem (+Stmt, "implicit GUARD signal cannot be assigned"); - return; - when others => - Error_Msg_Sem - (+Stmt, "target (%n) is not a signal", +Get_Base_Name (Target)); - return; - end case; - if Get_Name_Staticness (Target_Object) < Staticness then - Error_Msg_Sem (+Stmt, "signal name must be static"); - end if; - - -- LRM93 2.1.1.2 - -- A formal signal parameter is a guarded signal if and only if - -- it is associated with an actual signal that is a guarded - -- signal. - -- GHDL: a formal signal interface of a subprogram has no static - -- kind. This is determined at run-time, according to the actual - -- associated with the formal. - -- GHDL: parent of target cannot be a function. - if Targ_Obj_Kind = Iir_Kind_Interface_Signal_Declaration - and then Is_Parameter (Target_Prefix) - then - Guarded_Target := Unknown; - else - if Get_Guarded_Signal_Flag (Target_Prefix) then - Guarded_Target := True; - else - Guarded_Target := False; - end if; - end if; - - case Get_Guarded_Target_State (Stmt) is - when Unknown => - Set_Guarded_Target_State (Stmt, Guarded_Target); - when True - | False => - if Get_Guarded_Target_State (Stmt) /= Guarded_Target then - -- LRM93 9.5 - -- It is an error if the target of a concurrent signal - -- assignment is neither a guarded target nor an - -- unguarded target. - Error_Msg_Sem (+Target, "guarded and unguarded target"); - end if; - end case; - end Check_Simple_Signal_Target; - - procedure Check_Simple_Variable_Target - (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness) - is - Target_Object : Iir; - Target_Prefix : Iir; - begin - Target_Object := Name_To_Object (Target); - if Target_Object = Null_Iir then - Error_Msg_Sem (+Stmt, "target is not a variable name"); - return; - end if; - Target_Prefix := Get_Object_Prefix (Target_Object); - case Get_Kind (Target_Prefix) is - when Iir_Kind_Interface_Variable_Declaration => - if not Iir_Mode_Writable (Get_Mode (Target_Prefix)) then - Error_Msg_Sem (+Target, "%n cannot be written (bad mode)", - +Target_Prefix); - return; - end if; - when Iir_Kind_Variable_Declaration => - null; - when Iir_Kind_Implicit_Dereference - | Iir_Kind_Dereference => - -- LRM 3.3 - -- An object designated by an access type is always an object of - -- class variable. - null; - when others => - Error_Msg_Sem (+Stmt, "%n is not a variable to be assigned", - +Target_Prefix); - return; - end case; - if Get_Name_Staticness (Target_Object) < Staticness then - Error_Msg_Sem - (+Target, "element of a target aggregate must be a static name"); - end if; - end Check_Simple_Variable_Target; - - procedure Check_Target (Stmt : Iir; Target : Iir) - is - Nbr : Natural; - begin - if Get_Kind (Target) = Iir_Kind_Aggregate then - Nbr := 0; - Check_Aggregate_Target (Stmt, Target, Nbr); - Check_Uniq_Aggregate_Associated (Target, Nbr); - else - case Get_Kind (Stmt) is - when Iir_Kind_Variable_Assignment_Statement - | Iir_Kind_Conditional_Variable_Assignment_Statement => - Check_Simple_Variable_Target (Stmt, Target, None); - when others => - Check_Simple_Signal_Target (Stmt, Target, None); - end case; - end if; - end Check_Target; - - type Resolve_Stages is (Resolve_Stage_1, Resolve_Stage_2); - pragma Unreferenced (Resolve_Stage_2); - - procedure Sem_Signal_Assignment_Target_And_Option - (Stmt: Iir; Sig_Type : in out Iir) - is - -- The target of the assignment. - Target: Iir; - -- The value that will be assigned. - Expr: Iir; - begin - Target := Get_Target (Stmt); - Target := Sem_Expression_Wildcard (Target, Get_Base_Type (Sig_Type)); - - if Target /= Null_Iir then - Set_Target (Stmt, Target); - if Is_Expr_Fully_Analyzed (Target) then - Check_Target (Stmt, Target); - Sig_Type := Get_Type (Target); - Sem_Types.Set_Type_Has_Signal (Sig_Type); - end if; - end if; - - Expr := Get_Reject_Time_Expression (Stmt); - if Expr /= Null_Iir - and then Is_Expr_Not_Analyzed (Expr) - then - Expr := Sem_Expression (Expr, Time_Type_Definition); - if Expr /= Null_Iir then - Check_Read (Expr); - Set_Reject_Time_Expression (Stmt, Expr); - end if; - end if; - end Sem_Signal_Assignment_Target_And_Option; - - -- Analyze a waveform_list WAVEFORM_LIST that is assigned via statement - -- ASSIGN_STMT to a subelement or a slice of a signal SIGNAL_DECL. - procedure Sem_Waveform_Chain (Waveform_Chain : Iir_Waveform_Element; - Waveform_Type : in out Iir) - is - Expr: Iir; - We: Iir_Waveform_Element; - Time, Last_Time : Iir_Int64; - begin - if Get_Kind (Waveform_Chain) = Iir_Kind_Unaffected_Waveform then - -- Unaffected. - return; - end if; - - -- Start with -1 to allow after 0 ns. - Last_Time := -1; - We := Waveform_Chain; - while We /= Null_Iir loop - Expr := Get_We_Value (We); - if Get_Kind (Expr) = Iir_Kind_Null_Literal then - -- GHDL: allowed only if target is guarded; this is checked by - -- sem_check_waveform_list. - null; - else - Expr := Sem_Expression_Wildcard (Expr, Waveform_Type, True); - - if Expr /= Null_Iir then - if Is_Expr_Fully_Analyzed (Expr) then - Check_Read (Expr); - Expr := Eval_Expr_If_Static (Expr); - end if; - Set_We_Value (We, Expr); - - Merge_Wildcard_Type (Expr, Waveform_Type); - else - Expr := Get_We_Value (We); - Expr := Create_Error_Expr (Expr, Waveform_Type); - Set_We_Value (We, Expr); - end if; - end if; - - -- Analyze time expression. - if Get_Time (We) /= Null_Iir then - Expr := Get_Time (We); - if Is_Expr_Not_Analyzed (Expr) then - Expr := Sem_Expression (Expr, Time_Type_Definition); - if Expr /= Null_Iir then - Set_Time (We, Expr); - Check_Read (Expr); - - if Get_Expr_Staticness (Expr) = Locally - or else (Get_Kind (Expr) = Iir_Kind_Physical_Int_Literal - and then Flags.Flag_Time_64) - then - -- LRM 8.4 - -- It is an error if the time expression in a waveform - -- element evaluates to a negative value. - -- - -- LRM 8.4.1 - -- It is an error if the sequence of new transactions is - -- not in ascending order with repect to time. - -- GHDL: this must be checked at run-time, but this is - -- also checked now for static expressions. - if Get_Expr_Staticness (Expr) = Locally then - -- The expression is static, and therefore may be - -- evaluated. - Expr := Eval_Expr (Expr); - Set_Time (We, Expr); - Time := Get_Value (Expr); - else - -- The expression is a physical literal (common case). - -- Extract its value. - Time := Get_Physical_Value (Expr); - end if; - if Time < 0 then - Error_Msg_Sem - (+Expr, "waveform time expression must be >= 0"); - elsif Time <= Last_Time then - Error_Msg_Sem - (+Expr, - "time must be greather than previous transaction"); - else - Last_Time := Time; - end if; - end if; - end if; - end if; - else - if We /= Waveform_Chain then - -- Time expression must be in ascending order. - Error_Msg_Sem (+We, "time expression required here"); - end if; - - -- LRM93 12.6.4 - -- It is an error if the execution of any postponed process - -- causes a delta cycle to occur immediatly after the current - -- simulation cycle. - -- GHDL: try to warn for such an error; note the context may be - -- a procedure body. - if Current_Concurrent_Statement /= Null_Iir then - case Get_Kind (Current_Concurrent_Statement) is - when Iir_Kind_Sensitized_Process_Statement - | Iir_Kind_Process_Statement - | Iir_Kind_Concurrent_Conditional_Signal_Assignment - | Iir_Kind_Concurrent_Selected_Signal_Assignment => - if Get_Postponed_Flag (Current_Concurrent_Statement) then - Warning_Msg_Sem - (Warnid_Delta_Cycle, +We, - "waveform may cause a delta cycle in a " & - "postponed process"); - end if; - when others => - -- Context is a subprogram. - null; - end case; - end if; - - Last_Time := 0; - end if; - - We := Get_Chain (We); - end loop; - end Sem_Waveform_Chain; - - -- Analyze a waveform chain WAVEFORM_CHAIN that is assigned via statement - -- ASSIGN_STMT to a subelement or a slice of a signal SIGNAL_DECL. - procedure Sem_Check_Waveform_Chain - (Assign_Stmt: Iir; Waveform_Chain: Iir_Waveform_Element) - is - We: Iir_Waveform_Element; - Expr : Iir; - Targ_Type : Iir; - begin - if Get_Kind (Waveform_Chain) = Iir_Kind_Unaffected_Waveform then - return; - end if; - - Targ_Type := Get_Type (Get_Target (Assign_Stmt)); - - We := Waveform_Chain; - while We /= Null_Iir loop - Expr := Get_We_Value (We); - if Get_Kind (Expr) = Iir_Kind_Null_Literal then - -- This is a null waveform element. - -- LRM93 8.4.1 - -- It is an error if the target of a signal assignment statement - -- containing a null waveform is not a guarded signal or an - -- aggregate of guarded signals. - if Get_Guarded_Target_State (Assign_Stmt) = False then - Error_Msg_Sem - (+Assign_Stmt, - "null transactions can be assigned only to guarded signals"); - end if; - else - if Is_Valid (Get_Type (Expr)) - and then not Eval_Is_In_Bound (Expr, Targ_Type) - and then Get_Kind (Expr) /= Iir_Kind_Overflow_Literal - then - Warning_Msg_Sem - (Warnid_Runtime_Error, +We, - "value constraints don't match target ones"); - Set_We_Value (We, Build_Overflow (Expr, Targ_Type)); - end if; - end if; - We := Get_Chain (We); - end loop; - end Sem_Check_Waveform_Chain; - - procedure Sem_Guard (Stmt: Iir) - is - Guard: Iir; - Guard_Interpretation : Name_Interpretation_Type; - begin - Guard := Get_Guard (Stmt); - if Guard = Null_Iir then - -- This assignment is not guarded. - - -- LRM93 9.5 - -- It is an error if a concurrent signal assignment is not a guarded - -- assignment, and the target of the concurrent signal assignment - -- is a guarded target. - if Get_Guarded_Target_State (Stmt) = True then - Error_Msg_Sem - (+Stmt, "not a guarded assignment for a guarded target"); - end if; - return; - end if; - if Guard /= Stmt then - -- if set, guard must be equal to stmt here. - raise Internal_Error; - end if; - Guard_Interpretation := Get_Interpretation (Std_Names.Name_Guard); - if not Valid_Interpretation (Guard_Interpretation) then - Error_Msg_Sem (+Stmt, "no guard signals for this guarded assignment"); - return; - end if; - - Guard := Get_Declaration (Guard_Interpretation); - -- LRM93 9.5: - -- The signal GUARD [...] an explicitly declared signal of type - -- BOOLEAN that is visible at the point of the concurrent signal - -- assignment statement - -- FIXME. - case Get_Kind (Guard) is - when Iir_Kind_Signal_Declaration - | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Guard_Signal_Declaration => - null; - when others => - Error_Msg_Sem (+Stmt, "visible GUARD object is not a signal", - Cont => True); - Error_Msg_Sem (+Stmt, "GUARD object is %n", +Guard); - return; - end case; - - if Get_Type (Guard) /= Boolean_Type_Definition then - Error_Msg_Sem (+Guard, "GUARD is not of boolean type"); - end if; - Set_Guard (Stmt, Guard); - end Sem_Guard; - - procedure Sem_Signal_Assignment (Stmt: Iir) - is - Cond_Wf : Iir_Conditional_Waveform; - Expr : Iir; - Wf_Chain : Iir_Waveform_Element; - Target_Type : Iir; - Done : Boolean; - begin - Target_Type := Wildcard_Any_Type; - - Done := False; - for S in Resolve_Stages loop - Sem_Signal_Assignment_Target_And_Option (Stmt, Target_Type); - if Is_Defined_Type (Target_Type) then - Done := True; - end if; - - case Get_Kind (Stmt) is - when Iir_Kind_Concurrent_Simple_Signal_Assignment - | Iir_Kind_Simple_Signal_Assignment_Statement => - Wf_Chain := Get_Waveform_Chain (Stmt); - Sem_Waveform_Chain (Wf_Chain, Target_Type); - if Done then - Sem_Check_Waveform_Chain (Stmt, Wf_Chain); - end if; - - when Iir_Kind_Concurrent_Conditional_Signal_Assignment - | Iir_Kind_Conditional_Signal_Assignment_Statement => - Cond_Wf := Get_Conditional_Waveform_Chain (Stmt); - while Cond_Wf /= Null_Iir loop - Wf_Chain := Get_Waveform_Chain (Cond_Wf); - Sem_Waveform_Chain (Wf_Chain, Target_Type); - if Done then - Sem_Check_Waveform_Chain (Stmt, Wf_Chain); - end if; - if S = Resolve_Stage_1 then - -- Must be analyzed only once. - Expr := Get_Condition (Cond_Wf); - if Expr /= Null_Iir then - Expr := Sem_Condition (Expr); - if Expr /= Null_Iir then - Set_Condition (Cond_Wf, Expr); - end if; - end if; - end if; - Cond_Wf := Get_Chain (Cond_Wf); - end loop; - - when Iir_Kind_Concurrent_Selected_Signal_Assignment => - declare - El : Iir; - begin - El := Get_Selected_Waveform_Chain (Stmt); - while El /= Null_Iir loop - Wf_Chain := Get_Associated_Chain (El); - if Is_Valid (Wf_Chain) then - -- The first choice of a list. - Sem_Waveform_Chain (Wf_Chain, Target_Type); - if Done then - Sem_Check_Waveform_Chain (Stmt, Wf_Chain); - end if; - end if; - El := Get_Chain (El); - end loop; - end; - - when others => - raise Internal_Error; - end case; - - exit when Done; - if not Is_Defined_Type (Target_Type) then - Error_Msg_Sem (+Stmt, "cannot resolve type of waveform"); - exit; - end if; - end loop; - - case Get_Kind (Stmt) is - when Iir_Kind_Concurrent_Simple_Signal_Assignment - | Iir_Kind_Concurrent_Conditional_Signal_Assignment => - Sem_Guard (Stmt); - when others => - null; - end case; - end Sem_Signal_Assignment; - - procedure Sem_Conditional_Expression (Cond_Expr : Iir; Atype : in out Iir) - is - El : Iir; - Expr : Iir; - Cond : Iir; - begin - El := Cond_Expr; - while El /= Null_Iir loop - Expr := Get_Expression (El); - Expr := Sem_Expression_Wildcard (Expr, Atype, True); - - if Expr /= Null_Iir then - Set_Expression (El, Expr); - - if Is_Expr_Fully_Analyzed (Expr) then - Check_Read (Expr); - Expr := Eval_Expr_If_Static (Expr); - end if; - - Merge_Wildcard_Type (Expr, Atype); - end if; - - Cond := Get_Condition (El); - exit when Cond = Null_Iir; - - if Is_Expr_Not_Analyzed (Cond) then - Cond := Sem_Condition (Cond); - Set_Condition (El, Cond); - end if; - - El := Get_Chain (El); - end loop; - end Sem_Conditional_Expression; - - procedure Sem_Variable_Assignment (Stmt: Iir) - is - Target : Iir; - Expr : Iir; - Target_Type : Iir; - Stmt_Type : Iir; - Done : Boolean; - begin - -- LRM93 8.5 Variable assignment statement - -- If the target of the variable assignment statement is in the form of - -- an aggregate, then the type of the aggregate must be determinable - -- from the context, excluding the aggregate itself but including the - -- fact that the type of the aggregate must be a composite type. The - -- base type of the expression on the right-hand side must be the - -- same as the base type of the aggregate. - -- - -- GHDL: this means that the type can only be deduced from the - -- expression (and not from the target). - - Target := Get_Target (Stmt); - Stmt_Type := Wildcard_Any_Type; - for S in Resolve_Stages loop - Done := False; - - Target := Sem_Expression_Wildcard (Target, Stmt_Type); - if Target = Null_Iir then - Target_Type := Stmt_Type; - else - Set_Target (Stmt, Target); - if Is_Expr_Fully_Analyzed (Target) then - Check_Target (Stmt, Target); - Done := True; - end if; - Target_Type := Get_Type (Target); - Stmt_Type := Target_Type; - end if; - - case Iir_Kinds_Variable_Assignment_Statement (Get_Kind (Stmt)) is - when Iir_Kind_Variable_Assignment_Statement => - Expr := Get_Expression (Stmt); - Expr := Sem_Expression_Wildcard (Expr, Stmt_Type, True); - if Expr /= Null_Iir then - if Is_Expr_Fully_Analyzed (Expr) then - Check_Read (Expr); - Expr := Eval_Expr_If_Static (Expr); - end if; - Set_Expression (Stmt, Expr); - Merge_Wildcard_Type (Expr, Stmt_Type); - if Done - and then not Eval_Is_In_Bound (Expr, Target_Type) - and then Get_Kind (Expr) /= Iir_Kind_Overflow_Literal - then - Warning_Msg_Sem - (Warnid_Runtime_Error, +Stmt, - "expression constraints don't match target ones"); - Set_Expression (Stmt, Build_Overflow (Expr, Target_Type)); - end if; - end if; - - when Iir_Kind_Conditional_Variable_Assignment_Statement => - Expr := Get_Conditional_Expression (Stmt); - Sem_Conditional_Expression (Expr, Stmt_Type); - end case; - - exit when Done; - if not Is_Defined_Type (Stmt_Type) then - Error_Msg_Sem (+Stmt, "cannot resolve type"); - if Get_Kind (Target) = Iir_Kind_Aggregate then - -- Try to give an advice. - Error_Msg_Sem (+Stmt, "use a qualified expression for the RHS"); - end if; - exit; - end if; - end loop; - end Sem_Variable_Assignment; - - procedure Sem_Return_Statement (Stmt: Iir_Return_Statement) is - Expr: Iir; - begin - if Current_Subprogram = Null_Iir then - Error_Msg_Sem (+Stmt, "return statement not in a subprogram body"); - return; - end if; - Expr := Get_Expression (Stmt); - case Get_Kind (Current_Subprogram) is - when Iir_Kind_Procedure_Declaration => - if Expr /= Null_Iir then - Error_Msg_Sem - (+Stmt, "return in a procedure can't have an expression"); - end if; - return; - when Iir_Kind_Function_Declaration => - if Expr = Null_Iir then - Error_Msg_Sem - (+Stmt, "return in a function must have an expression"); - return; - end if; - when Iir_Kinds_Process_Statement => - Error_Msg_Sem (+Stmt, "return statement not allowed in a process"); - return; - when others => - Error_Kind ("sem_return_statement", Stmt); - end case; - Set_Type (Stmt, Get_Return_Type (Current_Subprogram)); - Expr := Sem_Expression (Expr, Get_Return_Type (Current_Subprogram)); - if Expr /= Null_Iir then - Check_Read (Expr); - Set_Expression (Stmt, Eval_Expr_If_Static (Expr)); - end if; - end Sem_Return_Statement; - - -- Sem for concurrent and sequential assertion statements. - procedure Sem_Report_Statement (Stmt : Iir) - is - Expr : Iir; - begin - Expr := Get_Report_Expression (Stmt); - if Expr /= Null_Iir then - Expr := Sem_Expression (Expr, String_Type_Definition); - Check_Read (Expr); - Expr := Eval_Expr_If_Static (Expr); - Set_Report_Expression (Stmt, Expr); - end if; - - Expr := Get_Severity_Expression (Stmt); - if Expr /= Null_Iir then - Expr := Sem_Expression (Expr, Severity_Level_Type_Definition); - Check_Read (Expr); - Set_Severity_Expression (Stmt, Expr); - end if; - end Sem_Report_Statement; - - procedure Sem_Assertion_Statement (Stmt: Iir) - is - Expr : Iir; - begin - Expr := Get_Assertion_Condition (Stmt); - Expr := Sem_Condition (Expr); - Expr := Eval_Expr_If_Static (Expr); - Set_Assertion_Condition (Stmt, Expr); - - Sem_Report_Statement (Stmt); - end Sem_Assertion_Statement; - - -- Analyze a list of case choice LIST, and check for correct CHOICE type. - procedure Sem_Case_Choices - (Choice : Iir; Chain : in out Iir; Loc : Location_Type) - is - -- Check restrictions on the expression of a One-Dimensional Character - -- Array Type (ODCAT) given by LRM 8.8 - -- Return FALSE in case of violation. - function Check_Odcat_Expression (Expr : Iir) return Boolean - is - Expr_Type : constant Iir := Get_Type (Expr); - begin - -- LRM 8.8 Case Statement - -- If the expression is of a one-dimensional character array type, - -- then the expression must be one of the following: - case Get_Kind (Expr) is - when Iir_Kinds_Object_Declaration - | Iir_Kind_Selected_Element => - -- FIXME: complete the list. - -- * the name of an object whose subtype is locally static. - if Get_Type_Staticness (Expr_Type) /= Locally then - Error_Msg_Sem - (+Choice, "object subtype is not locally static"); - return False; - end if; - when Iir_Kind_Indexed_Name => - -- LRM93 - -- * an indexed name whose prefix is one of the members of - -- this list and whose indexing expressions are locally - -- static expression. - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Sem - (+Expr, "indexed name not allowed here in vhdl87"); - return False; - end if; - if not Check_Odcat_Expression (Get_Prefix (Expr)) then - return False; - end if; - -- GHDL: I don't understand why the indexing expressions - -- must be locally static. So I don't check this in 93c. - if Flags.Vhdl_Std /= Vhdl_93c - and then - (Get_Expr_Staticness - (Get_Nth_Element (Get_Index_List (Expr), 0)) /= Locally) - then - Error_Msg_Sem - (+Expr, "indexing expression must be locally static"); - return False; - end if; - when Iir_Kind_Slice_Name => - -- LRM93 - -- * a slice name whose prefix is one of the members of this - -- list and whose discrete range is a locally static - -- discrete range. - - -- LRM87/INT1991 IR96 - -- then the expression must be either a slice name whose - -- discrete range is locally static, or .. - if False and Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Sem - (+Expr, "slice not allowed as case expression in vhdl87"); - return False; - end if; - if not Check_Odcat_Expression (Get_Prefix (Expr)) then - return False; - end if; - if Get_Type_Staticness (Expr_Type) /= Locally then - Error_Msg_Sem - (+Expr, "slice discrete range must be locally static"); - return False; - end if; - when Iir_Kind_Function_Call => - -- LRM93 - -- * a function call whose return type mark denotes a - -- locally static subtype. - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Sem - (+Expr, "function call not allowed here in vhdl87"); - return False; - end if; - if Get_Type_Staticness (Expr_Type) /= Locally then - Error_Msg_Sem - (+Expr, "function call type is not locally static"); - end if; - when Iir_Kind_Qualified_Expression - | Iir_Kind_Type_Conversion => - -- * a qualified expression or type conversion whose type mark - -- denotes a locally static subtype. - if Get_Type_Staticness (Expr_Type) /= Locally then - Error_Msg_Sem - (+Expr, "type mark is not a locally static subtype"); - return False; - end if; - when Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name => - return Check_Odcat_Expression (Get_Named_Entity (Expr)); - when others => - Error_Msg_Sem - (+Choice, "bad form of case expression (refer to LRM 8.8)"); - return False; - end case; - return True; - end Check_Odcat_Expression; - - Choice_Type : constant Iir := Get_Type (Choice); - Low, High : Iir; - El_Type : Iir; - begin - -- LRM 8.8 Case Statement - -- The expression must be of a discrete type, or of a one-dimensional - -- array type whose element base type is a character type. - case Get_Kind (Choice_Type) is - when Iir_Kinds_Discrete_Type_Definition => - Sem_Choices_Range - (Chain, Choice_Type, Low, High, Loc, False, True); - when Iir_Kind_Array_Subtype_Definition - | Iir_Kind_Array_Type_Definition => - if not Is_One_Dimensional_Array_Type (Choice_Type) then - Error_Msg_Sem - (+Choice, - "expression must be of a one-dimensional array type"); - return; - end if; - El_Type := Get_Base_Type (Get_Element_Subtype (Choice_Type)); - if Get_Kind (El_Type) /= Iir_Kind_Enumeration_Type_Definition - or else not Get_Is_Character_Type (El_Type) - then - Error_Msg_Sem - (+Choice, - "element type of the expression must be a character type"); - return; - end if; - if Flags.Vhdl_Std >= Vhdl_08 then - -- No specific restrictions in vhdl 2008. - null; - else - if not Check_Odcat_Expression (Choice) then - return; - end if; - end if; - Sem_String_Choices_Range (Chain, Choice); - when others => - Error_Msg_Sem (+Choice, "type of expression must be discrete"); - end case; - end Sem_Case_Choices; - - procedure Sem_Case_Statement (Stmt: Iir_Case_Statement) - is - Expr: Iir; - Chain : Iir; - El: Iir; - begin - Expr := Get_Expression (Stmt); - Chain := Get_Case_Statement_Alternative_Chain (Stmt); - -- FIXME: overload. - Expr := Sem_Case_Expression (Expr); - if Expr /= Null_Iir then - Check_Read (Expr); - Set_Expression (Stmt, Expr); - - Sem_Case_Choices (Expr, Chain, Get_Location (Stmt)); - Set_Case_Statement_Alternative_Chain (Stmt, Chain); - end if; - - El := Chain; - while El /= Null_Iir loop - if not Get_Same_Alternative_Flag (El) then - Sem_Sequential_Statements_Internal (Get_Associated_Chain (El)); - end if; - El := Get_Chain (El); - end loop; - end Sem_Case_Statement; - - -- Sem the sensitivity list LIST. - procedure Sem_Sensitivity_List (List: Iir_List) - is - El: Iir; - It : List_Iterator; - Res: Iir; - Prefix : Iir; - begin - if List = Iir_List_All then - return; - end if; - - It := List_Iterate (List); - while Is_Valid (It) loop - -- El is an iir_identifier. - El := Get_Element (It); - - if Is_Error (El) then - pragma Assert (Flags.Flag_Force_Analysis); - Res := Error_Mark; - else - Sem_Name (El); - - Res := Get_Named_Entity (El); - end if; - - if Res = Error_Mark then - null; - elsif Is_Overload_List (Res) or else not Is_Object_Name (Res) then - Error_Msg_Sem (+El, "a sensitivity element must be a signal name"); - else - Res := Finish_Sem_Name (El); - Prefix := Get_Object_Prefix (Res); - case Get_Kind (Prefix) is - when Iir_Kind_Signal_Declaration - | Iir_Kind_Guard_Signal_Declaration - | Iir_Kinds_Signal_Attribute => - null; - when Iir_Kind_Interface_Signal_Declaration => - if not Is_Interface_Signal_Readable (Prefix) then - Error_Msg_Sem - (+El, - "%n of mode out can't be in a sensivity list", +Res); - end if; - when others => - Error_Msg_Sem (+El, - "%n is neither a signal nor a port", +Res); - end case; - -- LRM 9.2 - -- Only static signal names (see section 6.1) for which reading - -- is permitted may appear in the sensitivity list of a process - -- statement. - - -- LRM 8.1 Wait statement - -- Each signal name in the sensitivity list must be a static - -- signal name, and each name must denote a signal for which - -- reading is permitted. - if Get_Name_Staticness (Res) < Globally then - Error_Msg_Sem - (+El, "sensitivity element %n must be a static name", +Res); - end if; - - Set_Element (It, Res); - end if; - - Next (It); - end loop; - end Sem_Sensitivity_List; - - -- Mark STMT and its parents as suspendable. - procedure Mark_Suspendable (Stmt : Iir) - is - Parent : Iir; - begin - Parent := Get_Parent (Stmt); - loop - case Get_Kind (Parent) is - when Iir_Kind_Function_Body - | Iir_Kind_Sensitized_Process_Statement => - exit; - when Iir_Kind_Process_Statement - | Iir_Kind_Procedure_Body => - Set_Suspend_Flag (Parent, True); - exit; - when Iir_Kind_If_Statement - | Iir_Kind_While_Loop_Statement - | Iir_Kind_For_Loop_Statement - | Iir_Kind_Case_Statement => - Set_Suspend_Flag (Parent, True); - Parent := Get_Parent (Parent); - when others => - Error_Kind ("mark_suspendable", Parent); - end case; - end loop; - end Mark_Suspendable; - - procedure Sem_Wait_Statement (Stmt: Iir_Wait_Statement) - is - Expr: Iir; - Sensitivity_List : Iir_List; - begin - -- Check validity. - case Get_Kind (Current_Subprogram) is - when Iir_Kind_Process_Statement => - null; - when Iir_Kind_Function_Declaration => - -- LRM93 8.2 - -- It is an error if a wait statement appears in a function - -- subprogram [...] - Error_Msg_Sem - (+Stmt, "wait statement not allowed in a function subprogram"); - return; - when Iir_Kind_Procedure_Declaration => - -- LRM93 8.2 - -- [It is an error ...] or in a procedure that has a parent that - -- is a function subprogram. - -- LRM93 8.2 - -- [...] or in a procedure that has a parent that is such a - -- process statement. - -- GHDL: this is checked at the end of analysis or during - -- elaboration. - Set_Wait_State (Current_Subprogram, True); - when Iir_Kind_Sensitized_Process_Statement => - -- LRM93 8.2 - -- Furthermore, it is an error if a wait statement appears in an - -- explicit process statement that includes a sensitivity list, - -- [...] - Error_Msg_Sem - (+Stmt, "wait statement not allowed in a sensitized process"); - return; - when others => - raise Internal_Error; - end case; - - Sensitivity_List := Get_Sensitivity_List (Stmt); - if Sensitivity_List /= Null_Iir_List then - Sem_Sensitivity_List (Sensitivity_List); - end if; - - Expr := Get_Condition_Clause (Stmt); - if Expr /= Null_Iir then - Expr := Sem_Condition (Expr); - Set_Condition_Clause (Stmt, Expr); - end if; - - Expr := Get_Timeout_Clause (Stmt); - if Expr /= Null_Iir then - Expr := Sem_Expression (Expr, Time_Type_Definition); - if Expr /= Null_Iir then - Check_Read (Expr); - Expr := Eval_Expr_If_Static (Expr); - Set_Timeout_Clause (Stmt, Expr); - if Get_Expr_Staticness (Expr) = Locally - and then Get_Value (Expr) < 0 - then - Error_Msg_Sem (+Stmt, "timeout value must be positive"); - end if; - end if; - end if; - - Mark_Suspendable (Stmt); - end Sem_Wait_Statement; - - procedure Sem_Exit_Next_Statement (Stmt : Iir) - is - Cond: Iir; - Loop_Label : Iir; - Loop_Stmt: Iir; - P : Iir; - begin - Cond := Get_Condition (Stmt); - if Cond /= Null_Iir then - Cond := Sem_Condition (Cond); - Set_Condition (Stmt, Cond); - end if; - - Loop_Label := Get_Loop_Label (Stmt); - if Loop_Label /= Null_Iir then - Loop_Label := Sem_Denoting_Name (Loop_Label); - Set_Loop_Label (Stmt, Loop_Label); - Loop_Stmt := Get_Named_Entity (Loop_Label); - case Get_Kind (Loop_Stmt) is - when Iir_Kind_For_Loop_Statement - | Iir_Kind_While_Loop_Statement => - null; - when others => - Error_Class_Match (Loop_Label, "loop statement"); - Loop_Stmt := Null_Iir; - end case; - else - Loop_Stmt := Null_Iir; - end if; - - -- Check the current statement is inside the labeled loop. - P := Stmt; - loop - P := Get_Parent (P); - case Get_Kind (P) is - when Iir_Kind_While_Loop_Statement - | Iir_Kind_For_Loop_Statement => - if Loop_Stmt = Null_Iir or else P = Loop_Stmt then - exit; - end if; - when Iir_Kind_If_Statement - | Iir_Kind_Elsif - | Iir_Kind_Case_Statement => - null; - when others => - -- FIXME: should emit a message for label mismatch. - Error_Msg_Sem (+Stmt, "exit/next must be inside a loop"); - exit; - end case; - end loop; - end Sem_Exit_Next_Statement; - - -- Process is the scope, this is also the process for which drivers can - -- be created. - procedure Sem_Sequential_Statements_Internal (First_Stmt : Iir) - is - Stmt: Iir; - begin - Stmt := First_Stmt; - while Stmt /= Null_Iir loop - case Get_Kind (Stmt) is - when Iir_Kind_Null_Statement => - null; - when Iir_Kind_If_Statement => - declare - Clause: Iir := Stmt; - Cond: Iir; - begin - while Clause /= Null_Iir loop - Cond := Get_Condition (Clause); - if Cond /= Null_Iir then - Cond := Sem_Condition (Cond); - Set_Condition (Clause, Cond); - end if; - Sem_Sequential_Statements_Internal - (Get_Sequential_Statement_Chain (Clause)); - Clause := Get_Else_Clause (Clause); - end loop; - end; - when Iir_Kind_For_Loop_Statement => - declare - Iterator : constant Iir := - Get_Parameter_Specification (Stmt); - begin - -- LRM 10.1 Declarative region - -- 9. A loop statement. - Open_Declarative_Region; - - Set_Is_Within_Flag (Stmt, True); - Sem_Scopes.Add_Name (Iterator); - Sem_Iterator (Iterator, None); - Set_Visible_Flag (Iterator, True); - Sem_Sequential_Statements_Internal - (Get_Sequential_Statement_Chain (Stmt)); - Set_Is_Within_Flag (Stmt, False); - - Close_Declarative_Region; - end; - when Iir_Kind_While_Loop_Statement => - declare - Cond: Iir; - begin - Cond := Get_Condition (Stmt); - if Cond /= Null_Iir then - Cond := Sem_Condition (Cond); - Set_Condition (Stmt, Cond); - end if; - Sem_Sequential_Statements_Internal - (Get_Sequential_Statement_Chain (Stmt)); - end; - when Iir_Kind_Simple_Signal_Assignment_Statement - | Iir_Kind_Conditional_Signal_Assignment_Statement => - Sem_Signal_Assignment (Stmt); - if Current_Concurrent_Statement /= Null_Iir and then - Get_Kind (Current_Concurrent_Statement) - in Iir_Kinds_Process_Statement - and then Get_Passive_Flag (Current_Concurrent_Statement) - then - Error_Msg_Sem - (+Stmt, "signal statement forbidden in passive process"); - end if; - when Iir_Kind_Variable_Assignment_Statement - | Iir_Kind_Conditional_Variable_Assignment_Statement => - Sem_Variable_Assignment (Stmt); - when Iir_Kind_Return_Statement => - Sem_Return_Statement (Stmt); - when Iir_Kind_Assertion_Statement => - Sem_Assertion_Statement (Stmt); - when Iir_Kind_Report_Statement => - Sem_Report_Statement (Stmt); - when Iir_Kind_Case_Statement => - Sem_Case_Statement (Stmt); - when Iir_Kind_Wait_Statement => - Sem_Wait_Statement (Stmt); - when Iir_Kind_Procedure_Call_Statement => - declare - Call : constant Iir := Get_Procedure_Call (Stmt); - Imp : Iir; - begin - Sem_Procedure_Call (Call, Stmt); - - -- Set suspend flag, if calling a suspendable procedure - -- from a procedure or from a process. - Imp := Get_Implementation (Call); - if Imp /= Null_Iir - and then Get_Kind (Imp) = Iir_Kind_Procedure_Declaration - and then Get_Suspend_Flag (Imp) - and then (Get_Kind (Get_Current_Subprogram) - /= Iir_Kind_Function_Declaration) - and then (Get_Kind (Get_Current_Subprogram) - /= Iir_Kind_Sensitized_Process_Statement) - then - Set_Suspend_Flag (Stmt, True); - Mark_Suspendable (Stmt); - end if; - end; - when Iir_Kind_Next_Statement - | Iir_Kind_Exit_Statement => - Sem_Exit_Next_Statement (Stmt); - when others => - Error_Kind ("sem_sequential_statements_Internal", Stmt); - end case; - Stmt := Get_Chain (Stmt); - end loop; - end Sem_Sequential_Statements_Internal; - - procedure Sem_Sequential_Statements (Decl : Iir; Body_Parent : Iir) - is - Outer_Subprogram: Iir; - begin - Outer_Subprogram := Current_Subprogram; - Current_Subprogram := Decl; - - -- Sem declarations - Sem_Sequential_Labels (Get_Sequential_Statement_Chain (Body_Parent)); - Sem_Declaration_Chain (Body_Parent); - Sem_Specification_Chain (Body_Parent, Null_Iir); - - -- Sem statements. - Sem_Sequential_Statements_Internal - (Get_Sequential_Statement_Chain (Body_Parent)); - - Check_Full_Declaration (Body_Parent, Body_Parent); - - Current_Subprogram := Outer_Subprogram; - end Sem_Sequential_Statements; - - -- Sem the instantiated unit of STMT and return the node constaining - -- ports and generics (either a entity_declaration or a component - -- declaration). - function Sem_Instantiated_Unit - (Stmt : Iir_Component_Instantiation_Statement) return Iir - is - Inst : constant Iir := Get_Instantiated_Unit (Stmt); - Comp_Name : Iir; - Comp : Iir; - begin - if Get_Kind (Inst) in Iir_Kinds_Entity_Aspect then - return Sem_Entity_Aspect (Inst); - else - Comp := Get_Named_Entity (Inst); - if Comp /= Null_Iir then - -- Already analyzed before, while trying to separate - -- concurrent procedure calls from instantiation stmts. - pragma Assert (Get_Kind (Comp) = Iir_Kind_Component_Declaration); - return Comp; - end if; - - -- Needs a denoting name - if Get_Kind (Inst) not in Iir_Kinds_Denoting_Name then - Error_Msg_Sem (+Inst, "name for a component expected"); - return Null_Iir; - end if; - - -- The component may be an entity or a configuration. - Comp_Name := Sem_Denoting_Name (Inst); - Set_Instantiated_Unit (Stmt, Comp_Name); - Comp := Get_Named_Entity (Comp_Name); - if Get_Kind (Comp) /= Iir_Kind_Component_Declaration then - Error_Class_Match (Comp_Name, "component"); - return Null_Iir; - end if; - - return Comp; - end if; - end Sem_Instantiated_Unit; - - procedure Sem_Component_Instantiation_Statement - (Stmt: Iir_Component_Instantiation_Statement; Is_Passive : Boolean) - is - Decl : Iir; - Entity_Unit : Iir_Design_Unit; - Bind : Iir_Binding_Indication; - begin - -- FIXME: move this check in parse ? - if Is_Passive then - Error_Msg_Sem (+Stmt, "component instantiation forbidden in entity"); - end if; - - -- Check for label. - -- This cannot be moved in parse since a procedure_call may be revert - -- into a component instantiation. - if Get_Label (Stmt) = Null_Identifier then - Error_Msg_Sem (+Stmt, "component instantiation requires a label"); - end if; - - -- Look for the component. - Decl := Sem_Instantiated_Unit (Stmt); - if Decl = Null_Iir then - return; - end if; - - -- The association - Sem_Generic_Port_Association_Chain (Decl, Stmt); - - -- FIXME: add sources for signals, in order to detect multiple sources - -- to unresolved signals. - -- What happen if the component is not bound ? - - -- Create a default binding indication if necessary. - if Get_Component_Configuration (Stmt) = Null_Iir - and then Is_Component_Instantiation (Stmt) - then - Entity_Unit := Get_Visible_Entity_Declaration (Decl); - if Entity_Unit = Null_Iir then - if Is_Warning_Enabled (Warnid_Default_Binding) - and then not Flags.Flag_Elaborate - then - Warning_Msg_Sem - (Warnid_Default_Binding, +Stmt, - "no default binding for instantiation of %n", +Decl); - Explain_No_Visible_Entity (Decl); - end if; - elsif Flags.Flag_Elaborate - and then (Flags.Flag_Elaborate_With_Outdated - or else Get_Date (Entity_Unit) in Date_Valid) - then - Bind := Sem_Create_Default_Binding_Indication - (Decl, Entity_Unit, Stmt, False, True); - Set_Default_Binding_Indication (Stmt, Bind); - end if; - end if; - end Sem_Component_Instantiation_Statement; - - -- Note: a statement such as - -- label1: name; - -- can be parsed as a procedure call statement or as a - -- component instantiation statement. - -- Check now and revert in case of error. - function Sem_Concurrent_Procedure_Call_Statement - (Stmt : Iir; Is_Passive : Boolean) return Iir - is - Call : Iir_Procedure_Call; - Decl : Iir; - Label : Name_Id; - N_Stmt : Iir_Component_Instantiation_Statement; - Imp : Iir; - begin - Call := Get_Procedure_Call (Stmt); - if Get_Parameter_Association_Chain (Call) = Null_Iir then - Imp := Get_Prefix (Call); - Sem_Name (Imp); - Set_Prefix (Call, Imp); - - Decl := Get_Named_Entity (Imp); - if Get_Kind (Decl) = Iir_Kind_Component_Declaration then - N_Stmt := Create_Iir (Iir_Kind_Component_Instantiation_Statement); - Label := Get_Label (Stmt); - Set_Label (N_Stmt, Label); - Set_Parent (N_Stmt, Get_Parent (Stmt)); - Set_Instantiated_Unit (N_Stmt, Finish_Sem_Name (Imp)); - Location_Copy (N_Stmt, Stmt); - - if Label /= Null_Identifier then - -- A component instantiation statement must have - -- a label, this condition is checked during the - -- sem of the statement. - Sem_Scopes.Replace_Name (Label, Stmt, N_Stmt); - end if; - - Free_Iir (Stmt); - Free_Iir (Call); - - Sem_Component_Instantiation_Statement (N_Stmt, Is_Passive); - return N_Stmt; - end if; - end if; - Sem_Procedure_Call (Call, Stmt); - - if Is_Passive then - Imp := Get_Implementation (Call); - if Imp /= Null_Iir - and then Get_Kind (Imp) = Iir_Kind_Procedure_Declaration - then - Decl := Get_Interface_Declaration_Chain (Imp); - while Decl /= Null_Iir loop - if Get_Mode (Decl) in Iir_Out_Modes then - Error_Msg_Sem (+Stmt, "%n is not passive", +Imp); - exit; - end if; - Decl := Get_Chain (Decl); - end loop; - end if; - end if; - - return Stmt; - end Sem_Concurrent_Procedure_Call_Statement; - - procedure Sem_Block_Statement (Stmt: Iir_Block_Statement) - is - Header : constant Iir_Block_Header := Get_Block_Header (Stmt); - Guard : constant Iir_Guard_Signal_Declaration := Get_Guard_Decl (Stmt); - Expr: Iir; - Generic_Chain : Iir; - Port_Chain : Iir; - begin - -- LRM 10.1 Declarative region. - -- 7. A block statement. - Open_Declarative_Region; - - Set_Is_Within_Flag (Stmt, True); - - if Header /= Null_Iir then - Generic_Chain := Get_Generic_Chain (Header); - Sem_Interface_Chain (Generic_Chain, Generic_Interface_List); - Port_Chain := Get_Port_Chain (Header); - Sem_Interface_Chain (Port_Chain, Port_Interface_List); - - -- LRM 9.1 - -- Such actuals are evaluated in the context of the enclosing - -- declarative region. - -- GHDL: close the declarative region... - Set_Is_Within_Flag (Stmt, False); - Close_Declarative_Region; - - Sem_Generic_Port_Association_Chain (Header, Header); - - -- ... and reopen-it. - Open_Declarative_Region; - Set_Is_Within_Flag (Stmt, True); - Add_Declarations_From_Interface_Chain (Generic_Chain); - Add_Declarations_From_Interface_Chain (Port_Chain); - end if; - - -- LRM93 9.1 - -- If a guard expression appears after the reserved word BLOCK, then a - -- signal with the simple name GUARD of predefined type BOOLEAN is - -- implicitly declared at the beginning of the declarative part of the - -- block, and the guard expression defined the value of that signal at - -- any given time. - if Guard /= Null_Iir then - -- LRM93 9.1 - -- The type of the guard expression must be type BOOLEAN. - -- GHDL: guard expression must be analyzed before creating the - -- implicit GUARD signal, since the expression may reference GUARD. - Set_Expr_Staticness (Guard, None); - Set_Name_Staticness (Guard, Locally); - Expr := Get_Guard_Expression (Guard); - Expr := Sem_Condition (Expr); - if Expr /= Null_Iir then - Set_Guard_Expression (Guard, Expr); - end if; - - -- FIXME: should extract sensivity now and set the has_active flag - -- on signals, since the guard expression is evaluated when one of - -- its signal is active. However, how can a bug be introduced by - -- evaluating only when signals have events ? - - -- the guard expression is an implicit definition of a signal named - -- GUARD. Create this definition. This is necessary for the type. - Set_Identifier (Guard, Std_Names.Name_Guard); - Set_Type (Guard, Boolean_Type_Definition); - Set_Block_Statement (Guard, Stmt); - Sem_Scopes.Add_Name (Guard); - Set_Visible_Flag (Guard, True); - end if; - - Sem_Block (Stmt); - Set_Is_Within_Flag (Stmt, False); - Close_Declarative_Region; - end Sem_Block_Statement; - - procedure Sem_Generate_Statement_Body (Bod : Iir) is - begin - Set_Is_Within_Flag (Bod, True); - Sem_Block (Bod); - Set_Is_Within_Flag (Bod, False); - end Sem_Generate_Statement_Body; - - procedure Sem_For_Generate_Statement (Stmt : Iir) - is - Param : constant Iir := Get_Parameter_Specification (Stmt); - begin - -- LRM93 10.1 Declarative region. - -- 12. A generate statement. - Open_Declarative_Region; - Set_Is_Within_Flag (Stmt, True); - - Sem_Scopes.Add_Name (Param); - - -- LRM93 7.4.2 (Globally Static Primaries) - -- 4. a generate parameter; - Sem_Iterator (Param, Globally); - Set_Visible_Flag (Param, True); - - -- LRM93 9.7 - -- The discrete range in a generation scheme of the first form must - -- be a static discrete range; - if Get_Type (Param) /= Null_Iir - and then Get_Type_Staticness (Get_Type (Param)) < Globally - then - Error_Msg_Sem (+Stmt, "range must be a static discrete range"); - end if; - - -- In the same declarative region. - Sem_Generate_Statement_Body (Get_Generate_Statement_Body (Stmt)); - - Set_Is_Within_Flag (Stmt, True); - Close_Declarative_Region; - end Sem_For_Generate_Statement; - - procedure Sem_If_Case_Generate_Statement_Body (Bod : Iir) - is - Alt_Label : Name_Id; - begin - Alt_Label := Get_Alternative_Label (Bod); - if Alt_Label /= Null_Identifier then - -- Declare label. This doesn't appear in the LRM (bug ?), but - -- used here to detect duplicated labels. - Sem_Scopes.Add_Name (Bod); - Xref_Decl (Bod); - end if; - - -- Contrary to the LRM, a new declarative region is declared. This - -- is required so that declarations in a generate statement body are - -- not in the scope of the following generate bodies. - Open_Declarative_Region; - Sem_Generate_Statement_Body (Bod); - Close_Declarative_Region; - end Sem_If_Case_Generate_Statement_Body; - - procedure Sem_If_Generate_Statement (Stmt : Iir) - is - Clause : Iir; - Condition : Iir; - begin - -- LRM93 10.1 Declarative region. - -- 12. A generate statement. - Open_Declarative_Region; - Set_Is_Within_Flag (Stmt, True); - - Clause := Stmt; - while Clause /= Null_Iir loop - Condition := Get_Condition (Clause); - - if Condition /= Null_Iir then - Condition := Sem_Condition (Condition); - -- LRM93 9.7 - -- the condition in a generation scheme of the second form must be - -- a static expression. - if Condition /= Null_Iir - and then Get_Expr_Staticness (Condition) < Globally - then - Error_Msg_Sem - (+Condition, "condition must be a static expression"); - else - Set_Condition (Clause, Condition); - end if; - else - -- No condition for the last 'else' part. - pragma Assert (Get_Generate_Else_Clause (Clause) = Null_Iir); - null; - end if; - - Sem_If_Case_Generate_Statement_Body - (Get_Generate_Statement_Body (Clause)); - - Clause := Get_Generate_Else_Clause (Clause); - end loop; - - Set_Is_Within_Flag (Stmt, False); - Close_Declarative_Region; - end Sem_If_Generate_Statement; - - procedure Sem_Case_Generate_Statement (Stmt : Iir) - is - Expr : Iir; - Chain : Iir; - El : Iir; - begin - -- LRM93 10.1 Declarative region. - -- 12. A generate statement. - Open_Declarative_Region; - Set_Is_Within_Flag (Stmt, True); - - Expr := Get_Expression (Stmt); - Chain := Get_Case_Statement_Alternative_Chain (Stmt); - -- FIXME: overload. - Expr := Sem_Case_Expression (Expr); - if Expr /= Null_Iir then - Check_Read (Expr); - Set_Expression (Stmt, Expr); - - if Get_Expr_Staticness (Expr) < Globally then - Error_Msg_Sem - (+Expr, "case expression must be a static expression"); - end if; - - Sem_Case_Choices (Expr, Chain, Get_Location (Stmt)); - Set_Case_Statement_Alternative_Chain (Stmt, Chain); - end if; - - El := Chain; - while El /= Null_Iir loop - if not Get_Same_Alternative_Flag (El) then - Sem_If_Case_Generate_Statement_Body (Get_Associated_Block (El)); - end if; - El := Get_Chain (El); - end loop; - - Set_Is_Within_Flag (Stmt, False); - Close_Declarative_Region; - end Sem_Case_Generate_Statement; - - procedure Sem_Process_Statement (Proc: Iir) is - begin - Set_Is_Within_Flag (Proc, True); - - -- LRM 10.1 - -- 8. A process statement - Open_Declarative_Region; - - -- Sem declarations - Sem_Sequential_Statements (Proc, Proc); - - Close_Declarative_Region; - - Set_Is_Within_Flag (Proc, False); - - if Get_Kind (Proc) = Iir_Kind_Sensitized_Process_Statement - and then Get_Callees_List (Proc) /= Null_Iir_List - then - -- Check there is no wait statement in subprograms called. - -- Also in the case of all-sensitized process, check that package - -- subprograms don't read signals. - Sem.Add_Analysis_Checks_List (Proc); - end if; - end Sem_Process_Statement; - - procedure Sem_Sensitized_Process_Statement - (Proc: Iir_Sensitized_Process_Statement) is - begin - Sem_Sensitivity_List (Get_Sensitivity_List (Proc)); - Sem_Process_Statement (Proc); - end Sem_Sensitized_Process_Statement; - - procedure Sem_Concurrent_Selected_Signal_Assignment (Stmt: Iir) - is - Expr: Iir; - Chain : Iir; - begin - -- LRM 9.5 Concurrent Signal Assgnment Statements. - -- The process statement equivalent to a concurrent signal assignment - -- statement [...] is constructed as follows: [...] - -- - -- LRM 9.5.2 Selected Signal Assignment - -- The characteristics of the selected expression, the waveforms and - -- the choices in the selected assignment statement must be such that - -- the case statement in the equivalent statement is a legal - -- statement - - -- Target and waveforms. - Sem_Signal_Assignment (Stmt); - - -- The choices. - Chain := Get_Selected_Waveform_Chain (Stmt); - Expr := Sem_Case_Expression (Get_Expression (Stmt)); - if Expr /= Null_Iir then - Check_Read (Expr); - Set_Expression (Stmt, Expr); - Sem_Case_Choices (Expr, Chain, Get_Location (Stmt)); - Set_Selected_Waveform_Chain (Stmt, Chain); - end if; - - Sem_Guard (Stmt); - end Sem_Concurrent_Selected_Signal_Assignment; - - procedure Simple_Simultaneous_Statement (Stmt : Iir) is - Left, Right : Iir; - Res_Type : Iir; - begin - Left := Get_Simultaneous_Left (Stmt); - Right := Get_Simultaneous_Right (Stmt); - - Left := Sem_Expression_Ov (Left, Null_Iir); - Right := Sem_Expression_Ov (Right, Null_Iir); - - -- Give up in case of error - if Left = Null_Iir or else Right = Null_Iir then - return; - end if; - - Res_Type := Search_Compatible_Type (Get_Type (Left), Get_Type (Right)); - if Res_Type = Null_Iir then - Error_Msg_Sem - (+Stmt, "types of left and right expressions are incompatible"); - return; - end if; - - -- FIXME: check for nature type... - end Simple_Simultaneous_Statement; - - procedure Sem_Concurrent_Statement_Chain (Parent : Iir) - is - Is_Passive : constant Boolean := - Get_Kind (Parent) = Iir_Kind_Entity_Declaration; - El: Iir; - New_El : Iir; - Next_El : Iir; - - procedure No_Generate_Statement is - begin - if Is_Passive then - Error_Msg_Sem (+El, "generate statement forbidden in entity"); - end if; - end No_Generate_Statement; - - Prev_El : Iir; - Prev_Concurrent_Statement : Iir; - begin - Prev_Concurrent_Statement := Current_Concurrent_Statement; - - El := Get_Concurrent_Statement_Chain (Parent); - Prev_El := Null_Iir; - while El /= Null_Iir loop - Current_Concurrent_Statement := El; - New_El := El; - Next_El := Get_Chain (El); - - case Get_Kind (El) is - when Iir_Kind_Concurrent_Simple_Signal_Assignment - | Iir_Kind_Concurrent_Conditional_Signal_Assignment => - if Is_Passive then - Error_Msg_Sem (+El, "signal assignment forbidden in entity"); - end if; - Sem_Signal_Assignment (El); - when Iir_Kind_Concurrent_Selected_Signal_Assignment => - if Is_Passive then - Error_Msg_Sem (+El, "signal assignment forbidden in entity"); - end if; - Sem_Concurrent_Selected_Signal_Assignment (El); - when Iir_Kind_Sensitized_Process_Statement => - Set_Passive_Flag (El, Is_Passive); - Sem_Sensitized_Process_Statement (El); - when Iir_Kind_Process_Statement => - Set_Passive_Flag (El, Is_Passive); - Sem_Process_Statement (El); - when Iir_Kind_Component_Instantiation_Statement => - Sem_Component_Instantiation_Statement (El, Is_Passive); - when Iir_Kind_Concurrent_Assertion_Statement => - -- FIXME: must check assertion expressions does not contain - -- non-passive subprograms ?? - Sem_Assertion_Statement (El); - when Iir_Kind_Block_Statement => - if Is_Passive then - Error_Msg_Sem (+El, "block forbidden in entity"); - end if; - Sem_Block_Statement (El); - when Iir_Kind_If_Generate_Statement => - No_Generate_Statement; - Sem_If_Generate_Statement (El); - when Iir_Kind_For_Generate_Statement => - No_Generate_Statement; - Sem_For_Generate_Statement (El); - when Iir_Kind_Case_Generate_Statement => - No_Generate_Statement; - Sem_Case_Generate_Statement (El); - when Iir_Kind_Concurrent_Procedure_Call_Statement => - New_El := Sem_Concurrent_Procedure_Call_Statement - (El, Is_Passive); - when Iir_Kind_Psl_Declaration => - Sem_Psl.Sem_Psl_Declaration (El); - when Iir_Kind_Psl_Endpoint_Declaration => - Sem_Psl.Sem_Psl_Endpoint_Declaration (El); - when Iir_Kind_Psl_Assert_Statement => - New_El := Sem_Psl.Sem_Psl_Assert_Statement (El); - when Iir_Kind_Psl_Cover_Statement => - Sem_Psl.Sem_Psl_Cover_Statement (El); - when Iir_Kind_Psl_Default_Clock => - Sem_Psl.Sem_Psl_Default_Clock (El); - when Iir_Kind_Simple_Simultaneous_Statement => - Simple_Simultaneous_Statement (El); - when others => - Error_Kind ("sem_concurrent_statement_chain", El); - end case; - - if New_El /= El then - -- Replace this node. - if Prev_El = Null_Iir then - Set_Concurrent_Statement_Chain (Parent, New_El); - else - Set_Chain (Prev_El, New_El); - end if; - Set_Chain (New_El, Next_El); - Set_Parent (New_El, Parent); - Prev_El := New_El; - else - Prev_El := El; - pragma Assert (Get_Parent (El) = Parent); - end if; - - El := Next_El; - end loop; - - Current_Concurrent_Statement := Prev_Concurrent_Statement; - end Sem_Concurrent_Statement_Chain; - - -- Put labels in declarative region. - procedure Sem_Labels_Chain (Parent : Iir) - is - Stmt: Iir; - Label: Name_Id; - begin - Stmt := Get_Concurrent_Statement_Chain (Parent); - while Stmt /= Null_Iir loop - - case Get_Kind (Stmt) is - when Iir_Kind_Psl_Declaration - | Iir_Kind_Psl_Endpoint_Declaration => - -- Special case for in-lined PSL declarations. - null; - when others => - Label := Get_Label (Stmt); - - if Label /= Null_Identifier then - Sem_Scopes.Add_Name (Stmt); - Name_Visible (Stmt); - Xref_Decl (Stmt); - end if; - end case; - - -- INT-1991/issue report 27 - -- Generate statements represent declarative region and have - -- implicit declarative part. - if False - and then Flags.Vhdl_Std = Vhdl_87 - and then - (Get_Kind (Stmt) = Iir_Kind_For_Generate_Statement - or else Get_Kind (Stmt) = Iir_Kind_If_Generate_Statement) - then - Sem_Labels_Chain (Stmt); - end if; - - Stmt := Get_Chain (Stmt); - end loop; - end Sem_Labels_Chain; - - procedure Sem_Block (Blk: Iir) - is - Implicit : Implicit_Signal_Declaration_Type; - Prev_Psl_Default_Clock : Iir; - begin - Prev_Psl_Default_Clock := Current_Psl_Default_Clock; - Push_Signals_Declarative_Part (Implicit, Blk); - - Sem_Labels_Chain (Blk); - Sem_Declaration_Chain (Blk); - - Sem_Concurrent_Statement_Chain (Blk); - - -- FIXME: do it only if there is conf. spec. in the declarative - -- part. - Sem_Specification_Chain (Blk, Blk); - Check_Full_Declaration (Blk, Blk); - - Pop_Signals_Declarative_Part (Implicit); - Current_Psl_Default_Clock := Prev_Psl_Default_Clock; - end Sem_Block; - - -- Add a driver for SIG. - -- STMT is used in case of error (it is the statement that creates the - -- driver). - -- Do nothing if: - -- The current statement list does not belong to a process, - -- SIG is a formal signal interface. - procedure Sem_Add_Driver (Sig : Iir; Stmt : Iir) - is - Sig_Object : Iir; - Sig_Object_Type : Iir; - begin - if Sig = Null_Iir then - return; - end if; - Sig_Object := Get_Object_Prefix (Sig); - Sig_Object_Type := Get_Type (Sig_Object); - - -- LRM 4.3.1.2 Signal Declaration - -- It is an error if, after the elaboration of a description, a - -- signal has multiple sources and it is not a resolved signal. - - -- Check for multiple driver for a unresolved signal declaration. - -- Do this only if the object is a non-composite signal declaration. - -- NOTE: THIS IS DISABLED, since the assignment may be within a - -- generate statement. - if False - and then Get_Kind (Sig_Object) = Iir_Kind_Signal_Declaration - and then Get_Kind (Sig_Object_Type) - not in Iir_Kinds_Composite_Type_Definition - and then not Get_Resolved_Flag (Sig_Object_Type) - then - if Get_Signal_Driver (Sig_Object) /= Null_Iir and then - Get_Signal_Driver (Sig_Object) /= Current_Concurrent_Statement - then - Error_Msg_Sem (+Stmt, "unresolved %n has already a driver at %l", - (+Sig_Object, +Get_Signal_Driver (Sig_Object))); - else - Set_Signal_Driver (Sig_Object, Current_Concurrent_Statement); - end if; - end if; - - -- LRM 8.4.1 - -- If a given procedure is declared by a declarative item that is not - -- contained within a process statement, and if a signal assignment - -- statement appears in that procedure, then the target of the - -- assignment statement must be a formal parameter of the given - -- procedure or of a parent of that procedure, or an aggregate of such - -- formal parameters. - -- Similarly, if a given procedure is declared by a declarative item - -- that is not contained within a process statement and if a signal is - -- associated with an INOUT or OUT mode signal parameter in a - -- subprogram call within that procedure, then the signal so associated - -- must be a formal parameter of the given procedure or of a parent of - -- that procedure. - if Current_Concurrent_Statement = Null_Iir - or else (Get_Kind (Current_Concurrent_Statement) - not in Iir_Kinds_Process_Statement) - then - -- Not within a process statement. - if Current_Subprogram = Null_Iir then - -- not within a subprogram: concurrent statement. - return; - end if; - - -- Within a subprogram. - if Get_Kind (Sig_Object) = Iir_Kind_Signal_Declaration - or else not Is_Parameter (Sig_Object) - then - Error_Msg_Sem (+Stmt, "%n is not a formal parameter", +Sig_Object); - end if; - end if; - end Sem_Add_Driver; -end Sem_Stmts; diff --git a/src/vhdl/sem_stmts.ads b/src/vhdl/sem_stmts.ads deleted file mode 100644 index 5df75e09c..000000000 --- a/src/vhdl/sem_stmts.ads +++ /dev/null @@ -1,58 +0,0 @@ --- Semantic analysis. --- 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 Iirs; use Iirs; - -package Sem_Stmts is - -- Analyze declarations and concurrent statements of BLK, which is - -- either an architecture_declaration, and entity_declaration, - -- a block_statement or a generate_statement_body. - procedure Sem_Block (Blk: Iir); - - -- Analyze the concurrent statements of PARENT. - procedure Sem_Concurrent_Statement_Chain (Parent : Iir); - - -- Analyze declaration chain and sequential statement chain - -- of BODY_PARENT. - -- DECL is the declaration for these chains (DECL is the declaration, which - -- is different from the bodies). - -- This is used by processes and subprograms analyze. - procedure Sem_Sequential_Statements (Decl : Iir; Body_Parent : Iir); - - -- Sem for concurrent and sequential assertion statements. - procedure Sem_Report_Statement (Stmt : Iir); - - -- Get the current subprogram or process. - function Get_Current_Subprogram return Iir; - pragma Inline (Get_Current_Subprogram); - - -- Get the current concurrent statement, or NULL_IIR if none. - function Get_Current_Concurrent_Statement return Iir; - pragma Inline (Get_Current_Concurrent_Statement); - - -- Current PSL default_clock declaration. - -- Automatically saved and restore while analyzing concurrent statements. - Current_Psl_Default_Clock : Iir; - - -- Add a driver for SIG. - -- STMT is used in case of error (it is the statement that creates the - -- driver). - -- Do nothing if: - -- The current statement list does not belong to a process, - -- SIG is a formal signal interface. - procedure Sem_Add_Driver (Sig : Iir; Stmt : Iir); -end Sem_Stmts; diff --git a/src/vhdl/sem_types.adb b/src/vhdl/sem_types.adb deleted file mode 100644 index 4bb4ac2dd..000000000 --- a/src/vhdl/sem_types.adb +++ /dev/null @@ -1,2382 +0,0 @@ --- Semantic analysis. --- 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 Libraries; -with Flags; use Flags; -with Types; use Types; -with Errorout; use Errorout; -with Evaluation; use Evaluation; -with Sem_Utils; -with Sem_Expr; use Sem_Expr; -with Sem_Scopes; use Sem_Scopes; -with Sem_Names; use Sem_Names; -with Sem_Decls; -with Sem_Inst; -with Name_Table; -with Std_Names; -with Iirs_Utils; use Iirs_Utils; -with Std_Package; use Std_Package; -with Ieee.Std_Logic_1164; -with Xrefs; use Xrefs; - -package body Sem_Types is - -- Mark the resolution function (this may be required by the back-end to - -- generate resolver). - procedure Mark_Resolution_Function (Subtyp : Iir) - is - Func : Iir_Function_Declaration; - begin - if not Get_Resolved_Flag (Subtyp) then - return; - end if; - - Func := Has_Resolution_Function (Subtyp); - -- Maybe the type is resolved through its elements. - if Func /= Null_Iir then - Set_Resolution_Function_Flag (Func, True); - - -- For internal reasons of translation, the element subtype has - -- to be translated for signals. - -- FIXME: maybe move the whole Has_Signal flag generation in - -- translation, as this is needed only for translation. - -- FIXME: how to deal with incorrect function ? Use an Error node ? - Set_Type_Has_Signal - (Get_Element_Subtype - (Get_Type (Get_Interface_Declaration_Chain (Func)))); - end if; - end Mark_Resolution_Function; - - procedure Set_Type_Has_Signal (Atype : Iir) - is - Orig : Iir; - begin - -- Sanity check: ATYPE can be a signal type (eg: not an access type) - if not Get_Signal_Type_Flag (Atype) then - -- Do not crash since this may be called on an erroneous design. - return; - end if; - - -- If the type is already marked, nothing to do. - if Get_Has_Signal_Flag (Atype) then - return; - end if; - - -- This type is used to declare a signal. - Set_Has_Signal_Flag (Atype, True); - - -- If this type was instantiated, also mark the origin. - Orig := Sem_Inst.Get_Origin (Atype); - if Orig /= Null_Iir then - Set_Type_Has_Signal (Orig); - end if; - - -- For subtype, mark resolution function and base type. - case Get_Kind (Atype) is - when Iir_Kinds_Scalar_Subtype_Definition - | Iir_Kind_Array_Subtype_Definition - | Iir_Kind_Record_Subtype_Definition => - Set_Type_Has_Signal (Get_Base_Type (Atype)); - Mark_Resolution_Function (Atype); - declare - Tm : constant Iir := Get_Subtype_Type_Mark (Atype); - begin - if Tm /= Null_Iir then - Set_Type_Has_Signal (Get_Type (Get_Named_Entity (Tm))); - end if; - end; - when others => - null; - end case; - - -- For composite types, also mark type of elements. - case Get_Kind (Atype) is - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Physical_Type_Definition - | Iir_Kind_Floating_Type_Definition => - null; - when Iir_Kinds_Scalar_Subtype_Definition => - null; - when Iir_Kind_Array_Subtype_Definition - | Iir_Kind_Array_Type_Definition => - Set_Type_Has_Signal (Get_Element_Subtype (Atype)); - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - declare - El_List : constant Iir_Flist := - Get_Elements_Declaration_List (Atype); - El : Iir; - begin - for I in Flist_First .. Flist_Last (El_List) loop - El := Get_Nth_Element (El_List, I); - Set_Type_Has_Signal (Get_Type (El)); - end loop; - end; - when Iir_Kind_Error => - null; - when Iir_Kind_Incomplete_Type_Definition => - -- No need to copy the flag. - null; - when Iir_Kind_Interface_Type_Definition => - null; - when others => - Error_Kind ("set_type_has_signal(2)", Atype); - end case; - end Set_Type_Has_Signal; - - -- Sem a range expression that appears in an integer, real or physical - -- type definition. - -- - -- Both left and right bounds must be of the same type class, ie - -- integer types, or if INT_ONLY is false, real types. - -- However, the two bounds need not have the same type. - function Sem_Type_Range_Expression (Expr : Iir; Int_Only : Boolean) - return Iir - is - Left, Right: Iir; - Bt_L_Kind, Bt_R_Kind : Iir_Kind; - begin - Left := Sem_Expression_Universal (Get_Left_Limit_Expr (Expr)); - Right := Sem_Expression_Universal (Get_Right_Limit_Expr (Expr)); - if Left = Null_Iir or Right = Null_Iir then - return Null_Iir; - end if; - - -- Emit error message for overflow and replace with a value to avoid - -- error storm. - if Get_Kind (Left) = Iir_Kind_Overflow_Literal then - Error_Msg_Sem (+Left, "overflow in left bound"); - Left := Build_Extreme_Value - (Get_Direction (Expr) = Iir_Downto, Left); - end if; - if Get_Kind (Right) = Iir_Kind_Overflow_Literal then - Error_Msg_Sem (+Right, "overflow in right bound"); - Right := Build_Extreme_Value - (Get_Direction (Expr) = Iir_To, Right); - end if; - Set_Left_Limit_Expr (Expr, Left); - Set_Right_Limit_Expr (Expr, Right); - Set_Left_Limit (Expr, Left); - Set_Right_Limit (Expr, Right); - - Set_Expr_Staticness (Expr, Min (Get_Expr_Staticness (Left), - Get_Expr_Staticness (Right))); - - Bt_L_Kind := Get_Kind (Get_Base_Type (Get_Type (Left))); - Bt_R_Kind := Get_Kind (Get_Base_Type (Get_Type (Right))); - - if Int_Only then - if Bt_L_Kind /= Iir_Kind_Integer_Type_Definition - and then Bt_R_Kind = Iir_Kind_Integer_Type_Definition - then - Error_Msg_Sem (+Left, "left bound must be an integer expression"); - return Null_Iir; - end if; - if Bt_R_Kind /= Iir_Kind_Integer_Type_Definition - and then Bt_L_Kind = Iir_Kind_Integer_Type_Definition - then - Error_Msg_Sem - (+Right, "right bound must be an integer expression"); - return Null_Iir; - end if; - if Bt_R_Kind /= Iir_Kind_Integer_Type_Definition - and then Bt_L_Kind /= Iir_Kind_Integer_Type_Definition - then - Error_Msg_Sem (+Expr, "each bound must be an integer expression"); - return Null_Iir; - end if; - else - if Bt_L_Kind /= Bt_R_Kind then - Error_Msg_Sem - (+Expr, "left and right bounds must be of the same type class"); - return Null_Iir; - end if; - case Bt_L_Kind is - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Floating_Type_Definition => - null; - when others => - -- Enumeration range are not allowed to define a new type. - Error_Msg_Sem - (+Expr, "bad range type, only integer or float is allowed"); - return Null_Iir; - end case; - end if; - - return Expr; - end Sem_Type_Range_Expression; - - function Create_Integer_Type (Loc : Iir; Constraint : Iir; Decl : Iir) - return Iir - is - Ntype: Iir_Integer_Subtype_Definition; - Ndef: Iir_Integer_Type_Definition; - begin - Ntype := Create_Iir (Iir_Kind_Integer_Subtype_Definition); - Location_Copy (Ntype, Loc); - Ndef := Create_Iir (Iir_Kind_Integer_Type_Definition); - Location_Copy (Ndef, Loc); - Set_Base_Type (Ndef, Ndef); - Set_Type_Declarator (Ndef, Decl); - Set_Type_Staticness (Ndef, Locally); - Set_Signal_Type_Flag (Ndef, True); - Set_Base_Type (Ntype, Ndef); - Set_Type_Declarator (Ntype, Decl); - Set_Range_Constraint (Ntype, Constraint); - Set_Type_Staticness (Ntype, Get_Expr_Staticness (Constraint)); - Set_Resolved_Flag (Ntype, False); - Set_Signal_Type_Flag (Ntype, True); - if Get_Type_Staticness (Ntype) /= Locally then - Error_Msg_Sem - (+Decl, "range constraint of type must be locally static"); - end if; - return Ntype; - end Create_Integer_Type; - - function Range_Expr_To_Type_Definition (Expr : Iir; Decl: Iir) - return Iir - is - Rng : Iir; - Res : Iir; - Base_Type : Iir; - begin - if Sem_Type_Range_Expression (Expr, False) = Null_Iir then - return Null_Iir; - end if; - Rng := Eval_Range_If_Static (Expr); - if Get_Expr_Staticness (Rng) /= Locally then - -- FIXME: create an artificial range to avoid error storm ? - null; - end if; - - case Get_Kind (Get_Base_Type (Get_Type (Get_Left_Limit (Rng)))) is - when Iir_Kind_Integer_Type_Definition => - Res := Create_Integer_Type (Expr, Rng, Decl); - when Iir_Kind_Floating_Type_Definition => - declare - Ntype: Iir_Floating_Subtype_Definition; - Ndef: Iir_Floating_Type_Definition; - begin - Ntype := Create_Iir (Iir_Kind_Floating_Subtype_Definition); - Location_Copy (Ntype, Expr); - Ndef := Create_Iir (Iir_Kind_Floating_Type_Definition); - Location_Copy (Ndef, Expr); - Set_Base_Type (Ndef, Ndef); - Set_Type_Declarator (Ndef, Decl); - Set_Type_Staticness (Ndef, Get_Expr_Staticness (Expr)); - Set_Signal_Type_Flag (Ndef, True); - Set_Base_Type (Ntype, Ndef); - Set_Type_Declarator (Ntype, Decl); - Set_Range_Constraint (Ntype, Rng); - Set_Resolved_Flag (Ntype, False); - Set_Type_Staticness (Ntype, Get_Expr_Staticness (Expr)); - Set_Signal_Type_Flag (Ntype, True); - Res := Ntype; - end; - when others => - -- sem_range_expression should catch such errors. - raise Internal_Error; - end case; - - -- A type and a subtype were declared. The type of the bounds are now - -- used for the implicit subtype declaration. But the type of the - -- bounds aren't of the type of the type declaration (this is 'obvious' - -- because they exist before the type declaration). Override their - -- type. This is doable without destroying information as they are - -- either literals (of type convertible_xx_type_definition) or an - -- evaluated literal. - -- - -- Overriding makes these implicit subtype homogenous with explicit - -- subtypes. - Base_Type := Get_Base_Type (Res); - Set_Type (Rng, Base_Type); - Set_Type (Get_Left_Limit (Rng), Base_Type); - Set_Type (Get_Right_Limit (Rng), Base_Type); - - return Res; - end Range_Expr_To_Type_Definition; - - function Create_Physical_Literal (Val : Iir_Int64; Unit : Iir) return Iir - is - Lit : Iir; - begin - Lit := Create_Iir (Iir_Kind_Physical_Int_Literal); - Set_Value (Lit, Val); - Set_Physical_Unit (Lit, Unit); - Set_Expr_Staticness (Lit, Locally); - Set_Type (Lit, Get_Type (Unit)); - Location_Copy (Lit, Unit); - return Lit; - end Create_Physical_Literal; - - -- Analyze a physical type definition. Create a subtype. - function Sem_Physical_Type_Definition (Def : Iir; Decl : Iir) - return Iir_Physical_Subtype_Definition - is - Unit: Iir_Unit_Declaration; - Sub_Type: Iir_Physical_Subtype_Definition; - Range_Expr : Iir; - Range_Expr1: Iir; - Val : Iir; - Lit : Iir_Physical_Int_Literal; - begin - Range_Expr := Get_Range_Constraint (Def); - - -- LRM93 4.1 - -- The simple name declared by a type declaration denotes the - -- declared type, unless the type declaration declares both a base - -- type and a subtype of the base type, in which case the simple name - -- denotes the subtype, and the base type is anonymous. - Set_Type_Declarator (Def, Decl); - Set_Base_Type (Def, Def); - Set_Resolved_Flag (Def, False); - Set_Type_Staticness (Def, Locally); - Set_Signal_Type_Flag (Def, True); - - -- LRM93 3.1.3 - -- Each bound of a range constraint that is used in a physical type - -- definition must be a locally static expression of some integer type - -- but the two bounds need not have the same integer type. - case Get_Kind (Range_Expr) is - when Iir_Kind_Range_Expression => - Range_Expr1 := Sem_Type_Range_Expression (Range_Expr, True); - when Iir_Kind_Attribute_Name => - Sem_Name (Range_Expr); - Range_Expr1 := Name_To_Range (Range_Expr); - when Iir_Kind_Error => - Range_Expr1 := Null_Iir; - when others => - Error_Kind ("sem_physical_type_definition", Range_Expr); - end case; - if Range_Expr1 = Null_Iir or else Is_Error (Range_Expr1) then - -- Avoid cascading errors. - Range_Expr1 := - Get_Range_Constraint (Universal_Integer_Subtype_Definition); - end if; - if Get_Expr_Staticness (Range_Expr1) /= Locally then - Error_Msg_Sem (+Range_Expr1, - "range constraint for a physical type must be static"); - Range_Expr1 := - Get_Range_Constraint (Universal_Integer_Subtype_Definition); - else - Range_Expr1 := Eval_Range_If_Static (Range_Expr1); - end if; - - -- Create the subtype. - Sub_Type := Create_Iir (Iir_Kind_Physical_Subtype_Definition); - Location_Copy (Sub_Type, Range_Expr); - Set_Base_Type (Sub_Type, Def); - Set_Signal_Type_Flag (Sub_Type, True); - - -- Analyze the primary unit. - Unit := Get_Unit_Chain (Def); - - -- Set its value to 1. - Set_Type (Unit, Def); - Set_Expr_Staticness (Unit, Locally); - Set_Name_Staticness (Unit, Locally); - Lit := Create_Physical_Literal (1, Unit); - Set_Physical_Literal (Unit, Lit); - - Sem_Scopes.Add_Name (Unit); - Set_Visible_Flag (Unit, True); - Xref_Decl (Unit); - - declare - -- Convert an integer literal to a physical literal. - -- This is used to convert bounds. - function Lit_To_Phys_Lit (Lim : Iir_Integer_Literal) - return Iir_Physical_Int_Literal - is - Res : Iir_Physical_Int_Literal; - begin - Res := Create_Iir (Iir_Kind_Physical_Int_Literal); - Location_Copy (Res, Lim); - Set_Type (Res, Def); - Set_Value (Res, Get_Value (Lim)); - Set_Physical_Unit (Res, Get_Primary_Unit (Def)); - Set_Expr_Staticness (Res, Locally); - Set_Literal_Origin (Res, Lim); - return Res; - end Lit_To_Phys_Lit; - - Phys_Range : Iir_Range_Expression; - Lit : Iir; - begin - -- Create the physical range. - Phys_Range := Create_Iir (Iir_Kind_Range_Expression); - Location_Copy (Phys_Range, Range_Expr1); - Set_Type (Phys_Range, Def); - Set_Direction (Phys_Range, Get_Direction (Range_Expr1)); - Lit := Lit_To_Phys_Lit (Get_Left_Limit (Range_Expr1)); - Set_Left_Limit (Phys_Range, Lit); - Set_Left_Limit_Expr (Phys_Range, Lit); - Lit := Lit_To_Phys_Lit (Get_Right_Limit (Range_Expr1)); - Set_Right_Limit (Phys_Range, Lit); - Set_Right_Limit_Expr (Phys_Range, Lit); - Set_Expr_Staticness - (Phys_Range, Get_Expr_Staticness (Range_Expr1)); - - Set_Range_Constraint (Sub_Type, Phys_Range); - Set_Range_Constraint (Def, Null_Iir); - -- This must be locally... - Set_Type_Staticness (Sub_Type, Get_Expr_Staticness (Range_Expr1)); - - -- FIXME: the original range is not used. Reuse it ? - Free_Iir (Range_Expr); - end; - Set_Resolved_Flag (Sub_Type, False); - - -- Analyze secondary units. - Unit := Get_Chain (Unit); - while Unit /= Null_Iir loop - Sem_Scopes.Add_Name (Unit); - Val := Sem_Expression (Get_Physical_Literal (Unit), Def); - if Val /= Null_Iir then - Val := Eval_Physical_Literal (Val); - Set_Physical_Literal (Unit, Val); - - -- LRM93 §3.1 - -- The position number of unit names need not lie within the range - -- specified by the range constraint. - -- GHDL: this was not true in VHDL87. - -- GHDL: This is not so simple if 1 is not included in the range. - if False and then Flags.Vhdl_Std = Vhdl_87 - and then Range_Expr1 /= Null_Iir - then - if not Eval_Int_In_Range (Get_Value (Unit), Range_Expr1) then - Error_Msg_Sem - (+Unit, "physical literal does not lie within the range"); - end if; - end if; - else - -- Avoid errors storm. - Val := Create_Physical_Literal (1, Get_Primary_Unit (Def)); - Set_Literal_Origin (Val, Get_Physical_Literal (Unit)); - Set_Physical_Literal (Unit, Val); - end if; - - Set_Type (Unit, Def); - Set_Expr_Staticness (Unit, Locally); - Set_Name_Staticness (Unit, Locally); - Sem_Scopes.Name_Visible (Unit); - Xref_Decl (Unit); - Unit := Get_Chain (Unit); - end loop; - - return Sub_Type; - end Sem_Physical_Type_Definition; - - -- Return true iff decl is std.textio.text - function Is_Text_Type_Declaration (Decl : Iir_Type_Declaration) - return Boolean - is - use Std_Names; - P : Iir; - begin - if Get_Identifier (Decl) /= Name_Text then - return False; - end if; - P := Get_Parent (Decl); - if Get_Kind (P) /= Iir_Kind_Package_Declaration - or else Get_Identifier (P) /= Name_Textio - then - return False; - end if; - -- design_unit, design_file, library_declaration. - P := Get_Library (Get_Design_File (Get_Design_Unit (P))); - if P /= Libraries.Std_Library then - return False; - end if; - return True; - end Is_Text_Type_Declaration; - - procedure Check_No_File_Type (El_Type : Iir; Loc : Iir) is - begin - case Get_Kind (El_Type) is - when Iir_Kind_File_Type_Definition => - Error_Msg_Sem - (+Loc, "file type element not allowed in a composite type"); - when Iir_Kind_Protected_Type_Declaration => - Error_Msg_Sem - (+Loc, "protected type element not allowed in a composite type"); - when others => - null; - end case; - end Check_No_File_Type; - - -- Analyze the array_element type of array type DEF. - -- Set resolved_flag of DEF. - procedure Sem_Array_Element (Def : Iir) - is - El_Type : Iir; - begin - El_Type := Get_Element_Subtype_Indication (Def); - El_Type := Sem_Subtype_Indication (El_Type); - if El_Type = Null_Iir then - Set_Type_Staticness (Def, None); - Set_Resolved_Flag (Def, False); - return; - end if; - Set_Element_Subtype_Indication (Def, El_Type); - - El_Type := Get_Type_Of_Subtype_Indication (El_Type); - Set_Element_Subtype (Def, El_Type); - Check_No_File_Type (El_Type, Def); - Set_Signal_Type_Flag (Def, Get_Signal_Type_Flag (El_Type)); - - -- LRM93 §3.2.1.1 - -- The same requirement exists [must define a constrained - -- array subtype] [...] for the element subtype indication - -- of an array type definition, if the type of the array - -- element is itself an array type. - if Vhdl_Std < Vhdl_08 - and then not Is_Fully_Constrained_Type (El_Type) - then - Error_Msg_Sem - (+Def, - "array element of unconstrained %n is not allowed before vhdl08", - +El_Type); - end if; - Set_Resolved_Flag (Def, Get_Resolved_Flag (El_Type)); - end Sem_Array_Element; - - procedure Sem_Protected_Type_Declaration (Type_Decl : Iir_Type_Declaration) - is - Decl : Iir_Protected_Type_Declaration; - El : Iir; - begin - Decl := Get_Type_Definition (Type_Decl); - Set_Base_Type (Decl, Decl); - Set_Resolved_Flag (Decl, False); - Set_Signal_Type_Flag (Decl, False); - Set_Type_Staticness (Decl, None); - - -- LRM 10.3 Visibility - -- [...] except in the declaration of a design_unit or a protected type - -- declaration, in which case it starts immediatly after the reserved - -- word is occuring after the identifier of the design unit or - -- protected type declaration. - Set_Visible_Flag (Type_Decl, True); - - -- LRM 10.1 - -- n) A protected type declaration, together with the corresponding - -- body. - Open_Declarative_Region; - - Sem_Decls.Sem_Declaration_Chain (Decl); - El := Get_Declaration_Chain (Decl); - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Use_Clause - | Iir_Kind_Attribute_Specification => - null; - when Iir_Kind_Procedure_Declaration - | Iir_Kind_Function_Declaration => - declare - Inter : Iir; - Inter_Type : Iir; - begin - -- LRM08 3.5.1 Protected type declarations - -- Such formal parameters must not be of an access type or - -- a file type; moreover, they must not have a subelement - -- that is an access type of a file type. - Inter := Get_Interface_Declaration_Chain (El); - while Inter /= Null_Iir loop - Inter_Type := Get_Type (Inter); - if Inter_Type /= Null_Iir - and then Get_Signal_Type_Flag (Inter_Type) = False - and then Get_Kind (Inter_Type) - /= Iir_Kind_Protected_Type_Declaration - then - Error_Msg_Sem - (+Inter, "formal parameter method must not be " - & "access or file type"); - end if; - Inter := Get_Chain (Inter); - end loop; - - -- LRM08 3.5.1 Protected type declarations - -- Additionally, in the case of a function subprogram, the - -- return type of the function must not be of an access type - -- or file type; moreover, it must not have a subelement - -- that is an access type of a file type. - if Get_Kind (El) = Iir_Kind_Function_Declaration then - Inter_Type := Get_Return_Type (El); - if Inter_Type /= Null_Iir - and then Get_Signal_Type_Flag (Inter_Type) = False - then - Error_Msg_Sem - (+El, "method cannot return an access or a file"); - end if; - end if; - end; - when Iir_Kind_Anonymous_Type_Declaration => - -- This is an error, but an anonynmous type declaration is - -- followed by a subtype declaration, which is also an error. - -- Avoid duplicate messages. - null; - when others => - Error_Msg_Sem - (+El, "%n is not allowed in protected type declaration", - +El); - end case; - El := Get_Chain (El); - end loop; - - Close_Declarative_Region; - end Sem_Protected_Type_Declaration; - - procedure Sem_Protected_Type_Body (Bod : Iir) - is - Inter : Name_Interpretation_Type; - Type_Decl : Iir; - Decl : Iir; - begin - -- LRM 3.5 Protected types. - -- Each protected type declaration appearing immediatly within a given - -- declaration region must have exactly one corresponding protected type - -- body appearing immediatly within the same declarative region and - -- textually subsequent to the protected type declaration. - -- - -- Similarly, each protected type body appearing immediatly within a - -- given declarative region must have exactly one corresponding - -- protected type declaration appearing immediatly within the same - -- declarative region and textually prior to the protected type body. - Inter := Get_Interpretation (Get_Identifier (Bod)); - if Valid_Interpretation (Inter) - and then Is_In_Current_Declarative_Region (Inter) - then - Type_Decl := Get_Declaration (Inter); - if Get_Kind (Type_Decl) = Iir_Kind_Type_Declaration then - Decl := Get_Type_Definition (Type_Decl); - else - Decl := Null_Iir; - end if; - else - Decl := Null_Iir; - end if; - - if Decl /= Null_Iir - and then Get_Kind (Decl) = Iir_Kind_Protected_Type_Declaration - then - Set_Protected_Type_Declaration (Bod, Decl); - if Get_Protected_Type_Body (Decl) /= Null_Iir then - Error_Msg_Sem - (+Bod, "protected type body already declared for %n", - (1 => +Decl), Cont => True); - Error_Msg_Sem - (+Get_Protected_Type_Body (Decl), "(previous body)"); - Decl := Null_Iir; - elsif not Get_Visible_Flag (Type_Decl) then - -- Can this happen ? - Error_Msg_Sem - (+Bod, "protected type declaration not yet visible", - Cont => True); - Error_Msg_Sem - (+Decl, "(location of protected type declaration)"); - Decl := Null_Iir; - else - Set_Protected_Type_Body (Decl, Bod); - end if; - else - Error_Msg_Sem - (+Bod, "no protected type declaration for this body"); - if Decl /= Null_Iir then - Error_Msg_Sem (+Decl, "(found %n declared here)", +Decl); - Decl := Null_Iir; - end if; - end if; - - -- LRM 10.1 - -- n) A protected type declaration, together with the corresponding - -- body. - Open_Declarative_Region; - - if Decl /= Null_Iir then - Xref_Body (Bod, Decl); - Add_Protected_Type_Declarations (Decl); - end if; - - Sem_Decls.Sem_Declaration_Chain (Bod); - - Sem_Decls.Check_Full_Declaration (Bod, Bod); - - -- LRM 3.5.2 Protected type bodies - -- Each subprogram declaration appearing in a given protected type - -- declaration shall have a corresponding subprogram body appearing in - -- the corresponding protected type body. - if Decl /= Null_Iir then - Sem_Decls.Check_Full_Declaration (Decl, Bod); - end if; - - Close_Declarative_Region; - end Sem_Protected_Type_Body; - - -- Return the constraint state from CONST (the initial state) and EL_TYPE, - -- as if ATYPE was a new element of a record. - -- - -- LRM08 5 Types - -- A composite subtype is said to be unconstrained if: - -- - [...] - -- - It is a record subtype with at least one element of a composite - -- subtype and each element that is of a composite subtype is - -- unconstrained. - -- - -- A composite subtype is said to be fully constrained if: - -- - [...] - -- - It is a record subtype and each element subtype either is not a - -- composite subtype or is a fully constrained composite subtype. - procedure Update_Record_Constraint (Constraint : in out Iir_Constraint; - Composite_Found : in out Boolean; - El_Type : Iir) is - begin - if Get_Kind (El_Type) not in Iir_Kinds_Composite_Type_Definition then - pragma Assert (Composite_Found or Constraint = Fully_Constrained); - return; - end if; - - if Composite_Found then - case Constraint is - when Fully_Constrained - | Unconstrained => - if Get_Constraint_State (El_Type) /= Constraint then - Constraint := Partially_Constrained; - end if; - when Partially_Constrained => - Constraint := Partially_Constrained; - end case; - else - Composite_Found := True; - Constraint := Get_Constraint_State (El_Type); - end if; - end Update_Record_Constraint; - - function Get_Array_Constraint (Def : Iir) return Iir_Constraint - is - El_Type : constant Iir := Get_Element_Subtype (Def); - Constrained_Index : constant Boolean := Get_Index_Constraint_Flag (Def); - begin - if Get_Kind (El_Type) in Iir_Kinds_Composite_Type_Definition then - case Get_Constraint_State (El_Type) is - when Fully_Constrained => - if Constrained_Index then - return Fully_Constrained; - else - return Partially_Constrained; - end if; - when Partially_Constrained => - return Partially_Constrained; - when Unconstrained => - if not Constrained_Index then - return Unconstrained; - else - return Partially_Constrained; - end if; - end case; - else - -- Element subtype is not a composite subtype. - if Constrained_Index then - return Fully_Constrained; - else - return Unconstrained; - end if; - end if; - end Get_Array_Constraint; - - function Sem_Enumeration_Type_Definition (Def: Iir; Decl: Iir) return Iir - is - Literal_List : constant Iir_Flist := Get_Enumeration_Literal_List (Def); - El: Iir; - Only_Characters : Boolean; - begin - Set_Base_Type (Def, Def); - Set_Type_Staticness (Def, Locally); - Set_Signal_Type_Flag (Def, True); - - -- Makes all literal visible. - Only_Characters := True; - for I in Flist_First .. Flist_Last (Literal_List) loop - El := Get_Nth_Element (Literal_List, I); - Set_Expr_Staticness (El, Locally); - Set_Name_Staticness (El, Locally); - Set_Type (El, Def); - Sem_Utils.Compute_Subprogram_Hash (El); - Sem_Scopes.Add_Name (El); - Name_Visible (El); - Xref_Decl (El); - - -- LRM93 3.1.1 Enumeration types - -- An enumeration type is said to be a character type if at least - -- one of its enumeration literals is a character literal. - if Name_Table.Is_Character (Get_Identifier (El)) then - Set_Is_Character_Type (Def, True); - else - Only_Characters := False; - end if; - end loop; - Set_Only_Characters_Flag (Def, Only_Characters); - Set_Resolved_Flag (Def, False); - - Create_Range_Constraint_For_Enumeration_Type (Def); - - -- Identifier IEEE.Std_Logic_1164.Std_Ulogic. - if Get_Identifier (Decl) = Std_Names.Name_Std_Ulogic - and then - Get_Parent (Decl) = Ieee.Std_Logic_1164.Std_Logic_1164_Pkg - then - Ieee.Std_Logic_1164.Std_Ulogic_Type := Def; - end if; - - return Def; - end Sem_Enumeration_Type_Definition; - - function Sem_Record_Type_Definition (Def: Iir) return Iir - is - -- Analyzed type of previous element - Last_Type : Iir; - - El_List : constant Iir_Flist := Get_Elements_Declaration_List (Def); - El : Iir; - El_Type : Iir; - Resolved_Flag : Boolean; - Type_Staticness : Iir_Staticness; - Constraint : Iir_Constraint; - Composite_Found : Boolean; - begin - -- LRM 10.1 - -- 5. A record type declaration, - Open_Declarative_Region; - - Resolved_Flag := True; - Last_Type := Null_Iir; - Type_Staticness := Locally; - Constraint := Fully_Constrained; - Composite_Found := False; - Set_Signal_Type_Flag (Def, True); - - for I in Flist_First .. Flist_Last (El_List) loop - El := Get_Nth_Element (El_List, I); - El_Type := Get_Subtype_Indication (El); - if El_Type /= Null_Iir then - -- Be careful for a declaration list (r,g,b: integer). - El_Type := Sem_Subtype_Indication (El_Type); - Set_Subtype_Indication (El, El_Type); - El_Type := Get_Type_Of_Subtype_Indication (El_Type); - Last_Type := El_Type; - else - El_Type := Last_Type; - end if; - if El_Type /= Null_Iir then - Set_Type (El, El_Type); - Check_No_File_Type (El_Type, El); - if not Get_Signal_Type_Flag (El_Type) then - Set_Signal_Type_Flag (Def, False); - end if; - - -- LRM93 3.2.1.1 - -- The same requirement [must define a constrained array - -- subtype] exits for the subtype indication of an - -- element declaration, if the type of the record - -- element is an array type. - if Vhdl_Std < Vhdl_08 - and then not Is_Fully_Constrained_Type (El_Type) - then - Error_Msg_Sem - (+El, - "element declaration of unconstrained %n is not allowed", - +El_Type); - end if; - Resolved_Flag := - Resolved_Flag and Get_Resolved_Flag (El_Type); - Type_Staticness := Min (Type_Staticness, - Get_Type_Staticness (El_Type)); - Update_Record_Constraint (Constraint, Composite_Found, El_Type); - else - Type_Staticness := None; - end if; - Sem_Scopes.Add_Name (El); - Name_Visible (El); - Xref_Decl (El); - end loop; - Close_Declarative_Region; - Set_Base_Type (Def, Def); - Set_Resolved_Flag (Def, Resolved_Flag); - Set_Type_Staticness (Def, Type_Staticness); - Set_Constraint_State (Def, Constraint); - return Def; - end Sem_Record_Type_Definition; - - function Sem_Unbounded_Array_Type_Definition (Def: Iir) return Iir - is - Index_List : constant Iir_Flist := - Get_Index_Subtype_Definition_List (Def); - Index_Type : Iir; - begin - Set_Base_Type (Def, Def); - - for I in Flist_First .. Flist_Last (Index_List) loop - Index_Type := Get_Nth_Element (Index_List, I); - - Index_Type := Sem_Type_Mark (Index_Type); - Set_Nth_Element (Index_List, I, Index_Type); - - Index_Type := Get_Type (Index_Type); - if Get_Kind (Index_Type) not in Iir_Kinds_Discrete_Type_Definition - then - Error_Msg_Sem - (+Index_Type, - "an index type of an array must be a discrete type"); - -- FIXME: disp type Index_Type ? - end if; - end loop; - - Set_Index_Subtype_List (Def, Index_List); - - Sem_Array_Element (Def); - Set_Constraint_State (Def, Get_Array_Constraint (Def)); - - -- According to LRM93 7.4.1, an unconstrained array type is not static. - Set_Type_Staticness (Def, None); - - return Def; - end Sem_Unbounded_Array_Type_Definition; - - -- Return the subtype declaration corresponding to the base type of ATYPE - -- (for integer and real types), or the type for enumerated types. To say - -- that differently, it returns the type or subtype which defines the - -- original range. - function Get_First_Subtype_Declaration (Atype : Iir) return Iir is - Base_Type : constant Iir := Get_Base_Type (Atype); - Base_Decl : constant Iir := Get_Type_Declarator (Base_Type); - begin - if Get_Kind (Base_Type) = Iir_Kind_Enumeration_Type_Definition then - pragma Assert (Get_Kind (Base_Decl) = Iir_Kind_Type_Declaration); - return Base_Decl; - else - return Get_Type_Declarator (Get_Subtype_Definition (Base_Decl)); - end if; - end Get_First_Subtype_Declaration; - - function Sem_Constrained_Array_Type_Definition (Def: Iir; Decl: Iir) - return Iir - is - Index_List : constant Iir_Flist := Get_Index_Constraint_List (Def); - Index_Type : Iir; - Index_Name : Iir; - Base_Index_List : Iir_Flist; - El_Type : Iir; - Staticness : Iir_Staticness; - - -- array_type_definition, which is the same as the subtype, - -- but without any constraint in the indexes. - Base_Type: Iir; - begin - -- LRM08 5.3.2.1 Array types - -- A constrained array definition similarly defines both an array - -- type and a subtype of this type. - -- - The array type is an implicitely declared anonymous type, - -- this type is defined by an (implicit) unbounded array - -- definition in which the element subtype indication either - -- denotes the base type of the subtype denoted by the element - -- subtype indication of the constrained array definition, if - -- that subtype is a composite type, or otherwise is the - -- element subtype indication of the constrained array - -- definition, and in which the type mark of each index subtype - -- definition denotes the subtype defined by the corresponding - -- discrete range. - -- - The array subtype is the subtype obtained by imposition of - -- the index constraint on the array type and if the element - -- subtype indication of the constrained array definition - -- denotes a fully or partially constrained composite subtype, - -- imposition of the constraint of that subtype as an array - -- element constraint on the array type. - - -- FIXME: all indexes must be either constrained or - -- unconstrained. - -- If all indexes are unconstrained, this is really a type - -- otherwise, this is a subtype. - - -- Create a definition for the base type of subtype DEF. - Base_Type := Create_Iir (Iir_Kind_Array_Type_Definition); - Location_Copy (Base_Type, Def); - Set_Base_Type (Base_Type, Base_Type); - Set_Type_Declarator (Base_Type, Decl); - Base_Index_List := Create_Iir_Flist (Get_Nbr_Elements (Index_List)); - Set_Index_Subtype_Definition_List (Base_Type, Base_Index_List); - Set_Index_Subtype_List (Base_Type, Base_Index_List); - - Staticness := Locally; - for I in Flist_First .. Flist_Last (Index_List) loop - Index_Type := Get_Nth_Element (Index_List, I); - - Index_Name := Sem_Discrete_Range_Integer (Index_Type); - if Index_Name /= Null_Iir then - Index_Name := Range_To_Subtype_Indication (Index_Name); - -- Index_Name is a subtype_indication, which can be a type_mark. - else - -- Avoid errors. - Index_Name := - Build_Simple_Name (Natural_Subtype_Declaration, Index_Type); - Set_Type (Index_Name, Natural_Subtype_Definition); - end if; - - Set_Nth_Element (Index_List, I, Index_Name); - - Index_Type := Get_Index_Type (Index_Name); - Staticness := Min (Staticness, Get_Type_Staticness (Index_Type)); - - -- Set the index subtype definition for the array base type. - if Get_Kind (Index_Name) in Iir_Kinds_Denoting_Name then - Index_Type := Get_Named_Entity (Index_Name); - else - pragma Assert - (Get_Kind (Index_Name) in Iir_Kinds_Subtype_Definition); - Index_Type := Get_Subtype_Type_Mark (Index_Name); - if Index_Type = Null_Iir then - -- From a range expression like '1 to 4' or from an attribute - -- name. - Index_Type := Get_First_Subtype_Declaration (Index_Name); - else - Index_Type := Get_Named_Entity (Index_Type); - end if; - end if; - - -- Create a new simple_name, as the type_mark is owned by the - -- index constraint of the array subtype. - Index_Name := Build_Simple_Name (Index_Type, Index_Name); - Set_Type (Index_Name, Get_Type (Index_Type)); - - Set_Nth_Element (Base_Index_List, I, Index_Name); - end loop; - Set_Index_Subtype_List (Def, Index_List); - - -- Element type. Transfer it to the base type. - Set_Element_Subtype_Indication - (Base_Type, Get_Array_Element_Constraint (Def)); - Sem_Array_Element (Base_Type); - El_Type := Get_Element_Subtype (Base_Type); - Set_Element_Subtype (Def, El_Type); - Set_Array_Element_Constraint (Def, Null_Iir); - - Set_Signal_Type_Flag (Def, Get_Signal_Type_Flag (Base_Type)); - - -- According to LRM93 §7.4.1, an unconstrained array type - -- is not static. - Set_Type_Staticness (Base_Type, None); - Set_Type_Staticness (Def, Min (Staticness, - Get_Type_Staticness (El_Type))); - - Set_Type_Declarator (Base_Type, Decl); - Set_Resolved_Flag (Base_Type, Get_Resolved_Flag (Def)); - Set_Index_Constraint_Flag (Def, True); - Set_Constraint_State (Def, Get_Array_Constraint (Def)); - Set_Constraint_State (Base_Type, Get_Array_Constraint (Base_Type)); - Set_Base_Type (Def, Base_Type); - Set_Subtype_Type_Mark (Def, Null_Iir); - return Def; - end Sem_Constrained_Array_Type_Definition; - - function Sem_Access_Type_Definition (Def: Iir) return Iir - is - D_Type : Iir; - begin - D_Type := Sem_Subtype_Indication - (Get_Designated_Subtype_Indication (Def), True); - Set_Designated_Subtype_Indication (Def, D_Type); - - D_Type := Get_Type_Of_Subtype_Indication (D_Type); - if D_Type /= Null_Iir then - case Get_Kind (D_Type) is - when Iir_Kind_Incomplete_Type_Definition => - -- Append on the chain of incomplete type ref - Set_Incomplete_Type_Ref_Chain - (Def, Get_Incomplete_Type_Ref_Chain (D_Type)); - Set_Incomplete_Type_Ref_Chain (D_Type, Def); - when Iir_Kind_File_Type_Definition => - -- LRM 3.3 - -- The designated type must not be a file type. - Error_Msg_Sem (+Def, "designated type must not be a file type"); - when Iir_Kind_Protected_Type_Declaration => - -- LRM02 3.3 - -- [..] or a protected type. - Error_Msg_Sem - (+Def, "designated type must not be a protected type"); - when others => - null; - end case; - Set_Designated_Type (Def, D_Type); - end if; - Set_Base_Type (Def, Def); - Set_Type_Staticness (Def, None); - Set_Resolved_Flag (Def, False); - Set_Signal_Type_Flag (Def, False); - return Def; - end Sem_Access_Type_Definition; - - function Sem_File_Type_Definition (Def: Iir; Decl: Iir) return Iir - is - Type_Mark : Iir; - begin - Type_Mark := Sem_Type_Mark (Get_File_Type_Mark (Def)); - Set_File_Type_Mark (Def, Type_Mark); - - Type_Mark := Get_Type (Type_Mark); - - if Get_Kind (Type_Mark) = Iir_Kind_Error then - null; - elsif Get_Signal_Type_Flag (Type_Mark) = False then - -- LRM 3.4 - -- The base type of this subtype must not be a file type - -- or an access type. - -- If the base type is a composite type, it must not - -- contain a subelement of an access type. - Error_Msg_Sem (+Def, "%n cannot be a file type", +Type_Mark); - else - -- LRM08 5.5 File type - -- If the base type is an array type, it shall be a one-dimensional - -- array type whose element subtype is fully constrained. If the - -- base type is a record type, it shall be fully constrained. - case Get_Kind (Type_Mark) is - when Iir_Kinds_Array_Type_Definition => - -- LRM 3.4 - -- If the base type is an array type, it must be a one - -- dimensional array type. - if not Is_One_Dimensional_Array_Type (Type_Mark) then - Error_Msg_Sem - (+Def, "multi-dimensional %n cannot be a file type", - +Type_Mark); - elsif not Is_Fully_Constrained_Type - (Get_Element_Subtype (Type_Mark)) - then - Error_Msg_Sem - (+Def, "element subtype of %n must be fully constrained", - +Type_Mark); - end if; - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - if Get_Constraint_State (Type_Mark) /= Fully_Constrained then - Error_Msg_Sem - (+Def, "%n must be fully constrained", +Type_Mark); - end if; - when Iir_Kind_Interface_Type_Definition => - Error_Msg_Sem (+Def, "%n cannot be a file type", +Type_Mark); - when others => - null; - end case; - end if; - - Set_Base_Type (Def, Def); - Set_Resolved_Flag (Def, False); - Set_Text_File_Flag (Def, Is_Text_Type_Declaration (Decl)); - Set_Signal_Type_Flag (Def, False); - Set_Type_Staticness (Def, None); - return Def; - end Sem_File_Type_Definition; - - function Sem_Type_Definition (Def: Iir; Decl: Iir) return Iir is - begin - case Get_Kind (Def) is - when Iir_Kind_Enumeration_Type_Definition => - return Sem_Enumeration_Type_Definition (Def, Decl); - - when Iir_Kind_Physical_Type_Definition => - return Sem_Physical_Type_Definition (Def, Decl); - - when Iir_Kind_Range_Expression => - return Range_Expr_To_Type_Definition (Def, Decl); - - when Iir_Kind_Range_Array_Attribute - | Iir_Kind_Attribute_Name - | Iir_Kind_Parenthesis_Name => - if Get_Type (Def) /= Null_Iir then - return Sem_Physical_Type_Definition (Def, Decl); - end if; - -- Nb: the attribute is expected to be a 'range or - -- a 'reverse_range attribute. - declare - Res : Iir; - begin - Res := Sem_Discrete_Range_Expression (Def, Null_Iir, True); - if Res = Null_Iir then - return Null_Iir; - end if; - -- This cannot be a floating range. - return Create_Integer_Type (Def, Res, Decl); - end; - - when Iir_Kind_Array_Subtype_Definition => - return Sem_Constrained_Array_Type_Definition (Def, Decl); - - when Iir_Kind_Array_Type_Definition => - return Sem_Unbounded_Array_Type_Definition (Def); - - when Iir_Kind_Record_Type_Definition => - return Sem_Record_Type_Definition (Def); - - when Iir_Kind_Access_Type_Definition => - return Sem_Access_Type_Definition (Def); - - when Iir_Kind_File_Type_Definition => - return Sem_File_Type_Definition (Def, Decl); - - when Iir_Kind_Protected_Type_Declaration => - Sem_Protected_Type_Declaration (Decl); - return Def; - - when others => - Error_Kind ("sem_type_definition", Def); - return Def; - end case; - end Sem_Type_Definition; - - function Range_To_Subtype_Indication (A_Range: Iir) return Iir - is - Sub_Type: Iir; - Range_Type : Iir; - begin - case Get_Kind (A_Range) is - when Iir_Kind_Range_Expression - | Iir_Kind_Range_Array_Attribute - | Iir_Kind_Reverse_Range_Array_Attribute => - -- Create a sub type. - Range_Type := Get_Type (A_Range); - when Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name => - return A_Range; - when Iir_Kinds_Discrete_Type_Definition => - -- A_RANGE is already a subtype definition. - return A_Range; - when others => - Error_Kind ("range_to_subtype_indication", A_Range); - return Null_Iir; - end case; - - case Get_Kind (Range_Type) is - when Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Enumeration_Subtype_Definition => - Sub_Type := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Integer_Subtype_Definition => - Sub_Type := Create_Iir (Iir_Kind_Integer_Subtype_Definition); - when Iir_Kind_Floating_Type_Definition - | Iir_Kind_Floating_Subtype_Definition => - Sub_Type := Create_Iir (Iir_Kind_Floating_Subtype_Definition); - when others => - raise Internal_Error; - end case; - Location_Copy (Sub_Type, A_Range); - Set_Range_Constraint (Sub_Type, A_Range); - Set_Base_Type (Sub_Type, Get_Base_Type (Range_Type)); - Set_Type_Staticness (Sub_Type, Get_Expr_Staticness (A_Range)); - Set_Signal_Type_Flag (Sub_Type, True); - return Sub_Type; - end Range_To_Subtype_Indication; - - -- Return TRUE iff FUNC is a resolution function for ATYPE. - function Is_A_Resolution_Function (Func: Iir; Atype: Iir) return Boolean - is - Decl: Iir; - Decl_Type : Iir; - Ret_Type : Iir; - begin - -- LRM93 2.4 - -- A resolution function must be a [pure] function; - if Get_Kind (Func) /= Iir_Kind_Function_Declaration then - return False; - end if; - Decl := Get_Interface_Declaration_Chain (Func); - -- LRM93 2.4 - -- moreover, it must have a single input parameter of class constant - if Decl = Null_Iir or else Get_Chain (Decl) /= Null_Iir then - return False; - end if; - if Get_Kind (Decl) /= Iir_Kind_Interface_Constant_Declaration then - return False; - end if; - -- LRM93 2.4 - -- that is a one-dimensional, unconstrained array - Decl_Type := Get_Type (Decl); - if Get_Kind (Decl_Type) /= Iir_Kind_Array_Type_Definition then - return False; - end if; - if not Is_One_Dimensional_Array_Type (Decl_Type) then - return False; - end if; - -- LRM93 2.4 - -- whose element type is that of the resolved signal. - -- The type of the return value of the function must also be that of - -- the signal. - Ret_Type := Get_Return_Type (Func); - if Get_Base_Type (Get_Element_Subtype (Decl_Type)) - /= Get_Base_Type (Ret_Type) - then - return False; - end if; - if Atype /= Null_Iir - and then Get_Base_Type (Ret_Type) /= Get_Base_Type (Atype) - then - return False; - end if; - -- LRM93 2.4 - -- A resolution function must be a [pure] function; - if Flags.Vhdl_Std >= Vhdl_93 and then Get_Pure_Flag (Func) = False then - if Atype /= Null_Iir then - Error_Msg_Sem (+Atype, "resolution %n must be pure", +Func); - end if; - return False; - end if; - return True; - end Is_A_Resolution_Function; - - -- Note: this sets resolved_flag. - procedure Sem_Resolution_Function (Name : Iir; Atype : Iir) - is - Func : Iir; - Res: Iir; - El : Iir; - List : Iir_List; - It : List_Iterator; - Has_Error : Boolean; - Name1 : Iir; - begin - Sem_Name (Name); - - Func := Get_Named_Entity (Name); - if Func = Error_Mark then - return; - end if; - - Res := Null_Iir; - - if Is_Overload_List (Func) then - List := Get_Overload_List (Func); - Has_Error := False; - It := List_Iterate (List); - while Is_Valid (It) loop - El := Get_Element (It); - if Is_A_Resolution_Function (El, Atype) then - if Res /= Null_Iir then - if not Has_Error then - Has_Error := True; - Error_Msg_Sem - (+Atype, - "can't resolve overload for resolution function", - Cont => True); - Error_Msg_Sem (+Atype, "candidate functions are:"); - Error_Msg_Sem (+Func, " " & Disp_Subprg (Func)); - end if; - Error_Msg_Sem (+El, " " & Disp_Subprg (El)); - else - Res := El; - end if; - end if; - Next (It); - end loop; - Free_Overload_List (Func); - if Has_Error then - return; - end if; - Set_Named_Entity (Name, Res); - else - if Is_A_Resolution_Function (Func, Atype) then - Res := Func; - end if; - end if; - - if Res = Null_Iir then - Error_Msg_Sem - (+Atype, "no matching resolution function for %n", +Name); - else - Name1 := Finish_Sem_Name (Name); - Sem_Decls.Mark_Subprogram_Used (Res); - Set_Resolved_Flag (Atype, True); - Set_Resolution_Indication (Atype, Name1); - end if; - end Sem_Resolution_Function; - - -- Analyze the constraint DEF + RESOLUTION for type TYPE_MARK. The - -- result is always a subtype definition. - function Sem_Subtype_Constraint - (Def : Iir; Type_Mark : Iir; Resolution : Iir) return Iir; - - -- Create a copy of elements_declaration_list of SRC and set it to DST. - procedure Copy_Record_Elements_Declaration_List (Dst : Iir; Src : Iir) - is - El_List : constant Iir_Flist := Get_Elements_Declaration_List (Src); - New_El_List : Iir_Flist; - El : Iir; - begin - New_El_List := Create_Iir_Flist (Get_Nbr_Elements (El_List)); - Set_Elements_Declaration_List (Dst, New_El_List); - for I in Flist_First .. Flist_Last (El_List) loop - El := Get_Nth_Element (El_List, I); - Set_Nth_Element (New_El_List, I, El); - end loop; - end Copy_Record_Elements_Declaration_List; - - function Copy_Resolution_Indication (Subdef : Iir) return Iir - is - Ind : constant Iir := Get_Resolution_Indication (Subdef); - begin - if Is_Null (Ind) - or else Get_Kind (Ind) = Iir_Kind_Array_Element_Resolution - then - -- No need to copy array_element_resolution, it is part of the - -- element_subtype. - return Null_Iir; - else - return Build_Reference_Name (Ind); - end if; - end Copy_Resolution_Indication; - - function Copy_Subtype_Indication (Def : Iir) return Iir - is - Res : Iir; - begin - case Get_Kind (Def) is - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition => - Res := Create_Iir (Get_Kind (Def)); - Set_Range_Constraint (Res, Get_Range_Constraint (Def)); - Set_Is_Ref (Res, True); - Set_Resolution_Indication - (Res, Copy_Resolution_Indication (Def)); - - when Iir_Kind_Enumeration_Type_Definition => - Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); - Set_Range_Constraint (Res, Get_Range_Constraint (Def)); - Set_Is_Ref (Res, True); - - when Iir_Kind_Access_Subtype_Definition - | Iir_Kind_Access_Type_Definition => - Res := Create_Iir (Iir_Kind_Access_Subtype_Definition); - Set_Designated_Type (Res, Get_Designated_Type (Def)); - - when Iir_Kind_Array_Type_Definition => - Res := Create_Iir (Iir_Kind_Array_Subtype_Definition); - Set_Type_Staticness (Res, Get_Type_Staticness (Def)); - Set_Resolved_Flag (Res, Get_Resolved_Flag (Def)); - Set_Index_Constraint_List (Res, Null_Iir_Flist); - Set_Index_Subtype_List - (Res, Get_Index_Subtype_Definition_List (Def)); - Set_Element_Subtype (Res, Get_Element_Subtype (Def)); - Set_Index_Constraint_Flag (Res, False); - Set_Constraint_State (Res, Get_Constraint_State (Def)); - - when Iir_Kind_Array_Subtype_Definition => - Res := Create_Iir (Iir_Kind_Array_Subtype_Definition); - Set_Resolution_Indication (Res, Copy_Resolution_Indication (Def)); - Set_Resolved_Flag (Res, Get_Resolved_Flag (Def)); - Set_Index_Subtype_List (Res, Get_Index_Subtype_List (Def)); - Set_Element_Subtype (Res, Get_Element_Subtype (Def)); - Set_Index_Constraint_Flag - (Res, Get_Index_Constraint_Flag (Def)); - Set_Constraint_State (Res, Get_Constraint_State (Def)); - - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - Res := Create_Iir (Iir_Kind_Record_Subtype_Definition); - Set_Is_Ref (Res, True); - Set_Type_Staticness (Res, Get_Type_Staticness (Def)); - if Get_Kind (Def) = Iir_Kind_Record_Subtype_Definition then - Set_Resolution_Indication - (Res, Copy_Resolution_Indication (Def)); - end if; - Set_Resolved_Flag (Res, Get_Resolved_Flag (Def)); - Set_Constraint_State (Res, Get_Constraint_State (Def)); - Copy_Record_Elements_Declaration_List (Res, Def); - - when others => - -- FIXME: todo (protected type ?) - Error_Kind ("copy_subtype_indication", Def); - end case; - Location_Copy (Res, Def); - Set_Base_Type (Res, Get_Base_Type (Def)); - Set_Type_Staticness (Res, Get_Type_Staticness (Def)); - Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Def)); - return Res; - end Copy_Subtype_Indication; - - procedure Sem_Array_Constraint_Indexes (Def : Iir; Type_Mark : Iir) - is - El_Type : constant Iir := Get_Element_Subtype (Type_Mark); - Base_Type : constant Iir := Get_Base_Type (Type_Mark); - Type_Index, Subtype_Index: Iir; - Index_Staticness : Iir_Staticness; - Type_Nbr_Dim : Natural; - Subtype_Nbr_Dim : Natural; - Type_Index_List : Iir_Flist; - Subtype_Index_List : Iir_Flist; - Subtype_Index_List2 : Iir_Flist; - begin - -- Check each index constraint against array type. - Set_Base_Type (Def, Base_Type); - - Index_Staticness := Locally; - Type_Index_List := Get_Index_Subtype_Definition_List (Base_Type); - Subtype_Index_List := Get_Index_Constraint_List (Def); - - -- LRM08 5.3.2.2 - -- If an array constraint of the first form (including an index - -- constraint) applies to a type or subtype, then the type or - -- subtype shall be an unconstrained or partially constrained - -- array type with no index constraint applying to the index - -- subtypes, or an access type whose designated type is such - -- a type. - if Subtype_Index_List = Null_Iir_Flist then - -- Array is not constrained, but the type mark may already have - -- constrained on indexes. - if Get_Kind (Type_Mark) = Iir_Kind_Array_Subtype_Definition then - Set_Index_Constraint_Flag - (Def, Get_Index_Constraint_Flag (Type_Mark)); - Set_Index_Subtype_List - (Def, Get_Index_Subtype_List (Type_Mark)); - else - Set_Index_Constraint_Flag (Def, False); - Set_Index_Subtype_List (Def, Type_Index_List); - end if; - else - if Get_Kind (Type_Mark) = Iir_Kind_Array_Subtype_Definition - and then Get_Index_Constraint_Flag (Type_Mark) - then - Error_Msg_Sem (+Def, "constrained array cannot be re-constrained"); - end if; - Type_Nbr_Dim := Get_Nbr_Elements (Type_Index_List); - Subtype_Nbr_Dim := Get_Nbr_Elements (Subtype_Index_List); - - if Subtype_Nbr_Dim /= Type_Nbr_Dim then - -- Number of dimension mismatch. Create an index with the right - -- length. - Subtype_Index_List2 := Create_Iir_Flist (Type_Nbr_Dim); - for I in 1 .. Natural'Min (Subtype_Nbr_Dim, Type_Nbr_Dim) loop - Set_Nth_Element - (Subtype_Index_List2, I - 1, - Get_Nth_Element (Subtype_Index_List, I - 1)); - end loop; - - if Subtype_Nbr_Dim < Type_Nbr_Dim then - Error_Msg_Sem - (+Def, - "subtype has less indexes than %n defined at %l", - (+Type_Mark, +Type_Mark)); - - -- Clear extra indexes. - for I in Subtype_Nbr_Dim + 1 .. Type_Nbr_Dim loop - Set_Nth_Element (Subtype_Index_List2, I - 1, Null_Iir); - end loop; - else - Error_Msg_Sem - (+Get_Nth_Element (Subtype_Index_List, Type_Nbr_Dim), - "subtype has more indexes than %n defined at %l", - (+Type_Mark, +Type_Mark)); - - -- Forget extra indexes. - end if; - Destroy_Iir_Flist (Subtype_Index_List); - Subtype_Index_List := Subtype_Index_List2; - end if; - - for I in 1 .. Type_Nbr_Dim loop - Type_Index := Get_Nth_Element (Type_Index_List, I - 1); - - if I <= Subtype_Nbr_Dim then - Subtype_Index := Get_Nth_Element (Subtype_Index_List, I - 1); - Subtype_Index := Sem_Discrete_Range_Expression - (Subtype_Index, Get_Index_Type (Type_Index), True); - if Subtype_Index /= Null_Iir then - Subtype_Index := - Range_To_Subtype_Indication (Subtype_Index); - Index_Staticness := Min - (Index_Staticness, - Get_Type_Staticness (Get_Type_Of_Subtype_Indication - (Subtype_Index))); - end if; - else - Subtype_Index := Null_Iir; - end if; - if Subtype_Index = Null_Iir then - -- Create a fake subtype from type_index. - -- FIXME: It is too fake. - Subtype_Index := Type_Index; - Index_Staticness := None; - end if; - Set_Nth_Element (Subtype_Index_List, I - 1, Subtype_Index); - end loop; - - Set_Index_Subtype_List (Def, Subtype_Index_List); - Set_Index_Constraint_Flag (Def, True); - end if; - Set_Type_Staticness - (Def, Min (Get_Type_Staticness (El_Type), Index_Staticness)); - Set_Signal_Type_Flag (Def, Get_Signal_Type_Flag (Type_Mark)); - end Sem_Array_Constraint_Indexes; - - -- DEF is an incomplete subtype_indication or array_constraint, - -- TYPE_MARK is the base type of the subtype_indication. - function Sem_Array_Constraint - (Def : Iir; Type_Mark : Iir; Resolution : Iir) return Iir - is - El_Type : constant Iir := Get_Element_Subtype (Type_Mark); - Res : Iir; - El_Def : Iir; - Resolv_Func : Iir := Null_Iir; - Resolv_El : Iir := Null_Iir; - Resolv_Ind : Iir; - begin - if Resolution /= Null_Iir then - -- A resolution indication is present. - case Get_Kind (Resolution) is - when Iir_Kinds_Denoting_Name => - Resolv_Func := Resolution; - when Iir_Kind_Array_Element_Resolution => - Resolv_El := Get_Resolution_Indication (Resolution); - when Iir_Kind_Record_Resolution => - Error_Msg_Sem - (+Resolution, - "record resolution not allowed for array subtype"); - when others => - Error_Kind ("sem_array_constraint(resolution)", Resolution); - end case; - end if; - - if Def = Null_Iir then - -- There is no element_constraint. - pragma Assert (Resolution /= Null_Iir); - Res := Copy_Subtype_Indication (Type_Mark); - El_Def := Null_Iir; - else - case Get_Kind (Def) is - when Iir_Kind_Subtype_Definition => - -- This is the case of "subtype new_array is [func] old_array". - -- def must be a constrained array. - if Get_Range_Constraint (Def) /= Null_Iir then - Error_Msg_Sem - (+Def, "cannot use a range constraint for array types"); - return Copy_Subtype_Indication (Type_Mark); - end if; - - -- LRM08 6.3 Subtype declarations - -- - -- If the subtype indication does not include a constraint, the - -- subtype is the same as that denoted by the type mark. - if Resolution = Null_Iir then - -- FIXME: is it reachable ? - Free_Name (Def); - return Type_Mark; - end if; - - Res := Copy_Subtype_Indication (Type_Mark); - Location_Copy (Res, Def); - Free_Name (Def); - - -- No element constraint. - El_Def := Null_Iir; - - when Iir_Kind_Array_Subtype_Definition => - -- Case of a constraint for an array. - El_Def := Get_Array_Element_Constraint (Def); - Sem_Array_Constraint_Indexes (Def, Type_Mark); - Res := Def; - - when others => - -- LRM93 3.2.1.1 / LRM08 5.3.2.2 - -- Index Constraints and Discrete Ranges - -- - -- If an index constraint appears after a type mark [...] - -- The type mark must denote either an unconstrained array - -- type, or an access type whose designated type is such - -- an array type. - Error_Msg_Sem - (+Def, - "only unconstrained array type may be contrained by index", - Cont => True); - Error_Msg_Sem - (+Type_Mark, " (type mark is %n)", +Type_Mark); - return Type_Mark; - end case; - end if; - - -- Element subtype. - if Resolv_El /= Null_Iir or else El_Def /= Null_Iir then - El_Def := Sem_Subtype_Constraint (El_Def, El_Type, Resolv_El); - if Resolv_El /= Null_Iir then - -- Save EL_DEF so that it is owned. - Set_Element_Subtype_Indication (Resolution, El_Def); - Set_Resolution_Indication (Resolution, Null_Iir); - end if; - end if; - if El_Def = Null_Iir then - El_Def := Get_Element_Subtype (Type_Mark); - end if; - Set_Element_Subtype (Res, El_Def); - - Set_Constraint_State (Res, Get_Array_Constraint (Res)); - - if Resolv_Func /= Null_Iir then - Sem_Resolution_Function (Resolv_Func, Res); - elsif Resolv_El /= Null_Iir then - Set_Resolution_Indication (Res, Resolution); - -- FIXME: may a resolution indication for a record be incomplete ? - Set_Resolved_Flag (Res, Get_Resolved_Flag (El_Def)); - elsif Get_Kind (Type_Mark) = Iir_Kind_Array_Subtype_Definition then - Resolv_Ind := Get_Resolution_Indication (Type_Mark); - if Resolv_Ind /= Null_Iir then - case Get_Kind (Resolv_Ind) is - when Iir_Kinds_Denoting_Name => - Error_Kind ("sem_array_constraint(resolution)", Resolv_Ind); - when Iir_Kind_Array_Element_Resolution => - -- Already applied to the element. - Resolv_Ind := Null_Iir; - when others => - Error_Kind ("sem_array_constraint(resolution2)", Resolv_Ind); - end case; - Set_Resolution_Indication (Res, Resolv_Ind); - end if; - Set_Resolved_Flag (Res, Get_Resolved_Flag (Type_Mark)); - else - pragma Assert (Get_Kind (Type_Mark) = Iir_Kind_Array_Type_Definition); - Set_Resolved_Flag (Res, Get_Resolved_Flag (Type_Mark)); - end if; - - return Res; - end Sem_Array_Constraint; - - function Reparse_As_Record_Element_Constraint (Name : Iir) return Iir - is - Prefix : Iir; - Parent : Iir; - El : Iir; - begin - if Get_Kind (Name) /= Iir_Kind_Parenthesis_Name then - Error_Msg_Sem (+Name, "record element constraint expected"); - return Null_Iir; - else - Prefix := Get_Prefix (Name); - Parent := Name; - while Get_Kind (Prefix) = Iir_Kind_Parenthesis_Name loop - Parent := Prefix; - Prefix := Get_Prefix (Prefix); - end loop; - if Get_Kind (Prefix) /= Iir_Kind_Simple_Name then - Error_Msg_Sem - (+Prefix, "record element name must be a simple name"); - return Null_Iir; - else - El := Create_Iir (Iir_Kind_Record_Element_Constraint); - Location_Copy (El, Prefix); - Set_Identifier (El, Get_Identifier (Prefix)); - Set_Type (El, Name); - Set_Prefix (Parent, Null_Iir); - Free_Name (Prefix); - return El; - end if; - end if; - end Reparse_As_Record_Element_Constraint; - - function Reparse_As_Record_Constraint (Def : Iir) return Iir - is - Res : Iir; - Chain : Iir; - El_List : Iir_List; - El : Iir; - begin - pragma Assert (Get_Prefix (Def) = Null_Iir); - Res := Create_Iir (Iir_Kind_Record_Subtype_Definition); - Set_Is_Ref (Res, True); - Location_Copy (Res, Def); - El_List := Create_Iir_List; - Chain := Get_Association_Chain (Def); - while Chain /= Null_Iir loop - if Get_Kind (Chain) /= Iir_Kind_Association_Element_By_Expression - or else Get_Formal (Chain) /= Null_Iir - then - Error_Msg_Sem (+Chain, "badly formed record constraint"); - else - El := Reparse_As_Record_Element_Constraint (Get_Actual (Chain)); - if El /= Null_Iir then - Append_Element (El_List, El); - Set_Parent (El, Res); - Append_Owned_Element_Constraint (Res, El); - end if; - end if; - Chain := Get_Chain (Chain); - end loop; - Set_Elements_Declaration_List (Res, List_To_Flist (El_List)); - return Res; - end Reparse_As_Record_Constraint; - - function Reparse_As_Array_Constraint (Def : Iir; Def_Type : Iir) return Iir - is - Parent : Iir; - Name : Iir; - Prefix : Iir; - Res : Iir; - Chain : Iir; - El_List : Iir_List; - Def_El_Type : Iir; - begin - Name := Def; - Prefix := Get_Prefix (Name); - Parent := Null_Iir; - while Prefix /= Null_Iir - and then Get_Kind (Prefix) = Iir_Kind_Parenthesis_Name - loop - Parent := Name; - Name := Prefix; - Prefix := Get_Prefix (Name); - end loop; - -- Detach prefix. - if Parent /= Null_Iir then - Set_Prefix (Parent, Null_Iir); - end if; - Res := Create_Iir (Iir_Kind_Array_Subtype_Definition); - Location_Copy (Res, Name); - Chain := Get_Association_Chain (Name); - if Get_Kind (Chain) = Iir_Kind_Association_Element_Open then - if Get_Chain (Chain) /= Null_Iir then - Error_Msg_Sem (+Chain, "'open' must be alone"); - end if; - else - El_List := Create_Iir_List; - while Chain /= Null_Iir loop - if Get_Kind (Chain) /= Iir_Kind_Association_Element_By_Expression - or else Get_Formal (Chain) /= Null_Iir - then - Error_Msg_Sem (+Chain, "bad form of array constraint"); - else - Append_Element (El_List, Get_Actual (Chain)); - end if; - Chain := Get_Chain (Chain); - end loop; - Set_Index_Constraint_List (Res, List_To_Flist (El_List)); - end if; - - Def_El_Type := Get_Element_Subtype (Def_Type); - if Parent /= Null_Iir then - case Get_Kind (Def_El_Type) is - when Iir_Kinds_Array_Type_Definition => - Set_Element_Subtype_Indication - (Res, Reparse_As_Array_Constraint (Def, Def_El_Type)); - when others => - Error_Kind ("reparse_as_array_constraint", Def_El_Type); - end case; - end if; - return Res; - end Reparse_As_Array_Constraint; - - function Sem_Record_Constraint - (Def : Iir; Type_Mark : Iir; Resolution : Iir) return Iir - is - Res : Iir; - El_List, Tm_El_List : Iir_Flist; - El : Iir; - Tm_El : Iir; - Tm_El_Type : Iir; - El_Type : Iir; - Res_List : Iir_Flist; - - Index_List : Iir_Flist; - Index_El : Iir; - begin - Res := Create_Iir (Iir_Kind_Record_Subtype_Definition); - Set_Is_Ref (Res, True); - Location_Copy (Res, Def); - Set_Base_Type (Res, Get_Base_Type (Type_Mark)); - if Get_Kind (Type_Mark) = Iir_Kind_Record_Subtype_Definition then - Set_Resolution_Indication - (Res, Get_Resolution_Indication (Type_Mark)); - end if; - - case Get_Kind (Def) is - when Iir_Kind_Subtype_Definition => - -- Just an alias, without new constraints. - Free_Name (Def); - Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark)); - Set_Constraint_State (Res, Get_Constraint_State (Type_Mark)); - El_List := Null_Iir_Flist; - - when Iir_Kind_Array_Subtype_Definition => - -- Record constraints are parsed as array constraints. - pragma Assert (Get_Kind (Def) = Iir_Kind_Array_Subtype_Definition); - Index_List := Get_Index_Constraint_List (Def); - El_List := Create_Iir_Flist (Get_Nbr_Elements (Index_List)); - Set_Elements_Declaration_List (Res, El_List); - for I in Flist_First .. Flist_Last (Index_List) loop - Index_El := Get_Nth_Element (Index_List, I); - El := Reparse_As_Record_Element_Constraint (Index_El); - if El = Null_Iir then - return Create_Error_Type (Type_Mark); - end if; - Set_Nth_Element (El_List, I, El); - end loop; - - when Iir_Kind_Record_Subtype_Definition => - El_List := Get_Elements_Declaration_List (Def); - Set_Elements_Declaration_List (Res, El_List); - - when others => - Error_Kind ("sem_record_constraint", Def); - end case; - - -- Handle resolution. - Res_List := Null_Iir_Flist; - if Resolution /= Null_Iir then - case Get_Kind (Resolution) is - when Iir_Kinds_Denoting_Name => - null; - when Iir_Kind_Record_Subtype_Definition => - Res_List := Get_Elements_Declaration_List (Resolution); - when Iir_Kind_Array_Subtype_Definition => - Error_Msg_Sem - (+Resolution, - "resolution indication must be an array element resolution"); - when others => - Error_Kind ("sem_record_constraint(resolution)", Resolution); - end case; - end if; - - Tm_El_List := Get_Elements_Declaration_List (Type_Mark); - if El_List /= Null_Iir_Flist or Res_List /= Null_Iir_Flist then - -- Constraints (either range or resolution) have been added. - declare - Nbr_Els : constant Natural := Get_Nbr_Elements (Tm_El_List); - Els : Iir_Array (0 .. Nbr_Els - 1) := (others => Null_Iir); - Res_Els : Iir_Array (0 .. Nbr_Els - 1) := (others => Null_Iir); - Pos : Natural; - Constraint : Iir_Constraint; - Composite_Found : Boolean; - Staticness : Iir_Staticness; - begin - -- Fill ELS with record constraints. - if El_List /= Null_Iir_Flist then - for I in Flist_First .. Flist_Last (El_List) loop - El := Get_Nth_Element (El_List, I); - Tm_El := Find_Name_In_Flist - (Tm_El_List, Get_Identifier (El)); - if Tm_El = Null_Iir then - -- Constraint element references an element name that - -- doesn't exist. - Error_Msg_Sem (+El, "%n has no %n", (+Type_Mark, +El)); - else - Pos := Natural (Get_Element_Position (Tm_El)); - if Els (Pos) /= Null_Iir then - Error_Msg_Sem - (+El, "%n was already constrained", - (1 => +El), Cont => True); - Error_Msg_Sem - (+Els (Pos), " (location of previous constrained)"); - else - Els (Pos) := El; - Set_Parent (El, Res); - end if; - El_Type := Get_Type (El); - Tm_El_Type := Get_Type (Tm_El); - if Get_Kind (El_Type) = Iir_Kind_Parenthesis_Name then - -- Recurse. - case Get_Kind (Tm_El_Type) is - when Iir_Kinds_Array_Type_Definition => - El_Type := Reparse_As_Array_Constraint - (El_Type, Tm_El_Type); - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - El_Type := Reparse_As_Record_Constraint - (El_Type); - when Iir_Kind_Error => - null; - when others => - Error_Msg_Sem - (+El_Type, - "only composite types may be constrained"); - end case; - end if; - Set_Type (El, El_Type); - end if; - end loop; - -- Record element constraints are now in Els. - Destroy_Iir_Flist (El_List); - end if; - - -- Fill Res_Els (handle resolution constraints). - if Res_List /= Null_Iir_Flist then - for I in Flist_First .. Flist_Last (Res_List) loop - El := Get_Nth_Element (Res_List, I); - Tm_El := - Find_Name_In_Flist (Tm_El_List, Get_Identifier (El)); - if Tm_El = Null_Iir then - Error_Msg_Sem (+El, "%n has no %n", (+Type_Mark, +El)); - else - Pos := Natural (Get_Element_Position (Tm_El)); - if Res_Els (Pos) /= Null_Iir then - Error_Msg_Sem (+El, "%n was already resolved", - (1 => +El), Cont => True); - Error_Msg_Sem - (+Els (Pos), " (location of previous constrained)"); - else - Res_Els (Pos) := Tm_El; - end if; - end if; - --Free_Iir (El); - end loop; - Destroy_Iir_Flist (Res_List); - end if; - - -- Build elements list. - El_List := Create_Iir_Flist (Nbr_Els); - Set_Elements_Declaration_List (Res, El_List); - Constraint := Fully_Constrained; - Composite_Found := False; - Staticness := Locally; - for I in Els'Range loop - Tm_El := Get_Nth_Element (Tm_El_List, I); - if Els (I) = Null_Iir and Res_Els (I) = Null_Iir then - -- No new record element constraints. Copy the element from - -- the type mark. - El := Tm_El; - El_Type := Get_Type (El); - else - if Els (I) = Null_Iir then - -- Only a resolution constraint. - El := Create_Iir (Iir_Kind_Record_Element_Constraint); - Location_Copy (El, Tm_El); - Set_Parent (El, Res); - El_Type := Null_Iir; - Append_Owned_Element_Constraint (Res, El); - else - El := Els (I); - El_Type := Get_Type (El); - pragma Assert - (Get_Kind (El) = Iir_Kind_Record_Element_Constraint); - end if; - El_Type := Sem_Subtype_Constraint (El_Type, - Get_Type (Tm_El), - Res_Els (I)); - Set_Type (El, El_Type); - Set_Element_Position (El, Get_Element_Position (Tm_El)); - end if; - Set_Nth_Element (El_List, I, El); - Update_Record_Constraint (Constraint, Composite_Found, El_Type); - Staticness := Min (Staticness, Get_Type_Staticness (El_Type)); - end loop; - Set_Constraint_State (Res, Constraint); - Set_Type_Staticness (Res, Staticness); - end; - else - Copy_Record_Elements_Declaration_List (Res, Type_Mark); - Set_Constraint_State (Res, Get_Constraint_State (Type_Mark)); - Set_Type_Staticness (Res, Get_Type_Staticness (Type_Mark)); - end if; - - Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark)); - - if Resolution /= Null_Iir - and then Get_Kind (Resolution) in Iir_Kinds_Denoting_Name - then - Sem_Resolution_Function (Resolution, Res); - end if; - - return Res; - end Sem_Record_Constraint; - - -- Return a scalar subtype definition (even in case of error). - function Sem_Range_Constraint - (Def : Iir; Type_Mark : Iir; Resolution : Iir) - return Iir - is - Res : Iir; - A_Range : Iir; - Tolerance : Iir; - begin - if Def = Null_Iir then - Res := Copy_Subtype_Indication (Type_Mark); - elsif Get_Kind (Def) /= Iir_Kind_Subtype_Definition then - -- FIXME: find the correct sentence from LRM - -- GHDL: subtype_definition may also be used just to add - -- a resolution function. - Error_Msg_Sem - (+Def, "only scalar types may be constrained by range", - Cont => True); - Error_Msg_Sem - (+Type_Mark, " (type mark is %n)", +Type_Mark); - Res := Copy_Subtype_Indication (Type_Mark); - else - Tolerance := Get_Tolerance (Def); - - if Get_Range_Constraint (Def) = Null_Iir - and then Resolution = Null_Iir - and then Tolerance = Null_Iir - then - -- This defines an alias, and must have been handled just - -- before the case statment. - raise Internal_Error; - end if; - - -- There are limits. Create a new subtype. - if Get_Kind (Type_Mark) = Iir_Kind_Enumeration_Type_Definition then - Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); - else - Res := Create_Iir (Get_Kind (Type_Mark)); - end if; - Location_Copy (Res, Def); - Set_Base_Type (Res, Get_Base_Type (Type_Mark)); - Set_Resolution_Indication (Res, Get_Resolution_Indication (Def)); - A_Range := Get_Range_Constraint (Def); - if A_Range = Null_Iir then - A_Range := Get_Range_Constraint (Type_Mark); - Set_Is_Ref (Res, True); - else - A_Range := Sem_Range_Expression (A_Range, Type_Mark, True); - if A_Range = Null_Iir then - -- Avoid error propagation. - A_Range := Get_Range_Constraint (Type_Mark); - Set_Is_Ref (Res, True); - end if; - end if; - Set_Range_Constraint (Res, A_Range); - Set_Type_Staticness (Res, Get_Expr_Staticness (A_Range)); - Free_Name (Def); - Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark)); - if Tolerance /= Null_Iir then - -- LRM93 4.2 Subtype declarations - -- It is an error in this case the subtype is not a nature - -- type - -- - -- FIXME: should be moved into sem_subtype_indication - if Get_Kind (Res) /= Iir_Kind_Floating_Subtype_Definition then - Error_Msg_Sem - (+Tolerance, "tolerance allowed only for floating subtype"); - else - -- LRM93 4.2 Subtype declarations - -- If the subtype indication includes a tolerance aspect, then - -- the string expression must be a static expression - Tolerance := Sem_Expression (Tolerance, String_Type_Definition); - if Tolerance /= Null_Iir - and then Get_Expr_Staticness (Tolerance) /= Locally - then - Error_Msg_Sem - (+Tolerance, "tolerance must be a static string"); - end if; - Set_Tolerance (Res, Tolerance); - end if; - end if; - end if; - - if Resolution /= Null_Iir then - -- LRM08 6.3 Subtype declarations. - if Get_Kind (Resolution) not in Iir_Kinds_Denoting_Name then - Error_Msg_Sem - (+Resolution, "resolution indication must be a function name"); - else - Sem_Resolution_Function (Resolution, Res); - Location_Copy (Res, Resolution); - end if; - end if; - return Res; - end Sem_Range_Constraint; - - function Sem_Subtype_Constraint - (Def : Iir; Type_Mark : Iir; Resolution : Iir) - return Iir is - begin - case Get_Kind (Type_Mark) is - when Iir_Kind_Array_Subtype_Definition - | Iir_Kind_Array_Type_Definition => - return Sem_Array_Constraint (Def, Type_Mark, Resolution); - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition - | Iir_Kind_Enumeration_Type_Definition=> - return Sem_Range_Constraint (Def, Type_Mark, Resolution); - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - return Sem_Record_Constraint (Def, Type_Mark, Resolution); - when Iir_Kind_Access_Type_Definition - | Iir_Kind_Access_Subtype_Definition => - -- LRM93 4.2 - -- A subtype indication denoting an access type [or a file type] - -- may not contain a resolution function. - if Resolution /= Null_Iir then - Error_Msg_Sem - (+Def, "resolution function not allowed for an access type"); - end if; - - case Get_Kind (Def) is - when Iir_Kind_Subtype_Definition => - Free_Name (Def); - return Copy_Subtype_Indication (Type_Mark); - when Iir_Kind_Array_Subtype_Definition => - -- LRM93 3.3 - -- The only form of constraint that is allowed after a name - -- of an access type in a subtype indication is an index - -- constraint. - declare - Base_Type : constant Iir := - Get_Designated_Type (Type_Mark); - Sub_Type : Iir; - Res : Iir; - begin - Sub_Type := Sem_Array_Constraint - (Def, Base_Type, Null_Iir); - Res := Create_Iir (Iir_Kind_Access_Subtype_Definition); - Location_Copy (Res, Def); - Set_Base_Type (Res, Type_Mark); - Set_Designated_Subtype_Indication (Res, Sub_Type); - Set_Signal_Type_Flag (Res, False); - - -- The type_mark is a type_mark of the access subtype, - -- not of the array subtype. - Set_Subtype_Type_Mark - (Res, Get_Subtype_Type_Mark (Sub_Type)); - Set_Subtype_Type_Mark (Sub_Type, Null_Iir); - return Res; - end; - when others => - raise Internal_Error; - end case; - - when Iir_Kind_File_Type_Definition => - -- LRM08 6.3 Subtype declarations - -- A subtype indication denoting a subtype of [...] a file - -- type [...] shall not contain a constraint. - if Get_Kind (Def) /= Iir_Kind_Subtype_Definition - or else Get_Range_Constraint (Def) /= Null_Iir - then - Error_Msg_Sem (+Def, "file types can't be constrained"); - return Type_Mark; - end if; - - -- LRM93 4.2 - -- A subtype indication denoting [an access type or] a file type - -- may not contain a resolution function. - if Resolution /= Null_Iir then - Error_Msg_Sem - (+Def, "resolution function not allowed for file types"); - return Type_Mark; - end if; - Free_Name (Def); - return Type_Mark; - - when Iir_Kind_Protected_Type_Declaration => - -- LRM08 6.3 Subtype declarations - -- A subtype indication denoting a subtype of [...] a protected - -- type [...] shall not contain a constraint. - if Get_Kind (Def) /= Iir_Kind_Subtype_Definition - or else Get_Range_Constraint (Def) /= Null_Iir - then - Error_Msg_Sem (+Def, "protected types can't be constrained"); - return Type_Mark; - end if; - - -- LRM08 6.3 Subtype declarations - -- A subtype indication denoting [...] a protected type shall - -- not contain a resolution function. - if Resolution /= Null_Iir then - Error_Msg_Sem - (+Def, "resolution function not allowed for file types"); - return Type_Mark; - end if; - Free_Name (Def); - return Type_Mark; - - when Iir_Kind_Error => - return Type_Mark; - - when others => - Error_Kind ("sem_subtype_constraint", Type_Mark); - return Type_Mark; - end case; - end Sem_Subtype_Constraint; - - function Sem_Subtype_Indication (Def: Iir; Incomplete : Boolean := False) - return Iir - is - Type_Mark_Name : Iir; - Type_Mark: Iir; - Res : Iir; - begin - -- LRM08 6.3 Subtype declarations - -- - -- If the subtype indication does not include a constraint, the subtype - -- is the same as that denoted by the type mark. - case Get_Kind (Def) is - when Iir_Kinds_Denoting_Name - | Iir_Kind_Attribute_Name => - Type_Mark := Sem_Type_Mark (Def, Incomplete); - return Type_Mark; - when Iir_Kind_Error => - return Def; - when others => - null; - end case; - - -- Analyze the type mark. - Type_Mark_Name := Get_Subtype_Type_Mark (Def); - Type_Mark_Name := Sem_Type_Mark (Type_Mark_Name); - Set_Subtype_Type_Mark (Def, Type_Mark_Name); - if Is_Error (Type_Mark_Name) then - return Type_Mark_Name; - end if; - - Type_Mark := Get_Type (Type_Mark_Name); - -- FIXME: incomplete type ? - if Is_Error (Type_Mark) then - -- FIXME: handle inversion such as "subtype BASETYPE RESOLV", which - -- should emit "resolution function must precede type name". - - -- Discard the subtype definition and only keep the type mark. - return Type_Mark_Name; - end if; - - Res := Sem_Subtype_Constraint - (Def, Type_Mark, Get_Resolution_Indication (Def)); - if not Is_Error (Res) then - Set_Subtype_Type_Mark (Res, Type_Mark_Name); - end if; - return Res; - end Sem_Subtype_Indication; - - function Sem_Subnature_Indication (Def: Iir) return Iir - is - Nature_Mark: Iir; - Res : Iir; - begin - -- LRM 4.8 Nature declatation - -- - -- If the subnature indication does not include a constraint, the - -- subnature is the same as that denoted by the type mark. - case Get_Kind (Def) is - when Iir_Kind_Scalar_Nature_Definition => - -- Used for reference declared by a nature - return Def; - when Iir_Kinds_Denoting_Name => - Nature_Mark := Sem_Denoting_Name (Def); - Res := Get_Named_Entity (Nature_Mark); - if Get_Kind (Res) /= Iir_Kind_Scalar_Nature_Definition then - Error_Class_Match (Nature_Mark, "nature"); - raise Program_Error; -- TODO - else - return Nature_Mark; - end if; - when others => - raise Program_Error; -- TODO - end case; - end Sem_Subnature_Indication; - -end Sem_Types; diff --git a/src/vhdl/sem_types.ads b/src/vhdl/sem_types.ads deleted file mode 100644 index f4ad3ff74..000000000 --- a/src/vhdl/sem_types.ads +++ /dev/null @@ -1,68 +0,0 @@ --- Semantic analysis. --- 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 Iirs; use Iirs; - -package Sem_Types is - -- Analyze of types (LRM93 3 / LRM08 5) - - -- Analyze subtype indication DEF. - -- If INCOMPLETE is TRUE, then DEF may designate an incomplete type - -- definition. Return either a name (denoting a type), an anonymous - -- subtype definition or a name whose type is an error node. - function Sem_Subtype_Indication (Def: Iir; Incomplete : Boolean := False) - return Iir; - - procedure Sem_Protected_Type_Body (Bod : Iir); - - function Sem_Type_Definition (Def: Iir; Decl: Iir) return Iir; - - -- If A_RANGE is a range (range expression or range attribute), convert it - -- to a subtype definition. Otherwise return A_RANGE. - -- The result is a subtype indication: either a type name or a subtype - -- definition. - function Range_To_Subtype_Indication (A_Range: Iir) return Iir; - - -- ATYPE is used to declare a signal. - -- Set (recursively) the Has_Signal_Flag on ATYPE and all types used by - -- ATYPE (basetype, elements...) - -- If ATYPE can have signal (eg: access or file type), then this procedure - -- returns silently. - procedure Set_Type_Has_Signal (Atype : Iir); - - -- Return TRUE iff FUNC is a resolution function. - -- If ATYPE is not NULL_IIR, type must match. - function Is_A_Resolution_Function (Func: Iir; Atype: Iir) return Boolean; - - -- Return a subtype definition copy of DEF. - -- This is used when an alias of DEF is required (eg: subtype a is b). - function Copy_Subtype_Indication (Def : Iir) return Iir; - - -- Return a copy of the resolution_indication in SUBDEF, or null_iir if - -- none. - function Copy_Resolution_Indication (Subdef : Iir) return Iir; - - -- Adjust the constraint state CONSTRAINT given new element EL_TYPE. - -- Initially CONSTRAINT must be Fully_Constrained and COMPOSITE_FOUND - -- must be false. - procedure Update_Record_Constraint (Constraint : in out Iir_Constraint; - Composite_Found : in out Boolean; - El_Type : Iir); - - -- Although a nature is not a type, it is patterned like a type. - function Sem_Subnature_Indication (Def: Iir) return Iir; -end Sem_Types; diff --git a/src/vhdl/sem_utils.adb b/src/vhdl/sem_utils.adb deleted file mode 100644 index f1d57d85f..000000000 --- a/src/vhdl/sem_utils.adb +++ /dev/null @@ -1,1039 +0,0 @@ --- Semantic utilities. --- Copyright (C) 2018 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 Ada.Unchecked_Conversion; -with Types; use Types; -with Flags; use Flags; -with Errorout; use Errorout; -with Iirs_Utils; use Iirs_Utils; -with Iir_Chains; use Iir_Chains; -with Ieee.Std_Logic_1164; -with Std_Names; -with Std_Package; use Std_Package; - -package body Sem_Utils is - procedure Compute_Subprogram_Hash (Subprg : Iir) - is - type Hash_Type is mod 2**32; - function To_Hash is new Ada.Unchecked_Conversion - (Source => Iir, Target => Hash_Type); - function To_Int32 is new Ada.Unchecked_Conversion - (Source => Hash_Type, Target => Iir_Int32); - - Kind : Iir_Kind; - Hash : Hash_Type; - Sig : Hash_Type; - Inter : Iir; - Itype : Iir; - begin - Kind := Get_Kind (Subprg); - if Kind = Iir_Kind_Function_Declaration - or else Kind = Iir_Kind_Enumeration_Literal - then - Itype := Get_Base_Type (Get_Return_Type (Subprg)); - Hash := To_Hash (Itype); - Sig := 8; - else - Sig := 1; - Hash := 0; - end if; - - if Kind /= Iir_Kind_Enumeration_Literal then - Inter := Get_Interface_Declaration_Chain (Subprg); - while Inter /= Null_Iir loop - Itype := Get_Base_Type (Get_Type (Inter)); - Sig := Sig + 1; - Hash := Hash * 7 + To_Hash (Itype); - Hash := Hash + Hash / 2**28; - Inter := Get_Chain (Inter); - end loop; - end if; - Set_Subprogram_Hash (Subprg, To_Int32 (Hash + Sig)); - end Compute_Subprogram_Hash; - - -- LRM93 7.2.2 - -- A discrete array is a one-dimensional array whose elements are of a - -- discrete type. - function Is_Discrete_Array (Def : Iir) return Boolean - is - begin - case Get_Kind (Def) is - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Array_Subtype_Definition => - null; - when others => - raise Internal_Error; - -- return False; - end case; - if not Is_One_Dimensional_Array_Type (Def) then - return False; - end if; - if Get_Kind (Get_Element_Subtype (Def)) - not in Iir_Kinds_Discrete_Type_Definition - then - return False; - end if; - return True; - end Is_Discrete_Array; - - function Create_Anonymous_Interface (Atype : Iir) - return Iir_Interface_Constant_Declaration - is - Inter : Iir_Interface_Constant_Declaration; - begin - Inter := Create_Iir (Iir_Kind_Interface_Constant_Declaration); - Location_Copy (Inter, Atype); - Set_Identifier (Inter, Null_Identifier); - Set_Mode (Inter, Iir_In_Mode); - Set_Type (Inter, Atype); - return Inter; - end Create_Anonymous_Interface; - - -- Create an implicit/predefined function for DECL. - function Create_Implicit_Function (Name : Name_Id; - Decl : Iir; - Def : Iir_Predefined_Functions; - Interface_Chain : Iir; - Return_Type : Iir) - return Iir - is - Operation : Iir_Function_Declaration; - begin - Operation := Create_Iir (Iir_Kind_Function_Declaration); - Location_Copy (Operation, Decl); - Set_Parent (Operation, Get_Parent (Decl)); - Set_Interface_Declaration_Chain (Operation, Interface_Chain); - Set_Return_Type (Operation, Return_Type); - Set_Implicit_Definition (Operation, Def); - Set_Identifier (Operation, Name); - Set_Visible_Flag (Operation, True); - Compute_Subprogram_Hash (Operation); - return Operation; - end Create_Implicit_Function; - - procedure Create_Implicit_File_Primitives - (Decl : Iir_Type_Declaration; Type_Definition : Iir_File_Type_Definition) - is - use Iir_Chains.Interface_Declaration_Chain_Handling; - Type_Mark : constant Iir := Get_File_Type_Mark (Type_Definition); - Type_Mark_Type : constant Iir := Get_Type (Type_Mark); - Proc: Iir_Procedure_Declaration; - Func: Iir_Function_Declaration; - Inter: Iir; - Loc : Location_Type; - File_Interface_Kind : Iir_Kind; - Last_Interface : Iir; - Last : Iir; - begin - Last := Decl; - Loc := Get_Location (Decl); - - if Flags.Vhdl_Std >= Vhdl_93c then - for I in 1 .. 2 loop - -- Create the implicit file_open (form 1) declaration. - -- Create the implicit file_open (form 2) declaration. - Proc := Create_Iir (Iir_Kind_Procedure_Declaration); - Set_Location (Proc, Loc); - Set_Parent (Proc, Get_Parent (Decl)); - Set_Identifier (Proc, Std_Names.Name_File_Open); - Set_Visible_Flag (Proc, True); - Set_Wait_State (Proc, False); - Build_Init (Last_Interface); - case I is - when 1 => - Set_Implicit_Definition (Proc, Iir_Predefined_File_Open); - when 2 => - Set_Implicit_Definition (Proc, - Iir_Predefined_File_Open_Status); - -- status : out file_open_status. - Inter := - Create_Iir (Iir_Kind_Interface_Variable_Declaration); - Set_Location (Inter, Loc); - Set_Identifier (Inter, Std_Names.Name_Status); - Set_Type (Inter, - Std_Package.File_Open_Status_Type_Definition); - Set_Mode (Inter, Iir_Out_Mode); - Set_Visible_Flag (Inter, True); - Append (Last_Interface, Proc, Inter); - end case; - -- File F : FT - Inter := Create_Iir (Iir_Kind_Interface_File_Declaration); - Set_Location (Inter, Loc); - Set_Identifier (Inter, Std_Names.Name_F); - Set_Type (Inter, Type_Definition); - Set_Mode (Inter, Iir_Inout_Mode); - Set_Visible_Flag (Inter, True); - Append (Last_Interface, Proc, Inter); - -- External_Name : in STRING - Inter := Create_Iir (Iir_Kind_Interface_Constant_Declaration); - Set_Location (Inter, Loc); - Set_Identifier (Inter, Std_Names.Name_External_Name); - Set_Type (Inter, Std_Package.String_Type_Definition); - Set_Mode (Inter, Iir_In_Mode); - Set_Visible_Flag (Inter, True); - Append (Last_Interface, Proc, Inter); - -- Open_Kind : in File_Open_Kind := Read_Mode. - Inter := Create_Iir (Iir_Kind_Interface_Constant_Declaration); - Set_Location (Inter, Loc); - Set_Identifier (Inter, Std_Names.Name_Open_Kind); - Set_Type (Inter, Std_Package.File_Open_Kind_Type_Definition); - Set_Mode (Inter, Iir_In_Mode); - Set_Default_Value - (Inter, - Build_Simple_Name (Std_Package.File_Open_Kind_Read_Mode, Loc)); - Set_Visible_Flag (Inter, True); - Append (Last_Interface, Proc, Inter); - Compute_Subprogram_Hash (Proc); - -- Add it to the list. - Insert_Incr (Last, Proc); - end loop; - - -- Create the implicit file_close declaration. - Proc := Create_Iir (Iir_Kind_Procedure_Declaration); - Set_Identifier (Proc, Std_Names.Name_File_Close); - Set_Location (Proc, Loc); - Set_Parent (Proc, Get_Parent (Decl)); - Set_Implicit_Definition (Proc, Iir_Predefined_File_Close); - Set_Visible_Flag (Proc, True); - Set_Wait_State (Proc, False); - Build_Init (Last_Interface); - Inter := Create_Iir (Iir_Kind_Interface_File_Declaration); - Set_Identifier (Inter, Std_Names.Name_F); - Set_Location (Inter, Loc); - Set_Type (Inter, Type_Definition); - Set_Mode (Inter, Iir_Inout_Mode); - Set_Visible_Flag (Inter, True); - Append (Last_Interface, Proc, Inter); - Compute_Subprogram_Hash (Proc); - -- Add it to the list. - Insert_Incr (Last, Proc); - end if; - - if Flags.Vhdl_Std = Vhdl_87 then - File_Interface_Kind := Iir_Kind_Interface_Variable_Declaration; - else - File_Interface_Kind := Iir_Kind_Interface_File_Declaration; - end if; - - -- Create the implicit procedure read declaration. - Proc := Create_Iir (Iir_Kind_Procedure_Declaration); - Set_Identifier (Proc, Std_Names.Name_Read); - Set_Location (Proc, Loc); - Set_Parent (Proc, Get_Parent (Decl)); - Set_Visible_Flag (Proc, True); - Set_Wait_State (Proc, False); - Build_Init (Last_Interface); - Inter := Create_Iir (File_Interface_Kind); - Set_Identifier (Inter, Std_Names.Name_F); - Set_Location (Inter, Loc); - Set_Type (Inter, Type_Definition); - Set_Mode (Inter, Iir_In_Mode); - Set_Visible_Flag (Inter, True); - Append (Last_Interface, Proc, Inter); - Inter := Create_Iir (Iir_Kind_Interface_Variable_Declaration); - Set_Identifier (Inter, Std_Names.Name_Value); - Set_Location (Inter, Loc); - Set_Subtype_Indication (Inter, Build_Simple_Name (Decl, Loc)); - Set_Type (Inter, Type_Mark_Type); - Set_Mode (Inter, Iir_Out_Mode); - Set_Visible_Flag (Inter, True); - Append (Last_Interface, Proc, Inter); - if Get_Kind (Type_Mark_Type) in Iir_Kinds_Array_Type_Definition - and then Get_Constraint_State (Type_Mark_Type) /= Fully_Constrained - then - Inter := Create_Iir (Iir_Kind_Interface_Variable_Declaration); - Set_Identifier (Inter, Std_Names.Name_Length); - Set_Location (Inter, Loc); - Set_Type (Inter, Std_Package.Natural_Subtype_Definition); - Set_Mode (Inter, Iir_Out_Mode); - Set_Visible_Flag (Inter, True); - Append (Last_Interface, Proc, Inter); - Set_Implicit_Definition (Proc, Iir_Predefined_Read_Length); - else - Set_Implicit_Definition (Proc, Iir_Predefined_Read); - end if; - Compute_Subprogram_Hash (Proc); - -- Add it to the list. - Insert_Incr (Last, Proc); - - -- Create the implicit procedure write declaration. - Proc := Create_Iir (Iir_Kind_Procedure_Declaration); - Set_Identifier (Proc, Std_Names.Name_Write); - Set_Location (Proc, Loc); - Set_Parent (Proc, Get_Parent (Decl)); - Set_Visible_Flag (Proc, True); - Set_Wait_State (Proc, False); - Build_Init (Last_Interface); - Inter := Create_Iir (File_Interface_Kind); - Set_Identifier (Inter, Std_Names.Name_F); - Set_Location (Inter, Loc); - Set_Type (Inter, Type_Definition); - Set_Mode (Inter, Iir_Out_Mode); - Set_Name_Staticness (Inter, Locally); - Set_Expr_Staticness (Inter, None); - Set_Visible_Flag (Inter, True); - Append (Last_Interface, Proc, Inter); - Inter := Create_Iir (Iir_Kind_Interface_Constant_Declaration); - Set_Identifier (Inter, Std_Names.Name_Value); - Set_Location (Inter, Loc); - Set_Subtype_Indication (Inter, Build_Simple_Name (Decl, Loc)); - Set_Type (Inter, Type_Mark_Type); - Set_Mode (Inter, Iir_In_Mode); - Set_Visible_Flag (Inter, True); - Append (Last_Interface, Proc, Inter); - Set_Implicit_Definition (Proc, Iir_Predefined_Write); - Compute_Subprogram_Hash (Proc); - -- Add it to the list. - Insert_Incr (Last, Proc); - - -- Create the implicit procedure flush declaration - if Flags.Vhdl_Std >= Vhdl_08 then - Proc := Create_Iir (Iir_Kind_Procedure_Declaration); - Set_Identifier (Proc, Std_Names.Name_Flush); - Set_Location (Proc, Loc); - Set_Parent (Proc, Get_Parent (Decl)); - Set_Visible_Flag (Proc, True); - Set_Wait_State (Proc, False); - Build_Init (Last_Interface); - Inter := Create_Iir (File_Interface_Kind); - Set_Identifier (Inter, Std_Names.Name_F); - Set_Location (Inter, Loc); - Set_Type (Inter, Type_Definition); - Set_Name_Staticness (Inter, Locally); - Set_Expr_Staticness (Inter, None); - Set_Visible_Flag (Inter, True); - Append (Last_Interface, Proc, Inter); - Set_Implicit_Definition (Proc, Iir_Predefined_Flush); - Compute_Subprogram_Hash (Proc); - -- Add it to the list. - Insert_Incr (Last, Proc); - end if; - -- Create the implicit function endfile declaration. - Func := Create_Iir (Iir_Kind_Function_Declaration); - Set_Identifier (Func, Std_Names.Name_Endfile); - Set_Location (Func, Loc); - Set_Parent (Func, Get_Parent (Decl)); - Set_Visible_Flag (Func, True); - Build_Init (Last_Interface); - Inter := Create_Iir (File_Interface_Kind); - Set_Identifier (Inter, Std_Names.Name_F); - Set_Location (Inter, Loc); - Set_Type (Inter, Type_Definition); - Set_Mode (Inter, Iir_In_Mode); - Set_Visible_Flag (Inter, True); - Append (Last_Interface, Func, Inter); - Set_Return_Type (Func, Std_Package.Boolean_Type_Definition); - Set_Implicit_Definition (Func, Iir_Predefined_Endfile); - Compute_Subprogram_Hash (Func); - -- Add it to the list. - Insert_Incr (Last, Func); - end Create_Implicit_File_Primitives; - - procedure Create_Implicit_Operations - (Decl : Iir; Is_Std_Standard : Boolean := False) - is - use Std_Names; - Binary_Chain : Iir; - Unary_Chain : Iir; - Type_Definition : Iir; - Last : Iir; - - procedure Add_Operation (Name : Name_Id; - Def : Iir_Predefined_Functions; - Interface_Chain : Iir; - Return_Type : Iir) - is - Operation : Iir_Function_Declaration; - begin - Operation := Create_Implicit_Function - (Name, Decl, Def, Interface_Chain, Return_Type); - Insert_Incr (Last, Operation); - end Add_Operation; - - procedure Add_Relational (Name : Name_Id; Def : Iir_Predefined_Functions) - is - begin - Add_Operation - (Name, Def, Binary_Chain, Std_Package.Boolean_Type_Definition); - end Add_Relational; - - procedure Add_Binary (Name : Name_Id; Def : Iir_Predefined_Functions) is - begin - Add_Operation (Name, Def, Binary_Chain, Type_Definition); - end Add_Binary; - - procedure Add_Unary (Name : Name_Id; Def : Iir_Predefined_Functions) is - begin - Add_Operation (Name, Def, Unary_Chain, Type_Definition); - end Add_Unary; - - procedure Add_To_String (Def : Iir_Predefined_Functions) is - begin - Add_Operation (Name_To_String, Def, - Unary_Chain, String_Type_Definition); - end Add_To_String; - - procedure Add_Min_Max (Name : Name_Id; Def : Iir_Predefined_Functions) - is - Left, Right : Iir; - begin - Left := Create_Anonymous_Interface (Type_Definition); - Set_Identifier (Left, Name_L); - Right := Create_Anonymous_Interface (Type_Definition); - Set_Identifier (Right, Name_R); - Set_Chain (Left, Right); - Add_Operation (Name, Def, Left, Type_Definition); - end Add_Min_Max; - - procedure Add_Vector_Min_Max - (Name : Name_Id; Def : Iir_Predefined_Functions) - is - Left : Iir; - begin - Left := Create_Anonymous_Interface (Type_Definition); - Set_Identifier (Left, Name_L); - Add_Operation - (Name, Def, Left, Get_Element_Subtype (Type_Definition)); - end Add_Vector_Min_Max; - - procedure Add_Shift_Operators - is - Inter_Chain : Iir_Interface_Constant_Declaration; - Inter_Int : Iir; - begin - Inter_Chain := Create_Anonymous_Interface (Type_Definition); - - Inter_Int := Create_Iir (Iir_Kind_Interface_Constant_Declaration); - Location_Copy (Inter_Int, Decl); - Set_Identifier (Inter_Int, Null_Identifier); - Set_Mode (Inter_Int, Iir_In_Mode); - Set_Type (Inter_Int, Std_Package.Integer_Subtype_Definition); - - Set_Chain (Inter_Chain, Inter_Int); - - Add_Operation - (Name_Sll, Iir_Predefined_Array_Sll, Inter_Chain, Type_Definition); - Add_Operation - (Name_Srl, Iir_Predefined_Array_Srl, Inter_Chain, Type_Definition); - Add_Operation - (Name_Sla, Iir_Predefined_Array_Sla, Inter_Chain, Type_Definition); - Add_Operation - (Name_Sra, Iir_Predefined_Array_Sra, Inter_Chain, Type_Definition); - Add_Operation - (Name_Rol, Iir_Predefined_Array_Rol, Inter_Chain, Type_Definition); - Add_Operation - (Name_Ror, Iir_Predefined_Array_Ror, Inter_Chain, Type_Definition); - end Add_Shift_Operators; - begin - Last := Decl; - - Type_Definition := Get_Base_Type (Get_Type_Definition (Decl)); - if Get_Kind (Type_Definition) /= Iir_Kind_File_Type_Definition then - Unary_Chain := Create_Anonymous_Interface (Type_Definition); - Binary_Chain := Create_Anonymous_Interface (Type_Definition); - Set_Chain (Binary_Chain, Unary_Chain); - end if; - - case Get_Kind (Type_Definition) is - when Iir_Kind_Enumeration_Type_Definition => - Add_Relational (Name_Op_Equality, Iir_Predefined_Enum_Equality); - Add_Relational - (Name_Op_Inequality, Iir_Predefined_Enum_Inequality); - Add_Relational (Name_Op_Greater, Iir_Predefined_Enum_Greater); - Add_Relational - (Name_Op_Greater_Equal, Iir_Predefined_Enum_Greater_Equal); - Add_Relational (Name_Op_Less, Iir_Predefined_Enum_Less); - Add_Relational - (Name_Op_Less_Equal, Iir_Predefined_Enum_Less_Equal); - - if Flags.Vhdl_Std >= Vhdl_08 then - -- LRM08 5.2.6 Predefined operations on scalar types - -- Given a type declaration that declares a scalar type T, the - -- following operations are implicitely declared immediately - -- following the type declaration (except for the TO_STRING - -- operations in package STANDARD [...]) - Add_Min_Max (Name_Minimum, Iir_Predefined_Enum_Minimum); - Add_Min_Max (Name_Maximum, Iir_Predefined_Enum_Maximum); - if not Is_Std_Standard then - Add_To_String (Iir_Predefined_Enum_To_String); - end if; - - -- LRM08 9.2.3 Relational operators - -- The matching relational operators are predefined for the - -- [predefined type BIT and for the] type STD_ULOGIC defined - -- in package STD_LOGIC_1164. - if Type_Definition = Ieee.Std_Logic_1164.Std_Ulogic_Type then - Add_Binary (Name_Op_Match_Equality, - Iir_Predefined_Std_Ulogic_Match_Equality); - Add_Binary (Name_Op_Match_Inequality, - Iir_Predefined_Std_Ulogic_Match_Inequality); - Add_Binary (Name_Op_Match_Less, - Iir_Predefined_Std_Ulogic_Match_Less); - Add_Binary (Name_Op_Match_Less_Equal, - Iir_Predefined_Std_Ulogic_Match_Less_Equal); - Add_Binary (Name_Op_Match_Greater, - Iir_Predefined_Std_Ulogic_Match_Greater); - Add_Binary (Name_Op_Match_Greater_Equal, - Iir_Predefined_Std_Ulogic_Match_Greater_Equal); - end if; - end if; - - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Array_Subtype_Definition => - declare - Element_Type : Iir; - - Element_Array_Inter_Chain : Iir; - Array_Element_Inter_Chain : Iir; - Element_Element_Inter_Chain : Iir; - begin - Add_Relational - (Name_Op_Equality, Iir_Predefined_Array_Equality); - Add_Relational - (Name_Op_Inequality, Iir_Predefined_Array_Inequality); - if Is_Discrete_Array (Type_Definition) then - Add_Relational - (Name_Op_Greater, Iir_Predefined_Array_Greater); - Add_Relational - (Name_Op_Greater_Equal, - Iir_Predefined_Array_Greater_Equal); - Add_Relational - (Name_Op_Less, Iir_Predefined_Array_Less); - Add_Relational - (Name_Op_Less_Equal, Iir_Predefined_Array_Less_Equal); - - -- LRM08 5.3.2.4 Predefined operations on array types - -- Given a type declaration that declares a discrete array - -- type T, the following operatons are implicitly declared - -- immediately following the type declaration: - -- function MINIMUM (L, R : T) return T; - -- function MAXIMUM (L, R : T) return T; - if Vhdl_Std >= Vhdl_08 then - Add_Min_Max (Name_Maximum, Iir_Predefined_Array_Maximum); - Add_Min_Max (Name_Minimum, Iir_Predefined_Array_Minimum); - end if; - end if; - - Element_Type := Get_Element_Subtype (Type_Definition); - - if Is_One_Dimensional_Array_Type (Type_Definition) then - -- LRM93 7.2.4 Adding operators - -- The concatenation operator & is predefined for any - -- one-dimensional array type. - Add_Operation (Name_Op_Concatenation, - Iir_Predefined_Array_Array_Concat, - Binary_Chain, - Type_Definition); - - Element_Array_Inter_Chain := - Create_Anonymous_Interface (Element_Type); - Set_Chain (Element_Array_Inter_Chain, Unary_Chain); - Add_Operation (Name_Op_Concatenation, - Iir_Predefined_Element_Array_Concat, - Element_Array_Inter_Chain, - Type_Definition); - - Array_Element_Inter_Chain := - Create_Anonymous_Interface (Type_Definition); - Set_Chain (Array_Element_Inter_Chain, - Create_Anonymous_Interface (Element_Type)); - Add_Operation (Name_Op_Concatenation, - Iir_Predefined_Array_Element_Concat, - Array_Element_Inter_Chain, - Type_Definition); - - Element_Element_Inter_Chain := - Create_Anonymous_Interface (Element_Type); - Set_Chain (Element_Element_Inter_Chain, - Create_Anonymous_Interface (Element_Type)); - Add_Operation (Name_Op_Concatenation, - Iir_Predefined_Element_Element_Concat, - Element_Element_Inter_Chain, - Type_Definition); - - -- LRM08 5.3.2.4 Predefined operations on array types - -- In addition, given a type declaration that declares a - -- one-dimensional array type T whose elements are of a - -- sclar type E, the following operations are implicitly - -- declared immediately following the type declaration: - -- function MINIMUM (L : T) return E; - -- function MAXIMUM (L : T) return E; - if Vhdl_Std >= Vhdl_08 - and then (Get_Kind (Element_Type) in - Iir_Kinds_Scalar_Type_And_Subtype_Definition) - then - Add_Vector_Min_Max - (Name_Maximum, Iir_Predefined_Vector_Maximum); - Add_Vector_Min_Max - (Name_Minimum, Iir_Predefined_Vector_Minimum); - end if; - - if Element_Type = Std_Package.Boolean_Type_Definition - or else Element_Type = Std_Package.Bit_Type_Definition - then - -- LRM93 7.2.1 Logical operators - -- LRM08 9.2.2 Logical operators - -- The binary logical operators AND, OR, NAND, NOR, XOR, - -- and XNOR, and the unary logical operator NOT are - -- defined for predefined types BIT and BOOLEAN. They - -- are also defined for any one-dimensional array type - -- whose element type is BIT or BOOLEAN. - - Add_Unary (Name_Not, Iir_Predefined_TF_Array_Not); - - Add_Binary (Name_And, Iir_Predefined_TF_Array_And); - Add_Binary (Name_Or, Iir_Predefined_TF_Array_Or); - Add_Binary (Name_Nand, Iir_Predefined_TF_Array_Nand); - Add_Binary (Name_Nor, Iir_Predefined_TF_Array_Nor); - Add_Binary (Name_Xor, Iir_Predefined_TF_Array_Xor); - if Flags.Vhdl_Std > Vhdl_87 then - Add_Binary (Name_Xnor, Iir_Predefined_TF_Array_Xnor); - - -- LRM93 7.2.3 Shift operators - -- The shift operators SLL, SRL, SLA, SRA, ROL and - -- ROR are defined for any one-dimensional array type - -- whose element type is either of the predefined - -- types BIT or BOOLEAN. - Add_Shift_Operators; - end if; - - -- LRM08 9.2.2 Logical operators - -- For the binary operators AND, OR, NAND, NOR, XOR and - -- XNOR, the operands shall both be [of the same base - -- type,] or one operand shall be of a scalar type and - -- the other operand shall be a one-dimensional array - -- whose element type is the scalar type. The result - -- type is the same as the base type of the operands if - -- [both operands are scalars of the same base type or] - -- both operands are arrays, or the same as the base type - -- of the array operand if one operand is a scalar and - -- the other operand is an array. - if Flags.Vhdl_Std >= Vhdl_08 then - Add_Operation - (Name_And, Iir_Predefined_TF_Element_Array_And, - Element_Array_Inter_Chain, Type_Definition); - Add_Operation - (Name_And, Iir_Predefined_TF_Array_Element_And, - Array_Element_Inter_Chain, Type_Definition); - Add_Operation - (Name_Or, Iir_Predefined_TF_Element_Array_Or, - Element_Array_Inter_Chain, Type_Definition); - Add_Operation - (Name_Or, Iir_Predefined_TF_Array_Element_Or, - Array_Element_Inter_Chain, Type_Definition); - Add_Operation - (Name_Nand, Iir_Predefined_TF_Element_Array_Nand, - Element_Array_Inter_Chain, Type_Definition); - Add_Operation - (Name_Nand, Iir_Predefined_TF_Array_Element_Nand, - Array_Element_Inter_Chain, Type_Definition); - Add_Operation - (Name_Nor, Iir_Predefined_TF_Element_Array_Nor, - Element_Array_Inter_Chain, Type_Definition); - Add_Operation - (Name_Nor, Iir_Predefined_TF_Array_Element_Nor, - Array_Element_Inter_Chain, Type_Definition); - Add_Operation - (Name_Xor, Iir_Predefined_TF_Element_Array_Xor, - Element_Array_Inter_Chain, Type_Definition); - Add_Operation - (Name_Xor, Iir_Predefined_TF_Array_Element_Xor, - Array_Element_Inter_Chain, Type_Definition); - Add_Operation - (Name_Xnor, Iir_Predefined_TF_Element_Array_Xnor, - Element_Array_Inter_Chain, Type_Definition); - Add_Operation - (Name_Xnor, Iir_Predefined_TF_Array_Element_Xnor, - Array_Element_Inter_Chain, Type_Definition); - end if; - - if Flags.Vhdl_Std >= Vhdl_08 then - -- LRM08 9.2.2 Logical operations - -- The unary logical operators AND, OR, NAND, NOR, - -- XOR, and XNOR are referred to as logical reduction - -- operators. The logical reduction operators are - -- predefined for any one-dimensional array type whose - -- element type is BIT or BOOLEAN. The result type - -- for the logical reduction operators is the same as - -- the element type of the operand. - Add_Operation - (Name_And, Iir_Predefined_TF_Reduction_And, - Unary_Chain, Element_Type); - Add_Operation - (Name_Or, Iir_Predefined_TF_Reduction_Or, - Unary_Chain, Element_Type); - Add_Operation - (Name_Nand, Iir_Predefined_TF_Reduction_Nand, - Unary_Chain, Element_Type); - Add_Operation - (Name_Nor, Iir_Predefined_TF_Reduction_Nor, - Unary_Chain, Element_Type); - Add_Operation - (Name_Xor, Iir_Predefined_TF_Reduction_Xor, - Unary_Chain, Element_Type); - Add_Operation - (Name_Xnor, Iir_Predefined_TF_Reduction_Xnor, - Unary_Chain, Element_Type); - end if; - end if; - - -- LRM08 9.2.3 Relational operators - -- The matching equality and matching inequality operatotrs - -- are also defined for any one-dimensional array type - -- whose element type is BIT or STD_ULOGIC. - if Flags.Vhdl_Std >= Vhdl_08 then - if Element_Type = Std_Package.Bit_Type_Definition then - Add_Operation - (Name_Op_Match_Equality, - Iir_Predefined_Bit_Array_Match_Equality, - Binary_Chain, Element_Type); - Add_Operation - (Name_Op_Match_Inequality, - Iir_Predefined_Bit_Array_Match_Inequality, - Binary_Chain, Element_Type); - elsif Element_Type = Ieee.Std_Logic_1164.Std_Ulogic_Type - then - Add_Operation - (Name_Op_Match_Equality, - Iir_Predefined_Std_Ulogic_Array_Match_Equality, - Binary_Chain, Element_Type); - Add_Operation - (Name_Op_Match_Inequality, - Iir_Predefined_Std_Ulogic_Array_Match_Inequality, - Binary_Chain, Element_Type); - end if; - end if; - - -- LRM08 5.3.2.4 Predefined operations on array type - -- - -- Given a type declaration that declares a one-dimensional - -- array type T whose element type is a character type that - -- contains only character literals, the following operation - -- is implicitely declared immediately following the type - -- declaration - if Vhdl_Std >= Vhdl_08 - and then String_Type_Definition /= Null_Iir - and then (Get_Kind (Element_Type) - = Iir_Kind_Enumeration_Type_Definition) - and then Get_Only_Characters_Flag (Element_Type) - then - Add_Operation (Name_To_String, - Iir_Predefined_Array_Char_To_String, - Unary_Chain, - String_Type_Definition); - end if; - end if; - end; - - when Iir_Kind_Access_Type_Definition => - Add_Relational (Name_Op_Equality, Iir_Predefined_Access_Equality); - Add_Relational - (Name_Op_Inequality, Iir_Predefined_Access_Inequality); - declare - Deallocate_Proc: Iir_Procedure_Declaration; - Var_Interface: Iir_Interface_Variable_Declaration; - begin - Deallocate_Proc := - Create_Iir (Iir_Kind_Procedure_Declaration); - Location_Copy (Deallocate_Proc, Decl); - Set_Identifier (Deallocate_Proc, Std_Names.Name_Deallocate); - Set_Implicit_Definition - (Deallocate_Proc, Iir_Predefined_Deallocate); - Set_Parent (Deallocate_Proc, Get_Parent (Decl)); - - Var_Interface := - Create_Iir (Iir_Kind_Interface_Variable_Declaration); - Location_Copy (Var_Interface, Decl); - Set_Identifier (Var_Interface, Std_Names.Name_P); - Set_Parent (Var_Interface, Deallocate_Proc); - Set_Type (Var_Interface, Type_Definition); - Set_Mode (Var_Interface, Iir_Inout_Mode); - --Set_Purity_State (Deallocate_Proc, Impure); - Set_Wait_State (Deallocate_Proc, False); - Set_Visible_Flag (Deallocate_Proc, True); - - Set_Interface_Declaration_Chain - (Deallocate_Proc, Var_Interface); - Compute_Subprogram_Hash (Deallocate_Proc); - Insert_Incr (Last, Deallocate_Proc); - end; - - when Iir_Kind_Record_Type_Definition => - Add_Relational (Name_Op_Equality, Iir_Predefined_Record_Equality); - Add_Relational - (Name_Op_Inequality, Iir_Predefined_Record_Inequality); - - when Iir_Kind_Integer_Type_Definition => - Add_Relational (Name_Op_Equality, Iir_Predefined_Integer_Equality); - Add_Relational - (Name_Op_Inequality, Iir_Predefined_Integer_Inequality); - Add_Relational (Name_Op_Greater, Iir_Predefined_Integer_Greater); - Add_Relational - (Name_Op_Greater_Equal, Iir_Predefined_Integer_Greater_Equal); - Add_Relational (Name_Op_Less, Iir_Predefined_Integer_Less); - Add_Relational - (Name_Op_Less_Equal, Iir_Predefined_Integer_Less_Equal); - - Add_Binary (Name_Op_Plus, Iir_Predefined_Integer_Plus); - Add_Binary (Name_Op_Minus, Iir_Predefined_Integer_Minus); - - Add_Unary (Name_Op_Minus, Iir_Predefined_Integer_Negation); - Add_Unary (Name_Op_Plus, Iir_Predefined_Integer_Identity); - - Add_Binary (Name_Op_Mul, Iir_Predefined_Integer_Mul); - Add_Binary (Name_Op_Div, Iir_Predefined_Integer_Div); - Add_Binary (Name_Mod, Iir_Predefined_Integer_Mod); - Add_Binary (Name_Rem, Iir_Predefined_Integer_Rem); - - Add_Unary (Name_Abs, Iir_Predefined_Integer_Absolute); - - declare - Inter_Chain : Iir; - begin - Inter_Chain := Create_Anonymous_Interface (Type_Definition); - Set_Chain - (Inter_Chain, - Create_Anonymous_Interface (Integer_Type_Definition)); - Add_Operation (Name_Op_Exp, Iir_Predefined_Integer_Exp, - Inter_Chain, Type_Definition); - end; - - if Vhdl_Std >= Vhdl_08 then - -- LRM08 5.2.6 Predefined operations on scalar types - -- Given a type declaration that declares a scalar type T, the - -- following operations are implicitely declared immediately - -- following the type declaration (except for the TO_STRING - -- operations in package STANDARD [...]) - Add_Min_Max (Name_Minimum, Iir_Predefined_Integer_Minimum); - Add_Min_Max (Name_Maximum, Iir_Predefined_Integer_Maximum); - if not Is_Std_Standard then - Add_To_String (Iir_Predefined_Integer_To_String); - end if; - end if; - - when Iir_Kind_Floating_Type_Definition => - Add_Relational - (Name_Op_Equality, Iir_Predefined_Floating_Equality); - Add_Relational - (Name_Op_Inequality, Iir_Predefined_Floating_Inequality); - Add_Relational - (Name_Op_Greater, Iir_Predefined_Floating_Greater); - Add_Relational - (Name_Op_Greater_Equal, Iir_Predefined_Floating_Greater_Equal); - Add_Relational - (Name_Op_Less, Iir_Predefined_Floating_Less); - Add_Relational - (Name_Op_Less_Equal, Iir_Predefined_Floating_Less_Equal); - - Add_Binary (Name_Op_Plus, Iir_Predefined_Floating_Plus); - Add_Binary (Name_Op_Minus, Iir_Predefined_Floating_Minus); - - Add_Unary (Name_Op_Minus, Iir_Predefined_Floating_Negation); - Add_Unary (Name_Op_Plus, Iir_Predefined_Floating_Identity); - - Add_Binary (Name_Op_Mul, Iir_Predefined_Floating_Mul); - Add_Binary (Name_Op_Div, Iir_Predefined_Floating_Div); - - Add_Unary (Name_Abs, Iir_Predefined_Floating_Absolute); - - declare - Inter_Chain : Iir; - begin - Inter_Chain := Create_Anonymous_Interface (Type_Definition); - Set_Chain - (Inter_Chain, - Create_Anonymous_Interface (Integer_Type_Definition)); - Add_Operation (Name_Op_Exp, Iir_Predefined_Floating_Exp, - Inter_Chain, Type_Definition); - end; - - if Vhdl_Std >= Vhdl_08 then - -- LRM08 5.2.6 Predefined operations on scalar types - -- Given a type declaration that declares a scalar type T, the - -- following operations are implicitely declared immediately - -- following the type declaration (except for the TO_STRING - -- operations in package STANDARD [...]) - Add_Min_Max (Name_Minimum, Iir_Predefined_Floating_Minimum); - Add_Min_Max (Name_Maximum, Iir_Predefined_Floating_Maximum); - if not Is_Std_Standard then - Add_To_String (Iir_Predefined_Floating_To_String); - end if; - end if; - - when Iir_Kind_Physical_Type_Definition => - Add_Relational - (Name_Op_Equality, Iir_Predefined_Physical_Equality); - Add_Relational - (Name_Op_Inequality, Iir_Predefined_Physical_Inequality); - Add_Relational - (Name_Op_Greater, Iir_Predefined_Physical_Greater); - Add_Relational - (Name_Op_Greater_Equal, Iir_Predefined_Physical_Greater_Equal); - Add_Relational - (Name_Op_Less, Iir_Predefined_Physical_Less); - Add_Relational - (Name_Op_Less_Equal, Iir_Predefined_Physical_Less_Equal); - - Add_Binary (Name_Op_Plus, Iir_Predefined_Physical_Plus); - Add_Binary (Name_Op_Minus, Iir_Predefined_Physical_Minus); - - Add_Unary (Name_Op_Minus, Iir_Predefined_Physical_Negation); - Add_Unary (Name_Op_Plus, Iir_Predefined_Physical_Identity); - - declare - Inter_Chain : Iir; - begin - Inter_Chain := Create_Anonymous_Interface (Type_Definition); - Set_Chain - (Inter_Chain, - Create_Anonymous_Interface (Integer_Type_Definition)); - Add_Operation (Name_Op_Mul, Iir_Predefined_Physical_Integer_Mul, - Inter_Chain, Type_Definition); - Add_Operation (Name_Op_Div, Iir_Predefined_Physical_Integer_Div, - Inter_Chain, Type_Definition); - end; - - declare - Inter_Chain : Iir; - begin - Inter_Chain := - Create_Anonymous_Interface (Integer_Type_Definition); - Set_Chain (Inter_Chain, Unary_Chain); - Add_Operation (Name_Op_Mul, Iir_Predefined_Integer_Physical_Mul, - Inter_Chain, Type_Definition); - end; - - declare - Inter_Chain : Iir; - begin - Inter_Chain := Create_Anonymous_Interface (Type_Definition); - Set_Chain (Inter_Chain, - Create_Anonymous_Interface (Real_Type_Definition)); - Add_Operation (Name_Op_Mul, Iir_Predefined_Physical_Real_Mul, - Inter_Chain, Type_Definition); - Add_Operation (Name_Op_Div, Iir_Predefined_Physical_Real_Div, - Inter_Chain, Type_Definition); - end; - - declare - Inter_Chain : Iir; - begin - Inter_Chain := - Create_Anonymous_Interface (Real_Type_Definition); - Set_Chain (Inter_Chain, Unary_Chain); - Add_Operation (Name_Op_Mul, Iir_Predefined_Real_Physical_Mul, - Inter_Chain, Type_Definition); - end; - Add_Operation (Name_Op_Div, Iir_Predefined_Physical_Physical_Div, - Binary_Chain, - Std_Package.Convertible_Integer_Type_Definition); - - Add_Unary (Name_Abs, Iir_Predefined_Physical_Absolute); - - if Vhdl_Std >= Vhdl_08 then - -- LRM08 5.2.6 Predefined operations on scalar types - -- Given a type declaration that declares a scalar type T, the - -- following operations are implicitely declared immediately - -- following the type declaration (except for the TO_STRING - -- operations in package STANDARD [...]) - Add_Min_Max (Name_Minimum, Iir_Predefined_Physical_Minimum); - Add_Min_Max (Name_Maximum, Iir_Predefined_Physical_Maximum); - if not Is_Std_Standard then - Add_To_String (Iir_Predefined_Physical_To_String); - end if; - end if; - - when Iir_Kind_File_Type_Definition => - Create_Implicit_File_Primitives (Decl, Type_Definition); - - when Iir_Kind_Protected_Type_Declaration => - null; - - when others => - Error_Kind ("create_predefined_operations", Type_Definition); - end case; - - if not Is_Std_Standard then - return; - end if; - if Decl = Std_Package.Boolean_Type_Declaration then - Add_Binary (Name_And, Iir_Predefined_Boolean_And); - Add_Binary (Name_Or, Iir_Predefined_Boolean_Or); - Add_Binary (Name_Nand, Iir_Predefined_Boolean_Nand); - Add_Binary (Name_Nor, Iir_Predefined_Boolean_Nor); - Add_Binary (Name_Xor, Iir_Predefined_Boolean_Xor); - if Flags.Vhdl_Std > Vhdl_87 then - Add_Binary (Name_Xnor, Iir_Predefined_Boolean_Xnor); - end if; - Add_Unary (Name_Not, Iir_Predefined_Boolean_Not); - elsif Decl = Std_Package.Bit_Type_Declaration then - Add_Binary (Name_And, Iir_Predefined_Bit_And); - Add_Binary (Name_Or, Iir_Predefined_Bit_Or); - Add_Binary (Name_Nand, Iir_Predefined_Bit_Nand); - Add_Binary (Name_Nor, Iir_Predefined_Bit_Nor); - Add_Binary (Name_Xor, Iir_Predefined_Bit_Xor); - if Flags.Vhdl_Std > Vhdl_87 then - Add_Binary (Name_Xnor, Iir_Predefined_Bit_Xnor); - end if; - Add_Unary (Name_Not, Iir_Predefined_Bit_Not); - if Flags.Vhdl_Std >= Vhdl_08 then - Add_Binary (Name_Op_Match_Equality, - Iir_Predefined_Bit_Match_Equality); - Add_Binary (Name_Op_Match_Inequality, - Iir_Predefined_Bit_Match_Inequality); - Add_Binary (Name_Op_Match_Less, - Iir_Predefined_Bit_Match_Less); - Add_Binary (Name_Op_Match_Less_Equal, - Iir_Predefined_Bit_Match_Less_Equal); - Add_Binary (Name_Op_Match_Greater, - Iir_Predefined_Bit_Match_Greater); - Add_Binary (Name_Op_Match_Greater_Equal, - Iir_Predefined_Bit_Match_Greater_Equal); - - -- LRM08 9.2.9 Condition operator - -- The unary operator ?? is predefined for type BIT defined in - -- package STANDARD. - Add_Operation (Name_Op_Condition, Iir_Predefined_Bit_Condition, - Unary_Chain, Std_Package.Boolean_Type_Definition); - - end if; - elsif Decl = Std_Package.Universal_Real_Type_Declaration then - declare - Inter_Chain : Iir; - begin - Inter_Chain := Create_Anonymous_Interface (Type_Definition); - Set_Chain - (Inter_Chain, - Create_Anonymous_Interface (Universal_Integer_Type_Definition)); - Add_Operation (Name_Op_Mul, Iir_Predefined_Universal_R_I_Mul, - Inter_Chain, Type_Definition); - Add_Operation (Name_Op_Div, Iir_Predefined_Universal_R_I_Div, - Inter_Chain, Type_Definition); - end; - - declare - Inter_Chain : Iir; - begin - Inter_Chain := - Create_Anonymous_Interface (Universal_Integer_Type_Definition); - Set_Chain (Inter_Chain, Unary_Chain); - Add_Operation (Name_Op_Mul, Iir_Predefined_Universal_I_R_Mul, - Inter_Chain, Type_Definition); - end; - end if; - end Create_Implicit_Operations; -end Sem_Utils; diff --git a/src/vhdl/sem_utils.ads b/src/vhdl/sem_utils.ads deleted file mode 100644 index 263a9de31..000000000 --- a/src/vhdl/sem_utils.ads +++ /dev/null @@ -1,30 +0,0 @@ --- Semantic utilities. --- Copyright (C) 2018 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 Iirs; use Iirs; - -package Sem_Utils is - -- Compute and set the hash profile of a subprogram or enumeration clause. - procedure Compute_Subprogram_Hash (Subprg : Iir); - - function Create_Anonymous_Interface - (Atype : Iir) return Iir_Interface_Constant_Declaration; - - -- Create predefined operations for DECL. - procedure Create_Implicit_Operations - (Decl : Iir; Is_Std_Standard : Boolean := False); -end Sem_Utils; diff --git a/src/vhdl/simulate/simul-debugger.adb b/src/vhdl/simulate/simul-debugger.adb index 10789cb25..8c911a706 100644 --- a/src/vhdl/simulate/simul-debugger.adb +++ b/src/vhdl/simulate/simul-debugger.adb @@ -26,8 +26,8 @@ with Files_Map; with Vhdl.Parse; with Vhdl.Scanner; with Vhdl.Tokens; -with Sem_Expr; -with Sem_Scopes; +with Vhdl.Sem_Expr; +with Vhdl.Sem_Scopes; with Vhdl.Canon; with Std_Names; with Libraries; @@ -1750,7 +1750,7 @@ package body Simul.Debugger is procedure Add_Decls_For (N : Iir) is - use Sem_Scopes; + use Vhdl.Sem_Scopes; begin case Get_Kind (N) is when Iir_Kind_Entity_Declaration => @@ -1819,7 +1819,7 @@ package body Simul.Debugger is procedure Enter_Scope (Node : Iir) is - use Sem_Scopes; + use Vhdl.Sem_Scopes; begin Push_Interpretations; Open_Declarative_Region; @@ -1833,7 +1833,7 @@ package body Simul.Debugger is procedure Del_Decls_For (N : Iir) is - use Sem_Scopes; + use Vhdl.Sem_Scopes; begin case Get_Kind (N) is when Iir_Kind_Entity_Declaration => @@ -1858,7 +1858,7 @@ package body Simul.Debugger is procedure Leave_Scope (Node : Iir) is - use Sem_Scopes; + use Vhdl.Sem_Scopes; begin Foreach_Scopes (Node, Del_Decls_For'Access); @@ -1914,7 +1914,7 @@ package body Simul.Debugger is end if; Enter_Scope (Dbg_Cur_Frame.Stmt); - Expr := Sem_Expr.Sem_Expression_Universal (Expr); + Expr := Vhdl.Sem_Expr.Sem_Expression_Universal (Expr); Leave_Scope (Dbg_Cur_Frame.Stmt); if Expr = Null_Iir diff --git a/src/vhdl/simulate/simul-elaboration.adb b/src/vhdl/simulate/simul-elaboration.adb index cb9c8cb9b..3addbef91 100644 --- a/src/vhdl/simulate/simul-elaboration.adb +++ b/src/vhdl/simulate/simul-elaboration.adb @@ -26,7 +26,7 @@ with Libraries; with Name_Table; with Simul.File_Operation; with Iir_Chains; use Iir_Chains; -with Sem_Lib; use Sem_Lib; +with Vhdl.Sem_Lib; use Vhdl.Sem_Lib; with Simul.Annotations; use Simul.Annotations; with Simul.Elaboration.AMS; use Simul.Elaboration.AMS; with Areapools; use Areapools; diff --git a/src/vhdl/simulate/simul-execution.adb b/src/vhdl/simulate/simul-execution.adb index f034bb9b6..3a1c11028 100644 --- a/src/vhdl/simulate/simul-execution.adb +++ b/src/vhdl/simulate/simul-execution.adb @@ -44,7 +44,7 @@ with Grt.Errors; with Grt.Std_Logic_1164; with Grt.Lib; with Grt.Strings; -with Sem_Inst; +with Vhdl.Sem_Inst; package body Simul.Execution is @@ -3344,7 +3344,7 @@ package body Simul.Execution is if Res /= Null_Iir then return Res; else - Orig := Sem_Inst.Get_Origin (Spec); + Orig := Vhdl.Sem_Inst.Get_Origin (Spec); pragma Assert (Orig /= Null_Iir); return Get_Subprogram_Body_Origin (Orig); end if; @@ -3361,7 +3361,7 @@ package body Simul.Execution is if Res /= Null_Iir then return Res; else - Orig := Sem_Inst.Get_Origin (Spec); + Orig := Vhdl.Sem_Inst.Get_Origin (Spec); return Get_Protected_Type_Body_Origin (Orig); end if; end Get_Protected_Type_Body_Origin; diff --git a/src/vhdl/std_package.adb b/src/vhdl/std_package.adb index a04fafd4c..5dd659d6a 100644 --- a/src/vhdl/std_package.adb +++ b/src/vhdl/std_package.adb @@ -22,7 +22,7 @@ with Str_Table; with Std_Names; use Std_Names; with Flags; use Flags; with Iirs_Utils; -with Sem_Utils; +with Vhdl.Sem_Utils; with Iir_Chains; package body Std_Package is @@ -174,7 +174,7 @@ package body Std_Package is Set_Expr_Staticness (Res, Locally); Set_Name_Staticness (Res, Locally); Set_Enum_Pos (Res, Iir_Int32 (Pos)); - Sem_Utils.Compute_Subprogram_Hash (Res); + Vhdl.Sem_Utils.Compute_Subprogram_Hash (Res); Set_Nth_Element (List, Pos, Res); return Res; end Create_Std_Literal; @@ -195,7 +195,7 @@ package body Std_Package is is Nxt : Iir; begin - Sem_Utils.Create_Implicit_Operations (Decl, True); + Vhdl.Sem_Utils.Create_Implicit_Operations (Decl, True); -- Update Last_Decl loop @@ -359,7 +359,7 @@ package body Std_Package is Set_Chain (Inter, Inter2); end if; - Sem_Utils.Compute_Subprogram_Hash (Decl); + Vhdl.Sem_Utils.Compute_Subprogram_Hash (Decl); Add_Decl (Decl); end Create_To_String; @@ -384,7 +384,7 @@ package body Std_Package is Set_Visible_Flag (Inter, True); Set_Interface_Declaration_Chain (Decl, Inter); - Sem_Utils.Compute_Subprogram_Hash (Decl); + Vhdl.Sem_Utils.Compute_Subprogram_Hash (Decl); Add_Decl (Decl); end Create_Edge_Function; @@ -980,7 +980,7 @@ package body Std_Package is Set_Pure_Flag (Function_Now, False); end if; Set_Implicit_Definition (Function_Now, Iir_Predefined_Now_Function); - Sem_Utils.Compute_Subprogram_Hash (Function_Now); + Vhdl.Sem_Utils.Compute_Subprogram_Hash (Function_Now); Add_Decl (Function_Now); end; diff --git a/src/vhdl/translate/ortho_front.adb b/src/vhdl/translate/ortho_front.adb index 208348ef4..3fc6f4e81 100644 --- a/src/vhdl/translate/ortho_front.adb +++ b/src/vhdl/translate/ortho_front.adb @@ -29,8 +29,8 @@ with Std_Package; with Flags; with Configuration; with Translation; -with Sem; -with Sem_Lib; use Sem_Lib; +with Vhdl.Sem; +with Vhdl.Sem_Lib; use Vhdl.Sem_Lib; with Errorout; use Errorout; with Errorout.Console; with GNAT.OS_Lib; @@ -317,7 +317,7 @@ package body Ortho_Front is -- Do late analysis checks. Design := Get_First_Design_Unit (New_Design_File); while Is_Valid (Design) loop - Sem.Sem_Analysis_Checks_List + Vhdl.Sem.Sem_Analysis_Checks_List (Design, Is_Warning_Enabled (Warnid_Delayed_Checks)); Design := Get_Chain (Design); end loop; diff --git a/src/vhdl/translate/trans-chap12.adb b/src/vhdl/translate/trans-chap12.adb index 1e39d3456..1659d54fb 100644 --- a/src/vhdl/translate/trans-chap12.adb +++ b/src/vhdl/translate/trans-chap12.adb @@ -22,8 +22,8 @@ with Std_Package; use Std_Package; with Iirs_Utils; use Iirs_Utils; with Libraries; with Flags; -with Sem; -with Sem_Lib; use Sem_Lib; +with Vhdl.Sem; +with Vhdl.Sem_Lib; use Vhdl.Sem_Lib; with Trans.Chap1; with Trans.Chap2; with Trans.Chap6; @@ -550,7 +550,7 @@ package body Trans.Chap12 is if Flag_Load_All_Design_Units then for I in Design_Units.First .. Design_Units.Last loop Unit := Design_Units.Table (I); - Sem.Sem_Analysis_Checks_List (Unit, False); + Vhdl.Sem.Sem_Analysis_Checks_List (Unit, False); -- There cannot be remaining checks to do. pragma Assert (Get_Analysis_Checks_List (Unit) = Null_Iir_List); diff --git a/src/vhdl/translate/trans-chap2.adb b/src/vhdl/translate/trans-chap2.adb index 01703b842..433d18443 100644 --- a/src/vhdl/translate/trans-chap2.adb +++ b/src/vhdl/translate/trans-chap2.adb @@ -19,7 +19,7 @@ with Std_Names; with Std_Package; use Std_Package; with Errorout; use Errorout; -with Sem_Inst; +with Vhdl.Sem_Inst; with Nodes_Meta; with Iirs_Utils; use Iirs_Utils; with Trans.Chap3; @@ -1377,7 +1377,7 @@ package body Trans.Chap2 is Kind : constant Iir_Kind := Get_Kind (N); Fields : constant Fields_Array := Get_Fields (Kind); F : Fields_Enum; - Orig : constant Iir := Sem_Inst.Get_Origin (N); + Orig : constant Iir := Vhdl.Sem_Inst.Get_Origin (N); pragma Assert (Orig /= Null_Iir); Orig_Info : constant Ortho_Info_Acc := Get_Info (Orig); Info : Ortho_Info_Acc; @@ -1489,7 +1489,7 @@ package body Trans.Chap2 is begin Inter := Chain; while Inter /= Null_Iir loop - Orig := Sem_Inst.Get_Origin (Inter); + Orig := Vhdl.Sem_Inst.Get_Origin (Inter); Orig_Info := Get_Info (Orig); Info := Add_Info (Inter, Orig_Info.Kind); diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb index 4f66723cf..4c5ba5eca 100644 --- a/src/vhdl/translate/translation.adb +++ b/src/vhdl/translate/translation.adb @@ -26,7 +26,7 @@ with Str_Table; with Files_Map; with Iirs_Utils; use Iirs_Utils; with Std_Package; use Std_Package; -with Sem_Specs; +with Vhdl.Sem_Specs; with Libraries; with Std_Names; with Vhdl.Canon; @@ -109,7 +109,7 @@ package body Translation is is -- Look for 'FOREIGN. Attr : constant Iir_Attribute_Value := - Sem_Specs.Find_Attribute_Value (Decl, Std_Names.Name_Foreign); + Vhdl.Sem_Specs.Find_Attribute_Value (Decl, Std_Names.Name_Foreign); pragma Assert (Attr /= Null_Iir); Spec : constant Iir_Attribute_Specification := Get_Attribute_Specification (Attr); diff --git a/src/vhdl/vhdl-canon.adb b/src/vhdl/vhdl-canon.adb index 2675e7cba..2c27e61d7 100644 --- a/src/vhdl/vhdl-canon.adb +++ b/src/vhdl/vhdl-canon.adb @@ -20,9 +20,9 @@ with Iirs_Utils; use Iirs_Utils; with Types; use Types; with Flags; use Flags; with Name_Table; -with Sem; -with Sem_Inst; -with Sem_Specs; +with Vhdl.Sem; +with Vhdl.Sem_Inst; +with Vhdl.Sem_Specs; with Iir_Chains; use Iir_Chains; with PSL.Nodes; with PSL.Rewrites; diff --git a/src/vhdl/vhdl-sem.adb b/src/vhdl/vhdl-sem.adb new file mode 100644 index 000000000..b1875bc1e --- /dev/null +++ b/src/vhdl/vhdl-sem.adb @@ -0,0 +1,3314 @@ +-- Semantic analysis pass. +-- 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 Errorout; use Errorout; +with Std_Package; use Std_Package; +with Ieee.Std_Logic_1164; +with Libraries; +with Std_Names; +with Vhdl.Sem_Scopes; use Vhdl.Sem_Scopes; +with Vhdl.Sem_Expr; use Vhdl.Sem_Expr; +with Vhdl.Sem_Names; use Vhdl.Sem_Names; +with Vhdl.Sem_Specs; use Vhdl.Sem_Specs; +with Vhdl.Sem_Decls; use Vhdl.Sem_Decls; +with Vhdl.Sem_Assocs; use Vhdl.Sem_Assocs; +with Vhdl.Sem_Inst; +with Vhdl.Sem_Lib; use Vhdl.Sem_Lib; +with Iirs_Utils; use Iirs_Utils; +with Flags; use Flags; +with Str_Table; +with Vhdl.Sem_Utils; +with Vhdl.Sem_Stmts; use Vhdl.Sem_Stmts; +with Iir_Chains; +with Xrefs; use Xrefs; + +package body Vhdl.Sem is + -- Forward declarations. + procedure Sem_Context_Clauses (Unit: Iir); + procedure Sem_Block_Configuration + (Block_Conf : Iir_Block_Configuration; Father: Iir); + procedure Sem_Component_Configuration + (Conf : Iir_Component_Configuration; Father : Iir); + + procedure Add_Dependence (Unit : Iir) + is + Targ : constant Iir := Get_Current_Design_Unit; + begin + -- During normal analysis, there is a current design unit. But not + -- during debugging outside of any context. + if Targ = Null_Iir then + return; + end if; + + Add_Dependence (Targ, Unit); + end Add_Dependence; + + -- LRM 1.1 Entity declaration. + procedure Sem_Entity_Declaration (Entity : Iir_Entity_Declaration) is + begin + Xrefs.Xref_Decl (Entity); + Sem_Scopes.Add_Name (Entity); + Set_Visible_Flag (Entity, True); + + Set_Is_Within_Flag (Entity, True); + + -- LRM 10.1 + -- 1. An entity declaration, together with a corresponding architecture + -- body. + Open_Declarative_Region; + + -- Sem generics. + Sem_Interface_Chain (Get_Generic_Chain (Entity), Generic_Interface_List); + + -- Sem ports. + Sem_Interface_Chain (Get_Port_Chain (Entity), Port_Interface_List); + + -- Entity declarative part and concurrent statements. + Sem_Block (Entity); + + Close_Declarative_Region; + Set_Is_Within_Flag (Entity, False); + end Sem_Entity_Declaration; + + -- Get the entity unit for LIBRARY_UNIT (an architecture or a + -- configuration declaration). + -- Return NULL_IIR in case of error (not found, bad library). + function Sem_Entity_Name (Library_Unit : Iir) return Iir + is + Name : Iir; + Library : Iir_Library_Declaration; + Entity : Iir; + begin + -- Get the library of architecture/configuration. + Library := Get_Library + (Get_Design_File (Get_Design_Unit (Library_Unit))); + + -- Resolve the name. + + Name := Get_Entity_Name (Library_Unit); + if Is_Error (Name) then + pragma Assert (Flags.Flag_Force_Analysis); + return Null_Iir; + end if; + + if Get_Kind (Name) = Iir_Kind_Simple_Name then + -- LRM93 10.1 Declarative Region + -- LRM08 12.1 Declarative Region + -- a) An entity declaration, tohether with a corresponding + -- architecture body. + -- + -- GHDL: simple name needs to be handled specially. Because + -- architecture body is in the declarative region of its entity, + -- the entity name is directly visible. But we cannot really use + -- that rule as is, as we don't know which is the entity. + Entity := Load_Primary_Unit + (Library, Get_Identifier (Name), Library_Unit); + if Entity = Null_Iir then + Error_Msg_Sem (+Library_Unit, "entity %n was not analysed", +Name); + return Null_Iir; + end if; + Entity := Get_Library_Unit (Entity); + Set_Named_Entity (Name, Entity); + Xrefs.Xref_Ref (Name, Entity); + else + -- Certainly an expanded name. Use the standard name analysis. + Name := Sem_Denoting_Name (Name); + Set_Entity_Name (Library_Unit, Name); + Entity := Get_Named_Entity (Name); + end if; + + if Get_Kind (Entity) /= Iir_Kind_Entity_Declaration then + Error_Class_Match (Name, "entity"); + return Null_Iir; + end if; + + -- LRM 1.2 Architecture bodies + -- For a given design entity, both the entity declaration and the + -- associated architecture body must reside in the same library. + + -- LRM 1.3 Configuration Declarations + -- For a configuration of a given design entity, both the + -- configuration declaration and the corresponding entity + -- declaration must reside in the same library. + if Get_Library (Get_Design_File (Get_Design_Unit (Entity))) /= Library + then + Error_Msg_Sem + (+Library_Unit, "%n does not reside in %n", (+Entity, +Library)); + return Null_Iir; + end if; + + return Entity; + end Sem_Entity_Name; + + -- LRM 1.2 Architecture bodies. + procedure Sem_Architecture_Body (Arch: Iir_Architecture_Body) + is + Entity_Unit : Iir_Design_Unit; + Entity_Library : Iir_Entity_Declaration; + begin + Xrefs.Xref_Decl (Arch); + -- First, find the entity. + Entity_Library := Sem_Entity_Name (Arch); + if Entity_Library = Null_Iir then + return; + end if; + Entity_Unit := Get_Design_Unit (Entity_Library); + + -- LRM93 11.4 + -- In each case, the second unit depends on the first unit. + -- GHDL: an architecture depends on its entity. + Add_Dependence (Entity_Unit); + + Add_Context_Clauses (Entity_Unit); + + Set_Is_Within_Flag (Arch, True); + Set_Is_Within_Flag (Entity_Library, True); + + -- Makes the entity name visible. + -- FIXME: quote LRM. + Sem_Scopes.Add_Name + (Entity_Library, Get_Identifier (Entity_Library), False); + + -- LRM 10.1 Declarative Region + -- 1. An entity declaration, together with a corresponding architecture + -- body. + Open_Declarative_Region; + Sem_Scopes.Add_Entity_Declarations (Entity_Library); + + -- LRM02 1.2 Architecture bodies + -- For the purpose of interpreting the scope and visibility of the + -- identifier (see 10.2 and 10.3), the declaration of the identifier is + -- considered to occur after the final declarative item of the entity + -- declarative part of the corresponding entity declaration. + -- + -- FIXME: before VHDL-02, an architecture is not a declaration. + Sem_Scopes.Add_Name (Arch, Get_Identifier (Arch), True); + Set_Visible_Flag (Arch, True); + + -- LRM02 10.1 Declarative region + -- The declarative region associated with an architecture body is + -- considered to occur immediatly within the declarative region + -- associated with the entity declaration corresponding to the given + -- architecture body. + -- + -- GHDL: this is only in vhdl-2002. + if Vhdl_Std = Vhdl_02 then + Open_Declarative_Region; + end if; + + Current_Psl_Default_Clock := Null_Iir; + Sem_Block (Arch); + + if Vhdl_Std = Vhdl_02 then + Close_Declarative_Region; + end if; + + Close_Declarative_Region; + Set_Is_Within_Flag (Arch, False); + Set_Is_Within_Flag (Entity_Library, False); + end Sem_Architecture_Body; + + -- Return the real resolver used for (sub) object OBJ. + -- Return NULL_IIR if none. + function Get_Resolver (Obj : Iir) return Iir + is + Obj_Type : Iir; + Res : Iir; + begin + case Get_Kind (Obj) is + when Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Selected_Element => + Res := Get_Resolver (Get_Prefix (Obj)); + if Res /= Null_Iir then + return Res; + end if; + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration => + null; + when Iir_Kind_Object_Alias_Declaration => + return Get_Resolver (Get_Name (Obj)); + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return Get_Resolver (Get_Named_Entity (Obj)); + when others => + Error_Kind ("get_resolved", Obj); + end case; + + Obj_Type := Get_Type (Obj); + if Get_Kind (Obj_Type) in Iir_Kinds_Subtype_Definition then + return Get_Resolution_Indication (Obj_Type); + else + return Null_Iir; + end if; + end Get_Resolver; + + -- Return TRUE iff the actual of ASSOC can be the formal. + -- ASSOC must be an association_element_by_expression. + function Can_Collapse_Signals (Assoc : Iir; Formal : Iir) return Boolean + is + Actual : Iir; + Actual_Res : Iir; + Formal_Res : Iir; + Formal_Base : Iir; + Actual_Base : Iir; + begin + -- If there is a conversion, signals types are not necessarily + -- the same, and sharing is not possible. + -- FIXME: optimize type conversions + -- (unsigned <-> signed <-> std_ulogic_vector <-> ...) + if Get_Actual_Conversion (Assoc) /= Null_Iir + or else Get_Formal_Conversion (Assoc) /= Null_Iir + then + return False; + end if; + + -- Here we may assume formal and actual have the same type and the + -- same lengths. This is caught at elaboration time. + + Actual := Name_To_Object (Get_Actual (Assoc)); + if Actual = Null_Iir then + -- This is an expression. + return False; + end if; + + Formal_Base := Get_Object_Prefix (Formal); + Actual_Base := Get_Object_Prefix (Actual); + + -- If the formal is of mode IN, then it has no driving value, and its + -- effective value is the effective value of the actual. + -- Always collapse in this case. + if Get_Mode (Formal_Base) = Iir_In_Mode then + return True; + end if; + + -- Otherwise, these rules are applied: + -- + -- In this table, E means element, S means signal. + -- Er means the element is resolved, + -- Sr means the signal is resolved (at the signal level). + -- + -- Actual + -- | E,S | Er,S | E,Sr | Er,Sr | + -- ------+-------+-------+-------+-------+ + -- E,S |collap | no(3) | no(3) | no(3) | + -- ------+-------+-------+-------+-------+ + -- Er,S | no(1) |if same| no(2) | no(2) | + -- Formal ------+-------+-------+-------+-------+ + -- E,Sr | no(1) | no(2) |if same| no(4) | + -- ------+-------+-------+-------+-------+ + -- Er,Sr | no(1) | no(2) | no(4) |if same| + -- ------+-------+-------+-------+-------+ + -- + -- Notes: (1): formal may have several sources. + -- (2): resolver is not the same. + -- (3): this prevents to catch several sources error in instance. + -- (4): resolver is not the same, because the types are not the + -- same. + -- + -- Furthermore, signals cannot be collapsed if the kind (none, bus or + -- register) is not the same. + -- + -- Default value: default value is the effective value. + + -- Resolution function. + Actual_Res := Get_Resolver (Actual); + Formal_Res := Get_Resolver (Formal); + + -- If the resolutions are not the same, signals cannot be collapsed. + if Actual_Res /= Formal_Res then + return False; + end if; + + -- If neither the actual nor the formal is resolved, then collapsing is + -- possible. + -- (this is case ES/ES). + if Actual_Res = Null_Iir and Formal_Res = Null_Iir then + return True; + end if; + + -- If the formal can have sources and is guarded, but the actual is + -- not guarded (or has not the same kind of guard), signals cannot + -- be collapsed. + if (Get_Guarded_Signal_Flag (Formal_Base) + /= Get_Guarded_Signal_Flag (Actual_Base)) + or else (Get_Signal_Kind (Formal_Base) + /= Get_Signal_Kind (Actual_Base)) + then + return False; + end if; + + return True; + end Can_Collapse_Signals; + + -- INTER_PARENT contains generics interfaces; + -- ASSOC_PARENT constains generic aspects. + function Sem_Generic_Association_Chain + (Inter_Parent : Iir; Assoc_Parent : Iir) return Boolean + is + El : Iir; + Match : Compatibility_Level; + Assoc_Chain : Iir; + Inter_Chain : Iir; + Miss : Missing_Type; + begin + -- LRM08 6.5.6.2 Generic clauses + -- If no such actual is specified for a given formal generic constant + -- (either because the formal generic is unassociated or because the + -- actual is open), and if a default expression is specified for that + -- generic, the value of this expression is the value of the generic. + -- It is an error if no actual is specified for a given formal generic + -- constant and no default expression is present in the corresponding + -- interface element. + + -- Note: CHECK_MATCH argument of sem_subprogram_arguments must be + -- true if parent is a component instantiation. + case Get_Kind (Assoc_Parent) is + when Iir_Kind_Component_Instantiation_Statement => + -- LRM 9.6 Component Instantiation Statement + -- Each local generic (or subelement or slice thereof) must be + -- associated {VHDL87: exactly}{VHDL93: at most} once. + -- ... + -- Each local port (or subelement or slice therof) must be + -- associated {VHDL87: exactly}{VHDL93: at most} once. + + -- GHDL: for a direct instantiation, follow rules of + -- LRM 1.1.1.1 Generic and LRM 1.1.1.2 Ports. + -- The difference between 87 and 93 is simply a clarification: + -- missing association are left open, but need a default + -- expression in the formal declaration. + Miss := Missing_Generic; + when Iir_Kind_Binding_Indication => + -- LRM 5.2.1.2 Generic map and port map aspects + Miss := Missing_Allowed; + when Iir_Kind_Block_Header => + Miss := Missing_Generic; + when Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Interface_Package_Declaration + | Iir_Kind_Package_Header => + -- LRM08 4.9 + -- Each formal generic (or member thereof) shall be associated + -- at most once. + Miss := Missing_Generic; + when others => + Error_Kind ("sem_generic_association_list", Assoc_Parent); + end case; + + -- The generics + Inter_Chain := Get_Generic_Chain (Inter_Parent); + Assoc_Chain := Get_Generic_Map_Aspect_Chain (Assoc_Parent); + + -- Extract non-object associations, as the actual cannot be analyzed + -- as an expression. + Assoc_Chain := Extract_Non_Object_Association (Assoc_Chain, Inter_Chain); + Set_Generic_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain); + + if not Sem_Actual_Of_Association_Chain (Assoc_Chain) then + return False; + end if; + + Sem_Association_Chain + (Inter_Chain, Assoc_Chain, True, Miss, Assoc_Parent, Match); + Set_Generic_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain); + if Match = Not_Compatible then + return False; + end if; + + -- LRM 5.2.1.2 Generic map and port map aspects + -- An actual associated with a formal generic map aspect must be an + -- expression or the reserved word open; + El := Assoc_Chain; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Association_Element_By_Expression => + Check_Read (Get_Actual (El)); + when Iir_Kind_Association_Element_Open + | Iir_Kind_Association_Element_By_Individual + | Iir_Kind_Association_Element_Package + | Iir_Kind_Association_Element_Type + | Iir_Kind_Association_Element_Subprogram => + null; + when others => + Error_Kind ("sem_generic_association_chain(1)", El); + end case; + El := Get_Chain (El); + end loop; + + return True; + end Sem_Generic_Association_Chain; + + procedure Sem_Generic_Association_Chain + (Inter_Parent : Iir; Assoc_Parent : Iir) + is + Res : Boolean; + pragma Unreferenced (Res); + begin + Res := Sem_Generic_Association_Chain (Inter_Parent, Assoc_Parent); + end Sem_Generic_Association_Chain; + + -- INTER_PARENT contains ports interfaces; + -- ASSOC_PARENT constains ports map aspects. + procedure Sem_Port_Association_Chain + (Inter_Parent : Iir; Assoc_Parent : Iir) + is + Assoc : Iir; + Actual : Iir; + Prefix : Iir; + Object : Iir; + Match : Compatibility_Level; + Assoc_Chain : Iir; + Miss : Missing_Type; + Inter : Iir; + Formal : Iir; + Formal_Base : Iir; + begin + -- Note: CHECK_MATCH argument of sem_subprogram_arguments must be + -- true if parent is a component instantiation. + case Get_Kind (Assoc_Parent) is + when Iir_Kind_Component_Instantiation_Statement => + -- LRM 9.6 Component Instantiation Statement + -- Each local generic (or subelement or slice thereof) must be + -- associated {VHDL87: exactly}{VHDL93: at most} once. + -- ... + -- Each local port (or subelement or slice therof) must be + -- associated {VHDL87: exactly}{VHDL93: at most} once. + + -- GHDL: for a direct instantiation, follow rules of + -- LRM 1.1.1.1 Generic and LRM 1.1.1.2 Ports. + Miss := Missing_Port; + when Iir_Kind_Binding_Indication => + -- LRM 5.2.1.2 Generic map and port map aspects + Miss := Missing_Allowed; + when Iir_Kind_Block_Header => + -- FIXME: it is possible to have port unassociated ? + Miss := Missing_Port; + when others => + Error_Kind ("sem_port_association_list", Assoc_Parent); + end case; + + -- The ports + Assoc_Chain := Get_Port_Map_Aspect_Chain (Assoc_Parent); + if not Sem_Actual_Of_Association_Chain (Assoc_Chain) then + return; + end if; + Sem_Association_Chain (Get_Port_Chain (Inter_Parent), Assoc_Chain, + True, Miss, Assoc_Parent, Match); + Set_Port_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain); + if Match = Not_Compatible then + return; + end if; + + -- LRM 5.2.1.2 Generic map and port map aspects + -- [...]; an actual associated with a formal port in a port map aspect + -- must be a signal, an expression, or the reserved word open. + -- + -- Certain restriction apply to the actual associated with a formal in + -- a port map aspect; these restrictions are described in 1.1.1.2 + + -- LRM93 1.1.1.2 + -- The actual, if a port or signal, must be denoted by a static name. + -- The actual, if an expression, must be a globally static expression. + Assoc := Assoc_Chain; + Inter := Get_Port_Chain (Inter_Parent); + while Assoc /= Null_Iir loop + Formal := Get_Association_Formal (Assoc, Inter); + Formal_Base := Get_Interface_Of_Formal (Formal); + + if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression then + Actual := Get_Actual (Assoc); + -- There has been an error, exit from the loop. + exit when Actual = Null_Iir; + Object := Name_To_Object (Actual); + if Is_Valid (Object) and then Is_Signal_Object (Object) then + -- Port or signal. + Set_Collapse_Signal_Flag + (Assoc, Can_Collapse_Signals (Assoc, Formal)); + if Get_Name_Staticness (Object) < Globally then + Error_Msg_Sem (+Actual, "actual must be a static name"); + end if; + Check_Port_Association_Bounds_Restrictions + (Formal, Actual, Assoc); + Prefix := Get_Object_Prefix (Object); + if Get_Kind (Prefix) = Iir_Kind_Interface_Signal_Declaration + then + declare + P : Boolean; + pragma Unreferenced (P); + begin + P := Check_Port_Association_Mode_Restrictions + (Formal_Base, Prefix, Assoc); + end; + end if; + else + -- Expression. + Set_Collapse_Signal_Flag (Assoc, False); + + pragma Assert (Is_Null (Get_Actual_Conversion (Assoc))); + if Flags.Vhdl_Std >= Vhdl_93c then + -- LRM93 1.1.1.2 Ports + -- Moreover, the ports of a block may be associated + -- with an expression, in order to provide these ports + -- with constant driving values; such ports must be + -- of mode in. + if Get_Mode (Formal_Base) /= Iir_In_Mode then + Error_Msg_Sem + (+Assoc, "only 'in' ports may be associated with " + & "expression"); + end if; + + -- LRM93 1.1.1.2 Ports + -- The actual, if an expression, must be a globally + -- static expression. + if Get_Expr_Staticness (Actual) < Globally then + Error_Msg_Sem + (+Actual, + "actual expression must be globally static"); + end if; + else + Error_Msg_Sem + (+Assoc, + "cannot associate ports with expression in vhdl87"); + end if; + end if; + end if; + Next_Association_Interface (Assoc, Inter); + end loop; + end Sem_Port_Association_Chain; + + -- INTER_PARENT contains generics and ports interfaces; + -- ASSOC_PARENT constains generics and ports map aspects. + procedure Sem_Generic_Port_Association_Chain + (Inter_Parent : Iir; Assoc_Parent : Iir) + is + Res : Boolean; + pragma Unreferenced (Res); + begin + Sem_Generic_Association_Chain (Inter_Parent, Assoc_Parent); + Sem_Port_Association_Chain (Inter_Parent, Assoc_Parent); + end Sem_Generic_Port_Association_Chain; + + -- LRM 1.3 Configuration Declarations. + procedure Sem_Configuration_Declaration (Decl: Iir) + is + Entity: Iir_Entity_Declaration; + Entity_Unit : Iir_Design_Unit; + begin + Xref_Decl (Decl); + + -- LRM 1.3 + -- The entity name identifies the name of the entity declaration that + -- defines the design entity at the apex of the design hierarchy. + Entity := Sem_Entity_Name (Decl); + if Entity = Null_Iir then + return; + end if; + Entity_Unit := Get_Design_Unit (Entity); + + -- LRM 11.4 + -- A primary unit whose name is referenced within a given design unit + -- must be analyzed prior to the analysis of the given design unit. + Add_Dependence (Entity_Unit); + + Sem_Scopes.Add_Name (Decl); + + Set_Visible_Flag (Decl, True); + + -- LRM 10.1 Declarative Region + -- 2. A configuration declaration. + Open_Declarative_Region; + + -- LRM93 10.2 + -- In addition to the above rules, the scope of any declaration that + -- includes the end of the declarative part of a given block (whether + -- it be an external block defined by a design entity or an internal + -- block defined by a block statement) extends into a configuration + -- declaration that configures the given block. + Add_Context_Clauses (Entity_Unit); + Sem_Scopes.Add_Entity_Declarations (Entity); + + Sem_Declaration_Chain (Decl); + -- GHDL: no need to check for missing subprogram bodies, since they are + -- not allowed in configuration declarations. + + Sem_Block_Configuration (Get_Block_Configuration (Decl), Decl); + Close_Declarative_Region; + end Sem_Configuration_Declaration; + + -- Analyze the block specification of a block statement or of a generate + -- statement. Return the corresponding block statement, generate + -- statement body, or Null_Iir in case of error. + function Sem_Block_Specification_Of_Statement + (Block_Conf : Iir_Block_Configuration; Father : Iir) return Iir + is + Block_Spec : Iir; + Block_Name : Iir; + Block_Stmts : Iir; + Prev : Iir_Block_Configuration; + Block : Iir; + Res : Iir; + Assoc : Iir; + Clause : Iir; + Gen_Spec : Iir; + begin + Block_Spec := Get_Block_Specification (Block_Conf); + case Get_Kind (Block_Spec) is + when Iir_Kind_Simple_Name => + Block_Name := Block_Spec; + when Iir_Kind_Parenthesis_Name + | Iir_Kind_Slice_Name => + Block_Name := Get_Prefix (Block_Spec); + when others => + Error_Msg_Sem (+Block_Spec, "label expected"); + return Null_Iir; + end case; + + -- Analyze the label and generate specification. + Block_Name := Sem_Denoting_Name (Block_Name); + Block := Get_Named_Entity (Block_Name); + case Get_Kind (Block) is + when Iir_Kind_Block_Statement => + if Get_Kind (Block_Spec) /= Iir_Kind_Simple_Name then + Error_Msg_Sem (+Block_Spec, + "label does not denote a generate statement"); + end if; + Set_Block_Specification (Block_Conf, Block_Name); + Prev := Get_Block_Block_Configuration (Block); + Res := Block; + + when Iir_Kind_For_Generate_Statement => + Res := Get_Generate_Statement_Body (Block); + Set_Named_Entity (Block_Name, Res); + Prev := Get_Generate_Block_Configuration (Res); + + case Get_Kind (Block_Spec) is + when Iir_Kind_Simple_Name => + Set_Block_Specification (Block_Conf, Block_Name); + when Iir_Kind_Parenthesis_Name => + Block_Spec := Sem_Index_Specification + (Block_Spec, + Get_Type (Get_Parameter_Specification (Block))); + if Block_Spec /= Null_Iir then + Set_Prefix (Block_Spec, Block_Name); + Set_Block_Specification (Block_Conf, Block_Spec); + end if; + when others => + raise Internal_Error; + end case; + + when Iir_Kind_If_Generate_Statement => + case Get_Kind (Block_Spec) is + when Iir_Kind_Simple_Name => + -- LRM08 3.4.2 Block configuration + -- If no generate specification appears in such a block + -- configuration, then it applies to exactly one of the + -- following sets of blocks: + -- [...] + -- - The implicit block generated by the corresponding + -- generate statement, if and only if the corresponding + -- generate is an if generate statement and if the first + -- condition after IF evaluates to TRUE. + Res := Get_Generate_Statement_Body (Block); + + -- LRM08 3.4.2 Block configuration + -- If the block specification of a block configuration + -- contains a generate statement label that denotes an if + -- generate statement, and if the first condition after IF + -- has an alternative label, then it is an error if the + -- generate statement label does not contain a generate + -- specification that is an alternative label. + if Get_Has_Label (Res) then + Error_Msg_Sem + (+Block_Spec, + "alternative label required in block specification"); + end if; + + Set_Block_Specification (Block_Conf, Block_Name); + + when Iir_Kind_Parenthesis_Name => + if Vhdl_Std < Vhdl_08 then + Error_Msg_Sem + (+Block_Spec, + "alternative label only allowed by vhdl08"); + return Null_Iir; + end if; + Assoc := Get_Association_Chain (Block_Spec); + pragma Assert + (Get_Kind (Assoc) + = Iir_Kind_Association_Element_By_Expression); + Gen_Spec := Get_Actual (Assoc); + if Get_Kind (Gen_Spec) /= Iir_Kind_Simple_Name then + Error_Msg_Sem + (+Gen_Spec, + "alternative label expected for if-generate"); + return Null_Iir; + end if; + -- Search label. + Clause := Block; + while Clause /= Null_Iir loop + Res := Get_Generate_Statement_Body (Clause); + exit when Get_Alternative_Label (Res) + = Get_Identifier (Gen_Spec); + Clause := Get_Generate_Else_Clause (Clause); + end loop; + if Clause = Null_Iir then + Error_Msg_Sem + (+Gen_Spec, + "alternative label %i not found for if-generate", + +Gen_Spec); + return Null_Iir; + end if; + Set_Named_Entity (Block_Spec, Res); + Xref_Ref (Gen_Spec, Res); + Set_Prefix (Block_Spec, Block_Name); + Set_Block_Specification (Block_Conf, Block_Spec); + + when others => + raise Internal_Error; + end case; + + Set_Named_Entity (Block_Name, Res); + Prev := Get_Generate_Block_Configuration (Res); + + when Iir_Kind_Case_Generate_Statement => + case Get_Kind (Block_Spec) is + when Iir_Kind_Simple_Name => + -- LRM08 3.4.2 Block configuration + -- If no generate specification appears in such a block + -- configuration, [...] + -- GHDL: doesn't apply to case generate statement + Error_Msg_Sem + (+Block_Spec, + "missing alternative label for a case-generate"); + return Null_Iir; + when Iir_Kind_Parenthesis_Name => + Assoc := Get_Association_Chain (Block_Spec); + pragma Assert + (Get_Kind (Assoc) + = Iir_Kind_Association_Element_By_Expression); + Gen_Spec := Get_Actual (Assoc); + if Get_Kind (Gen_Spec) /= Iir_Kind_Simple_Name then + Error_Msg_Sem + (+Gen_Spec, + "alternative label expected for case-generate"); + return Null_Iir; + end if; + -- Search label. + Clause := Get_Case_Statement_Alternative_Chain (Block); + while Clause /= Null_Iir loop + Res := Get_Associated_Block (Clause); + exit when Get_Alternative_Label (Res) + = Get_Identifier (Gen_Spec); + Clause := Get_Chain (Clause); + end loop; + if Clause = Null_Iir then + Error_Msg_Sem + (+Gen_Spec, + "alternative label %i not found for case-generate", + +Gen_Spec); + return Null_Iir; + end if; + Set_Named_Entity (Block_Spec, Res); + Xref_Ref (Gen_Spec, Res); + Set_Prefix (Block_Spec, Block_Name); + Set_Block_Specification (Block_Conf, Block_Spec); + + when others => + raise Internal_Error; + end case; + + Set_Named_Entity (Block_Name, Res); + Prev := Get_Generate_Block_Configuration (Res); + + when others => + Error_Msg_Sem (+Block_Conf, + "block or generate statement label expected"); + return Null_Iir; + end case; + + -- LRM93 1.3.1 / LRM08 3.4.2 Block configuration + -- [...], and the label must denote a block statement or generate + -- statement that is contained immediatly within the block denoted by + -- the block specification of the containing block configuration. + Block_Stmts := Get_Concurrent_Statement_Chain + (Get_Block_From_Block_Specification + (Get_Block_Specification (Father))); + if not Is_In_Chain (Block_Stmts, Block) then + Error_Msg_Sem (+Block_Conf, + "label does not denotes an inner block statement"); + return Null_Iir; + end if; + + case Get_Kind (Block) is + when Iir_Kind_Block_Statement => + -- LRM93 1.3 + -- It is an error if, in a given block configuration, more than + -- one configuration item is defined for the same block [or + -- component instance]. + if Prev /= Null_Iir then + Error_Msg_Sem + (+Block_Conf, + "%n was already configured at %l", (+Block, +Prev)); + return Null_Iir; + end if; + Set_Block_Block_Configuration (Res, Block_Conf); + + when Iir_Kind_If_Generate_Statement + | Iir_Kind_Case_Generate_Statement => + -- LRM93 1.3 + -- It is an error if, in a given block configuration, more than + -- one configuration item is defined for the same block [or + -- component instance]. + if Prev /= Null_Iir then + Error_Msg_Sem + (+Block_Conf, + "%n was already configured at %l", (+Block, +Prev)); + return Null_Iir; + end if; + Set_Generate_Block_Configuration (Res, Block_Conf); + + when Iir_Kind_For_Generate_Statement => + -- LRM93 1.3 + -- For any name that is the label of a generate statement + -- immediately wihin a given block, one or more corresponding + -- block configuration may appear as configuration items + -- immediately within a block configuration corresponding to the + -- given block. + -- GHDL: keep them in a linked list, but don't try to detect + -- duplicate as values may not be static. FIXME: try for + -- static values only ? + Set_Prev_Block_Configuration (Block_Conf, Prev); + Set_Generate_Block_Configuration (Res, Block_Conf); + when others => + raise Internal_Error; + end case; + return Res; + end Sem_Block_Specification_Of_Statement; + + -- LRM 1.3.1 Block Configuration. + -- FATHER is the block_configuration, configuration_declaration, + -- component_configuration containing the block_configuration BLOCK_CONF. + procedure Sem_Block_Configuration + (Block_Conf : Iir_Block_Configuration; Father: Iir) + is + El : Iir; + Block : Iir; + begin + case Get_Kind (Father) is + when Iir_Kind_Configuration_Declaration => + -- LRM93 1.3.1 + -- If a block configuration appears immediately within a + -- configuration declaration, then the block specification of that + -- block configuration must be an architecture name, and that + -- architecture name must denote a design entity body whose + -- interface is defined by the entity declaration denoted by the + -- entity name of the enclosing configuration declaration. + declare + Block_Spec : Iir; + Arch : Iir_Architecture_Body; + Design: Iir_Design_Unit; + begin + Block_Spec := Get_Block_Specification (Block_Conf); + -- FIXME: handle selected name. + if Get_Kind (Block_Spec) /= Iir_Kind_Simple_Name then + Error_Msg_Sem (+Block_Spec, "architecture name expected"); + return; + end if; + -- LRM 10.3 rule b) + -- For an architecture body associated with a given entity + -- declaration: at the place of the block specification in a + -- block configuration for an external block whose interface + -- is defined by that entity declaration. + Design := Load_Secondary_Unit + (Get_Design_Unit (Get_Entity (Father)), + Get_Identifier (Block_Spec), + Block_Conf); + if Design = Null_Iir then + Error_Msg_Sem + (+Block_Conf, "no architecture %i", +Block_Spec); + return; + end if; + Arch := Get_Library_Unit (Design); + Set_Named_Entity (Block_Spec, Arch); + Xref_Ref (Block_Spec, Arch); + Block := Arch; + Add_Dependence (Design); + end; + + when Iir_Kind_Component_Configuration => + -- LRM93 1.3.1 + -- If a block configuration appears immediately within a component + -- configuration, then the corresponding components must be + -- fully bound, the block specification of that block + -- configuration must be an architecture name, and that + -- architecture name must denote the same architecture body as + -- that to which the corresponding components are bound. + declare + Block_Spec : Iir; + Arch : Iir_Architecture_Body; + Design: Iir_Design_Unit; + Entity_Aspect : Iir; + Entity : Iir; + Comp_Arch : Iir; + begin + Entity_Aspect := + Get_Entity_Aspect (Get_Binding_Indication (Father)); + if Entity_Aspect = Null_Iir or else + Get_Kind (Entity_Aspect) /= Iir_Kind_Entity_Aspect_Entity + then + Error_Msg_Sem + (+Block_Conf, "corresponding component not fully bound"); + end if; + + Block_Spec := Get_Block_Specification (Block_Conf); + -- FIXME: handle selected name. + if Get_Kind (Block_Spec) /= Iir_Kind_Simple_Name then + Error_Msg_Sem (+Block_Spec, "architecture name expected"); + return; + end if; + + Comp_Arch := Get_Architecture (Entity_Aspect); + if Comp_Arch /= Null_Iir then + pragma Assert (Get_Kind (Comp_Arch) = Iir_Kind_Simple_Name); + if Get_Identifier (Comp_Arch) /= Get_Identifier (Block_Spec) + then + Error_Msg_Sem + (+Block_Spec, "block specification name is different " + & "from component architecture name"); + return; + end if; + end if; + + Entity := Get_Entity (Entity_Aspect); + if Entity = Null_Iir then + return; + end if; + + Design := Load_Secondary_Unit (Get_Design_Unit (Entity), + Get_Identifier (Block_Spec), + Block_Conf); + if Design = Null_Iir then + Error_Msg_Sem + (+Block_Conf, "no architecture %i", +Block_Spec); + return; + end if; + Add_Dependence (Design); + Arch := Get_Library_Unit (Design); + Set_Named_Entity (Block_Spec, Arch); + Xref_Ref (Block_Spec, Arch); + Block := Arch; + end; + + when Iir_Kind_Block_Configuration => + -- LRM93 1.3.1 / LRM08 3.4.2 Block configuration + -- If a block configuration appears immediately within another + -- block configuration, then the block specification of the + -- contained block configuration must be a block statement or + -- generate statement label, and the label must denote a block + -- statement or generate statement that is contained immediatly + -- within the block denoted by the block specification of the + -- containing block configuration. + Block := Sem_Block_Specification_Of_Statement (Block_Conf, Father); + if Block = Null_Iir then + return; + end if; + + when others => + Error_Kind ("sem_block_configuration", Father); + end case; + + -- LRM93 §10.1 + -- 10. A block configuration + Sem_Scopes.Open_Scope_Extension; + + -- LRM 10.3 + -- In addition, any declaration that is directly visible at the end of + -- the declarative part of a given block is directly visible in a block + -- configuration that configure the given block. This rule holds unless + -- a use clause that makes a homograph of the declaration potentially + -- visible (see 10.4) appears in the corresponding configuration + -- declaration, and if the scope of that use clause encompasses all or + -- part of those configuration items. If such a use clase appears, then + -- the declaration will be directly visible within the corresponding + -- configuration items, except at hose places that fall within the scope + -- of the additional use clause. At such places, neither name will be + -- directly visible. + -- FIXME: handle use clauses. + Sem_Scopes.Extend_Scope_Of_Block_Declarations (Block); + + declare + El : Iir; + begin + El := Get_Declaration_Chain (Block_Conf); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Use_Clause => + Sem_Use_Clause (El); + when others => + -- Parse checks there are only use clauses. + raise Internal_Error; + end case; + El := Get_Chain (El); + end loop; + end; + + -- VHDL 87: do not remove configuration specification in generate stmts. + Clear_Instantiation_Configuration (Block, False); + + El := Get_Configuration_Item_Chain (Block_Conf); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Block_Configuration => + Sem_Block_Configuration (El, Block_Conf); + when Iir_Kind_Component_Configuration => + Sem_Component_Configuration (El, Block_Conf); + when others => + Error_Kind ("sem_block_configuration(2)", El); + end case; + El := Get_Chain (El); + end loop; + Sem_Scopes.Close_Scope_Extension; + end Sem_Block_Configuration; + + -- Check that incremental binding of the component configuration CONF only + -- rebinds non associated ports of each instantiations of CONFIGURED_BLOCK + -- which CONF applies to. + procedure Check_Incremental_Binding (Configured_Block : Iir; Conf : Iir) + is + Comp : constant Iir := Get_Named_Entity (Get_Component_Name (Conf)); + Inter_Chain : constant Iir := Get_Port_Chain (Comp); + Binding : constant Iir := Get_Binding_Indication (Conf); + Inst : Iir; + begin + -- Check each component instantiation of the block configured by CONF. + Inst := Get_Concurrent_Statement_Chain (Configured_Block); + while Inst /= Null_Iir loop + if Get_Kind (Inst) = Iir_Kind_Component_Instantiation_Statement + and then Get_Component_Configuration (Inst) = Conf + then + -- Check this instantiation. + declare + Primary_Binding : constant Iir := Get_Binding_Indication + (Get_Configuration_Specification (Inst)); + F_Chain : constant Iir := + Get_Port_Map_Aspect_Chain (Primary_Binding); + S_El : Iir; + S_Inter : Iir; + F_El : Iir; + Formal : Iir; + begin + S_El := Get_Port_Map_Aspect_Chain (Binding); + S_Inter := Inter_Chain; + while S_El /= Null_Iir loop + -- Find S_EL formal in F_CHAIN. + Formal := Get_Association_Interface (S_El, S_Inter); + F_El := Find_First_Association_For_Interface + (F_Chain, Inter_Chain, Formal); + if F_El /= Null_Iir + and then + Get_Kind (F_El) /= Iir_Kind_Association_Element_Open + then + Error_Msg_Sem + (+S_El, + "%n already associated in primary binding", +Formal); + end if; + Next_Association_Interface (S_El, S_Inter); + end loop; + end; + end if; + Inst := Get_Chain (Inst); + end loop; + end Check_Incremental_Binding; + + -- LRM 1.3.2 + procedure Sem_Component_Configuration + (Conf : Iir_Component_Configuration; Father : Iir) + is + Block : Iir; + Configured_Block : Iir; + Binding : Iir; + Entity : Iir_Design_Unit; + Comp : Iir_Component_Declaration; + Primary_Entity_Aspect : Iir; + begin + -- LRM 10.1 Declarative Region + -- 11. A component configuration. + Open_Declarative_Region; + + -- LRM93 10.2 + -- If a component configuration appears as a configuration item + -- immediatly within a block configuration that configures a given + -- block, and the scope of a given declaration includes the end of the + -- declarative part of that block, then the scope of the given + -- declaration extends from the beginning to the end of the + -- declarative region associated with the given component configuration. + -- GHDL: this is for labels of component instantiation statements, and + -- for local ports and generics of the component. + if Get_Kind (Father) = Iir_Kind_Block_Configuration then + Configured_Block := Get_Block_Specification (Father); + pragma Assert (Get_Kind (Configured_Block) /= Iir_Kind_Design_Unit); + Configured_Block := + Get_Block_From_Block_Specification (Configured_Block); + Sem_Scopes.Extend_Scope_Of_Block_Declarations (Configured_Block); + else + -- Can a component configuration not be just inside a block + -- configuration ? + raise Internal_Error; + end if; + -- FIXME: this is wrong (all declarations should be considered). + Sem_Component_Specification + (Configured_Block, Conf, Primary_Entity_Aspect); + + Comp := Get_Named_Entity (Get_Component_Name (Conf)); + if Get_Kind (Comp) /= Iir_Kind_Component_Declaration then + -- There has been an error in sem_component_specification. + -- Leave here. + Close_Declarative_Region; + return; + end if; + + -- FIXME: (todo) + -- If a given component instance is unbound in the corresponding block, + -- then any explicit component configuration for that instance that does + -- not contain an explicit binding indication will contain an implicit, + -- default binding indication (see 5.2.2). Similarly, if a given + -- component instance is unbound in the corresponding block, then any + -- implicit component configuration for that instance will contain an + -- implicit, default binding indication. + Open_Declarative_Region; + Sem_Scopes.Add_Component_Declarations (Comp); + Binding := Get_Binding_Indication (Conf); + if Binding /= Null_Iir then + Sem_Binding_Indication (Binding, Conf, Primary_Entity_Aspect); + + if Primary_Entity_Aspect /= Null_Iir then + -- LRM93 5.2.1 Binding Indication + -- It is an error if a formal port appears in the port map aspect + -- of the incremental binding indication and it is a formal + -- port that is associated with an actual other than OPEN in one + -- of the primary binding indications. + Check_Incremental_Binding (Configured_Block, Conf); + end if; + elsif Primary_Entity_Aspect = Null_Iir then + -- LRM93 5.2.1 + -- If the generic map aspect or port map aspect of a primary binding + -- indication is not present, then the default rules as described + -- in 5.2.2 apply. + + -- Create a default binding indication. + Entity := Get_Visible_Entity_Declaration (Comp); + Binding := Sem_Create_Default_Binding_Indication + (Comp, Entity, Conf, False, False); + + if Binding /= Null_Iir then + -- Remap to defaults. + Set_Default_Entity_Aspect (Binding, Get_Entity_Aspect (Binding)); + Set_Entity_Aspect (Binding, Null_Iir); + + Set_Binding_Indication (Conf, Binding); + end if; + end if; + Close_Declarative_Region; + + -- External block. + Block := Get_Block_Configuration (Conf); + if Block /= Null_Iir and then Binding /= Null_Iir then + Sem_Block_Configuration (Block, Conf); + end if; + Close_Declarative_Region; + end Sem_Component_Configuration; + + function Are_Trees_Chain_Equal (Left, Right : Iir) return Boolean + is + El_Left, El_Right : Iir; + begin + if Left = Right then + return True; + end if; + El_Left := Left; + El_Right := Right; + loop + if El_Left = Null_Iir and El_Right = Null_Iir then + return True; + end if; + if El_Left = Null_Iir or El_Right = Null_Iir then + return False; + end if; + if not Are_Trees_Equal (El_Left, El_Right) then + return False; + end if; + El_Left := Get_Chain (El_Left); + El_Right := Get_Chain (El_Right); + end loop; + end Are_Trees_Chain_Equal; + + -- Return TRUE iff LEFT and RIGHT are (in depth) equal. + -- This corresponds to conformance rules, LRM93 2.7 + function Are_Trees_Equal (Left, Right : Iir) return Boolean + is + El_Left, El_Right : Iir; + begin + -- Short-cut to speed up. + if Left = Right then + return True; + end if; + + -- Handle null_iir. + if Left = Null_Iir or Right = Null_Iir then + -- Note: LEFT *xor* RIGHT is null_iir. + return False; + end if; + + -- LRM 2.7 Conformance Rules + -- A simple name can be replaced by an expanded name in which this + -- simple name is the selector, if and only if at both places the + -- meaning of the simple name is given by the same declaration. + case Get_Kind (Left) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + case Get_Kind (Right) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return Are_Trees_Equal (Get_Named_Entity (Left), + Get_Named_Entity (Right)); + when others => + return False; + end case; + when others => + null; + end case; + + -- If nodes are not of the same kind, then they are not equals! + if Get_Kind (Left) /= Get_Kind (Right) then + return False; + end if; + + case Get_Kind (Left) is + when Iir_Kind_Procedure_Declaration => + return Are_Trees_Chain_Equal + (Get_Interface_Declaration_Chain (Left), + Get_Interface_Declaration_Chain (Right)); + when Iir_Kind_Function_Declaration => + if not Are_Trees_Equal (Get_Return_Type (Left), + Get_Return_Type (Right)) + then + return False; + end if; + if Get_Pure_Flag (Left) /= Get_Pure_Flag (Right) then + return False; + end if; + if not Are_Trees_Chain_Equal + (Get_Interface_Declaration_Chain (Left), + Get_Interface_Declaration_Chain (Right)) + then + return False; + end if; + return True; + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration => + if Get_Identifier (Left) /= Get_Identifier (Right) then + return False; + end if; + if Get_Has_Mode (Left) /= Get_Has_Mode (Right) + or else Get_Has_Class (Left) /= Get_Has_Class (Right) + or else (Get_Has_Identifier_List (Left) + /= Get_Has_Identifier_List (Right)) + or else Get_Mode (Left) /= Get_Mode (Right) + then + return False; + end if; + if not Are_Trees_Equal (Get_Type (Left), Get_Type (Right)) then + return False; + end if; + El_Left := Get_Default_Value (Left); + El_Right := Get_Default_Value (Right); + if (El_Left = Null_Iir) xor (El_Right = Null_Iir) then + return False; + end if; + if El_Left /= Null_Iir + and then Are_Trees_Equal (El_Left, El_Right) = False + then + return False; + end if; + return True; + + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + if Get_Base_Type (Left) /= Get_Base_Type (Right) then + return False; + end if; + if Get_Type_Declarator (Left) /= Get_Type_Declarator (Right) then + return False; + end if; + if not Are_Trees_Equal (Get_Resolution_Indication (Left), + Get_Resolution_Indication (Right)) + then + return False; + end if; + if Are_Trees_Equal (Get_Range_Constraint (Left), + Get_Range_Constraint (Right)) = False + then + return False; + end if; + return True; + when Iir_Kind_Array_Subtype_Definition => + if Get_Base_Type (Left) /= Get_Base_Type (Right) then + return False; + end if; + if not Are_Trees_Equal (Get_Resolution_Indication (Left), + Get_Resolution_Indication (Right)) + then + return False; + end if; + declare + L_Left : constant Iir_Flist := Get_Index_Subtype_List (Left); + L_Right : constant Iir_Flist := Get_Index_Subtype_List (Right); + begin + if Get_Nbr_Elements (L_Left) /= Get_Nbr_Elements (L_Right) then + return False; + end if; + for I in Flist_First .. Flist_Last (L_Left) loop + El_Left := Get_Nth_Element (L_Left, I); + El_Right := Get_Nth_Element (L_Right, I); + if not Are_Trees_Equal (El_Left, El_Right) then + return False; + end if; + end loop; + end; + return True; + when Iir_Kind_Record_Subtype_Definition => + if Get_Base_Type (Left) /= Get_Base_Type (Right) then + return False; + end if; + if not Are_Trees_Equal (Get_Resolution_Indication (Left), + Get_Resolution_Indication (Right)) + then + return False; + end if; + declare + L_Left : constant Iir_Flist := + Get_Elements_Declaration_List (Left); + L_Right : constant Iir_Flist := + Get_Elements_Declaration_List (Right); + begin + for I in Flist_First .. Flist_Last (L_Left) loop + El_Left := Get_Nth_Element (L_Left, I); + El_Right := Get_Nth_Element (L_Right, I); + if not Are_Trees_Equal (El_Left, El_Right) then + return False; + end if; + end loop; + end; + return True; + + when Iir_Kind_Integer_Literal => + if Get_Value (Left) /= Get_Value (Right) then + return False; + end if; + return Are_Trees_Equal (Get_Literal_Origin (Left), + Get_Literal_Origin (Right)); + when Iir_Kind_Enumeration_Literal => + if Get_Enum_Pos (Left) /= Get_Enum_Pos (Right) then + return False; + end if; + return Are_Trees_Equal (Get_Literal_Origin (Left), + Get_Literal_Origin (Right)); + when Iir_Kind_Physical_Int_Literal => + if Get_Value (Left) /= Get_Value (Right) + or else not Are_Trees_Equal (Get_Unit_Name (Left), + Get_Unit_Name (Right)) + then + return False; + end if; + return Are_Trees_Equal (Get_Literal_Origin (Left), + Get_Literal_Origin (Right)); + when Iir_Kind_Physical_Fp_Literal => + if Get_Fp_Value (Left) /= Get_Fp_Value (Right) + or else not Are_Trees_Equal (Get_Unit_Name (Left), + Get_Unit_Name (Right)) + then + return False; + end if; + return Are_Trees_Equal (Get_Literal_Origin (Left), + Get_Literal_Origin (Right)); + when Iir_Kind_Unit_Declaration => + return Left = Right; + when Iir_Kind_Floating_Point_Literal => + if Get_Fp_Value (Left) /= Get_Fp_Value (Right) then + return False; + end if; + return Are_Trees_Equal (Get_Literal_Origin (Left), + Get_Literal_Origin (Right)); + + when Iir_Kinds_Dyadic_Operator => + return Are_Trees_Equal (Get_Left (Left), Get_Left (Right)) + and then Are_Trees_Equal (Get_Right (Left), Get_Right (Right)); + when Iir_Kinds_Monadic_Operator => + return Are_Trees_Equal (Get_Operand (Left), Get_Operand (Right)); + + when Iir_Kind_Function_Call => + return Are_Trees_Equal (Get_Prefix (Left), Get_Prefix (Right)) + and then + Are_Trees_Chain_Equal (Get_Parameter_Association_Chain (Left), + Get_Parameter_Association_Chain (Right)); + + when Iir_Kind_Association_Element_By_Expression => + return Are_Trees_Equal (Get_Actual (Left), Get_Actual (Right)) + and then Are_Trees_Equal (Get_Formal (Left), Get_Formal (Right)) + and then Are_Trees_Equal (Get_Actual_Conversion (Left), + Get_Actual_Conversion (Right)) + and then Are_Trees_Equal (Get_Formal_Conversion (Left), + Get_Formal_Conversion (Right)); + + when Iir_Kind_Type_Conversion => + return Are_Trees_Equal (Get_Type_Mark (Left), + Get_Type_Mark (Right)) + and then + Are_Trees_Equal (Get_Expression (Left), + Get_Expression (Right)); + + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_File_Type_Definition => + return Left = Right; + + when Iir_Kind_Range_Expression => + if Get_Type (Left) /= Get_Type (Right) + or else Get_Direction (Left) /= Get_Direction (Right) + then + return False; + end if; + if not Are_Trees_Equal (Get_Left_Limit (Left), + Get_Left_Limit (Right)) + or else not Are_Trees_Equal (Get_Right_Limit (Left), + Get_Right_Limit (Right)) + then + return False; + end if; + return True; + + when Iir_Kind_High_Type_Attribute + | Iir_Kind_Low_Type_Attribute + | Iir_Kind_Left_Type_Attribute + | Iir_Kind_Right_Type_Attribute + | Iir_Kind_Ascending_Type_Attribute => + return Are_Trees_Equal (Get_Prefix (Left), Get_Prefix (Right)); + + when Iir_Kind_String_Literal8 => + if Get_Bit_String_Base (Left) /= Get_Bit_String_Base (Right) then + return False; + end if; + declare + use Str_Table; + Len : constant Nat32 := Get_String_Length (Left); + L_Id : constant String8_Id := Get_String8_Id (Left); + R_Id : constant String8_Id := Get_String8_Id (Right); + begin + if Get_String_Length (Right) /= Len then + return False; + end if; + for I in 1 .. Len loop + if Element_String8 (L_Id, I) /= Element_String8 (R_Id, I) + then + return False; + end if; + end loop; + return True; + end; + + when Iir_Kind_Aggregate => + if not Are_Trees_Equal (Get_Type (Left), Get_Type (Right)) then + return False; + end if; + declare + El_L, El_R : Iir; + begin + El_L := Get_Association_Choices_Chain (Left); + El_R := Get_Association_Choices_Chain (Right); + loop + exit when El_L = Null_Iir and El_R = Null_Iir; + if not Are_Trees_Equal (El_L, El_R) then + return False; + end if; + El_L := Get_Chain (El_L); + El_R := Get_Chain (El_R); + end loop; + return True; + end; + + when Iir_Kind_Choice_By_None + | Iir_Kind_Choice_By_Others => + return Are_Trees_Equal (Get_Associated_Expr (Left), + Get_Associated_Expr (Right)); + when Iir_Kind_Choice_By_Name => + if not Are_Trees_Equal (Get_Choice_Name (Left), + Get_Choice_Name (Right)) + then + return False; + end if; + return Are_Trees_Equal (Get_Associated_Expr (Left), + Get_Associated_Expr (Right)); + when Iir_Kind_Choice_By_Expression => + if not Are_Trees_Equal (Get_Choice_Expression (Left), + Get_Choice_Expression (Right)) then + return False; + end if; + return Are_Trees_Equal (Get_Associated_Expr (Left), + Get_Associated_Expr (Right)); + when Iir_Kind_Choice_By_Range => + if not Are_Trees_Equal (Get_Choice_Range (Left), + Get_Choice_Range (Right)) then + return False; + end if; + return Are_Trees_Equal (Get_Associated_Expr (Left), + Get_Associated_Expr (Right)); + when Iir_Kind_Character_Literal => + return Are_Trees_Equal (Get_Named_Entity (Left), + Get_Named_Entity (Right)); + when Iir_Kind_Allocator_By_Subtype => + return Are_Trees_Equal (Get_Subtype_Indication (Left), + Get_Subtype_Indication (Right)); + when Iir_Kind_Allocator_By_Expression => + return Are_Trees_Equal (Get_Expression (Left), + Get_Expression (Right)); + when others => + Error_Kind ("are_trees_equal", Left); + end case; + end Are_Trees_Equal; + + -- LRM 2.7 Conformance Rules. + procedure Check_Conformance_Rules (Subprg, Spec: Iir) is + begin + if not Are_Trees_Equal (Subprg, Spec) then + -- FIXME: should explain why it does not conform ? + Error_Msg_Sem + (+Subprg, "body of %n does not conform with specification at %l", + (+Subprg, +Spec)); + end if; + end Check_Conformance_Rules; + + -- Return the specification corresponding to a declaration DECL, or + -- null_Iir if none. + -- FIXME: respect rules of LRM93 2.7 + function Find_Subprogram_Specification (Decl: Iir) return Iir + is + Interpretation : Name_Interpretation_Type; + Decl1: Iir; + Hash : Iir_Int32; + begin + Hash := Get_Subprogram_Hash (Decl); + Interpretation := Get_Interpretation (Get_Identifier (Decl)); + while Valid_Interpretation (Interpretation) loop + if not Is_In_Current_Declarative_Region (Interpretation) then + -- The declaration does not belong to the current declarative + -- region, neither will the following one. So, we do not found + -- it. + return Null_Iir; + end if; + Decl1 := Get_Declaration (Interpretation); + -- Should be sure DECL1 and DECL belongs to the same declarative + -- region, ie DECL1 was not made visible via a USE clause. + -- + -- Also, only check for explicitly subprograms (and not + -- implicit one). + if not Is_Implicit_Subprogram (Decl1) + and then Get_Kind (Decl1) in Iir_Kinds_Subprogram_Declaration + and then not Is_Potentially_Visible (Interpretation) + and then Get_Subprogram_Hash (Decl1) = Hash + and then Is_Same_Profile (Decl, Decl1) + then + return Decl1; + end if; + Interpretation := Get_Next_Interpretation (Interpretation); + end loop; + return Null_Iir; + end Find_Subprogram_Specification; + + procedure Set_Subprogram_Overload_Number (Decl : Iir) + is + Id : constant Name_Id := Get_Identifier (Decl); + Inter : Name_Interpretation_Type; + Prev : Iir; + Num : Iir_Int32; + begin + Inter := Get_Interpretation (Id); + while Valid_Interpretation (Inter) + and then Is_In_Current_Declarative_Region (Inter) + loop + -- There is a previous declaration with the same name in the + -- current declarative region. + Prev := Get_Declaration (Inter); + case Get_Kind (Prev) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if Is_Implicit_Subprogram (Prev) then + -- Implicit declarations aren't taken into account (as they + -- are mangled differently). + Inter := Get_Next_Interpretation (Inter); + else + -- The previous declaration is a user subprogram. + Num := Get_Overload_Number (Prev) + 1; + if Num = 1 + and then Get_Parent (Prev) = Get_Parent (Decl) + then + -- The previous was not (yet) overloaded. Mark it as + -- overloaded. + -- Do not mark it if it is not in the same declarative + -- part (ie, do not change a subprogram declaration in + -- the package while analyzing the body). + Set_Overload_Number (Prev, 1); + Num := 2; + end if; + Set_Overload_Number (Decl, Num); + return; + end if; + when Iir_Kind_Enumeration_Literal => + -- Enumeration literal are ignored for overload number. + Inter := Get_Next_Interpretation (Inter); + when Iir_Kind_Non_Object_Alias_Declaration => + -- Subprogram aliases aren't considered, just skip them. + -- (No subprogram is created by an alias). + Inter := Get_Next_Interpretation (Inter); + when others => + -- Case of user error: redefinition of an identifier. + -- Error message is generated by sem_scope. + Set_Overload_Number (Decl, 0); + return; + end case; + end loop; + -- No previous declaration in the current declarative region. + Set_Overload_Number (Decl, 0); + end Set_Subprogram_Overload_Number; + + -- Check requirements on number of interfaces for subprogram specification + -- SUBPRG. Requirements only concern operators, and are defined in + -- LRM 2.3.1 + procedure Check_Operator_Requirements (Id : Name_Id; Subprg : Iir) + is + use Std_Names; + + Nbr_Interfaces : Natural; + Is_Method : Boolean; + begin + Nbr_Interfaces := Iir_Chains.Get_Chain_Length + (Get_Interface_Declaration_Chain (Subprg)); + + -- For vhdl-02, the protected variable is an implicit parameter. + if Flags.Vhdl_Std >= Vhdl_02 + and then Is_Subprogram_Method (Subprg) + then + Nbr_Interfaces := Nbr_Interfaces + 1; + else + Is_Method := False; + end if; + + case Id is + when Name_Abs + | Name_Not => + -- LRM93 2.3.1 + -- The subprogram specification of a unary operator must have a + -- single parameter. + + -- LRM02 2.3.1 + -- ..., unless the subprogram specification is a method (see + -- 3.5.1) of a protected type. In this latter case, the + -- subprogram specification must have no parameters. + if Nbr_Interfaces = 1 then + return; + end if; + Error_Msg_Sem + (+Subprg, "unary operator must have a single parameter"); + when Name_Mod + | Name_Rem + | Name_Op_Mul + | Name_Op_Div + | Name_Relational_Operators + | Name_Op_Concatenation + | Name_Shift_Operators + | Name_Op_Exp => + -- LRM93 2.3.1 + -- The subprogram specification of a binary operator must have + -- two parameters. + + -- LRM02 2.3.1 + -- ..., unless the subprogram specification is a method of a + -- protected type, in which case, the subprogram specification + -- must have a single parameter. + if Nbr_Interfaces = 2 then + return; + end if; + Error_Msg_Sem + (+Subprg, "binary operators must have two parameters"); + when Name_Logical_Operators + | Name_Xnor => + -- LRM08 4.5.2 Operator overloading + -- For each of the "+", "-", "and", "or", "xor", "nand", "nor" + -- and "xnor", overloading is allowed both as a unary operator + -- and as a binary operator. + if Nbr_Interfaces = 2 then + return; + end if; + if Nbr_Interfaces = 1 then + if Vhdl_Std >= Vhdl_08 then + return; + end if; + Error_Msg_Sem + (+Subprg, + "logical operators must have two parameters before vhdl08"); + else + Error_Msg_Sem + (+Subprg, "logical operators must have two parameters"); + end if; + when Name_Op_Plus + | Name_Op_Minus => + -- LRM93 2.3.1 + -- For each of the operators "+" and "-", overloading is allowed + -- both as a unary operator and as a binary operator. + if Nbr_Interfaces in 1 .. 2 then + return; + end if; + Error_Msg_Sem + (+Subprg, + """+"" and ""-"" operators must have 1 or 2 parameters"); + when others => + return; + end case; + if Is_Method then + Error_Msg_Sem + (+Subprg, + " (the protected object is an implicit parameter of methods)"); + end if; + end Check_Operator_Requirements; + + procedure Sem_Subprogram_Specification (Subprg: Iir) + is + Interface_Chain : Iir; + Return_Type : Iir; + begin + -- LRM 10.1 Declarative Region + -- 3. A subprogram declaration, together with the corresponding + -- subprogram body. + Open_Declarative_Region; + + -- Sem interfaces. + Interface_Chain := Get_Interface_Declaration_Chain (Subprg); + case Get_Kind (Subprg) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Interface_Function_Declaration => + Sem_Interface_Chain + (Interface_Chain, Function_Parameter_Interface_List); + Return_Type := Get_Return_Type_Mark (Subprg); + Return_Type := Sem_Type_Mark (Return_Type); + Set_Return_Type_Mark (Subprg, Return_Type); + Return_Type := Get_Type (Return_Type); + Set_Return_Type (Subprg, Return_Type); + Set_All_Sensitized_State (Subprg, Unknown); + + -- LRM08 4.2 Subprogram declarations + -- It is an error if the result subtype of a function denotes + -- either a file type or a protected type. Moreover, it is an + -- error if the result subtype of a pure function denotes an + -- access type or a subtype that has a subelement of an access + -- type. + + -- GHDL: this was added by VHDL 2008, but vital packages don't + -- follow that rule. So, it is not retroactive. + case Get_Kind (Return_Type) is + when Iir_Kind_File_Type_Definition => + Error_Msg_Sem + (+Subprg, "result subtype cannot denote a file type"); + when Iir_Kind_Protected_Type_Declaration => + Error_Msg_Sem + (+Subprg, "result subtype cannot denote a protected type"); + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + if Vhdl_Std >= Vhdl_08 + and then Get_Pure_Flag (Subprg) + then + Error_Msg_Sem_Relaxed + (Subprg, Warnid_Pure, + "result subtype of a pure function cannot denote an" + & " access type"); + end if; + when others => + if Vhdl_Std >= Vhdl_08 + and then not Get_Signal_Type_Flag (Return_Type) + and then Get_Pure_Flag (Subprg) + then + Error_Msg_Sem_Relaxed + (Subprg, Warnid_Pure, + "result subtype of a pure function cannot have" + & " access subelements"); + end if; + end case; + + when Iir_Kind_Interface_Procedure_Declaration => + Sem_Interface_Chain + (Interface_Chain, Procedure_Parameter_Interface_List); + + when Iir_Kind_Procedure_Declaration => + Sem_Interface_Chain + (Interface_Chain, Procedure_Parameter_Interface_List); + + -- Unless the body is analyzed, the procedure purity is unknown. + Set_Purity_State (Subprg, Unknown); + -- Check if the procedure is passive. + Set_Passive_Flag (Subprg, True); + Set_All_Sensitized_State (Subprg, Unknown); + declare + Inter : Iir; + begin + Inter := Interface_Chain; + while Inter /= Null_Iir loop + if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration + and then Get_Mode (Inter) /= Iir_In_Mode + then + -- There is a driver for this signal interface. + Set_Passive_Flag (Subprg, False); + exit; + end if; + Inter := Get_Chain (Inter); + end loop; + end; + + -- Mark the procedure as suspendable, unless in a std packages. + -- This is a minor optimization. + if Get_Library (Get_Design_File (Get_Current_Design_Unit)) + /= Libraries.Std_Library + then + Set_Suspend_Flag (Subprg, True); + end if; + when others => + Error_Kind ("sem_subprogram_declaration", Subprg); + end case; + + Check_Operator_Requirements (Get_Identifier (Subprg), Subprg); + + Sem_Utils.Compute_Subprogram_Hash (Subprg); + + -- The specification has been analyzed, close the declarative region + -- now. + Close_Declarative_Region; + end Sem_Subprogram_Specification; + + -- LRM 2.1 Subprogram Declarations. + procedure Sem_Subprogram_Declaration (Subprg: Iir) + is + Parent : constant Iir := Get_Parent (Subprg); + Spec: Iir; + Subprg_Body : Iir; + begin + -- Set depth. + case Get_Kind (Parent) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + raise Internal_Error; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Set_Subprogram_Depth + (Subprg, + Get_Subprogram_Depth + (Get_Subprogram_Specification (Parent)) + 1); + when others => + -- FIXME: protected type ? + Set_Subprogram_Depth (Subprg, 0); + end case; + + Sem_Subprogram_Specification (Subprg); + + -- Look if there is an associated body (the next node). + Subprg_Body := Get_Chain (Subprg); + if Subprg_Body /= Null_Iir + and then Get_Kind (Subprg_Body) in Iir_Kinds_Subprogram_Body + then + Spec := Find_Subprogram_Specification (Subprg); + else + Spec := Null_Iir; + end if; + + if Spec /= Null_Iir then + -- SUBPRG is the body of the specification SPEC. + if Get_Subprogram_Body (Spec) /= Null_Iir then + Error_Msg_Sem (+Subprg, "%n body already defined at %l", + (+Spec, +Get_Subprogram_Body (Spec))); + -- Kill warning. + Set_Use_Flag (Subprg, True); + else + Check_Conformance_Rules (Subprg, Spec); + Xref_Body (Subprg, Spec); + Set_Subprogram_Body (Subprg, Subprg_Body); + Set_Subprogram_Specification (Subprg_Body, Spec); + Set_Subprogram_Body (Spec, Subprg_Body); + end if; + else + -- Forward declaration or specification followed by body. + Set_Subprogram_Overload_Number (Subprg); + Sem_Scopes.Add_Name (Subprg); + Name_Visible (Subprg); + Xref_Decl (Subprg); + end if; + end Sem_Subprogram_Declaration; + + procedure Add_Analysis_Checks_List (El : Iir) + is + Design : constant Iir := Get_Current_Design_Unit; + List : Iir_List; + begin + List := Get_Analysis_Checks_List (Design); + if List = Null_Iir_List then + List := Create_Iir_List; + Set_Analysis_Checks_List (Design, List); + end if; + Add_Element (List, El); + end Add_Analysis_Checks_List; + + procedure Sem_Subprogram_Body (Subprg : Iir) + is + Spec : constant Iir := Get_Subprogram_Specification (Subprg); + Warn_Hide_Enabled : constant Boolean := Is_Warning_Enabled (Warnid_Hide); + El : Iir; + begin + Set_Impure_Depth (Subprg, Iir_Depth_Pure); + + -- LRM 10.1 Declarative regions + -- 3. A subprogram declaration, together with the corresponding + -- subprogram body. + Open_Declarative_Region; + Set_Is_Within_Flag (Spec, True); + + -- Add the interface names into the current declarative region. + -- (Do not emit warnings for hiding, they were already emitted during + -- analysis of the subprogram spec). + Enable_Warning (Warnid_Hide, False); + El := Get_Interface_Declaration_Chain (Spec); + while El /= Null_Iir loop + Add_Name (El, Get_Identifier (El), False); + if Get_Kind (El) = Iir_Kind_Interface_Signal_Declaration then + Set_Has_Active_Flag (El, False); + end if; + El := Get_Chain (El); + end loop; + Enable_Warning (Warnid_Hide, Warn_Hide_Enabled); + + Sem_Sequential_Statements (Spec, Subprg); + + Set_Is_Within_Flag (Spec, False); + Close_Declarative_Region; + + case Get_Kind (Spec) is + when Iir_Kind_Procedure_Declaration => + if Get_Suspend_Flag (Subprg) + and then not Get_Suspend_Flag (Spec) + then + -- Incoherence: procedures declared in std library are not + -- expected to suspend. This is an internal check. + Error_Msg_Sem (+Subprg, "unexpected suspendable procedure"); + end if; + + -- Update purity state of procedure if there are no callees. + case Get_Purity_State (Spec) is + when Pure + | Maybe_Impure => + -- We can't know this yet. + raise Internal_Error; + when Impure => + null; + when Unknown => + if Get_Callees_List (Subprg) = Null_Iir_List then + -- Since there are no callees, purity state can + -- be updated. + if Get_Impure_Depth (Subprg) = Iir_Depth_Pure then + Set_Purity_State (Spec, Pure); + else + Set_Purity_State (Spec, Maybe_Impure); + end if; + end if; + end case; + + -- Update wait state if the state of all callees is known. + if Get_Wait_State (Spec) = Unknown then + declare + Callees : constant Iir_List := Get_Callees_List (Subprg); + Callees_It : List_Iterator; + Callee : Iir; + State : Tri_State_Type; + begin + -- Per default, has no wait. + Set_Wait_State (Spec, False); + Callees_It := List_Iterate_Safe (Callees); + while Is_Valid (Callees_It) loop + Callee := Get_Element (Callees_It); + case Get_Kind (Callee) is + when Iir_Kind_Function_Declaration => + null; + when Iir_Kind_Procedure_Declaration => + State := Get_Wait_State (Callee); + case State is + when False => + null; + when Unknown => + -- Yet unknown, but can be TRUE. + Set_Wait_State (Spec, Unknown); + when True => + -- Can this happen ? + raise Internal_Error; + --Set_Wait_State (Spec, True); + --exit; + end case; + when others => + Error_Kind ("sem_subprogram_body(2)", Callee); + end case; + Next (Callees_It); + end loop; + end; + end if; + + -- Do not add to Analysis_Checks_List as procedures can't + -- generate purity/wait/all-sensitized errors by themselves. + + when Iir_Kind_Function_Declaration => + if Get_Callees_List (Subprg) /= Null_Iir_List then + -- Purity calls to be checked later. + -- No wait statements in procedures called. + Add_Analysis_Checks_List (Spec); + end if; + when others => + Error_Kind ("sem_subprogram_body", Spec); + end case; + + -- Set All_Sensitized_State in trivial cases. + if Get_All_Sensitized_State (Spec) = Unknown + and then Get_Callees_List (Subprg) = Null_Iir_List + then + Set_All_Sensitized_State (Spec, No_Signal); + end if; + end Sem_Subprogram_Body; + + -- Return the subprogram body of SPEC. If there is no body, and if SPEC + -- is an instance, returns the body of the generic specification but only + -- if known. + function Get_Subprogram_Body_Or_Generic (Spec : Iir) return Iir + is + Bod : Iir; + Orig : Iir; + begin + Bod := Get_Subprogram_Body (Spec); + + if Bod /= Null_Iir then + return Bod; + end if; + + Orig := Sem_Inst.Get_Origin (Spec); + if Orig = Null_Iir then + return Null_Iir; + end if; + + return Get_Subprogram_Body (Orig); + end Get_Subprogram_Body_Or_Generic; + + -- Status of Update_And_Check_Pure_Wait. + type Update_Pure_Status is + ( + -- The purity/wait/all-sensitized are computed and known. + Update_Pure_Done, + -- A missing body prevents from computing the purity/wait/all-sensitized + Update_Pure_Missing, + -- Purity/wait/all-sensitized is unknown (recursion). + Update_Pure_Unknown + ); + + function Update_And_Check_Pure_Wait (Subprg : Iir) return Update_Pure_Status + is + procedure Error_Wait (Caller : Iir; Callee : Iir) is + begin + Error_Msg_Sem + (+Caller, "%n must not contain wait statement, but calls", + (1 => +Caller), Cont => True); + Error_Msg_Sem + (+Callee, "%n which has (indirectly) a wait statement", +Callee); + end Error_Wait; + + -- Kind of subprg. + type Caller_Kind is (K_Function, K_Process, K_Procedure); + Kind : Caller_Kind; + + Callees_List : Iir_List; + Callees_List_Holder : Iir; + Callees_It : List_Iterator; + Callee : Iir; + Callee_Bod : Iir; + Subprg_Depth : Iir_Int32; + Subprg_Bod : Iir; + -- Current purity depth of SUBPRG. + Depth : Iir_Int32; + Depth_Callee : Iir_Int32; + Has_Wait_Errors : Boolean := False; + New_List : Iir_List; + Res, Res1 : Update_Pure_Status; + begin + case Get_Kind (Subprg) is + when Iir_Kind_Function_Declaration => + Kind := K_Function; + Subprg_Bod := Get_Subprogram_Body_Or_Generic (Subprg); + if Subprg_Bod = Null_Iir then + return Update_Pure_Missing; + end if; + Subprg_Depth := Get_Subprogram_Depth (Subprg); + Callees_List_Holder := Subprg_Bod; + if Get_Pure_Flag (Subprg) then + Depth := Iir_Depth_Pure; + else + Depth := Iir_Depth_Impure; + end if; + + when Iir_Kind_Procedure_Declaration => + Kind := K_Procedure; + Subprg_Bod := Get_Subprogram_Body_Or_Generic (Subprg); + if Subprg_Bod = Null_Iir then + return Update_Pure_Missing; + end if; + if Get_Purity_State (Subprg) = Impure + and then Get_Wait_State (Subprg) /= Unknown + and then Get_All_Sensitized_State (Subprg) /= Unknown + then + -- No need to go further. + if Get_All_Sensitized_State (Subprg) = No_Signal + or else Vhdl_Std < Vhdl_08 + then + Callees_List := Get_Callees_List (Subprg_Bod); + Destroy_Iir_List (Callees_List); + Set_Callees_List (Subprg_Bod, Null_Iir_List); + end if; + return Update_Pure_Done; + end if; + Subprg_Depth := Get_Subprogram_Depth (Subprg); + Depth := Get_Impure_Depth (Subprg_Bod); + Callees_List_Holder := Subprg_Bod; + + when Iir_Kind_Sensitized_Process_Statement => + Kind := K_Process; + Subprg_Bod := Null_Iir; + Subprg_Depth := Iir_Depth_Top; + Depth := Iir_Depth_Impure; + Callees_List_Holder := Subprg; + + when others => + Error_Kind ("update_and_check_pure_wait(1)", Subprg); + end case; + + -- If the subprogram has no callee list, there is nothing to do. + Callees_List := Get_Callees_List (Callees_List_Holder); + if Callees_List = Null_Iir_List then + -- There are two reasons why a callees_list is null: + -- * either because SUBPRG does not call any procedure + -- in this case, the status are already known and we should have + -- returned in the above case. + -- * or because of a recursion + -- in this case the status are still unknown here. + return Update_Pure_Unknown; + end if; + + -- By default we don't know the status. + Res := Update_Pure_Unknown; + + -- This subprogram is being considered. + -- To avoid infinite loop, suppress its callees list. + Set_Callees_List (Callees_List_Holder, Null_Iir_List); + + -- First loop: check without recursion. + -- Second loop: recurse if necessary. + for J in 0 .. 1 loop + New_List := Create_Iir_List; + Callees_It := List_Iterate (Callees_List); + while Is_Valid (Callees_It) loop + Callee := Get_Element (Callees_It); + + -- Note: + -- Pure functions should not be in the list. + -- Impure functions must have directly set Purity_State. + + -- The body of subprograms may not be set for instances. + -- Use the body from the generic (if any). + -- This is meaningful for non macro-expanded package interface, + -- because there is no associated body and because the call + -- tree is known (if there were an interface subprogram, it + -- would have been macro-expanded). + -- Do not set the body, as it would trigger an assert during + -- macro-expansion (maybe this shouldn't be called for macro + -- expanded packages). + Callee_Bod := Get_Subprogram_Body_Or_Generic (Callee); + + -- Check pure. + if Callee_Bod = Null_Iir then + -- No body yet for the subprogram called. + -- Nothing can be extracted from it, postpone the checks until + -- elaboration. + Res := Update_Pure_Missing; + else + -- Second loop: recurse if a state is not known. + if J = 1 + and then + ((Get_Kind (Callee) = Iir_Kind_Procedure_Declaration + and then Get_Purity_State (Callee) = Unknown) + or else Get_Wait_State (Callee) = Unknown + or else Get_All_Sensitized_State (Callee) = Unknown) + then + Res1 := Update_And_Check_Pure_Wait (Callee); + if Res1 = Update_Pure_Missing then + Res := Update_Pure_Missing; + end if; + end if; + + -- Check purity only if the subprogram is not impure. + if Depth /= Iir_Depth_Impure then + Depth_Callee := Get_Impure_Depth (Callee_Bod); + + -- Check purity depth. + if Depth_Callee < Subprg_Depth then + -- The call is an impure call because it calls an outer + -- subprogram (or an impure subprogram). + -- FIXME: check the compare. + Depth_Callee := Iir_Depth_Impure; + if Kind = K_Function then + -- FIXME: report call location + Error_Pure (Elaboration, Subprg_Bod, Callee, Null_Iir); + end if; + end if; + + -- Update purity depth. + if Depth_Callee < Depth then + Depth := Depth_Callee; + if Kind = K_Procedure then + -- Update for recursivity. + Set_Impure_Depth (Subprg_Bod, Depth); + if Depth = Iir_Depth_Impure then + Set_Purity_State (Subprg, Impure); + end if; + end if; + end if; + end if; + end if; + + -- Check wait. + if Has_Wait_Errors = False + and then Get_Wait_State (Callee) = True + then + if Kind = K_Procedure then + Set_Wait_State (Subprg, True); + else + Error_Wait (Subprg, Callee); + Has_Wait_Errors := True; + end if; + end if; + + if Get_All_Sensitized_State (Callee) = Invalid_Signal then + case Kind is + when K_Function | K_Procedure => + Set_All_Sensitized_State (Subprg, Invalid_Signal); + when K_Process => + -- LRM08 11.3 + -- + -- It is an error if a process statement with the + -- reserved word ALL as its process sensitivity list + -- is the parent of a subprogram declared in a design + -- unit other than that containing the process statement + -- and the subprogram reads an explicitly declared + -- signal that is not a formal signal parameter or + -- member of a formal signal parameter of the + -- subprogram or of any of its parents. Similarly, + -- it is an error if such subprogram reads an implicit + -- signal whose explicit ancestor is not a formal signal + -- parameter or member of a formal parameter of + -- the subprogram or of any of its parents. + Error_Msg_Sem + (+Subprg, "all-sensitized %n can't call %n", + (+Subprg, +Callee), Cont => True); + Error_Msg_Sem + (+Subprg, + " (as this subprogram reads (indirectly) a signal)"); + end case; + end if; + + -- Keep in list. + if Callee_Bod = Null_Iir + or else + (Get_Kind (Callee) = Iir_Kind_Procedure_Declaration + and then Get_Purity_State (Callee) = Unknown + and then Depth /= Iir_Depth_Impure) + or else + (Get_Wait_State (Callee) = Unknown + and then (Kind /= K_Procedure + or else Get_Wait_State (Subprg) = Unknown)) + or else + (Vhdl_Std >= Vhdl_08 + and then + (Get_All_Sensitized_State (Callee) = Unknown + or else Get_All_Sensitized_State (Callee) = Read_Signal)) + then + Append_Element (New_List, Callee); + end if; + Next (Callees_It); + end loop; + + -- End of callee loop. + if Is_Empty (New_List) then + Destroy_Iir_List (Callees_List); + Callees_List := Null_Iir_List; + Destroy_Iir_List (New_List); + if Kind = K_Procedure then + if Get_Purity_State (Subprg) = Unknown then + Set_Purity_State (Subprg, Maybe_Impure); + end if; + if Get_Wait_State (Subprg) = Unknown then + Set_Wait_State (Subprg, False); + end if; + end if; + if Kind = K_Procedure or Kind = K_Function then + if Get_All_Sensitized_State (Subprg) = Unknown then + Set_All_Sensitized_State (Subprg, No_Signal); + end if; + end if; + Res := Update_Pure_Done; + exit; + else + Destroy_Iir_List (Callees_List); + Callees_List := New_List; + end if; + end loop; + + Set_Callees_List (Callees_List_Holder, New_List); + + return Res; + end Update_And_Check_Pure_Wait; + + -- Check pure/wait/all-sensitized issues for SUBPRG (subprogram or + -- process). Return False if the analysis is incomplete (and must + -- be deferred). + function Root_Update_And_Check_Pure_Wait (Subprg : Iir) return Boolean + is + Res : Update_Pure_Status; + begin + Res := Update_And_Check_Pure_Wait (Subprg); + case Res is + when Update_Pure_Done => + return True; + when Update_Pure_Missing => + return False; + when Update_Pure_Unknown => + -- The purity/wait is unknown, but all callee were walked. + -- This means there are recursive calls but without violations. + if Get_Kind (Subprg) = Iir_Kind_Procedure_Declaration then + if Get_Purity_State (Subprg) = Unknown then + Set_Purity_State (Subprg, Maybe_Impure); + end if; + if Get_Wait_State (Subprg) = Unknown then + Set_Wait_State (Subprg, False); + end if; + end if; + if Get_Kind (Subprg) in Iir_Kinds_Subprogram_Declaration then + if Get_All_Sensitized_State (Subprg) = Unknown then + Set_All_Sensitized_State (Subprg, No_Signal); + end if; + end if; + return True; + end case; + end Root_Update_And_Check_Pure_Wait; + + procedure Sem_Analysis_Checks_List (Unit : Iir_Design_Unit; + Emit_Warnings : Boolean) + is + List : Iir_List; + El : Iir; + It : List_Iterator; + Keep : Boolean; + New_List : Iir_List; + begin + List := Get_Analysis_Checks_List (Unit); + if List = Null_Iir_List then + -- Return now if there is nothing to check. + return; + end if; + + New_List := Create_Iir_List; + It := List_Iterate (List); + while Is_Valid (It) loop + El := Get_Element (It); + Keep := False; + case Get_Kind (El) is + when Iir_Kind_Function_Declaration => + -- FIXME: remove from list if fully tested ? + if not Root_Update_And_Check_Pure_Wait (El) then + Keep := True; + if Emit_Warnings then + declare + Bod : constant Iir := Get_Subprogram_Body (El); + Callees : constant Iir_List := Get_Callees_List (Bod); + pragma Assert (Callees /= Null_Iir_List); + Callee : constant Iir := Get_First_Element (Callees); + begin + Warning_Msg_Sem + (Warnid_Delayed_Checks, +El, + "can't assert that all calls in %n" + & " are pure or have not wait;" + & " will be checked at elaboration", + +El, Cont => True); + -- FIXME: could improve this message by displaying + -- the chain of calls until the first subprograms in + -- unknown state. + Warning_Msg_Sem + (Warnid_Delayed_Checks, +Callee, + "(first such call is to %n)", +Callee); + end; + end if; + end if; + when Iir_Kind_Sensitized_Process_Statement => + if not Root_Update_And_Check_Pure_Wait (El) then + Keep := True; + if Emit_Warnings then + Warning_Msg_Sem + (Warnid_Delayed_Checks, +El, + "can't assert that %n has no wait; " + & "will be checked at elaboration", +El); + end if; + end if; + when others => + Error_Kind ("sem_analysis_checks_list", El); + end case; + if Keep then + Append_Element (New_List, El); + end if; + Next (It); + end loop; + if Is_Empty (New_List) then + Destroy_Iir_List (New_List); + New_List := Null_Iir_List; -- OK, redundant but clearer. + end if; + Destroy_Iir_List (List); + Set_Analysis_Checks_List (Unit, New_List); + end Sem_Analysis_Checks_List; + + -- Return true if package declaration DECL needs a body. + -- Ie, it contains subprogram specification or deferred constants. + function Package_Need_Body_P (Decl: Iir_Package_Declaration) + return Boolean + is + El: Iir; + Def : Iir; + begin + El := Get_Declaration_Chain (Decl); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if not Is_Implicit_Subprogram (El) then + return True; + end if; + when Iir_Kind_Constant_Declaration => + if Get_Default_Value (El) = Null_Iir then + return True; + end if; + when Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration => + null; + when Iir_Kind_Type_Declaration => + Def := Get_Type_Definition (El); + if Def /= Null_Iir + and then Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration + then + return True; + end if; + when Iir_Kind_Anonymous_Type_Declaration + | Iir_Kind_Subtype_Declaration => + null; + when Iir_Kind_Attribute_Declaration + | Iir_Kind_Attribute_Specification => + null; + when Iir_Kind_Disconnection_Specification => + null; + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Component_Declaration => + null; + when Iir_Kind_Protected_Type_Body => + null; + when Iir_Kind_Package_Declaration => + -- LRM08 4.8 Package bodies + -- A package body that is not a library unit shall appear + -- immediately within the same declarative region as the + -- corresponding package declaration and textually subsequent + -- to that package declaration. + if Get_Need_Body (El) then + return True; + end if; + when Iir_Kind_Package_Body => + null; + when Iir_Kind_Package_Instantiation_Declaration => + null; + when Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration => + null; + when Iir_Kind_Terminal_Declaration => + null; + when others => + pragma Assert (Flags.Flag_Force_Analysis); + null; + end case; + El := Get_Chain (El); + end loop; + return False; + end Package_Need_Body_P; + + -- Return true if package declaration DECL contains at least one package + -- instantiation that needs a body. + function Package_Need_Instance_Bodies_P (Decl: Iir_Package_Declaration) + return Boolean + is + El: Iir; + begin + El := Get_Declaration_Chain (Decl); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Package_Instantiation_Declaration => + declare + Pkg : constant Iir := Get_Uninstantiated_Package_Decl (El); + begin + if not Is_Error (Pkg) + and then Get_Need_Body (Pkg) + then + return True; + end if; + end; + when others => + null; + end case; + El := Get_Chain (El); + end loop; + return False; + end Package_Need_Instance_Bodies_P; + + -- Return true if uninstantiated pckage DECL must be macro-expanded (at + -- least one interface type). + function Is_Package_Macro_Expanded + (Decl : Iir_Package_Declaration) return Boolean + is + Header : constant Iir := Get_Package_Header (Decl); + Inter : Iir; + begin + Inter := Get_Generic_Chain (Header); + while Is_Valid (Inter) loop + case Iir_Kinds_Interface_Declaration (Get_Kind (Inter)) is + when Iir_Kinds_Interface_Object_Declaration => + null; + when Iir_Kind_Interface_Type_Declaration => + return True; + when Iir_Kind_Interface_Package_Declaration => + declare + Pkg : constant Iir := + Get_Uninstantiated_Package_Decl (Inter); + begin + if Get_Macro_Expanded_Flag (Pkg) then + return True; + end if; + end; + when Iir_Kinds_Interface_Subprogram_Declaration => + return True; + end case; + Inter := Get_Chain (Inter); + end loop; + return False; + end Is_Package_Macro_Expanded; + + -- LRM 2.5 Package Declarations. + procedure Sem_Package_Declaration (Pkg : Iir_Package_Declaration) + is + Unit : constant Iir_Design_Unit := Get_Design_Unit (Pkg); + Header : constant Iir := Get_Package_Header (Pkg); + Implicit : Implicit_Signal_Declaration_Type; + begin + Sem_Scopes.Add_Name (Pkg); + Set_Visible_Flag (Pkg, True); + Xref_Decl (Pkg); + + Set_Is_Within_Flag (Pkg, True); + + -- Identify IEEE.Std_Logic_1164 for VHDL08. + if Get_Identifier (Pkg) = Std_Names.Name_Std_Logic_1164 + and then (Get_Identifier (Get_Library (Get_Design_File (Unit))) + = Std_Names.Name_Ieee) + then + Ieee.Std_Logic_1164.Std_Logic_1164_Pkg := Pkg; + end if; + + -- LRM93 10.1 Declarative Region + -- 4. A package declaration, together with the corresponding + -- body (if any). + Open_Declarative_Region; + + Push_Signals_Declarative_Part (Implicit, Pkg); + + if Header /= Null_Iir then + declare + Generic_Chain : constant Iir := Get_Generic_Chain (Header); + Generic_Map : constant Iir := + Get_Generic_Map_Aspect_Chain (Header); + Assoc_El : Iir; + Inter_El : Iir; + Inter : Iir; + begin + Sem_Interface_Chain (Generic_Chain, Generic_Interface_List); + + if Generic_Map /= Null_Iir then + -- Generic-mapped packages are not macro-expanded. + Set_Macro_Expanded_Flag (Pkg, False); + + if Sem_Generic_Association_Chain (Header, Header) then + -- For generic-mapped packages, use the actual type for + -- interface type. + Assoc_El := Get_Generic_Map_Aspect_Chain (Header); + Inter_El := Generic_Chain; + while Is_Valid (Assoc_El) loop + if Get_Kind (Assoc_El) = Iir_Kind_Association_Element_Type + then + Inter := + Get_Association_Interface (Assoc_El, Inter_El); + Sem_Inst.Substitute_On_Chain + (Generic_Chain, + Get_Type (Inter), + Get_Type (Get_Named_Entity + (Get_Actual (Assoc_El)))); + end if; + Next_Association_Interface (Assoc_El, Inter_El); + end loop; + end if; + else + -- Uninstantiated package. Maybe macro expanded. + Set_Macro_Expanded_Flag + (Pkg, Is_Package_Macro_Expanded (Pkg)); + end if; + end; + else + -- Simple packages are never expanded. + Set_Macro_Expanded_Flag (Pkg, False); + end if; + + Sem_Declaration_Chain (Pkg); + -- GHDL: subprogram bodies appear in package body. + + Pop_Signals_Declarative_Part (Implicit); + Close_Declarative_Region; + Set_Is_Within_Flag (Pkg, False); + + Set_Need_Body (Pkg, Package_Need_Body_P (Pkg)); + + if Vhdl_Std >= Vhdl_08 then + Set_Need_Instance_Bodies + (Pkg, Package_Need_Instance_Bodies_P (Pkg)); + end if; + end Sem_Package_Declaration; + + -- LRM 2.6 Package Bodies. + procedure Sem_Package_Body (Decl : Iir) + is + Package_Ident : constant Name_Id := Get_Identifier (Decl); + Package_Decl : Iir; + begin + -- First, find the package declaration. + if not Is_Nested_Package (Decl) then + declare + Design_Unit: Iir_Design_Unit; + begin + Design_Unit := Load_Primary_Unit + (Get_Library (Get_Design_File (Get_Current_Design_Unit)), + Package_Ident, Decl); + if Design_Unit = Null_Iir then + Error_Msg_Sem + (+Decl, "package %i was not analysed", +Package_Ident); + return; + end if; + + Package_Decl := Get_Library_Unit (Design_Unit); + if Get_Kind (Package_Decl) /= Iir_Kind_Package_Declaration then + Error_Msg_Sem + (+Decl, "primary unit %i is not a package", +Package_Ident); + return; + end if; + + -- LRM08 13.5 Order of analysis + -- In each case, the second unit depends on the first unit + Add_Dependence (Design_Unit); + + Add_Name (Design_Unit); + + -- Add the context clauses from the primary unit. + Add_Context_Clauses (Design_Unit); + end; + else + declare + Interp : Name_Interpretation_Type; + begin + Interp := Get_Interpretation (Get_Identifier (Decl)); + if not Valid_Interpretation (Interp) + or else not Is_In_Current_Declarative_Region (Interp) + or else Is_Potentially_Visible (Interp) + then + Error_Msg_Sem + (+Decl, "no corresponding package declaration for %i", + +Package_Ident); + return; + end if; + + Package_Decl := Get_Declaration (Interp); + if Get_Kind (Package_Decl) /= Iir_Kind_Package_Declaration then + Error_Msg_Sem + (+Decl, "declaration %i is not a package", +Package_Ident); + return; + end if; + end; + end if; + + -- Emit a warning is a body is not necessary. + if not Get_Need_Body (Package_Decl) then + Warning_Msg_Sem (Warnid_Body, +Decl, + "%n does not require a body", +Package_Decl); + end if; + + Set_Package (Decl, Package_Decl); + Xref_Body (Decl, Package_Decl); + Set_Package_Body (Package_Decl, Decl); + Set_Is_Within_Flag (Package_Decl, True); + + -- LRM93 10.1 Declarative Region + -- 4. A package declaration, together with the corresponding + -- body (if any). + Open_Declarative_Region; + + Sem_Scopes.Add_Package_Declarations (Package_Decl); + + Sem_Declaration_Chain (Decl); + Check_Full_Declaration (Decl, Decl); + Check_Full_Declaration (Package_Decl, Decl); + + Close_Declarative_Region; + Set_Is_Within_Flag (Package_Decl, False); + end Sem_Package_Body; + + function Sem_Uninstantiated_Package_Name (Decl : Iir) return Iir + is + Name : Iir; + Pkg : Iir; + begin + Name := Sem_Denoting_Name (Get_Uninstantiated_Package_Name (Decl)); + Set_Uninstantiated_Package_Name (Decl, Name); + Pkg := Get_Named_Entity (Name); + if Is_Error (Pkg) then + null; + elsif Get_Kind (Pkg) /= Iir_Kind_Package_Declaration then + Error_Class_Match (Name, "package"); + Pkg := Create_Error (Pkg); + elsif not Is_Uninstantiated_Package (Pkg) then + Error_Msg_Sem (+Name, "%n is not an uninstantiated package", +Pkg); + Pkg := Create_Error (Pkg); + end if; + + Set_Uninstantiated_Package_Decl (Decl, Pkg); + + return Pkg; + end Sem_Uninstantiated_Package_Name; + + -- LRM08 4.9 Package Instantiation Declaration + procedure Sem_Package_Instantiation_Declaration (Decl : Iir) + is + Hdr : Iir; + Pkg : Iir; + Bod : Iir_Design_Unit; + begin + Sem_Scopes.Add_Name (Decl); + Set_Visible_Flag (Decl, True); + Xref_Decl (Decl); + + -- LRM08 4.9 + -- The uninstantiated package name shall denote an uninstantiated + -- package declared in a package declaration. + Pkg := Sem_Uninstantiated_Package_Name (Decl); + if Pkg = Null_Iir or Is_Error (Pkg) then + -- What could be done ? + return; + end if; + + -- LRM08 4.9 + -- The generic map aspect, if present, optionally associates a single + -- actual with each formal generic (or member thereof) in the + -- corresponding package declaration. Each formal generic (or member + -- thereof) shall be associated at most once. + + -- GHDL: the generics are first instantiated (ie copied) and then + -- the actuals are associated with the instantiated formal. + -- FIXME: do it in Instantiate_Package_Declaration ? + Hdr := Get_Package_Header (Pkg); + if not Sem_Generic_Association_Chain (Hdr, Decl) then + -- FIXME: stop analysis here ? + return; + end if; + + -- FIXME: unless the parent is a package declaration library unit, the + -- design unit depends on the body. + if Get_Need_Body (Pkg) and then not Is_Nested_Package (Pkg) then + Bod := Get_Package_Body (Pkg); + if Is_Null (Bod) then + Bod := Load_Secondary_Unit + (Get_Design_Unit (Pkg), Null_Identifier, Decl); + else + Bod := Get_Design_Unit (Bod); + end if; + if Is_Null (Bod) then + Error_Msg_Sem (+Decl, "cannot find package body of %n", +Pkg); + else + Add_Dependence (Bod); + end if; + end if; + + -- Instantiate the declaration after analyse of the body. So that + -- the use_flag on the declaration can be propagated to the instance. + Sem_Inst.Instantiate_Package_Declaration (Decl, Pkg); + end Sem_Package_Instantiation_Declaration; + + -- LRM 10.4 Use Clauses. + procedure Sem_Use_Clause_Name (Clause : Iir) + is + Name: Iir; + Prefix: Iir; + Name_Prefix : Iir; + begin + -- LRM93 10.4 + -- A use clause achieves direct visibility of declarations that are + -- visible by selection. + -- Each selected name is a use clause identifies one or more + -- declarations that will potentialy become directly visible. + + Name := Get_Selected_Name (Clause); + if Name = Null_Iir then + pragma Assert (Flags.Flag_Force_Analysis); + return; + end if; + + case Get_Kind (Name) is + when Iir_Kind_Selected_By_All_Name + | Iir_Kind_Selected_Name => + Name_Prefix := Get_Prefix (Name); + when others => + Error_Msg_Sem (+Name, "use clause allows only selected name"); + Set_Selected_Name (Clause, Create_Error_Name (Name)); + return; + end case; + + case Get_Kind (Name_Prefix) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + null; + when others => + Error_Msg_Sem + (+Name_Prefix, + "use clause prefix must be a name or a selected name"); + Set_Selected_Name (Clause, Create_Error_Name (Name)); + return; + end case; + + Name_Prefix := Sem_Denoting_Name (Name_Prefix); + Set_Prefix (Name, Name_Prefix); + Prefix := Get_Named_Entity (Name_Prefix); + if Is_Error (Prefix) then + Set_Selected_Name (Clause, Create_Error_Name (Name)); + return; + end if; + + -- LRM 10.4 Use Clauses + -- + -- If the suffix of the selected name is [...], then the + -- selected name identifies only the declaration(s) of that + -- [...] contained within the package or library denoted by + -- the prefix of the selected name. + -- + -- If the suffix is the reserved word ALL, then the selected name + -- identifies all declarations that are contained within the package + -- or library denoted by the prefix of the selected name. + -- + -- GHDL: therefore, the suffix must be either a package or a library. + case Get_Kind (Prefix) is + when Iir_Kind_Library_Declaration => + null; + when Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Interface_Package_Declaration => + null; + when Iir_Kind_Package_Declaration => + -- LRM08 12.4 Use clauses + -- It is an error if the prefix of a selected name in a use + -- clause denotes an uninstantiated package. + if Is_Uninstantiated_Package (Prefix) then + Error_Msg_Sem + (+Name_Prefix, + "use of uninstantiated package is not allowed"); + Set_Prefix (Name, Create_Error_Name (Name_Prefix)); + return; + end if; + when others => + Error_Msg_Sem + (+Prefix, "prefix must designate a package or a library"); + Set_Prefix (Name, Create_Error_Name (Name_Prefix)); + return; + end case; + + case Get_Kind (Name) is + when Iir_Kind_Selected_Name => + Sem_Name (Name, True); + case Get_Kind (Get_Named_Entity (Name)) is + when Iir_Kind_Error => + -- Continue in case of error. + null; + when Iir_Kind_Overload_List => + -- Analyze is correct as is. + null; + when others => + Name := Finish_Sem_Name (Name); + Set_Selected_Name (Clause, Name); + end case; + when Iir_Kind_Selected_By_All_Name => + null; + when others => + raise Internal_Error; + end case; + end Sem_Use_Clause_Name; + + -- LRM 10.4 Use Clauses. + procedure Sem_Use_Clause (Clauses: Iir_Use_Clause) + is + Clause : Iir_Use_Clause; + begin + Clause := Clauses; + loop + Sem_Use_Clause_Name (Clause); + + Clause := Get_Use_Clause_Chain (Clause); + exit when Clause = Null_Iir; + end loop; + + -- LRM 10.4 + -- For each use clause, there is a certain region of text called the + -- scope of the use clause. This region starts immediatly after the + -- use clause. + Sem_Scopes.Add_Use_Clause (Clauses); + end Sem_Use_Clause; + + -- LRM 11.2 Design Libraries. + procedure Sem_Library_Clause (Decl: Iir_Library_Clause) + is + Ident : Name_Id; + Lib: Iir; + begin + -- GHDL: 'redeclaration' is handled in sem_scopes. + + Ident := Get_Identifier (Decl); + Lib := Libraries.Get_Library (Ident, Get_Location (Decl)); + if Lib = Null_Iir then + Error_Msg_Sem (+Decl, "no resource library %i", +Ident); + else + Set_Library_Declaration (Decl, Lib); + Sem_Scopes.Add_Name (Lib, Ident, False); + Set_Visible_Flag (Lib, True); + Xref_Ref (Decl, Lib); + end if; + end Sem_Library_Clause; + + -- LRM08 13.4 Context clauses. + procedure Sem_One_Context_Reference (Ref : Iir) + is + Name : Iir; + Ent : Iir; + begin + Name := Get_Selected_Name (Ref); + if Get_Kind (Name) /= Iir_Kind_Selected_Name then + Error_Msg_Sem + (+Name, "context reference only allows selected names"); + return; + end if; + + Name := Sem_Denoting_Name (Name); + Set_Selected_Name (Ref, Name); + Ent := Get_Named_Entity (Name); + if Is_Error (Ent) then + return; + end if; + + -- LRM08 13.4 Context clauses + -- It is an error if a selected name in a context reference does not + -- denote a context declaration. + if Get_Kind (Ent) /= Iir_Kind_Context_Declaration then + Error_Msg_Sem (+Name, "name must denote a context declaration"); + Set_Named_Entity (Name, Null_Iir); + return; + end if; + end Sem_One_Context_Reference; + + -- LRM08 13.4 Context clauses. + procedure Sem_Context_Reference (Ctxt : Iir) + is + Ref : Iir; + begin + Ref := Ctxt; + loop + Sem_One_Context_Reference (Ref); + Ref := Get_Context_Reference_Chain (Ref); + exit when Ref = Null_Iir; + end loop; + + -- FIXME: must be done clause after clause ? + Add_Context_Reference (Ctxt); + end Sem_Context_Reference; + + -- LRM 11.3 Context Clauses. + procedure Sem_Context_Clauses (Unit: Iir) + is + El: Iir; + begin + El := Get_Context_Items (Unit); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Use_Clause => + Sem_Use_Clause (El); + when Iir_Kind_Library_Clause => + Sem_Library_Clause (El); + when Iir_Kind_Context_Reference => + Sem_Context_Reference (El); + when others => + Error_Kind ("sem_context_clauses", El); + end case; + El := Get_Chain (El); + end loop; + end Sem_Context_Clauses; + + -- LRM08 13.3 Context declarations + procedure Sem_Context_Declaration (Decl: Iir) + is + -- Return TRUE iff the first prefix of NAME denotes library WORK. + function Has_Work_Library_Prefix (Name : Iir) return Boolean + is + Prefix : Iir; + begin + Prefix := Name; + while Get_Kind (Prefix) = Iir_Kind_Selected_Name + or else Get_Kind (Prefix) = Iir_Kind_Selected_By_All_Name + loop + Prefix := Get_Prefix (Prefix); + end loop; + return Get_Kind (Prefix) = Iir_Kind_Simple_Name + and then Get_Identifier (Prefix) = Std_Names.Name_Work + and then (Get_Kind (Get_Named_Entity (Prefix)) + = Iir_Kind_Library_Declaration); + end Has_Work_Library_Prefix; + + procedure Error_Work_Prefix (Loc : Iir) is + begin + Error_Msg_Sem + (+Loc, "'work' not allowed as prefix in context declaration"); + end Error_Work_Prefix; + + El : Iir; + El1 : Iir; + begin + Sem_Scopes.Add_Name (Decl); + Xref_Decl (Decl); + + Sem_Context_Clauses (Decl); + + El := Get_Context_Items (Decl); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Library_Clause => + -- LRM08 13.3 Context declarations + -- It is an error if a library clause in a context declaration + -- defines the library logical name WORK, [...] + if Get_Identifier (El) = Std_Names.Name_Work then + Error_Msg_Sem + (+El, "'library work' not allowed in context declaration"); + end if; + when Iir_Kind_Use_Clause => + -- LRM08 13.3 Context declarations + -- [...] or if a selected name in a use clause [or a context + -- reference] in a context declaration has the library logic + -- name WORK as a prefix. + El1 := El; + while El1 /= Null_Iir loop + if Has_Work_Library_Prefix (Get_Selected_Name (El1)) then + Error_Work_Prefix (El1); + exit; + end if; + El1 := Get_Use_Clause_Chain (El1); + end loop; + when Iir_Kind_Context_Reference => + -- LRM08 13.3 Context declarations + -- [...] or if a selected name in [a use clause or] a context + -- reference in a context declaration has the library logic + -- name WORK as a prefix. + El1 := El; + while El1 /= Null_Iir loop + if Has_Work_Library_Prefix (Get_Selected_Name (El1)) then + Error_Work_Prefix (El1); + exit; + end if; + El1 := Get_Context_Reference_Chain (El1); + end loop; + when others => + raise Internal_Error; + end case; + El := Get_Chain (El); + end loop; + + -- GHDL: forbid self-reference by making declaration visible at the end. + -- This violates LRM08 12.3 Visibility: A declaration is visible only + -- within a certain part of its scope; ... + Set_Visible_Flag (Decl, True); + end Sem_Context_Declaration; + + -- Access to the current design unit. This is set, saved, restored, cleared + -- by the procedure semantic. + Current_Design_Unit: Iir_Design_Unit := Null_Iir; + + function Get_Current_Design_Unit return Iir_Design_Unit is + begin + return Current_Design_Unit; + end Get_Current_Design_Unit; + + -- LRM 11.1 Design units. + procedure Semantic (Design_Unit : Iir_Design_Unit) + is + Library_Unit : constant Iir := Get_Library_Unit (Design_Unit); + Library : constant Iir := Get_Library (Get_Design_File (Design_Unit)); + Prev_Unit : Iir; + Old_Design_Unit : Iir_Design_Unit; + Implicit : Implicit_Signal_Declaration_Type; + begin + -- Sanity check: can analyze either previously analyzed unit or just + -- parsed unit. + case Get_Date (Design_Unit) is + when Date_Parsed => + Set_Date (Design_Unit, Date_Analyzing); + when Date_Valid => + null; + when Date_Obsolete => + -- This happens only when design files are added into the library + -- and keeping obsolete units (eg: to pretty print a file). + Set_Date (Design_Unit, Date_Analyzing); + when others => + raise Internal_Error; + end case; + + -- If there is already a unit with the same name, mark it as being + -- replaced. + if Library_Unit /= Null_Iir then + if Get_Kind (Library_Unit) in Iir_Kinds_Primary_Unit then + Prev_Unit := Libraries.Find_Primary_Unit + (Library, Get_Identifier (Library_Unit)); + if Is_Valid (Prev_Unit) and then Prev_Unit /= Design_Unit then + Set_Date (Prev_Unit, Date_Replacing); + end if; + end if; + end if; + + -- Save and set current_design_unit. + Old_Design_Unit := Current_Design_Unit; + Current_Design_Unit := Design_Unit; + Push_Signals_Declarative_Part (Implicit, Null_Iir); + + -- Have a clean and empty state for scopes. + Push_Interpretations; + + -- LRM02 10.1 Declarative Region. + -- In addition to the above declarative region, there is a root + -- declarative region, not associated with a portion of the text of the + -- description, but encompassing any given primary unit. At the + -- beginning of the analysis of a given primary unit, there are no + -- declarations whose scopes (see 10.2) are within the root declarative + -- region. Moreover, the root declarative region associated with any + -- given secondary unit is the root declarative region of the + -- corresponding primary unit. + -- GHDL: for any revision of VHDL, a root declarative region is created, + -- due to reasons given by LCS 3 (VHDL Issue # 1028). + Open_Declarative_Region; + + -- LRM 11.2 + -- Every design unit is assumed to contain the following implicit + -- context items as part of its context clause: + -- library STD, WORK; use STD.STANDARD.all; + Sem_Scopes.Add_Name (Libraries.Std_Library, Std_Names.Name_Std, False); + Sem_Scopes.Add_Name (Library, Std_Names.Name_Work, False); + Sem_Scopes.Use_All_Names (Standard_Package); + if Get_Dependence_List (Design_Unit) = Null_Iir_List then + Set_Dependence_List (Design_Unit, Create_Iir_List); + end if; + Add_Dependence (Std_Standard_Unit); + + -- Analyze context clauses. + Sem_Context_Clauses (Design_Unit); + + -- Analyze the library unit. + if Library_Unit /= Null_Iir then + -- Can be null_iir in case of parse error. + case Iir_Kinds_Library_Unit (Get_Kind (Library_Unit)) is + when Iir_Kind_Entity_Declaration => + Sem_Entity_Declaration (Library_Unit); + when Iir_Kind_Architecture_Body => + Sem_Architecture_Body (Library_Unit); + when Iir_Kind_Package_Declaration => + Sem_Package_Declaration (Library_Unit); + when Iir_Kind_Package_Body => + Sem_Package_Body (Library_Unit); + when Iir_Kind_Configuration_Declaration => + Sem_Configuration_Declaration (Library_Unit); + when Iir_Kind_Package_Instantiation_Declaration => + Sem_Package_Instantiation_Declaration (Library_Unit); + when Iir_Kind_Context_Declaration => + Sem_Context_Declaration (Library_Unit); + end case; + end if; + + Close_Declarative_Region; + + Pop_Interpretations; + + if Get_Date (Design_Unit) = Date_Analyzing then + Set_Date (Design_Unit, Date_Analyzed); + end if; + + if Get_Analysis_Checks_List (Design_Unit) /= Null_Iir_List then + Sem_Analysis_Checks_List (Design_Unit, False); + end if; + + -- Restore current_design_unit. + Current_Design_Unit := Old_Design_Unit; + Pop_Signals_Declarative_Part (Implicit); + end Semantic; +end Vhdl.Sem; diff --git a/src/vhdl/vhdl-sem.ads b/src/vhdl/vhdl-sem.ads new file mode 100644 index 000000000..c6bb46bd8 --- /dev/null +++ b/src/vhdl/vhdl-sem.ads @@ -0,0 +1,94 @@ +-- Semantic analysis pass. +-- 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 Iirs; use Iirs; +with Types; use Types; + +package Vhdl.Sem is + -- Semantic analysis for chapters 1, 2, 10 (uses clauses) and 11. + + -- Do the semantic analysis of design unit DESIGN_UNIT. + -- Also add a few node or change some nodes, when for exemple an + -- identifier is changed into an access to the type. + procedure Semantic (Design_Unit: Iir_Design_Unit); + + -- Get the current design unit, ie, the parameter of the procedure semantic. + function Get_Current_Design_Unit return Iir_Design_Unit; + + -- Makes the current design unit depends on UNIT. + -- UNIT must be either an entity_aspect or a design_unit. + procedure Add_Dependence (Unit : Iir); + + -- Add EL in the current design unit list of items to be checked later. + procedure Add_Analysis_Checks_List (El : Iir); + + -- INTER_PARENT contains generics and ports interfaces; + -- ASSOC_PARENT constains generics and ports map aspects. + procedure Sem_Generic_Port_Association_Chain + (Inter_Parent : Iir; Assoc_Parent : Iir); + + -- INTER_PARENT contains generics interfaces; + -- ASSOC_PARENT constains generic aspects. + procedure Sem_Generic_Association_Chain + (Inter_Parent : Iir; Assoc_Parent : Iir); + + -- Return TRUE iff the actual of ASSOC can be the formal FORMAL. + -- ASSOC must be an association_element_by_expression. + function Can_Collapse_Signals (Assoc : Iir; Formal : Iir) return Boolean; + + -- Return TRUE iff LEFT and RIGHT are (in depth) equal. + -- This corresponds to conformance rules, LRM 2.7 + function Are_Trees_Equal (Left, Right : Iir) return Boolean; + + -- Check requirements on number of interfaces for subprogram specification + -- SUBPRG for a symbol operator ID. Requirements only concern operators, + -- and are defined in LRM 2.3.1. + -- If ID is not an operator name, this subprogram does no checks. + -- ID might be different from the identifier of SUBPRG when non object + -- aliases are checked. + procedure Check_Operator_Requirements (Id : Name_Id; Subprg : Iir); + + -- Analyze an use clause. + -- This may adds use clauses to the chain. + procedure Sem_Use_Clause (Clauses : Iir_Use_Clause); + + -- LRM 2.1 Subprogram Declarations. + procedure Sem_Subprogram_Specification (Subprg : Iir); + procedure Sem_Subprogram_Declaration (Subprg : Iir); + + -- LRM 2.2 Subprogram Bodies. + procedure Sem_Subprogram_Body (Subprg : Iir); + + -- LRM 2.5 Package Declarations. + procedure Sem_Package_Declaration (Pkg : Iir_Package_Declaration); + + -- LRM 2.6 Package Bodies. + procedure Sem_Package_Body (Decl : Iir); + + -- LRM08 4.9 Package Instantiation Declaration + procedure Sem_Package_Instantiation_Declaration (Decl : Iir); + + -- Do late analysis checks (pure rules). + procedure Sem_Analysis_Checks_List (Unit : Iir_Design_Unit; + Emit_Warnings : Boolean); + + -- Analyze the uninstantiated package name of DECL, and return the + -- package declaration. Return Null_Iir if the name doesn't denote an + -- uninstantiated package. + function Sem_Uninstantiated_Package_Name (Decl : Iir) return Iir; + +end Vhdl.Sem; diff --git a/src/vhdl/vhdl-sem_assocs.adb b/src/vhdl/vhdl-sem_assocs.adb new file mode 100644 index 000000000..146b582bc --- /dev/null +++ b/src/vhdl/vhdl-sem_assocs.adb @@ -0,0 +1,2571 @@ +-- Semantic analysis. +-- 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 Evaluation; use Evaluation; +with Errorout; use Errorout; +with Flags; use Flags; +with Types; use Types; +with Iirs_Utils; use Iirs_Utils; +with Vhdl.Parse; +with Std_Names; +with Vhdl.Sem_Names; use Vhdl.Sem_Names; +with Vhdl.Sem_Types; +with Vhdl.Sem_Decls; +with Std_Package; +with Vhdl.Sem_Scopes; +with Iir_Chains; use Iir_Chains; +with Xrefs; + +package body Vhdl.Sem_Assocs is + function Rewrite_Non_Object_Association (Assoc : Iir; Inter : Iir) + return Iir + is + N_Assoc : Iir; + Actual : Iir; + begin + Actual := Get_Actual (Assoc); + case Get_Kind (Inter) is + when Iir_Kind_Interface_Package_Declaration => + N_Assoc := Create_Iir (Iir_Kind_Association_Element_Package); + when Iir_Kind_Interface_Type_Declaration => + N_Assoc := Create_Iir (Iir_Kind_Association_Element_Type); + if Get_Kind (Actual) = Iir_Kind_Parenthesis_Name then + -- Convert parenthesis name to array subtype. + declare + N_Actual : Iir; + Sub_Assoc : Iir; + Indexes : Iir_List; + Old : Iir; + begin + N_Actual := Create_Iir (Iir_Kind_Array_Subtype_Definition); + Location_Copy (N_Actual, Actual); + Set_Subtype_Type_Mark (N_Actual, Get_Prefix (Actual)); + Sub_Assoc := Get_Association_Chain (Actual); + Indexes := Create_Iir_List; + while Is_Valid (Sub_Assoc) loop + if Get_Kind (Sub_Assoc) + /= Iir_Kind_Association_Element_By_Expression + then + Error_Msg_Sem + (+Sub_Assoc, "index constraint must be a range"); + else + if Get_Formal (Sub_Assoc) /= Null_Iir then + Error_Msg_Sem + (+Sub_Assoc, "formal part not allowed"); + end if; + Append_Element (Indexes, Get_Actual (Sub_Assoc)); + end if; + Old := Sub_Assoc; + Sub_Assoc := Get_Chain (Sub_Assoc); + Free_Iir (Old); + end loop; + Old := Actual; + Free_Iir (Old); + Set_Index_Constraint_List + (N_Actual, List_To_Flist (Indexes)); + Actual := N_Actual; + end; + end if; + when Iir_Kinds_Interface_Subprogram_Declaration => + N_Assoc := Create_Iir (Iir_Kind_Association_Element_Subprogram); + if Get_Kind (Actual) = Iir_Kind_String_Literal8 then + Actual := Vhdl.Parse.String_To_Operator_Symbol (Actual); + end if; + when others => + Error_Kind ("rewrite_non_object_association", Inter); + end case; + Location_Copy (N_Assoc, Assoc); + Set_Formal (N_Assoc, Get_Formal (Assoc)); + Set_Actual (N_Assoc, Actual); + Set_Chain (N_Assoc, Get_Chain (Assoc)); + Set_Whole_Association_Flag (N_Assoc, True); + Free_Iir (Assoc); + return N_Assoc; + end Rewrite_Non_Object_Association; + + function Extract_Non_Object_Association + (Assoc_Chain : Iir; Inter_Chain : Iir) return Iir + is + Inter : Iir; + Assoc : Iir; + -- N_Assoc : Iir; + Prev_Assoc : Iir; + Formal : Iir; + Res : Iir; + begin + Inter := Inter_Chain; + Assoc := Assoc_Chain; + Prev_Assoc := Null_Iir; + Res := Null_Iir; + + -- Common case: only objects in interfaces. + while Is_Valid (Inter) loop + exit when Get_Kind (Inter) + not in Iir_Kinds_Interface_Object_Declaration; + Inter := Get_Chain (Inter); + end loop; + if Is_Null (Inter) then + -- Only interface object, nothing to to. + return Assoc_Chain; + end if; + + Inter := Inter_Chain; + loop + -- Don't try to detect errors. + if Is_Null (Assoc) then + return Res; + end if; + + Formal := Get_Formal (Assoc); + if Formal = Null_Iir then + -- Positional association. + + if Inter = Null_Iir then + -- But after a named one. Be silent on that error. + null; + elsif Get_Kind (Inter) + not in Iir_Kinds_Interface_Object_Declaration + then + Assoc := Rewrite_Non_Object_Association (Assoc, Inter); + end if; + else + if Kind_In (Formal, Iir_Kind_Simple_Name, Iir_Kind_Operator_Symbol) + then + -- A candidate. Search the corresponding interface. + Inter := Find_Name_In_Chain + (Inter_Chain, Get_Identifier (Formal)); + if Inter /= Null_Iir + and then + Get_Kind (Inter) not in Iir_Kinds_Interface_Object_Declaration + then + Assoc := Rewrite_Non_Object_Association (Assoc, Inter); + end if; + end if; + + -- No more association by position. + Inter := Null_Iir; + end if; + + if Prev_Assoc = Null_Iir then + Res := Assoc; + else + Set_Chain (Prev_Assoc, Assoc); + end if; + Prev_Assoc := Assoc; + Assoc := Get_Chain (Assoc); + if Is_Valid (Inter) then + Inter := Get_Chain (Inter); + end if; + end loop; + end Extract_Non_Object_Association; + + -- Analyze all arguments of ASSOC_CHAIN + -- Return TRUE if no error. + function Sem_Actual_Of_Association_Chain (Assoc_Chain : Iir) + return Boolean + is + Has_Named : Boolean; + Ok : Boolean; + Assoc : Iir; + Res : Iir; + Formal : Iir; + begin + -- Analyze all arguments. + -- OK is false if there is an error during semantic of one of the + -- argument, but continue analyze. + Has_Named := False; + Ok := True; + Assoc := Assoc_Chain; + while Assoc /= Null_Iir loop + Formal := Get_Formal (Assoc); + if Formal /= Null_Iir then + Has_Named := True; + -- FIXME: check FORMAL is well composed. + elsif Has_Named then + -- FIXME: do the check in parser. + Error_Msg_Sem (+Assoc, "positional argument after named argument"); + Ok := False; + end if; + if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression then + Res := Sem_Expression_Ov (Get_Actual (Assoc), Null_Iir); + if Res = Null_Iir then + Ok := False; + else + Set_Actual (Assoc, Res); + end if; + end if; + Assoc := Get_Chain (Assoc); + end loop; + return Ok; + end Sem_Actual_Of_Association_Chain; + + procedure Check_Parameter_Association_Restriction + (Inter : Iir; Base_Actual : Iir; Loc : Iir) is + begin + case Iir_Parameter_Modes (Get_Mode (Inter)) is + when Iir_In_Mode => + if Can_Interface_Be_Read (Base_Actual) then + return; + end if; + when Iir_Out_Mode => + if Can_Interface_Be_Updated (Base_Actual) then + return; + end if; + when Iir_Inout_Mode => + if Can_Interface_Be_Read (Base_Actual) + and then Can_Interface_Be_Updated (Base_Actual) + then + return; + end if; + end case; + Error_Msg_Sem + (+Loc, "cannot associate an " & Get_Mode_Name (Get_Mode (Base_Actual)) + & " object with " & Get_Mode_Name (Get_Mode (Inter)) & " %n", + +Inter); + end Check_Parameter_Association_Restriction; + + procedure Check_Subprogram_Associations + (Inter_Chain : Iir; Assoc_Chain : Iir) + is + Assoc : Iir; + Formal_Inter : Iir; + Actual : Iir; + Prefix : Iir; + Object : Iir; + Inter : Iir; + begin + Assoc := Assoc_Chain; + Inter := Inter_Chain; + while Assoc /= Null_Iir loop + Formal_Inter := Get_Association_Interface (Assoc, Inter); + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_Open => + if Get_Default_Value (Formal_Inter) = Null_Iir then + Error_Msg_Sem + (+Assoc, "no parameter for %n", +Formal_Inter); + end if; + when Iir_Kind_Association_Element_By_Expression => + Actual := Get_Actual (Assoc); + Object := Name_To_Object (Actual); + if Object /= Null_Iir then + Prefix := Get_Object_Prefix (Object); + else + Prefix := Actual; + end if; + + case Get_Kind (Formal_Inter) is + when Iir_Kind_Interface_Signal_Declaration => + -- LRM93 2.1.1 + -- In a subprogram call, the actual designator + -- associated with a formal parameter of class + -- signal must be a signal. + case Get_Kind (Prefix) is + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kinds_Signal_Attribute => + -- LRM93 2.1.1.2 + -- If an actual signal is associated with + -- a signal parameter of any mode, the actual + -- must be denoted by a static signal name. + if Get_Name_Staticness (Object) < Globally then + Error_Msg_Sem + (+Actual, + "actual signal must be a static name"); + else + -- Inherit has_active_flag. + Set_Has_Active_Flag + (Prefix, Get_Has_Active_Flag (Formal_Inter)); + end if; + when others => + Error_Msg_Sem + (+Assoc, + "signal parameter requires a signal expression"); + end case; + + case Get_Kind (Prefix) is + when Iir_Kind_Interface_Signal_Declaration => + Check_Parameter_Association_Restriction + (Formal_Inter, Prefix, Assoc); + when Iir_Kind_Guard_Signal_Declaration => + if Get_Mode (Formal_Inter) /= Iir_In_Mode then + Error_Msg_Sem + (+Assoc, + "cannot associate a guard signal with " + & Get_Mode_Name (Get_Mode (Formal_Inter)) + & " %n", +Formal_Inter); + end if; + when Iir_Kinds_Signal_Attribute => + if Get_Mode (Formal_Inter) /= Iir_In_Mode then + Error_Msg_Sem + (+Assoc, + "cannot associate a signal attribute with " + & Get_Mode_Name (Get_Mode (Formal_Inter)) + & " %n", +Formal_Inter); + end if; + when others => + null; + end case; + + -- LRM 2.1.1.2 Signal parameters + -- It is an error if a conversion function or type + -- conversion appears in either the formal part or the + -- actual part of an association element that associates + -- an actual signal with a formal signal parameter. + if Get_Actual_Conversion (Assoc) /= Null_Iir + or Get_Formal_Conversion (Assoc) /= Null_Iir + then + Error_Msg_Sem + (+Assoc, + "conversion are not allowed for signal parameters"); + end if; + when Iir_Kind_Interface_Variable_Declaration => + -- LRM93 2.1.1 + -- The actual designator associated with a formal of + -- class variable must be a variable. + case Get_Kind (Prefix) is + when Iir_Kind_Interface_Variable_Declaration => + Check_Parameter_Association_Restriction + (Formal_Inter, Prefix, Assoc); + when Iir_Kind_Variable_Declaration + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference => + null; + when Iir_Kind_Interface_File_Declaration + | Iir_Kind_File_Declaration => + -- LRM87 4.3.1.4 + -- Such an object is a member of the variable + -- class of objects; + if Flags.Vhdl_Std >= Vhdl_93 then + Error_Msg_Sem + (+Assoc, "variable parameter cannot be a " + & "file (vhdl93)"); + end if; + when others => + Error_Msg_Sem + (+Assoc, "variable parameter must be a variable"); + end case; + when Iir_Kind_Interface_File_Declaration => + -- LRM93 2.1.1 + -- The actual designator associated with a formal + -- of class file must be a file. + case Get_Kind (Prefix) is + when Iir_Kind_Interface_File_Declaration + | Iir_Kind_File_Declaration => + null; + when Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration => + if Flags.Vhdl_Std >= Vhdl_93 then + Error_Msg_Sem (+Assoc, "file parameter " + & "must be a file (vhdl93)"); + end if; + when others => + Error_Msg_Sem + (+Assoc, "file parameter must be a file"); + end case; + + -- LRM 2.1.1.3 File parameters + -- It is an error if an association element associates + -- an actual with a formal parameter of a file type and + -- that association element contains a conversion + -- function or type conversion. + if Get_Actual_Conversion (Assoc) /= Null_Iir + or Get_Formal_Conversion (Assoc) /= Null_Iir + then + Error_Msg_Sem (+Assoc, "conversion are not allowed " + & "for file parameters"); + end if; + when Iir_Kind_Interface_Constant_Declaration => + -- LRM93 2.1.1 + -- The actual designator associated with a formal of + -- class constant must be an expression. + -- GHDL: unless this is in a formal_part. + if not Get_In_Formal_Flag (Assoc) then + Check_Read (Actual); + end if; + when others => + Error_Kind + ("check_subprogram_association(3)", Formal_Inter); + end case; + when Iir_Kind_Association_Element_By_Individual => + null; + when others => + Error_Kind ("check_subprogram_associations", Assoc); + end case; + Next_Association_Interface (Assoc, Inter); + end loop; + end Check_Subprogram_Associations; + + -- Assocs_Right_Map (FORMAL_MODE, ACTUAL_MODE) is true iff it is allowed + -- to associate a formal port of mode FORMAL_MODE with an actual port of + -- mode ACTUAL_MODE. + subtype Iir_Known_Mode is Iir_Mode range Iir_Linkage_Mode .. Iir_In_Mode; + type Assocs_Right_Map is array (Iir_Known_Mode, Iir_Known_Mode) of Boolean; + + -- LRM93 1.1.1.2 Ports + Vhdl93_Assocs_Map : constant Assocs_Right_Map := + (Iir_In_Mode => + (Iir_In_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, + others => False), + Iir_Out_Mode => + (Iir_Out_Mode | Iir_Inout_Mode => True, + others => False), + Iir_Inout_Mode => + (Iir_Inout_Mode => True, + others => False), + Iir_Buffer_Mode => + (Iir_Buffer_Mode => True, others => False), + Iir_Linkage_Mode => + (others => True)); + + -- LRM02 1.1.1.2 Ports + Vhdl02_Assocs_Map : constant Assocs_Right_Map := + (Iir_In_Mode => + (Iir_In_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, + others => False), + Iir_Out_Mode => + (Iir_Out_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, + others => False), + Iir_Inout_Mode => + (Iir_Inout_Mode | Iir_Buffer_Mode => True, + others => False), + Iir_Buffer_Mode => + (Iir_Out_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, + others => False), + Iir_Linkage_Mode => + (others => True)); + + -- LRM08 6.5.6.3 Port clauses + Vhdl08_Assocs_Map : constant Assocs_Right_Map := + (Iir_In_Mode => + (Iir_In_Mode | Iir_Out_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, + others => False), + Iir_Out_Mode => + (Iir_Out_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, + others => False), + Iir_Inout_Mode => + (Iir_Out_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, + others => False), + Iir_Buffer_Mode => + (Iir_Out_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True, + others => False), + Iir_Linkage_Mode => (others => True)); + + -- Check for restrictions in LRM 1.1.1.2 + -- Return FALSE in case of error. + function Check_Port_Association_Mode_Restrictions + (Formal : Iir_Interface_Signal_Declaration; + Actual : Iir_Interface_Signal_Declaration; + Assoc : Iir) + return Boolean + is + Fmode : constant Iir_Mode := Get_Mode (Formal); + Amode : constant Iir_Mode := Get_Mode (Actual); + begin + pragma Assert (Fmode /= Iir_Unknown_Mode); + pragma Assert (Amode /= Iir_Unknown_Mode); + + case Flags.Vhdl_Std is + when Vhdl_87 | Vhdl_93c | Vhdl_93 | Vhdl_00 => + if Vhdl93_Assocs_Map (Fmode, Amode) then + return True; + end if; + when Vhdl_02 => + if Vhdl02_Assocs_Map (Fmode, Amode) then + return True; + end if; + when Vhdl_08 => + if Vhdl08_Assocs_Map (Fmode, Amode) then + return True; + end if; + end case; + + if Assoc /= Null_Iir then + Error_Msg_Sem + (+Assoc, "cannot associate " & Get_Mode_Name (Fmode) & " %n" + & " with actual port of mode " + & Get_Mode_Name (Amode), +Formal); + end if; + return False; + end Check_Port_Association_Mode_Restrictions; + + -- Check restrictions of LRM02 12.2.4 + procedure Check_Port_Association_Bounds_Restrictions + (Formal : Iir; Actual : Iir; Assoc : Iir) + is + Inter : constant Iir := Get_Object_Prefix (Formal, False); + + function Is_Scalar_Type_Compatible (Src : Iir; Dest : Iir) + return Boolean + is + Src_Range : Iir; + Dst_Range : Iir; + begin + if Get_Kind (Src) not in Iir_Kinds_Scalar_Type_And_Subtype_Definition + then + return True; + end if; + + Src_Range := Get_Range_Constraint (Src); + Dst_Range := Get_Range_Constraint (Dest); + if Get_Expr_Staticness (Src_Range) /= Locally + or else Get_Expr_Staticness (Dst_Range) /= Locally + then + return True; + end if; + + -- FIXME: non-static bounds have to be checked at run-time + -- (during elaboration). + + -- In vhdl08, the subtypes must be compatible. Use the that rule + -- for 93c and relaxed rules. + if Vhdl_Std >= Vhdl_08 + or else Vhdl_Std = Vhdl_93c + or else Flag_Relaxed_Rules + then + return Eval_Is_Range_In_Bound (Src, Dest, True); + end if; + + -- Prior vhdl08, the subtypes must be identical. + if not Eval_Is_Eq (Get_Left_Limit (Src_Range), + Get_Left_Limit (Dst_Range)) + or else not Eval_Is_Eq (Get_Right_Limit (Src_Range), + Get_Right_Limit (Dst_Range)) + or else Get_Direction (Src_Range) /= Get_Direction (Dst_Range) + then + return False; + end if; + + return True; + end Is_Scalar_Type_Compatible; + + procedure Error_Msg + is + Id : Msgid_Type; + Orig : Report_Origin; + begin + if Flag_Elaborate then + Id := Msgid_Error; + Orig := Elaboration; + else + Id := Warnid_Port_Bounds; + Orig := Semantic; + end if; + Report_Msg + (Id, Orig, +Assoc, + "bounds or direction of actual don't match with %n", + (1 => +Inter)); + end Error_Msg; + + Ftype : constant Iir := Get_Type (Formal); + Atype : constant Iir := Get_Type (Actual); + F_Conv : constant Iir := Get_Formal_Conversion (Assoc); + A_Conv : constant Iir := Get_Actual_Conversion (Assoc); + F2a_Type : Iir; + A2f_Type : Iir; + begin + -- LRM02 12.2.4 The port map aspect + -- If an actual signal is associated with a port of any mode, and if + -- the type of the formal is a scalar type, then it is an error if + -- (after applying any conversion function or type conversion + -- expression present in the actual part) the bounds and direction of + -- the subtype denoted by the subtype indication of the formal are not + -- identical to the bounds and direction of the subtype denoted by the + -- subtype indication of the actual. + + -- LRM08 14.3.5 Port map aspect + -- If an actual signal is associated with a port of mode IN or INOUT, + -- and if the type of the formal is a scalar type, then it is an error + -- if (after applying any conversion function or type conversion + -- expression present in the actual part) the subtype of the actual is + -- not compatible with the subtype of the formal. [...] + -- + -- Similarly, if an actual signal is associated with a port of mode + -- OUT, INOUT, or BUFFER, and the type of the actual is a scalar type, + -- then it is an error if (after applying any conversion function or + -- type conversion expression present in the formal part) the subtype + -- or the formal is not compatible with the subtype of the actual. + if Is_Valid (F_Conv) then + F2a_Type := Get_Type (F_Conv); + else + F2a_Type := Ftype; + end if; + if Is_Valid (A_Conv) then + A2f_Type := Get_Type (A_Conv); + else + A2f_Type := Atype; + end if; + if Get_Mode (Inter) in Iir_In_Modes + and then not Is_Scalar_Type_Compatible (A2f_Type, Ftype) + then + Error_Msg; + end if; + if Get_Mode (Inter) in Iir_Out_Modes + and then not Is_Scalar_Type_Compatible (F2a_Type, Atype) + then + Error_Msg; + end if; + end Check_Port_Association_Bounds_Restrictions; + + -- Handle indexed name + -- FORMAL is the formal name to be handled. + -- BASE_ASSOC is an association_by_individual in which the formal will be + -- inserted. + procedure Add_Individual_Assoc_Indexed_Name + (Choice : out Iir; Base_Assoc : Iir; Formal : Iir) + is + Index_List : constant Iir_Flist := Get_Index_List (Formal); + Nbr : constant Natural := Get_Nbr_Elements (Index_List); + Last_Choice : Iir; + Index : Iir; + Staticness : Iir_Staticness; + Sub_Assoc : Iir; + begin + -- Find element. + Sub_Assoc := Base_Assoc; + for I in 0 .. Nbr - 1 loop + Index := Get_Nth_Element (Index_List, I); + + -- Evaluate index. + Staticness := Get_Expr_Staticness (Index); + if Staticness = Locally then + Index := Eval_Expr (Index); + Set_Nth_Element (Index_List, I, Index); + else + Error_Msg_Sem (+Index, "index expression must be locally static"); + Set_Choice_Staticness (Base_Assoc, None); + end if; + + -- Find index in choice list. + Last_Choice := Null_Iir; + Choice := Get_Individual_Association_Chain (Sub_Assoc); + while Choice /= Null_Iir loop + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Expression => + if Eval_Pos (Get_Choice_Expression (Choice)) + = Eval_Pos (Index) + then + goto Found; + end if; + when Iir_Kind_Choice_By_Range => + declare + Choice_Range : constant Iir := Get_Choice_Range (Choice); + begin + if Get_Expr_Staticness (Choice_Range) = Locally + and then + Eval_Int_In_Range (Eval_Pos (Index), Choice_Range) + then + -- FIXME: overlap. + raise Internal_Error; + end if; + end; + when others => + Error_Kind ("add_individual_assoc_index_name", Choice); + end case; + Last_Choice := Choice; + Choice := Get_Chain (Choice); + end loop; + + -- If not found, append it. + Choice := Create_Iir (Iir_Kind_Choice_By_Expression); + Set_Choice_Expression (Choice, Index); + Set_Choice_Staticness (Choice, Staticness); + Location_Copy (Choice, Formal); + if Last_Choice = Null_Iir then + Set_Individual_Association_Chain (Sub_Assoc, Choice); + else + Set_Chain (Last_Choice, Choice); + end if; + + << Found >> null; + + if I < Nbr - 1 then + -- Create an intermediate assoc by individual. + Sub_Assoc := Get_Associated_Expr (Choice); + if Sub_Assoc = Null_Iir then + Sub_Assoc := Create_Iir + (Iir_Kind_Association_Element_By_Individual); + Location_Copy (Sub_Assoc, Index); + Set_Associated_Expr (Choice, Sub_Assoc); + Set_Choice_Staticness (Sub_Assoc, Locally); + end if; + end if; + end loop; + end Add_Individual_Assoc_Indexed_Name; + + procedure Add_Individual_Assoc_Slice_Name + (Choice : out Iir; Sub_Assoc : Iir; Formal : Iir) + is + Index : Iir; + Staticness : Iir_Staticness; + begin + -- FIXME: handle cases such as param(5 to 6)(5) + + -- Find element. + Index := Get_Suffix (Formal); + + -- Evaluate index. + Staticness := Get_Expr_Staticness (Index); + if Staticness = Locally then + Index := Eval_Range (Index); + Set_Suffix (Formal, Index); + else + Error_Msg_Sem (+Index, "range expression must be locally static"); + Set_Choice_Staticness (Sub_Assoc, None); + end if; + + Choice := Create_Iir (Iir_Kind_Choice_By_Range); + Location_Copy (Choice, Formal); + Set_Choice_Range (Choice, Index); + Set_Chain (Choice, Get_Individual_Association_Chain (Sub_Assoc)); + Set_Choice_Staticness (Choice, Staticness); + Set_Individual_Association_Chain (Sub_Assoc, Choice); + end Add_Individual_Assoc_Slice_Name; + + procedure Add_Individual_Assoc_Selected_Name + (Choice : out Iir; Sub_Assoc : Iir; Formal : Iir) + is + Element : constant Iir := Get_Named_Entity (Formal); + Last_Choice : Iir; + begin + -- Try to find the existing choice. + Last_Choice := Null_Iir; + Choice := Get_Individual_Association_Chain (Sub_Assoc); + while Choice /= Null_Iir loop + if Get_Choice_Name (Choice) = Element then + return; + end if; + Last_Choice := Choice; + Choice := Get_Chain (Choice); + end loop; + + -- If not found, append it. + Choice := Create_Iir (Iir_Kind_Choice_By_Name); + Location_Copy (Choice, Formal); + Set_Choice_Name (Choice, Element); + if Last_Choice = Null_Iir then + Set_Individual_Association_Chain (Sub_Assoc, Choice); + else + Set_Chain (Last_Choice, Choice); + end if; + end Add_Individual_Assoc_Selected_Name; + + -- Subroutine of Add_Individual_Association. + -- Search/build the tree of choices for FORMAL, starting for IASSOC. + -- The root of the tree is an association by individual node. Each node + -- points to a chain of choices, whose associated expression is either an + -- association by individual (and the tree continue) or an association + -- by expression coming from the initial association (and this is a leaf). + procedure Add_Individual_Association_1 + (Iassoc : in out Iir; Formal : Iir; Last : Boolean) + is + Base_Assoc : constant Iir := Iassoc; + Formal_Object : constant Iir := Name_To_Object (Formal); + Sub : Iir; + Choice : Iir; + begin + pragma Assert + (Get_Kind (Iassoc) = Iir_Kind_Association_Element_By_Individual); + + -- Recurse to start from the basename of the formal. + case Get_Kind (Formal_Object) is + when Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Selected_Element => + Add_Individual_Association_1 + (Iassoc, Get_Prefix (Formal_Object), False); + when Iir_Kinds_Interface_Object_Declaration => + -- At the root of the formal. + pragma Assert + (Formal_Object = Get_Named_Entity (Get_Formal (Iassoc))); + return; + when others => + Error_Kind ("add_individual_association_1", Formal); + end case; + + -- Add the choices for the indexes/slice/element. + case Get_Kind (Formal_Object) is + when Iir_Kind_Indexed_Name => + Add_Individual_Assoc_Indexed_Name (Choice, Iassoc, Formal_Object); + when Iir_Kind_Slice_Name => + Add_Individual_Assoc_Slice_Name (Choice, Iassoc, Formal_Object); + when Iir_Kind_Selected_Element => + Add_Individual_Assoc_Selected_Name (Choice, Iassoc, Formal_Object); + when others => + Error_Kind ("add_individual_association_1(3)", Formal); + end case; + + Sub := Get_Associated_Expr (Choice); + if Sub = Null_Iir then + if not Last then + -- Create the individual association for the choice. + Sub := Create_Iir (Iir_Kind_Association_Element_By_Individual); + Location_Copy (Sub, Formal); + Set_Choice_Staticness (Sub, Locally); + Set_Formal (Sub, Formal); + Set_Associated_Expr (Choice, Sub); + end if; + else + if Last + or else Get_Kind (Sub) /= Iir_Kind_Association_Element_By_Individual + then + -- A final association. + pragma Assert + (Get_Kind (Sub) = Iir_Kind_Association_Element_By_Expression); + Error_Msg_Sem + (+Formal, "individual association of %n" + & " conflicts with that at %l", + (+Get_Interface_Of_Formal (Get_Formal (Iassoc)), + +Sub)); + else + if Get_Choice_Staticness (Sub) /= Locally then + -- Propagate error. + Set_Choice_Staticness (Base_Assoc, None); + end if; + end if; + end if; + + if Last then + Iassoc := Choice; + else + Iassoc := Sub; + end if; + end Add_Individual_Association_1; + + -- Insert ASSOC into the tree of individual assoc rooted by IASSOC. + -- This is done so that duplicate or missing associations are found (using + -- the same routine for aggregate/case statement). + procedure Add_Individual_Association (Iassoc : Iir; Assoc : Iir) + is + Formal : constant Iir := Get_Formal (Assoc); + Res_Iass : Iir; + Prev : Iir; + begin + -- Create the individual association for the formal. + Res_Iass := Iassoc; + Add_Individual_Association_1 (Res_Iass, Formal, True); + + Prev := Get_Associated_Expr (Res_Iass); + if Prev = Null_Iir then + Set_Associated_Expr (Res_Iass, Assoc); + end if; + end Add_Individual_Association; + + procedure Finish_Individual_Assoc_Array_Subtype + (Assoc : Iir; Atype : Iir; Dim : Positive) + is + Index_Tlist : constant Iir_Flist := Get_Index_Subtype_List (Atype); + Nbr_Dims : constant Natural := Get_Nbr_Elements (Index_Tlist); + Index_Type : constant Iir := Get_Nth_Element (Index_Tlist, Dim - 1); + Chain : constant Iir := Get_Individual_Association_Chain (Assoc); + Low, High : Iir; + El : Iir; + begin + Sem_Check_Continuous_Choices + (Chain, Index_Type, Low, High, Get_Location (Assoc), False); + if Dim < Nbr_Dims then + El := Chain; + while El /= Null_Iir loop + pragma Assert (Get_Kind (El) = Iir_Kind_Choice_By_Expression); + Finish_Individual_Assoc_Array_Subtype + (Get_Associated_Expr (El), Atype, Dim + 1); + El := Get_Chain (El); + end loop; + end if; + end Finish_Individual_Assoc_Array_Subtype; + + procedure Finish_Individual_Assoc_Array + (Actual : Iir; Assoc : Iir; Dim : Natural) + is + Actual_Type : constant Iir := Get_Actual_Type (Actual); + Actual_Index : Iir; + Base_Type : Iir; + Base_Index : Iir; + Low, High : Iir; + Chain : Iir; + begin + Actual_Index := Get_Nth_Element (Get_Index_Subtype_List (Actual_Type), + Dim - 1); + if Actual_Index /= Null_Iir then + Base_Index := Actual_Index; + else + Base_Type := Get_Base_Type (Actual_Type); + Base_Index := Get_Index_Type (Base_Type, Dim - 1); + end if; + Chain := Get_Individual_Association_Chain (Assoc); + Sem_Choices_Range + (Chain, Base_Index, Low, High, Get_Location (Assoc), True, False); + Set_Individual_Association_Chain (Assoc, Chain); + if Actual_Index = Null_Iir then + declare + Index_Constraint : Iir; + Index_Subtype_Constraint : Iir; + begin + -- Create an index subtype. + case Get_Kind (Base_Index) is + when Iir_Kind_Integer_Subtype_Definition => + Actual_Index := + Create_Iir (Iir_Kind_Integer_Subtype_Definition); + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + Actual_Index := + Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); + when others => + Error_Kind ("finish_individual_assoc_array", Base_Index); + end case; + Location_Copy (Actual_Index, Actual); + Set_Base_Type (Actual_Index, Get_Base_Type (Base_Index)); + Index_Constraint := Get_Range_Constraint (Base_Index); + + Index_Subtype_Constraint := Create_Iir (Iir_Kind_Range_Expression); + Location_Copy (Index_Subtype_Constraint, Actual); + Set_Range_Constraint (Actual_Index, Index_Subtype_Constraint); + Set_Type_Staticness (Actual_Index, Locally); + Set_Direction (Index_Subtype_Constraint, + Get_Direction (Index_Constraint)); + + -- For ownership purpose, the bounds must be copied otherwise + -- they would be referenced before being defined. This is non + -- optimal but it doesn't happen often. + Low := Copy_Constant (Low); + High := Copy_Constant (High); + + case Get_Direction (Index_Constraint) is + when Iir_To => + Set_Left_Limit (Index_Subtype_Constraint, Low); + Set_Left_Limit_Expr (Index_Subtype_Constraint, Low); + Set_Right_Limit (Index_Subtype_Constraint, High); + Set_Right_Limit_Expr (Index_Subtype_Constraint, High); + when Iir_Downto => + Set_Left_Limit (Index_Subtype_Constraint, High); + Set_Left_Limit_Expr (Index_Subtype_Constraint, High); + Set_Right_Limit (Index_Subtype_Constraint, Low); + Set_Right_Limit_Expr (Index_Subtype_Constraint, Low); + end case; + Set_Expr_Staticness (Index_Subtype_Constraint, Locally); + Set_Nth_Element (Get_Index_Subtype_List (Actual_Type), Dim - 1, + Actual_Index); + end; + else + declare + Act_High, Act_Low : Iir; + begin + Get_Low_High_Limit (Get_Range_Constraint (Actual_Type), + Act_Low, Act_High); + if Eval_Pos (Act_Low) /= Eval_Pos (Low) + or Eval_Pos (Act_High) /= Eval_Pos (High) + then + Error_Msg_Sem + (+Assoc, "indexes of individual association mismatch"); + end if; + end; + end if; + end Finish_Individual_Assoc_Array; + + procedure Finish_Individual_Assoc_Record (Assoc : Iir; Atype : Iir) + is + El_List : constant Iir_Flist := Get_Elements_Declaration_List (Atype); + Nbr_El : constant Natural := Get_Nbr_Elements (El_List); + Matches : Iir_Array (0 .. Nbr_El - 1); + Ch : Iir; + Pos : Natural; + Rec_El : Iir; + begin + -- Check for duplicate associations. + Matches := (others => Null_Iir); + Ch := Get_Individual_Association_Chain (Assoc); + while Ch /= Null_Iir loop + Rec_El := Get_Choice_Name (Ch); + Pos := Natural (Get_Element_Position (Rec_El)); + if Matches (Pos) /= Null_Iir then + Error_Msg_Sem (+Ch, "individual %n already associated at %l", + (+Rec_El, +Matches (Pos))); + else + Matches (Pos) := Ch; + end if; + Ch := Get_Chain (Ch); + end loop; + + -- Check for missing associations. + for I in Matches'Range loop + Rec_El := Get_Nth_Element (El_List, I); + if Matches (I) = Null_Iir then + Error_Msg_Sem (+Assoc, "%n not associated", +Rec_El); + end if; + end loop; + + if Get_Constraint_State (Atype) /= Fully_Constrained then + -- Some (sub-)elements are unbounded, create a bounded subtype. + declare + Inter : constant Iir := + Get_Interface_Of_Formal (Get_Formal (Assoc)); + Ntype : Iir; + Nel_List : Iir_Flist; + Nrec_El : Iir; + Rec_El_Type : Iir; + Staticness : Iir_Staticness; + begin + Ntype := Create_Iir (Iir_Kind_Record_Subtype_Definition); + Location_Copy (Ntype, Assoc); + Set_Base_Type (Ntype, Get_Base_Type (Atype)); + if Get_Kind (Atype) = Iir_Kind_Record_Subtype_Definition then + Set_Resolution_Indication + (Ntype, Get_Resolution_Indication (Atype)); + end if; + if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration + then + -- The subtype is used for signals. + Set_Has_Signal_Flag (Ntype, True); + end if; + + Nel_List := Create_Iir_Flist (Nbr_El); + Set_Elements_Declaration_List (Ntype, Nel_List); + + Staticness := Locally; + for I in Matches'Range loop + Rec_El := Get_Nth_Element (El_List, I); + Rec_El_Type := Get_Type (Rec_El); + if (Get_Kind (Rec_El_Type) + not in Iir_Kinds_Composite_Type_Definition) + or else + Get_Constraint_State (Rec_El_Type) = Fully_Constrained + or else + Matches (I) = Null_Iir -- In case of error. + then + Nrec_El := Rec_El; + else + Nrec_El := Create_Iir (Iir_Kind_Record_Element_Constraint); + Ch := Matches (I); + Location_Copy (Nrec_El, Ch); + Set_Parent (Nrec_El, Ntype); + Set_Identifier (Nrec_El, Get_Identifier (Rec_El)); + pragma Assert (I = Natural (Get_Element_Position (Rec_El))); + Set_Element_Position (Nrec_El, Iir_Index32 (I)); + Ch := Get_Associated_Expr (Ch); + Set_Type (Nrec_El, Get_Type (Get_Actual (Ch))); + Append_Owned_Element_Constraint (Ntype, Nrec_El); + end if; + Staticness := Min (Staticness, + Get_Type_Staticness (Get_Type (Nrec_El))); + Set_Nth_Element (Nel_List, I, Nrec_El); + end loop; + Set_Type_Staticness (Ntype, Staticness); + Set_Constraint_State (Ntype, Fully_Constrained); + + Set_Actual_Type (Assoc, Ntype); + end; + else + Set_Actual_Type (Assoc, Atype); + end if; + end Finish_Individual_Assoc_Record; + + -- Free recursively all the choices of ASSOC. Once the type is computed + -- this is not needed anymore. + procedure Clean_Individual_Association (Assoc : Iir) + is + El, N_El : Iir; + Expr : Iir; + begin + El := Get_Individual_Association_Chain (Assoc); + Set_Individual_Association_Chain (Assoc, Null_Iir); + + while Is_Valid (El) loop + N_El := Get_Chain (El); + + pragma Assert (Get_Kind (El) in Iir_Kinds_Choice); + Expr := Get_Associated_Expr (El); + if Get_Kind (Expr) = Iir_Kind_Association_Element_By_Individual then + Clean_Individual_Association (Expr); + Free_Iir (Expr); + end if; + + Free_Iir (El); + El := N_El; + end loop; + end Clean_Individual_Association; + + -- Called by sem_individual_association to finish the analyze of + -- individual association ASSOC: compute bounds, detect missing elements. + procedure Finish_Individual_Association (Assoc : Iir) + is + Inter : Iir; + Atype : Iir; + begin + -- Guard. + if Assoc = Null_Iir or else Get_Choice_Staticness (Assoc) /= Locally then + return; + end if; + + Inter := Get_Interface_Of_Formal (Get_Formal (Assoc)); + Atype := Get_Type (Inter); + Set_Whole_Association_Flag (Assoc, True); + + case Get_Kind (Atype) is + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Array_Type_Definition => + if Get_Constraint_State (Atype) = Fully_Constrained then + Finish_Individual_Assoc_Array_Subtype (Assoc, Atype, 1); + Set_Actual_Type (Assoc, Atype); + else + Atype := Create_Array_Subtype (Atype, Get_Location (Assoc)); + Set_Index_Constraint_Flag (Atype, True); + Set_Constraint_State (Atype, Fully_Constrained); + if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration + then + -- The subtype is used for signals. + Set_Has_Signal_Flag (Atype, True); + end if; + Set_Actual_Type (Assoc, Atype); + Set_Actual_Type_Definition (Assoc, Atype); + Finish_Individual_Assoc_Array (Assoc, Assoc, 1); + end if; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + Finish_Individual_Assoc_Record (Assoc, Atype); + when others => + Error_Kind ("finish_individual_association", Atype); + end case; + + -- Free the hierarchy, keep only the top individual association. + Clean_Individual_Association (Assoc); + end Finish_Individual_Association; + + -- Sem individual associations of ASSOCS: + -- Add an Iir_Kind_Association_Element_By_Individual before each + -- group of individual association for the same formal, and call + -- Finish_Individual_Association with each of these added nodes. + -- + -- The purpose of By_Individual association is to have the type of the + -- actual (might be an array subtype), and also to be sure that all + -- sub-elements are associated. For that a tree is created. The tree is + -- rooted by the top Association_Element_By_Individual, which contains a + -- chain of choices (like the aggregate). The child of a choice is either + -- an Association_Element written by the user, or a new subtree rooted + -- by another Association_Element_By_Individual. The tree doesn't + -- follow all the ownership rules: the formal of sub association_element + -- are directly set to the association, and the associated_expr of the + -- choices are directly set to formals. + -- + -- This tree is temporary (used only during analysis of the individual + -- association) and removed once the check is done. + procedure Sem_Individual_Association (Assoc_Chain : in out Iir) + is + Assoc : Iir; + Prev_Assoc : Iir; + Iassoc : Iir_Association_Element_By_Individual; + Cur_Iface : Iir; + Formal : Iir; + begin + Iassoc := Null_Iir; + Cur_Iface := Null_Iir; + Prev_Assoc := Null_Iir; + Assoc := Assoc_Chain; + while Assoc /= Null_Iir loop + Formal := Get_Formal (Assoc); + if Formal /= Null_Iir then + Formal := Get_Object_Prefix (Formal); + end if; + if Formal = Null_Iir or else Formal /= Cur_Iface then + -- New formal name, analyze the current individual association + -- (if any). + Finish_Individual_Association (Iassoc); + Cur_Iface := Formal; + Iassoc := Null_Iir; + end if; + + if Get_Whole_Association_Flag (Assoc) = False then + -- Individual association. + if Iassoc = Null_Iir then + -- The first one for the interface: create a new individual + -- association. + Iassoc := + Create_Iir (Iir_Kind_Association_Element_By_Individual); + Location_Copy (Iassoc, Assoc); + Set_Choice_Staticness (Iassoc, Locally); + pragma Assert (Cur_Iface /= Null_Iir); + Set_Formal + (Iassoc, + Build_Simple_Name (Cur_Iface, Get_Location (Formal))); + -- Insert IASSOC. + if Prev_Assoc = Null_Iir then + Assoc_Chain := Iassoc; + else + Set_Chain (Prev_Assoc, Iassoc); + end if; + Set_Chain (Iassoc, Assoc); + end if; + + -- Add this individual association to the tree. + Add_Individual_Association (Iassoc, Assoc); + end if; + Prev_Assoc := Assoc; + Assoc := Get_Chain (Assoc); + end loop; + -- There is maybe a remaining iassoc. + Finish_Individual_Association (Iassoc); + end Sem_Individual_Association; + + function Is_Conversion_Function (Assoc_Chain : Iir) return Boolean is + begin + -- [...] whose single parameter of the function [...] + if not Is_Chain_Length_One (Assoc_Chain) then + return False; + end if; + if Get_Kind (Assoc_Chain) /= Iir_Kind_Association_Element_By_Expression + then + return False; + end if; + -- FIXME: unfortunatly, the formal may already be set with the + -- interface. +-- if Get_Formal (Assoc_Chain) /= Null_Iir then +-- return Null_Iir; +-- end if; + return True; + end Is_Conversion_Function; + + function Is_Valid_Conversion + (Func : Iir; Res_Base_Type : Iir; Param_Base_Type : Iir) return Boolean + is + R_Type : Iir; + P_Type : Iir; + begin + case Get_Kind (Func) is + when Iir_Kind_Function_Declaration => + R_Type := Get_Type (Func); + P_Type := Get_Type (Get_Interface_Declaration_Chain (Func)); + if Get_Base_Type (R_Type) = Res_Base_Type + and then Get_Base_Type (P_Type) = Param_Base_Type + then + return True; + else + return False; + end if; + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration => + R_Type := Get_Type (Func); + if Get_Base_Type (R_Type) = Res_Base_Type + and then Are_Types_Closely_Related (R_Type, Param_Base_Type) + then + return True; + else + return False; + end if; + when Iir_Kind_Function_Call => + return Is_Valid_Conversion (Get_Implementation (Func), + Res_Base_Type, Param_Base_Type); + when Iir_Kind_Type_Conversion => + return Is_Valid_Conversion (Get_Type_Mark (Func), + Res_Base_Type, Param_Base_Type); + when Iir_Kinds_Denoting_Name => + return Is_Valid_Conversion (Get_Named_Entity (Func), + Res_Base_Type, Param_Base_Type); + when others => + return False; + end case; + end Is_Valid_Conversion; + + function Extract_Conversion + (Conv : Iir; Res_Type : Iir; Param_Type : Iir; Loc : Iir) return Iir + is + List : Iir_List; + It : List_Iterator; + Res_Base_Type : Iir; + Param_Base_Type : Iir; + El : Iir; + Res : Iir; + begin + Res_Base_Type := Get_Base_Type (Res_Type); + if Param_Type = Null_Iir then + -- In case of error. + return Null_Iir; + end if; + Param_Base_Type := Get_Base_Type (Param_Type); + if Is_Overload_List (Conv) then + List := Get_Overload_List (Conv); + Res := Null_Iir; + It := List_Iterate (List); + while Is_Valid (It) loop + El := Get_Element (It); + if Is_Valid_Conversion (El, Res_Base_Type, Param_Base_Type) then + if Res /= Null_Iir then + raise Internal_Error; + end if; + Free_Iir (Conv); + Res := El; + end if; + Next (It); + end loop; + else + if Is_Valid_Conversion (Conv, Res_Base_Type, Param_Base_Type) then + Res := Conv; + else + Res := Null_Iir; + Error_Msg_Sem (+Loc, "conversion function or type does not match"); + end if; + end if; + return Res; + end Extract_Conversion; + + function Extract_In_Conversion + (Conv : Iir; Res_Type : Iir; Param_Type : Iir) return Iir + is + Func : Iir; + Assoc : Iir; + begin + if Conv = Null_Iir then + return Null_Iir; + end if; + Func := Extract_Conversion (Conv, Res_Type, Param_Type, Conv); + if Func = Null_Iir then + return Null_Iir; + end if; + case Get_Kind (Func) is + when Iir_Kind_Function_Call => + Assoc := Get_Parameter_Association_Chain (Func); + Free_Iir (Assoc); + Set_Parameter_Association_Chain (Func, Null_Iir); + Name_To_Method_Object (Func, Conv); + return Func; + when Iir_Kind_Type_Conversion => + return Func; + when others => + Error_Kind ("extract_in_conversion", Func); + end case; + end Extract_In_Conversion; + + function Extract_Out_Conversion + (Conv : Iir; Res_Type : Iir; Param_Type : Iir) return Iir + is + Func : Iir; + begin + if Conv = Null_Iir then + return Null_Iir; + end if; + Func := Extract_Conversion (Conv, Res_Type, Param_Type, Conv); + + return Func; + end Extract_Out_Conversion; + + procedure Sem_Association_Open + (Assoc : Iir; + Finish : Boolean; + Match : out Compatibility_Level) + is + Formal : Iir; + begin + if Finish then + -- LRM 4.3.3.2 Associations lists + -- It is an error if an actual of open is associated with a + -- formal that is associated individually. + if Get_Whole_Association_Flag (Assoc) = False then + Error_Msg_Sem + (+Assoc, "cannot associate individually with open"); + end if; + + Formal := Get_Formal (Assoc); + if Formal /= Null_Iir then + Set_Formal (Assoc, Finish_Sem_Name (Formal)); + end if; + end if; + Match := Fully_Compatible; + end Sem_Association_Open; + + procedure Sem_Association_Package_Type_Not_Finish + (Assoc : Iir; + Inter : Iir; + Match : out Compatibility_Level) + is + Formal : constant Iir := Get_Formal (Assoc); + begin + if Formal = Null_Iir then + -- Can be associated only once + Match := Fully_Compatible; + else + if Kind_In (Formal, Iir_Kind_Simple_Name, Iir_Kind_Operator_Symbol) + and then Get_Identifier (Formal) = Get_Identifier (Inter) + then + Match := Fully_Compatible; + else + Match := Not_Compatible; + end if; + end if; + end Sem_Association_Package_Type_Not_Finish; + + procedure Sem_Association_Package_Type_Finish (Assoc : Iir; Inter : Iir) + is + Formal : constant Iir := Get_Formal (Assoc); + begin + if Formal /= Null_Iir then + pragma Assert (Get_Identifier (Formal) = Get_Identifier (Inter)); + pragma Assert (Get_Named_Entity (Formal) = Inter); + Set_Formal (Assoc, Finish_Sem_Name (Formal)); + end if; + end Sem_Association_Package_Type_Finish; + + procedure Sem_Association_Package + (Assoc : Iir; + Inter : Iir; + Finish : Boolean; + Match : out Compatibility_Level) + is + Actual : Iir; + Package_Inter : Iir; + begin + if not Finish then + Sem_Association_Package_Type_Not_Finish (Assoc, Inter, Match); + return; + end if; + + Match := Not_Compatible; + Sem_Association_Package_Type_Finish (Assoc, Inter); + + -- Analyze actual. + Actual := Get_Actual (Assoc); + Actual := Sem_Denoting_Name (Actual); + Set_Actual (Assoc, Actual); + + Actual := Get_Named_Entity (Actual); + if Is_Error (Actual) then + return; + end if; + + -- LRM08 6.5.7.2 Generic map aspects + -- An actual associated with a formal generic package in a + -- generic map aspect shall be the name that denotes an instance + -- of the uninstantiated package named in the formal generic + -- package declaration [...] + if Get_Kind (Actual) /= Iir_Kind_Package_Instantiation_Declaration then + Error_Msg_Sem + (+Assoc, "actual of association is not a package instantiation"); + return; + end if; + + Package_Inter := Get_Uninstantiated_Package_Decl (Inter); + if Get_Uninstantiated_Package_Decl (Actual) /= Package_Inter then + Error_Msg_Sem + (+Assoc, + "actual package name is not an instance of interface package"); + return; + end if; + + -- LRM08 6.5.7.2 Generic map aspects + -- b) If the formal generic package declaration includes an interface + -- generic map aspect in the form that includes the box (<>) symbol, + -- then the instantiaed package denotes by the actual may be any + -- instance of the uninstantiated package named in the formal + -- generic package declaration. + if Get_Generic_Map_Aspect_Chain (Inter) = Null_Iir then + null; + else + -- Other cases not yet handled. + raise Internal_Error; + end if; + + Match := Fully_Compatible; + + return; + end Sem_Association_Package; + + -- Create an implicit association_element_subprogram for the declaration + -- of function ID for ACTUAL_Type (a type/subtype definition). + function Sem_Implicit_Operator_Association + (Id : Name_Id; Actual_Type : Iir; Actual_Name : Iir) return Iir + is + use Sem_Scopes; + + -- Return TRUE if DECL is a function declaration with a comparaison + -- operator profile. + function Has_Comparaison_Profile (Decl : Iir) return Boolean + is + Inter : Iir; + begin + -- A function declaration. + if not Is_Function_Declaration (Decl) then + return False; + end if; + -- That returns a boolean. + if (Get_Base_Type (Get_Return_Type (Decl)) + /= Std_Package.Boolean_Type_Definition) + then + return False; + end if; + + -- With 2 interfaces of type ATYPE. + Inter := Get_Interface_Declaration_Chain (Decl); + for I in 1 .. 2 loop + if Inter = Null_Iir then + return False; + end if; + if Get_Base_Type (Get_Type (Inter)) /= Get_Base_Type (Actual_Type) + then + return False; + end if; + Inter := Get_Chain (Inter); + end loop; + if Inter /= Null_Iir then + return False; + end if; + return True; + end Has_Comparaison_Profile; + + Interp : Name_Interpretation_Type; + Decl : Iir; + Res : Iir; + begin + Interp := Get_Interpretation (Id); + while Valid_Interpretation (Interp) loop + Decl := Get_Declaration (Interp); + if Has_Comparaison_Profile (Decl) then + Res := Create_Iir (Iir_Kind_Association_Element_Subprogram); + Location_Copy (Res, Actual_Name); + Set_Actual + (Res, Build_Simple_Name (Decl, Get_Location (Actual_Name))); + Set_Use_Flag (Decl, True); + return Res; + end if; + Interp := Get_Next_Interpretation (Interp); + end loop; + + Error_Msg_Sem (+Actual_Name, "cannot find a %i declaration for type %i", + (+Id, +Actual_Name)); + return Null_Iir; + end Sem_Implicit_Operator_Association; + + procedure Sem_Association_Type (Assoc : Iir; + Inter : Iir; + Finish : Boolean; + Match : out Compatibility_Level) + is + Inter_Def : constant Iir := Get_Type (Inter); + Actual : Iir; + Actual_Type : Iir; + Op_Eq, Op_Neq : Iir; + begin + if not Finish then + Sem_Association_Package_Type_Not_Finish (Assoc, Inter, Match); + return; + end if; + + Match := Fully_Compatible; + Sem_Association_Package_Type_Finish (Assoc, Inter); + Actual := Get_Actual (Assoc); + + -- LRM08 6.5.7.2 Generic map aspects + -- An actual associated with a formal generic type must be a subtype + -- indication. + -- FIXME: ghdl only supports type_mark! + Actual := Sem_Types.Sem_Subtype_Indication (Actual); + Set_Actual (Assoc, Actual); + + -- Set type association for analysis of reference to this interface. + pragma Assert (Is_Null (Get_Associated_Type (Inter_Def))); + if Get_Kind (Actual) in Iir_Kinds_Subtype_Definition then + Actual_Type := Actual; + else + Actual_Type := Get_Type (Actual); + end if; + Set_Actual_Type (Assoc, Actual_Type); + Set_Associated_Type (Inter_Def, Actual_Type); + + -- FIXME: it is not clear at all from the LRM how the implicit + -- associations are done... + Op_Eq := Sem_Implicit_Operator_Association + (Std_Names.Name_Op_Equality, Actual_Type, Actual); + if Op_Eq /= Null_Iir then + Op_Neq := Sem_Implicit_Operator_Association + (Std_Names.Name_Op_Inequality, Actual_Type, Actual); + Set_Chain (Op_Eq, Op_Neq); + Set_Subprogram_Association_Chain (Assoc, Op_Eq); + end if; + end Sem_Association_Type; + + function Has_Interface_Subprogram_Profile + (Inter : Iir; + Decl : Iir; + Explain_Loc : Location_Type := No_Location) return Boolean + is + -- Handle previous assocation of interface type before full + -- instantiation. + function Get_Inter_Type (Inter : Iir) return Iir + is + Res : Iir; + begin + Res := Get_Type (Inter); + if Get_Kind (Res) = Iir_Kind_Interface_Type_Definition then + -- FIXME: recurse ? + return Get_Associated_Type (Res); + else + return Res; + end if; + end Get_Inter_Type; + + Explain : constant Boolean := Explain_Loc /= No_Location; + El_Inter, El_Decl : Iir; + begin + case Iir_Kinds_Interface_Subprogram_Declaration (Get_Kind (Inter)) is + when Iir_Kind_Interface_Function_Declaration => + if not Is_Function_Declaration (Decl) then + if Explain then + Error_Msg_Sem (Explain_Loc, " actual is not a function"); + end if; + return False; + end if; + if Get_Base_Type (Get_Inter_Type (Inter)) + /= Get_Base_Type (Get_Type (Decl)) + then + if Explain then + Error_Msg_Sem (Explain_Loc, " return type doesn't match"); + end if; + return False; + end if; + when Iir_Kind_Interface_Procedure_Declaration => + if not Is_Procedure_Declaration (Decl) then + if Explain then + Error_Msg_Sem (Explain_Loc, " actual is not a procedure"); + end if; + return False; + end if; + end case; + + El_Inter := Get_Interface_Declaration_Chain (Inter); + El_Decl := Get_Interface_Declaration_Chain (Decl); + loop + exit when Is_Null (El_Inter) and Is_Null (El_Decl); + if Is_Null (El_Inter) or Is_Null (El_Decl) then + if Explain then + Error_Msg_Sem + (Explain_Loc, " number of interfaces doesn't match"); + end if; + return False; + end if; + if Get_Base_Type (Get_Inter_Type (El_Inter)) + /= Get_Base_Type (Get_Type (El_Decl)) + then + if Explain then + Error_Msg_Sem + (Explain_Loc, + " type of interface %i doesn't match", +El_Inter); + end if; + return False; + end if; + El_Inter := Get_Chain (El_Inter); + El_Decl := Get_Chain (El_Decl); + end loop; + + return True; + end Has_Interface_Subprogram_Profile; + + procedure Sem_Association_Subprogram (Assoc : Iir; + Inter : Iir; + Finish : Boolean; + Match : out Compatibility_Level) + is + Discard : Boolean; + pragma Unreferenced (Discard); + Actual : Iir; + Res : Iir; + begin + if not Finish then + Sem_Association_Package_Type_Not_Finish (Assoc, Inter, Match); + return; + end if; + + Match := Fully_Compatible; + Sem_Association_Package_Type_Finish (Assoc, Inter); + Actual := Get_Actual (Assoc); + + -- LRM08 6.5.7.2 Generic map aspects + -- An actual associated with a formal generic subprogram shall be a name + -- that denotes a subprogram whose profile conforms to that of the + -- formal, or the reserved word OPEN. The actual, if a predefined + -- attribute name that denotes a function, shall be one of the + -- predefined attributes 'IMAGE, 'VALUE, 'POS, 'VAL, 'SUCC, 'PREV, + -- 'LEFTOF, or 'RIGHTOF. + Sem_Name (Actual); + Res := Get_Named_Entity (Actual); + + if Is_Error (Res) then + return; + end if; + + case Get_Kind (Res) is + when Iir_Kinds_Subprogram_Declaration + | Iir_Kinds_Interface_Subprogram_Declaration => + if not Has_Interface_Subprogram_Profile (Inter, Res) then + Error_Msg_Sem + (+Assoc, "profile of %n doesn't match profile of %n", + (+Actual, +Inter)); + -- Explain + Discard := Has_Interface_Subprogram_Profile + (Inter, Res, Get_Location (Assoc)); + return; + end if; + when Iir_Kind_Overload_List => + declare + Nbr_Errors : Natural; + List : Iir_List; + It : List_Iterator; + El, R : Iir; + begin + Nbr_Errors := 0; + R := Null_Iir; + List := Get_Overload_List (Res); + It := List_Iterate (List); + while Is_Valid (It) loop + El := Get_Element (It); + if Has_Interface_Subprogram_Profile (Inter, El) then + if Is_Null (R) then + R := El; + else + if Nbr_Errors = 0 then + Error_Msg_Sem + (+Assoc, + "many possible actual subprogram for %n:", + +Inter); + Error_Msg_Sem + (+Assoc, " %n declared at %l", (+R, + R)); + else + Error_Msg_Sem + (+Assoc, " %n declared at %l", (+El, +El)); + end if; + Nbr_Errors := Nbr_Errors + 1; + end if; + end if; + Next (It); + end loop; + if Is_Null (R) then + Error_Msg_Sem + (+Assoc, "no matching name for %n", +Inter); + if True then + Error_Msg_Sem + (+Assoc, " these names were incompatible:"); + It := List_Iterate (List); + while Is_Valid (It) loop + El := Get_Element (It); + Error_Msg_Sem + (+Assoc, " %n declared at %l", (+El, +El)); + Next (It); + end loop; + end if; + return; + elsif Nbr_Errors > 0 then + return; + end if; + Free_Overload_List (Res); + Res := R; + end; + when others => + Error_Kind ("sem_association_subprogram", Res); + end case; + + Set_Named_Entity (Actual, Res); + Xrefs.Xref_Name (Actual); + Sem_Decls.Mark_Subprogram_Used (Res); + end Sem_Association_Subprogram; + + -- Associate ASSOC with interface INTERFACE + -- This sets MATCH. + procedure Sem_Association_By_Expression + (Assoc : Iir; + Inter : Iir; + Formal_Name : Iir; + Formal_Conv : Iir; + Finish : Boolean; + Match : out Compatibility_Level) + is + Formal_Type : Iir; + Actual: Iir; + Out_Conv, In_Conv : Iir; + Expr : Iir; + Res_Type : Iir; + begin + Out_Conv := Formal_Conv; + if Formal_Name /= Null_Iir then + Formal_Type := Get_Type (Formal_Name); + else + Formal_Type := Get_Type (Inter); + end if; + + -- Extract conversion from actual. + -- LRM08 6.5.7.1 Association lists + Actual := Get_Actual (Assoc); + In_Conv := Null_Iir; + if Get_Kind (Inter) /= Iir_Kind_Interface_Constant_Declaration then + declare + -- Actual before the extraction of the conversion. + Prev_Actual : constant Iir := Actual; + begin + -- Extract conversion and new actual (conv_expr). + case Get_Kind (Actual) is + when Iir_Kind_Function_Call => + Expr := Get_Parameter_Association_Chain (Actual); + if Is_Conversion_Function (Expr) then + In_Conv := Actual; + Actual := Get_Actual (Expr); + end if; + when Iir_Kind_Type_Conversion => + if Flags.Vhdl_Std > Vhdl_87 then + In_Conv := Actual; + Actual := Get_Expression (Actual); + end if; + when others => + null; + end case; + + if Actual = Null_Iir then + Match := Fully_Compatible; + return; + end if; + + -- There could be an ambiguity between a conversion and a normal + -- actual expression. Check if the new actual is an object and + -- if the object is of the corresponding class. + if Is_Valid (In_Conv) then + if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then + if not Is_Signal_Object (Actual) then + -- Actual is not a signal object. This is not a + -- conversion but a regular association. + In_Conv := Null_Iir; + Actual := Prev_Actual; + end if; + else + -- Variable: let as is. + null; + end if; + end if; + end; + end if; + + -- 4 cases: F:out_conv, G:in_conv. + -- A => B type of A = type of B + -- F(A) => B type of B = type of F + -- A => G(B) type of A = type of G + -- F(A) => G(B) type of B = type of F, type of A = type of G + if Out_Conv = Null_Iir and then In_Conv = Null_Iir then + Match := Is_Expr_Compatible (Formal_Type, Actual); + else + Match := Fully_Compatible; + if In_Conv /= Null_Iir then + Match := Compatibility_Level'Min + (Match, Is_Expr_Compatible (Formal_Type, In_Conv)); + end if; + if Out_Conv /= Null_Iir then + Match := Compatibility_Level'Min + (Match, Is_Expr_Compatible (Get_Type (Out_Conv), Actual)); + end if; + end if; + + if Match = Not_Compatible then + if Finish and then not Is_Error (Actual) then + Error_Msg_Sem (+Assoc, "can't associate %n with %n", + (+Actual, +Inter), Cont => True); + Error_Msg_Sem + (+Assoc, "(type of %n is " & Disp_Type_Of (Actual) & ")", + (1 => +Actual), Cont => True); + Error_Msg_Sem + (+Inter, "(type of %n is " & Disp_Type_Of (Inter) & ")", +Inter); + end if; + return; + end if; + + if not Finish then + return; + end if; + + -- At that point, the analysis is being finished. + + if Out_Conv = Null_Iir and then In_Conv = Null_Iir then + Res_Type := Formal_Type; + else + if Out_Conv /= Null_Iir then + Res_Type := Search_Compatible_Type (Get_Type (Out_Conv), + Get_Type (Actual)); + else + Res_Type := Get_Type (Actual); + end if; + + if In_Conv /= Null_Iir then + In_Conv := Extract_In_Conversion (In_Conv, Formal_Type, Res_Type); + end if; + if Out_Conv /= Null_Iir then + Out_Conv := Extract_Out_Conversion (Out_Conv, + Res_Type, Formal_Type); + end if; + end if; + + if Res_Type = Null_Iir then + -- In case of error, do not go farther. + Match := Not_Compatible; + return; + end if; + + if Formal_Name /= Null_Iir then + declare + Formal : Iir; + Conv_Assoc : Iir; + begin + -- Extract formal from the conversion (and unlink it from the + -- conversion, as the owner of the formal is the association, not + -- the conversion). + Formal := Finish_Sem_Name (Get_Formal (Assoc)); + case Get_Kind (Formal) is + when Iir_Kind_Function_Call => + pragma Assert (Formal_Conv /= Null_Iir); + Set_Formal_Conversion (Assoc, Formal); + Conv_Assoc := Get_Parameter_Association_Chain (Formal); + Set_Parameter_Association_Chain (Formal, Null_Iir); + Formal := Get_Actual (Conv_Assoc); + Free_Iir (Conv_Assoc); + -- Name_To_Method_Object (Func, Conv); + when Iir_Kind_Type_Conversion => + pragma Assert (Formal_Conv /= Null_Iir); + Conv_Assoc := Formal; + Set_Formal_Conversion (Assoc, Formal); + Formal := Get_Expression (Formal); + Set_Expression (Conv_Assoc, Null_Iir); + when others => + pragma Assert (Formal_Conv = Null_Iir); + null; + end case; + Set_Formal (Assoc, Formal); + + -- Use the type of the formal to analyze the actual. In + -- particular, the formal may be constrained while the actual is + -- not. + Formal_Type := Get_Type (Formal); + if Out_Conv = Null_Iir and In_Conv = Null_Iir then + Res_Type := Formal_Type; + end if; + end; + end if; + + -- LRM08 6.5.7 Association lists + -- The formal part of a named association element may be in the form of + -- a function call [...] if and only if the formal is an interface + -- object, the mode of the formal is OUT, INOUT, BUFFER or LINKAGE [...] + if Out_Conv /= Null_Iir + and then Get_Mode (Inter) = Iir_In_Mode + then + Error_Msg_Sem + (+Assoc, "can't use an out conversion for an in interface"); + end if; + + -- LRM08 6.5.7 Association lists + -- The actual part of an association element may be in the form of a + -- function call [...] if and only if the mode of the format is IN, + -- INOUT or LINKAGE [...] + Set_Actual_Conversion (Assoc, In_Conv); + if In_Conv /= Null_Iir + and then Get_Mode (Inter) in Iir_Buffer_Mode .. Iir_Out_Mode + then + Error_Msg_Sem + (+Assoc, "can't use an in conversion for an out/buffer interface"); + end if; + + -- LRM08 5.3.2.2 Index constraints and discrete ranges + -- e) [...] + -- 3) [...] + -- -- For an interface object or subelement whose mode is IN, INOUT + -- or LINKAGE, if the actual part includes a conversion function + -- or a type conversion, then the result type of that function + -- or the type mark of the type conversion shall define a + -- constraint for the index range corresponding to the index + -- range of the objet, [...] + -- -- For an interface object or subelement whose mode is OUT, + -- BUFFER, INOUT or LINKAGE, if the formal part includes a + -- conversion function or a type conversion, then the parameter + -- subtype of that function or the type mark of the type + -- conversion shall define a constraint for the index range + -- corresponding to the index range of the object, [...] + if not Is_Fully_Constrained_Type (Formal_Type) then + if (Get_Mode (Inter) in Iir_In_Modes + or else Get_Mode (Inter) = Iir_Linkage_Mode) + and then In_Conv /= Null_Iir + and then not Is_Fully_Constrained_Type (Get_Type (In_Conv)) + then + Error_Msg_Sem + (+Assoc, "type of actual conversion must be fully constrained"); + end if; + if (Get_Mode (Inter) in Iir_Out_Modes + or else Get_Mode (Inter) = Iir_Linkage_Mode) + and then Out_Conv /= Null_Iir + and then not Is_Fully_Constrained_Type (Get_Type (Out_Conv)) + then + Error_Msg_Sem + (+Assoc, "type of formal conversion must be fully constrained"); + end if; + end if; + + -- FIXME: LRM refs + -- This is somewhat wrong. A missing conversion is not an error but + -- may result in a type mismatch. + if Get_Mode (Inter) = Iir_Inout_Mode then + if In_Conv = Null_Iir and then Out_Conv /= Null_Iir then + Error_Msg_Sem + (+Assoc, "out conversion without corresponding in conversion"); + elsif In_Conv /= Null_Iir and then Out_Conv = Null_Iir then + Error_Msg_Sem + (+Assoc, "in conversion without corresponding out conversion"); + end if; + end if; + Set_Actual (Assoc, Actual); + + -- Analyze actual. + Expr := Sem_Expression (Actual, Res_Type); + if Expr /= Null_Iir then + Expr := Eval_Expr_Check_If_Static (Expr, Res_Type); + Set_Actual (Assoc, Expr); + if In_Conv = Null_Iir and then Out_Conv = Null_Iir then + if not Eval_Is_In_Bound (Expr, Formal_Type) then + Error_Msg_Sem + (+Assoc, "actual constraints don't match formal ones"); + end if; + end if; + end if; + end Sem_Association_By_Expression; + + -- Associate ASSOC with interface INTERFACE + -- This sets MATCH. + procedure Sem_Association (Assoc : Iir; + Inter : Iir; + Formal : Iir; + Formal_Conv : Iir; + Finish : Boolean; + Match : out Compatibility_Level) is + begin + case Iir_Kinds_Interface_Declaration (Get_Kind (Inter)) is + when Iir_Kinds_Interface_Object_Declaration => + if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then + Sem_Association_Open (Assoc, Finish, Match); + else + Sem_Association_By_Expression + (Assoc, Inter, Formal, Formal_Conv, Finish, Match); + end if; + + when Iir_Kind_Interface_Package_Declaration => + Sem_Association_Package (Assoc, Inter, Finish, Match); + + when Iir_Kind_Interface_Type_Declaration => + Sem_Association_Type (Assoc, Inter, Finish, Match); + + when Iir_Kinds_Interface_Subprogram_Declaration => + Sem_Association_Subprogram (Assoc, Inter, Finish, Match); + end case; + end Sem_Association; + + procedure Sem_Association_Chain + (Interface_Chain : Iir; + Assoc_Chain: in out Iir; + Finish: Boolean; + Missing : Missing_Type; + Loc : Iir; + Match : out Compatibility_Level) + is + Assoc : Iir; + Inter : Iir; + + -- True if -Whide is enabled (save the state). + Warn_Hide_Enabled : Boolean; + + type Param_Assoc_Type is (None, Open, Individual, Whole); + + type Assoc_Array is array (Natural range <>) of Param_Assoc_Type; + Nbr_Inter : constant Natural := Get_Chain_Length (Interface_Chain); + Inter_Matched : Assoc_Array (0 .. Nbr_Inter - 1) := (others => None); + + Last_Individual : Iir; + Has_Individual : Boolean; + Pos : Integer; + Formal : Iir; + + First_Named_Assoc : Iir; + Last_Named_Assoc : Iir; + + Formal_Name : Iir; + Formal_Conv : Iir; + begin + Match := Fully_Compatible; + First_Named_Assoc := Null_Iir; + Has_Individual := False; + + -- Loop on every assoc element, try to match it. + Inter := Interface_Chain; + Last_Individual := Null_Iir; + Pos := 0; + + -- First positional associations + Assoc := Assoc_Chain; + while Assoc /= Null_Iir loop + Formal := Get_Formal (Assoc); + exit when Formal /= Null_Iir; + + -- Try to match actual of ASSOC with the interface. + if Inter = Null_Iir then + if Finish then + Error_Msg_Sem (+Assoc, "too many actuals for %n", +Loc); + end if; + Match := Not_Compatible; + return; + end if; + Set_Whole_Association_Flag (Assoc, True); + Sem_Association (Assoc, Inter, Null_Iir, Null_Iir, Finish, Match); + if Match = Not_Compatible then + return; + end if; + if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then + Inter_Matched (Pos) := Open; + else + Inter_Matched (Pos) := Whole; + end if; + Set_Whole_Association_Flag (Assoc, True); + Inter := Get_Chain (Inter); + + Pos := Pos + 1; + Assoc := Get_Chain (Assoc); + end loop; + + -- Then association by name. + if Assoc /= Null_Iir then + -- Make interfaces visible + -- + -- LRM08 12.3 Visibility + -- A declaration is visible by selection at places that are defined + -- as follows: + -- j) For a formal parameter declaration of a given subprogram + -- declaration: at the place of the formal part (before the + -- compound delimiter =>) of a named parameter association + -- element of a corresponding subprogram call. + -- k) For a local generic declaration of a given component + -- declaration ... + -- l) For a local port declaration of a given component declaration: + -- ... + -- m) For a formal generic declaration of a given entity declaration: + -- ... + -- n) For a formal port declaration of a given entity declaration: + -- ... + -- o) For a formal generic declaration or a formal port declaration + -- of a given block statement: ... + -- p) For a formal generic declaration of a given package + -- declaration: ... + -- q) For a formal generic declaration of a given subprogram + -- declarations: ... + -- + -- At a place in which a given declaration is visible by selection, + -- every declaration with the same designator as the given + -- declaration and that would otherwise be directly visible is + -- hidden. + Sem_Scopes.Open_Declarative_Region; + + -- Do not warn about hidding here, way to common, way useless. + Warn_Hide_Enabled := Is_Warning_Enabled (Warnid_Hide); + Enable_Warning (Warnid_Hide, False); + + Sem_Scopes.Add_Declarations_From_Interface_Chain (Interface_Chain); + + Enable_Warning (Warnid_Hide, Warn_Hide_Enabled); + + First_Named_Assoc := Assoc; + loop + if Formal = Null_Iir then + -- Positional after named argument. Already caught by + -- Sem_Actual_Of_Association_Chain (because it is called only + -- once, while sem_association_chain may be called several + -- times). + Match := Not_Compatible; + exit; + end if; + + -- Last assoc to be cleaned up. + Last_Named_Assoc := Assoc; + + if Finish then + Sem_Name (Formal); + else + Sem_Name_Soft (Formal); + end if; + Formal_Name := Get_Named_Entity (Formal); + if Is_Error (Formal_Name) then + if Finish then + -- FIXME: display the name of subprg or component/entity. + -- FIXME: fetch the interface (for parenthesis_name). + -- FIXME: this is always a duplicate of a message from + -- Sem_Name. + Error_Msg_Sem (+Assoc, "no interface for %n in association", + +Get_Formal (Assoc)); + end if; + Match := Not_Compatible; + exit; + end if; + + Assoc := Get_Chain (Assoc); + exit when Assoc = Null_Iir; + Formal := Get_Formal (Assoc); + end loop; + + -- Remove visibility by selection of interfaces. This is needed + -- to correctly analyze actuals. + Sem_Scopes.Close_Declarative_Region; + + if Match /= Not_Compatible then + Assoc := First_Named_Assoc; + loop + Formal := Get_Formal (Assoc); + Formal_Name := Get_Named_Entity (Formal); + + -- Extract conversion + Formal_Conv := Null_Iir; + case Get_Kind (Formal_Name) is + when Iir_Kind_Function_Call => + -- Only one actual + declare + Call_Assoc : constant Iir := + Get_Parameter_Association_Chain (Formal_Name); + begin + if (Get_Kind (Call_Assoc) + /= Iir_Kind_Association_Element_By_Expression) + or else Get_Chain (Call_Assoc) /= Null_Iir + or else Get_Formal (Call_Assoc) /= Null_Iir + or else (Get_Actual_Conversion (Call_Assoc) + /= Null_Iir) + then + if Finish then + Error_Msg_Sem + (+Assoc, "ill-formed formal conversion"); + end if; + Match := Not_Compatible; + exit; + end if; + Formal_Conv := Formal_Name; + Formal_Name := Get_Actual (Call_Assoc); + end; + when Iir_Kind_Type_Conversion => + Formal_Conv := Formal_Name; + Formal_Name := Get_Expression (Formal_Name); + when Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Simple_Name => + null; + when others => + Formal_Name := Formal; + end case; + case Get_Kind (Formal_Name) is + when Iir_Kind_Selected_Element + | Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name => + Inter := Get_Base_Name (Formal_Name); + Set_Whole_Association_Flag (Assoc, False); + when Iir_Kind_Simple_Name + | Iir_Kind_Operator_Symbol => + Inter := Get_Named_Entity (Formal_Name); + Formal_Name := Inter; + Set_Whole_Association_Flag (Assoc, True); + when others => + -- Error + if Finish then + Error_Msg_Sem (+Assoc, "formal is not a name"); + end if; + Match := Not_Compatible; + exit; + end case; + + -- Simplify overload list (for interface subprogram). + -- FIXME: Interface must hide previous subprogram declarations, + -- so there should be no need to filter. + if Is_Overload_List (Inter) then + declare + List : constant Iir_List := Get_Overload_List (Inter); + It : List_Iterator; + Filtered_Inter : Iir; + El : Iir; + begin + Filtered_Inter := Null_Iir; + It := List_Iterate (List); + while Is_Valid (It) loop + El := Get_Element (It); + if Get_Kind (El) in Iir_Kinds_Interface_Declaration + and then + Get_Parent (El) = Get_Parent (Interface_Chain) + then + Add_Result (Filtered_Inter, El); + end if; + Next (It); + end loop; + Free_Overload_List (Inter); + Inter := Filtered_Inter; + + pragma Assert + (Get_Kind (Formal) = Iir_Kind_Simple_Name + or else + Get_Kind (Formal) = Iir_Kind_Operator_Symbol); + Set_Named_Entity (Formal, Inter); + + if Inter = Null_Iir then + if Finish then + Error_Msg_Sem (+Assoc, "no interface %i for %n", + (+Formal, +Loc)); + end if; + Match := Not_Compatible; + exit; + end if; + + if Is_Overload_List (Inter) then + if Finish then + Error_Msg_Sem (+Assoc, "ambiguous formal name"); + end if; + Match := Not_Compatible; + exit; + end if; + end; + end if; + if Get_Kind (Inter) not in Iir_Kinds_Interface_Declaration + or else Interface_Chain = Null_Iir + or else Get_Parent (Inter) /= Get_Parent (Interface_Chain) + then + if Finish then + Error_Msg_Sem + (+Assoc, "%n is not an interface name", +Inter); + end if; + Match := Not_Compatible; + exit; + end if; + + -- LRM 4.3.2.2 Association Lists + -- The formal part of a named element association may be + -- in the form of a function call, [...], if and only + -- if the mode of the formal is OUT, INOUT, BUFFER, or + -- LINKAGE, and the actual is not OPEN. + if Formal_Conv /= Null_Iir + and then (Get_Kind (Inter) + not in Iir_Kinds_Interface_Object_Declaration + or else Get_Mode (Inter) = Iir_In_Mode) + then + if Finish then + Error_Msg_Sem + (+Assoc, + "formal conversion allowed only for interface object"); + end if; + Match := Not_Compatible; + exit; + end if; + + -- Find the Interface. + declare + Inter1 : Iir; + begin + Inter1 := Interface_Chain; + Pos := 0; + while Inter1 /= Null_Iir loop + exit when Inter = Inter1; + Inter1 := Get_Chain (Inter1); + Pos := Pos + 1; + end loop; + if Inter1 = Null_Iir then + if Finish then + Error_Msg_Sem + (+Assoc, + "no corresponding interface for %i", +Inter); + end if; + Match := Not_Compatible; + exit; + end if; + end; + + Sem_Association + (Assoc, Inter, Formal_Name, Formal_Conv, Finish, Match); + exit when Match = Not_Compatible; + + if Get_Whole_Association_Flag (Assoc) then + -- Whole association. + Last_Individual := Null_Iir; + if Inter_Matched (Pos) = None then + if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open + then + Inter_Matched (Pos) := Open; + else + Inter_Matched (Pos) := Whole; + end if; + else + if Finish then + Error_Msg_Sem + (+Assoc, "%n already associated", +Inter); + end if; + Match := Not_Compatible; + exit; + end if; + else + -- Individual association. + Has_Individual := True; + if Inter_Matched (Pos) /= Whole then + if Finish + and then Inter_Matched (Pos) = Individual + and then Last_Individual /= Inter + then + Error_Msg_Sem + (+Assoc, + "non consecutive individual association for %n", + +Inter); + Match := Not_Compatible; + exit; + end if; + Last_Individual := Inter; + Inter_Matched (Pos) := Individual; + else + if Finish then + Error_Msg_Sem + (+Assoc, "%n already associated", +Inter); + Match := Not_Compatible; + exit; + end if; + end if; + end if; + + Assoc := Get_Chain (Assoc); + exit when Assoc = Null_Iir; + end loop; + end if; + + if Finish and Has_Individual and Match /= Not_Compatible then + Sem_Individual_Association (Assoc_Chain); + end if; + + if not Finish then + -- Always cleanup if not finishing: there can be other tries in + -- case of overloading. + Assoc := First_Named_Assoc; + while Assoc /= Null_Iir loop + Formal := Get_Formal (Assoc); + -- User may have used by position assoc after named + -- assocs. + if Is_Valid (Formal) then + Sem_Name_Clean (Formal); + end if; + exit when Assoc = Last_Named_Assoc; + Assoc := Get_Chain (Assoc); + end loop; + end if; + + if Match = Not_Compatible then + return; + end if; + end if; + + if Missing = Missing_Allowed then + -- No need to check for missing associations. + return; + end if; + + -- LRM93 8.6 Procedure Call Statement + -- For each formal parameter of a procedure, a procedure call must + -- specify exactly one corresponding actual parameter. + -- This actual parameter is specified either explicitly, by an + -- association element (other than the actual OPEN) in the association + -- list, or in the absence of such an association element, by a default + -- expression (see Section 4.3.3.2). + + -- LRM93 7.3.3 Function Calls + -- For each formal parameter of a function, a function call must + -- specify exactly one corresponding actual parameter. + -- This actual parameter is specified either explicitly, by an + -- association element (other than the actual OPEN) in the association + -- list, or in the absence of such an association element, by a default + -- expression (see Section 4.3.3.2). + + -- LRM93 1.1.1.2 / LRM08 6.5.6.3 Port clauses + -- A port of mode IN may be unconnected or unassociated only if its + -- declaration includes a default expression. + -- A port of any mode other than IN may be unconnected or unassociated + -- as long as its type is not an unconstrained array type. + + -- LRM08 6.5.6.2 Generic clauses + -- It is an error if no such actual [instantiated package] is specified + -- for a given formal generic package (either because the formal generic + -- is unassociated or because the actual is OPEN). + + Inter := Interface_Chain; + Pos := 0; + while Inter /= Null_Iir loop + if Inter_Matched (Pos) <= Open then + -- Interface is unassociated (none or open). + case Get_Kind (Inter) is + when Iir_Kinds_Interface_Object_Declaration => + case Missing is + when Missing_Parameter + | Missing_Generic => + if Get_Mode (Inter) /= Iir_In_Mode + or else Get_Default_Value (Inter) = Null_Iir + then + if Finish then + Error_Msg_Sem (+Loc, "no actual for %n", +Inter); + end if; + Match := Not_Compatible; + return; + end if; + when Missing_Port => + case Get_Mode (Inter) is + when Iir_In_Mode => + -- No overloading for components/entities. + pragma Assert (Finish); + if Get_Default_Value (Inter) = Null_Iir then + Error_Msg_Sem + (+Loc, + "%n of mode IN must be connected", +Inter); + Match := Not_Compatible; + return; + end if; + when Iir_Out_Mode + | Iir_Linkage_Mode + | Iir_Inout_Mode + | Iir_Buffer_Mode => + -- No overloading for components/entities. + pragma Assert (Finish); + if not (Is_Fully_Constrained_Type + (Get_Type (Inter))) + then + Error_Msg_Sem + (+Loc, + "unconstrained %n must be connected", + +Inter); + Match := Not_Compatible; + return; + end if; + when Iir_Unknown_Mode => + raise Internal_Error; + end case; + when Missing_Allowed => + null; + end case; + when Iir_Kind_Interface_Package_Declaration + | Iir_Kind_Interface_Function_Declaration + | Iir_Kind_Interface_Procedure_Declaration => + Error_Msg_Sem (+Loc, "%n must be associated", +Inter); + Match := Not_Compatible; + when others => + Error_Kind ("sem_association_chain", Inter); + end case; + end if; + + -- Clear associated type of interface type. + if Get_Kind (Inter) = Iir_Kind_Interface_Type_Declaration then + Set_Associated_Type (Get_Type (Inter), Null_Iir); + end if; + + Inter := Get_Chain (Inter); + Pos := Pos + 1; + end loop; + end Sem_Association_Chain; +end Vhdl.Sem_Assocs; diff --git a/src/vhdl/vhdl-sem_assocs.ads b/src/vhdl/vhdl-sem_assocs.ads new file mode 100644 index 000000000..632956c3d --- /dev/null +++ b/src/vhdl/vhdl-sem_assocs.ads @@ -0,0 +1,68 @@ +-- Semantic analysis. +-- 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 Iirs; use Iirs; +with Vhdl.Sem_Expr; use Vhdl.Sem_Expr; + +package Vhdl.Sem_Assocs is + -- Rewrite the association chain by changing the kind of assocation + -- corresponding to non-object interfaces. Such an association mustn't be + -- handled an like association for object as the actual is not an + -- expression. + function Extract_Non_Object_Association + (Assoc_Chain : Iir; Inter_Chain : Iir) return Iir; + + -- Analyze actuals of ASSOC_CHAIN. + -- Check all named associations are after positionnal one. + -- Return TRUE if no error. + function Sem_Actual_Of_Association_Chain (Assoc_Chain : Iir) return Boolean; + + -- Analyze association chain ASSOC_CHAIN with interfaces from + -- INTERFACE_CHAIN. + -- Return the level of compatibility between the two chains in LEVEL. + -- If FINISH is true, then ASSOC_CHAIN may be modifies (individual assoc + -- added), and error messages (if any) are displayed. + -- MISSING control unassociated interfaces. + -- LOC is the association. + -- Sem_Actual_Of_Association_Chain must have been called before. + type Missing_Type is (Missing_Parameter, Missing_Port, Missing_Generic, + Missing_Allowed); + procedure Sem_Association_Chain + (Interface_Chain : Iir; + Assoc_Chain: in out Iir; + Finish: Boolean; + Missing : Missing_Type; + Loc : Iir; + Match : out Compatibility_Level); + + -- Do port Sem_Association_Chain checks for subprograms. + procedure Check_Subprogram_Associations + (Inter_Chain : Iir; Assoc_Chain : Iir); + + -- Check for restrictions in LRM93 1.1.1.2 + -- Return FALSE in case of error. + function Check_Port_Association_Mode_Restrictions + (Formal : Iir_Interface_Signal_Declaration; + Actual : Iir_Interface_Signal_Declaration; + Assoc : Iir) + return Boolean; + + -- Check restrictions of LRM02 12.2.4 + procedure Check_Port_Association_Bounds_Restrictions + (Formal : Iir; Actual : Iir; Assoc : Iir); + +end Vhdl.Sem_Assocs; diff --git a/src/vhdl/vhdl-sem_decls.adb b/src/vhdl/vhdl-sem_decls.adb new file mode 100644 index 000000000..f8e380c95 --- /dev/null +++ b/src/vhdl/vhdl-sem_decls.adb @@ -0,0 +1,2342 @@ +-- Semantic analysis. +-- 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 Errorout; use Errorout; +with Types; use Types; +with Std_Names; +with Vhdl.Tokens; +with Flags; use Flags; +with Std_Package; use Std_Package; +with Evaluation; use Evaluation; +with Iirs_Utils; use Iirs_Utils; +with Vhdl.Sem; use Vhdl.Sem; +with Vhdl.Sem_Utils; use Vhdl.Sem_Utils; +with Vhdl.Sem_Expr; use Vhdl.Sem_Expr; +with Vhdl.Sem_Scopes; use Vhdl.Sem_Scopes; +with Vhdl.Sem_Names; use Vhdl.Sem_Names; +with Vhdl.Sem_Specs; use Vhdl.Sem_Specs; +with Vhdl.Sem_Types; use Vhdl.Sem_Types; +with Vhdl.Sem_Psl; +with Vhdl.Sem_Inst; +with Xrefs; use Xrefs; + +package body Vhdl.Sem_Decls is + -- Region that can declare signals. Used to add implicit declarations. + Current_Signals_Region : Implicit_Signal_Declaration_Type := + (Null_Iir, Null_Iir, Null_Iir, False, Null_Iir); + + procedure Push_Signals_Declarative_Part + (Cell: out Implicit_Signal_Declaration_Type; Decls_Parent : Iir) is + begin + Cell := Current_Signals_Region; + Current_Signals_Region := + (Decls_Parent, Null_Iir, Null_Iir, False, Null_Iir); + end Push_Signals_Declarative_Part; + + procedure Pop_Signals_Declarative_Part + (Cell: in Implicit_Signal_Declaration_Type) is + begin + Current_Signals_Region := Cell; + end Pop_Signals_Declarative_Part; + + -- Insert the implicit signal declaration after LAST_DECL. + procedure Insert_Implicit_Signal (Last_Decl : Iir) is + begin + if Last_Decl = Null_Iir then + Set_Declaration_Chain (Current_Signals_Region.Decls_Parent, + Current_Signals_Region.Implicit_Decl); + else + Set_Chain (Last_Decl, Current_Signals_Region.Implicit_Decl); + end if; + end Insert_Implicit_Signal; + + -- Add SIG as an implicit declaration in the current region. + procedure Add_Declaration_For_Implicit_Signal (Sig : Iir) + is + Decl : Iir; + begin + -- We deal only with signal attribute. + pragma Assert (Get_Kind (Sig) in Iir_Kinds_Signal_Attribute); + + -- There must be a declarative part for implicit signals. + pragma Assert (Current_Signals_Region.Decls_Parent /= Null_Iir); + + -- Attr_Chain must be empty. + pragma Assert (Get_Attr_Chain (Sig) = Null_Iir); + + if Current_Signals_Region.Implicit_Decl = Null_Iir then + -- Create the signal_attribute_declaration to hold all the implicit + -- signals. + Decl := Create_Iir (Iir_Kind_Signal_Attribute_Declaration); + Location_Copy (Decl, Sig); + Set_Parent (Decl, Current_Signals_Region.Decls_Parent); + + -- Save the implicit declaration. + Current_Signals_Region.Implicit_Decl := Decl; + + -- Append SIG (this is the first one). + Set_Signal_Attribute_Chain (Decl, Sig); + + if Current_Signals_Region.Decls_Analyzed then + -- Declarative region was completely analyzed. Just append DECL + -- at the end of declarations. + Insert_Implicit_Signal (Current_Signals_Region.Last_Decl); + end if; + else + -- Append SIG. + Set_Attr_Chain (Current_Signals_Region.Last_Attribute_Signal, Sig); + end if; + Current_Signals_Region.Last_Attribute_Signal := Sig; + + Set_Signal_Attribute_Declaration + (Sig, Current_Signals_Region.Implicit_Decl); + end Add_Declaration_For_Implicit_Signal; + + -- Insert pending implicit declarations after the last analyzed LAST_DECL, + -- and update it. Then the caller has to insert the declaration which + -- created the implicit declarations. + procedure Insert_Pending_Implicit_Declarations + (Parent : Iir; Last_Decl : in out Iir) is + begin + if Current_Signals_Region.Decls_Parent = Parent + and then Current_Signals_Region.Implicit_Decl /= Null_Iir + then + pragma Assert (not Current_Signals_Region.Decls_Analyzed); + + -- Add pending implicit declarations before the current one. + Insert_Implicit_Signal (Last_Decl); + Last_Decl := Current_Signals_Region.Implicit_Decl; + + -- Detach the implicit declaration. + Current_Signals_Region.Implicit_Decl := Null_Iir; + Current_Signals_Region.Last_Attribute_Signal := Null_Iir; + end if; + end Insert_Pending_Implicit_Declarations; + + -- Mark the end of declaration analysis. New implicit declarations will + -- simply be appended to the last declaration. + procedure End_Of_Declarations_For_Implicit_Declarations + (Parent : Iir; Last_Decl : Iir) is + begin + if Current_Signals_Region.Decls_Parent = Parent then + pragma Assert (not Current_Signals_Region.Decls_Analyzed); + + -- All declarations have been analyzed, new implicit declarations + -- will be appended. + Current_Signals_Region.Decls_Analyzed := True; + Current_Signals_Region.Last_Decl := Last_Decl; + end if; + end End_Of_Declarations_For_Implicit_Declarations; + + procedure Mark_Subprogram_Used (Subprg : Iir) + is + N : Iir; + begin + N := Subprg; + loop + exit when Get_Use_Flag (N); + Set_Use_Flag (N, True); + N := Sem_Inst.Get_Origin (N); + -- The origin may also be an instance. + exit when N = Null_Iir; + end loop; + end Mark_Subprogram_Used; + + -- Emit an error if the type of DECL is a file type, access type, + -- protected type or if a subelement of DECL is an access type. + procedure Check_Signal_Type (Decl : Iir) + is + Decl_Type : constant Iir := Get_Type (Decl); + begin + if Get_Signal_Type_Flag (Decl_Type) then + return; + end if; + + if Is_Error (Decl_Type) then + return; + end if; + + Error_Msg_Sem (+Decl, "type of %n cannot be %n", (+Decl, +Decl_Type)); + case Get_Kind (Decl_Type) is + when Iir_Kind_File_Type_Definition => + null; + when Iir_Kind_Protected_Type_Declaration => + null; + when Iir_Kind_Interface_Type_Definition => + null; + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + null; + when Iir_Kinds_Array_Type_Definition + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + Error_Msg_Sem (+Decl, "(%n has an access subelement)", +Decl_Type); + when others => + Error_Kind ("check_signal_type", Decl_Type); + end case; + end Check_Signal_Type; + + procedure Sem_Interface_Object_Declaration + (Inter, Last : Iir; Interface_Kind : Interface_Kind_Type) + is + A_Type: Iir; + Default_Value: Iir; + begin + -- Avoid the reanalysed duplicated types. + -- This is not an optimization, since the unanalysed type must have + -- been freed. + A_Type := Get_Subtype_Indication (Inter); + if A_Type = Null_Iir then + if Last = Null_Iir or else not Get_Has_Identifier_List (Last) then + -- Subtype indication was not parsed. + A_Type := Create_Error_Type (Null_Iir); + Set_Subtype_Indication (Inter, A_Type); + else + A_Type := Get_Type (Last); + Default_Value := Get_Default_Value (Last); + end if; + else + A_Type := Sem_Subtype_Indication (A_Type); + Set_Subtype_Indication (Inter, A_Type); + A_Type := Get_Type_Of_Subtype_Indication (A_Type); + + Default_Value := Get_Default_Value (Inter); + if Default_Value /= Null_Iir and then not Is_Error (A_Type) then + Deferred_Constant_Allowed := True; + Default_Value := Sem_Expression (Default_Value, A_Type); + Default_Value := + Eval_Expr_Check_If_Static (Default_Value, A_Type); + Deferred_Constant_Allowed := False; + Check_Read (Default_Value); + end if; + end if; + + Set_Name_Staticness (Inter, Locally); + Xref_Decl (Inter); + + if not Is_Error (A_Type) then + Set_Type (Inter, A_Type); + + if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then + if Get_Guarded_Signal_Flag (Inter) then + case Get_Signal_Kind (Inter) is + when Iir_Bus_Kind => + -- LRM93 4.3.1.2 + -- It is also an error if a guarded signal of a scalar + -- type is neither a resolved signal nor a subelement of + -- a resolved signal. + if not Get_Resolved_Flag (A_Type) then + Error_Msg_Sem + (+Inter, "%n of guarded %n is not resolved", + (+A_Type, +Inter)); + end if; + + -- LRM 2.1.1.2 Signal parameter + -- It is an error if the declaration of a formal signal + -- parameter includes the reserved word BUS. + if Flags.Vhdl_Std >= Vhdl_93 + and then Interface_Kind in Parameter_Interface_List + then + Error_Msg_Sem + (+Inter, "signal parameter can't be of kind bus"); + end if; + when Iir_Register_Kind => + -- LRM93 4.3.2 Interface declarations + -- Grammar for interface_signal_declaration. + Error_Msg_Sem + (+Inter, "interface signal can't be of kind register"); + end case; + end if; + Set_Type_Has_Signal (A_Type); + end if; + + case Get_Kind (Inter) is + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Signal_Declaration => + -- LRM 4.3.2 Interface declarations + -- For an interface constant declaration or an interface + -- signal declaration, the subtype indication must define + -- a subtype that is neither a file type, an access type, + -- nor a protected type. Moreover, the subtype indication + -- must not denote a composite type with a subelement that + -- is a file type, an access type, or a protected type. + Check_Signal_Type (Inter); + when Iir_Kind_Interface_Variable_Declaration => + case Get_Kind (Get_Base_Type (A_Type)) is + when Iir_Kind_File_Type_Definition => + if Flags.Vhdl_Std >= Vhdl_93 then + Error_Msg_Sem + (+Inter, + "variable formal can't be a file (vhdl 93)"); + end if; + when Iir_Kind_Protected_Type_Declaration => + -- LRM 2.1.1.1 Constant and variable parameters + -- It is an error if the mode of the parameter is + -- other that INOUT. + if Get_Mode (Inter) /= Iir_Inout_Mode then + Error_Msg_Sem + (+Inter, + "parameter of protected type must be inout"); + end if; + when others => + null; + end case; + when Iir_Kind_Interface_File_Declaration => + if Get_Kind (Get_Base_Type (A_Type)) + /= Iir_Kind_File_Type_Definition + then + Error_Msg_Sem + (+Inter, "file formal type must be a file type"); + end if; + when others => + -- Inter is not an interface. + raise Internal_Error; + end case; + + if Default_Value /= Null_Iir then + Set_Default_Value (Inter, Default_Value); + + -- LRM 4.3.2 Interface declarations. + -- It is an error if a default expression appears in an + -- interface declaration and any of the following conditions + -- hold: + -- - The mode is linkage + -- - The interface object is a formal signal parameter + -- - The interface object is a formal variable parameter of + -- mode other than in + -- - The subtype indication of the interface declaration + -- denotes a protected type. + case Get_Kind (Inter) is + when Iir_Kind_Interface_Constant_Declaration => + null; + when Iir_Kind_Interface_Signal_Declaration => + if Get_Mode (Inter) = Iir_Linkage_Mode then + Error_Msg_Sem + (+Inter, + "default expression not allowed for linkage port"); + elsif Interface_Kind in Parameter_Interface_List then + Error_Msg_Sem + (+Inter, + "default expression not allowed for signal parameter"); + end if; + when Iir_Kind_Interface_Variable_Declaration => + if Get_Mode (Inter) /= Iir_In_Mode then + Error_Msg_Sem + (+Inter, "default expression not allowed for" + & " out or inout variable parameter"); + elsif Get_Kind (A_Type) = Iir_Kind_Protected_Type_Declaration + then + Error_Msg_Sem + (+Inter, "default expression not allowed for" + & " variable parameter of protected type"); + end if; + when Iir_Kind_Interface_File_Declaration => + raise Internal_Error; + when others => + null; + end case; + end if; + else + Set_Type (Inter, Error_Type); + end if; + + Sem_Scopes.Add_Name (Inter); + + -- By default, interface are not static. + -- This may be changed just below. + Set_Expr_Staticness (Inter, None); + + case Interface_Kind is + when Generic_Interface_List => + -- LRM93 1.1.1 + -- The generic list in the formal generic clause defines + -- generic constants whose values may be determined by the + -- environment. + if Get_Kind (Inter) /= Iir_Kind_Interface_Constant_Declaration then + Error_Msg_Sem (+Inter, "generic %n must be a constant", +Inter); + else + -- LRM93 7.4.2 (Globally static primaries) + -- 3. a generic constant. + Set_Expr_Staticness (Inter, Globally); + end if; + when Port_Interface_List => + if Get_Kind (Inter) /= Iir_Kind_Interface_Signal_Declaration then + Error_Msg_Sem (+Inter, "port %n must be a signal", +Inter); + end if; + when Parameter_Interface_List => + if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration + and then Interface_Kind = Function_Parameter_Interface_List + then + Error_Msg_Sem (+Inter, "variable interface parameter are not " + & "allowed for a function (use a constant)"); + end if; + + -- By default, we suppose a subprogram read the activity of + -- a signal. + -- This will be adjusted when the body is analyzed. + if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration + and then Get_Mode (Inter) in Iir_In_Modes + then + Set_Has_Active_Flag (Inter, True); + end if; + + case Get_Mode (Inter) is + when Iir_Unknown_Mode => + raise Internal_Error; + when Iir_In_Mode => + null; + when Iir_Inout_Mode + | Iir_Out_Mode => + if Interface_Kind = Function_Parameter_Interface_List + and then + Get_Kind (Inter) /= Iir_Kind_Interface_File_Declaration + then + Error_Msg_Sem + (+Inter, + "mode of a function parameter cannot be inout or out"); + end if; + when Iir_Buffer_Mode + | Iir_Linkage_Mode => + Error_Msg_Sem + (+Inter, "buffer or linkage mode is not allowed " + & "for a subprogram parameter"); + end case; + end case; + end Sem_Interface_Object_Declaration; + + procedure Sem_Interface_Package_Declaration (Inter : Iir) + is + Pkg : Iir; + begin + -- LRM08 6.5.5 Interface package declarations + -- the uninstantiated_package_name shall denote an uninstantiated + -- package declared in a package declaration. + Pkg := Sem_Uninstantiated_Package_Name (Inter); + if Pkg = Null_Iir then + return; + end if; + + if Get_Generic_Map_Aspect_Chain (Inter) /= Null_Iir then + Sem_Generic_Association_Chain (Get_Package_Header (Pkg), Inter); + -- Not yet fully supported - need to check the instance. + raise Internal_Error; + end if; + + Sem_Inst.Instantiate_Package_Declaration (Inter, Pkg); + + Sem_Scopes.Add_Name (Inter); + Set_Is_Within_Flag (Inter, True); + Xref_Decl (Inter); + end Sem_Interface_Package_Declaration; + + function Create_Implicit_Interface_Function (Name : Name_Id; + Decl : Iir; + Interface_Chain : Iir; + Return_Type : Iir) + return Iir + is + Operation : Iir_Function_Declaration; + begin + Operation := Create_Iir (Iir_Kind_Interface_Function_Declaration); + Location_Copy (Operation, Decl); + Set_Parent (Operation, Get_Parent (Decl)); + Set_Interface_Declaration_Chain (Operation, Interface_Chain); + Set_Return_Type (Operation, Return_Type); + Set_Identifier (Operation, Name); + Set_Visible_Flag (Operation, True); + Set_Pure_Flag (Operation, True); + Compute_Subprogram_Hash (Operation); + return Operation; + end Create_Implicit_Interface_Function; + + procedure Sem_Interface_Type_Declaration (Inter : Iir) + is + Def : Iir; + Finters : Iir; + Op_Eq, Op_Neq : Iir; + begin + -- Create type definition. + Def := Create_Iir (Iir_Kind_Interface_Type_Definition); + Set_Location (Def, Get_Location (Inter)); + Set_Type_Declarator (Def, Inter); + Set_Type (Inter, Def); + Set_Base_Type (Def, Def); + Set_Type_Staticness (Def, None); + Set_Resolved_Flag (Def, False); + Set_Signal_Type_Flag (Def, True); + Set_Has_Signal_Flag (Def, False); + + -- Create operations for the interface type. + Finters := Create_Anonymous_Interface (Def); + Set_Chain (Finters, Create_Anonymous_Interface (Def)); + + Op_Eq := Create_Implicit_Interface_Function + (Std_Names.Name_Op_Equality, + Inter, Finters, Std_Package.Boolean_Type_Definition); + + Op_Neq := Create_Implicit_Interface_Function + (Std_Names.Name_Op_Inequality, + Inter, Finters, Std_Package.Boolean_Type_Definition); + + Set_Interface_Type_Subprograms (Inter, Op_Eq); + Set_Chain (Op_Eq, Op_Neq); + + Sem_Scopes.Add_Name (Inter); + Sem_Scopes.Add_Name (Op_Eq); + Sem_Scopes.Add_Name (Op_Neq); + Xref_Decl (Inter); + end Sem_Interface_Type_Declaration; + + procedure Sem_Interface_Subprogram_Declaration (Inter : Iir) is + begin + Sem_Subprogram_Specification (Inter); + Sem_Scopes.Add_Name (Inter); + Xref_Decl (Inter); + end Sem_Interface_Subprogram_Declaration; + + procedure Sem_Interface_Chain (Interface_Chain: Iir; + Interface_Kind : Interface_Kind_Type) + is + -- Control visibility of interface object. See below for its use. + Immediately_Visible : constant Boolean := + Interface_Kind = Generic_Interface_List + and then Flags.Vhdl_Std >= Vhdl_08; + + Inter : Iir; + + -- LAST is the last interface declaration that has a type. This is + -- used to set type and default value for the following declarations + -- that appeared in a list of identifiers. + Last : Iir; + begin + Last := Null_Iir; + + Inter := Interface_Chain; + while Inter /= Null_Iir loop + case Iir_Kinds_Interface_Declaration (Get_Kind (Inter)) is + when Iir_Kinds_Interface_Object_Declaration => + Sem_Interface_Object_Declaration (Inter, Last, Interface_Kind); + Last := Inter; + when Iir_Kind_Interface_Package_Declaration => + Sem_Interface_Package_Declaration (Inter); + when Iir_Kind_Interface_Type_Declaration => + Sem_Interface_Type_Declaration (Inter); + when Iir_Kinds_Interface_Subprogram_Declaration => + Sem_Interface_Subprogram_Declaration (Inter); + end case; + + -- LRM08 6.5.6 Interface lists + -- A name that denotes an interface object declared in a port + -- interface list of a prameter interface list shall not appear in + -- any interface declaration within the interface list containing the + -- denoted interface object expect to declare this object. + -- A name that denotes an interface declaration in a generic + -- interface list may appear in an interface declaration within the + -- interface list containing the denoted interface declaration. + if Immediately_Visible then + Name_Visible (Inter); + end if; + + Inter := Get_Chain (Inter); + end loop; + + -- LRM 10.3 Visibility + -- A declaration is visible only within a certain part of its scope; + -- this starts at the end of the declaration [...] + + -- LRM 4.3.2.1 Interface List + -- A name that denotes an interface object must not appear in any + -- interface declaration within the interface list containing the + -- denotes interface except to declare this object. + + -- GHDL: this is achieved by making the interface object visible after + -- having analyzed the interface list. + if not Immediately_Visible then + Inter := Interface_Chain; + while Inter /= Null_Iir loop + Name_Visible (Inter); + Inter := Get_Chain (Inter); + end loop; + end if; + end Sem_Interface_Chain; + + -- Analyze a type or an anonymous type declaration. + procedure Sem_Type_Declaration (Decl: Iir; Is_Global : Boolean) + is + Def: Iir; + Inter : Name_Interpretation_Type; + Old_Decl : Iir; + St_Decl : Iir_Subtype_Declaration; + Bt_Def : Iir; + begin + -- Check if DECL complete a previous incomplete type declaration. + Inter := Get_Interpretation (Get_Identifier (Decl)); + if Valid_Interpretation (Inter) + and then Is_In_Current_Declarative_Region (Inter) + then + Old_Decl := Get_Declaration (Inter); + if Get_Kind (Old_Decl) /= Iir_Kind_Type_Declaration + or else (Get_Kind (Get_Type_Definition (Old_Decl)) /= + Iir_Kind_Incomplete_Type_Definition) + then + Old_Decl := Null_Iir; + else + Set_Incomplete_Type_Declaration (Decl, Old_Decl); + end if; + else + Old_Decl := Null_Iir; + end if; + + if Old_Decl = Null_Iir then + if Get_Kind (Decl) = Iir_Kind_Type_Declaration then + -- This is necessary at least for enumeration type definition. + -- Type declaration for anonymous types don't have name, only + -- their subtype have names. Those are added later. + Sem_Scopes.Add_Name (Decl); + end if; + else + -- This is a way to prevent: + -- type a; + -- type a is access a; + -- which is non-sense. + Set_Visible_Flag (Old_Decl, False); + end if; + + -- Check the definition of the type. + Def := Get_Type_Definition (Decl); + if Def = Null_Iir then + -- Incomplete type declaration + Def := Create_Iir (Iir_Kind_Incomplete_Type_Definition); + Location_Copy (Def, Decl); + Set_Type_Definition (Decl, Def); + Set_Base_Type (Def, Def); + Set_Signal_Type_Flag (Def, True); + Set_Type_Declarator (Def, Decl); + Set_Visible_Flag (Decl, True); + Xref_Decl (Decl); + + return; + + end if; + + -- A complete type declaration. + if Old_Decl = Null_Iir then + Xref_Decl (Decl); + else + Xref_Body (Decl, Old_Decl); + end if; + + Def := Sem_Type_Definition (Def, Decl); + if Def = Null_Iir then + return; + end if; + + case Get_Kind (Def) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Array_Subtype_Definition => + -- Some type declaration are in fact subtype declarations. + St_Decl := Create_Iir (Iir_Kind_Subtype_Declaration); + Location_Copy (St_Decl, Decl); + Set_Identifier (St_Decl, Get_Identifier (Decl)); + Set_Parent (St_Decl, Get_Parent (Decl)); + Set_Type (St_Decl, Def); + Set_Subtype_Indication (St_Decl, Def); + Set_Type_Declarator (Def, St_Decl); + Set_Chain (St_Decl, Get_Chain (Decl)); + Set_Chain (Decl, St_Decl); + + -- The type declaration declares the base type. + Bt_Def := Get_Base_Type (Def); + Set_Type_Definition (Decl, Bt_Def); + Set_Type_Declarator (Bt_Def, Decl); + Set_Subtype_Definition (Decl, Def); + + if Old_Decl = Null_Iir then + Sem_Scopes.Add_Name (St_Decl); + end if; + + Sem_Scopes.Name_Visible (St_Decl); + + -- The implicit subprogram will be added in the + -- scope just after. + Create_Implicit_Operations (Decl, False); + + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Access_Type_Definition + | Iir_Kind_File_Type_Definition => + St_Decl := Null_Iir; + Set_Type_Declarator (Def, Decl); + + Sem_Scopes.Name_Visible (Decl); + + -- The implicit subprogram will be added in the + -- scope just after. + Create_Implicit_Operations (Decl, False); + + when Iir_Kind_Protected_Type_Declaration => + Set_Type_Declarator (Def, Decl); + St_Decl := Null_Iir; + -- No implicit subprograms. + + when others => + Error_Kind ("sem_type_declaration", Def); + end case; + + if Old_Decl /= Null_Iir then + -- Complete the type definition. + declare + Old_Def : constant Iir := Get_Type_Definition (Old_Decl); + Ref : Iir; + begin + Set_Signal_Type_Flag (Old_Def, Get_Signal_Type_Flag (Def)); + Ref := Get_Incomplete_Type_Ref_Chain (Old_Def); + while Is_Valid (Ref) loop + pragma Assert + (Get_Kind (Ref) = Iir_Kind_Access_Type_Definition); + Set_Designated_Type (Ref, Def); + Ref := Get_Incomplete_Type_Ref_Chain (Ref); + end loop; + Set_Complete_Type_Definition (Old_Def, Def); + + -- The identifier now designates the complete type declaration. + if St_Decl = Null_Iir then + Replace_Name (Get_Identifier (Decl), Old_Decl, Decl); + else + Replace_Name (Get_Identifier (Decl), Old_Decl, St_Decl); + end if; + end; + end if; + + if Is_Global then + Set_Type_Has_Signal (Def); + end if; + end Sem_Type_Declaration; + + procedure Sem_Subtype_Declaration (Decl: Iir; Is_Global : Boolean) + is + Def: Iir; + Ind : Iir; + begin + -- Real hack to skip subtype declarations of anonymous type decls. + if Get_Visible_Flag (Decl) then + return; + end if; + + Sem_Scopes.Add_Name (Decl); + Xref_Decl (Decl); + + -- Analyze the definition of the type. + Ind := Get_Subtype_Indication (Decl); + Ind := Sem_Subtype_Indication (Ind); + Set_Subtype_Indication (Decl, Ind); + Def := Get_Type_Of_Subtype_Indication (Ind); + if Def = Null_Iir or else Is_Error (Def) then + return; + end if; + + if not Is_Anonymous_Type_Definition (Def) then + -- There is no added constraints and therefore the subtype + -- declaration is in fact an alias of the type. Create a copy so + -- that it has its own type declarator. + Def := Copy_Subtype_Indication (Def); + Location_Copy (Def, Decl); + Set_Subtype_Type_Mark (Def, Ind); + Set_Subtype_Indication (Decl, Def); + end if; + + Set_Type (Decl, Def); + Set_Type_Declarator (Def, Decl); + Name_Visible (Decl); + if Is_Global then + Set_Type_Has_Signal (Def); + end if; + end Sem_Subtype_Declaration; + + -- If DECL is a constant declaration, and there is already a incomplete + -- constant declaration in the current scope with the same name, then + -- return it. Otherwise, return NULL. + function Get_Deferred_Constant (Decl : Iir) return Iir + is + Deferred_Const : Iir; + Interp : Name_Interpretation_Type; + begin + if Get_Kind (Decl) /= Iir_Kind_Constant_Declaration then + return Null_Iir; + end if; + Interp := Get_Interpretation (Get_Identifier (Decl)); + if not Valid_Interpretation (Interp) then + return Null_Iir; + end if; + + if not Is_In_Current_Declarative_Region (Interp) + or else Is_Potentially_Visible (Interp) + then + -- Deferred and full declarations must be declared in the same + -- declarative region. + return Null_Iir; + end if; + + Deferred_Const := Get_Declaration (Interp); + if Get_Kind (Deferred_Const) /= Iir_Kind_Constant_Declaration then + return Null_Iir; + end if; + if not Get_Deferred_Declaration_Flag (Deferred_Const) then + -- Just a 'normal' duplicate declaration + return Null_Iir; + end if; + -- LRM93 4.3.1.1 + -- The corresponding full constant declaration, which defines the value + -- of the constant, must appear in the body of the package. + if Get_Kind (Get_Library_Unit (Get_Current_Design_Unit)) + /= Iir_Kind_Package_Body + then + Error_Msg_Sem + (+Decl, "full constant declaration must appear in package body"); + end if; + return Deferred_Const; + end Get_Deferred_Constant; + + procedure Sem_Object_Type_From_Value (Decl : Iir; Value : Iir) + is + Atype : constant Iir := Get_Type (Decl); + Value_Type : constant Iir := Get_Type (Value); + begin + if not Is_Fully_Constrained_Type (Atype) + and then not Is_Error (Value_Type) + then + if Get_Type_Staticness (Value_Type) >= Globally then + Set_Type (Decl, Value_Type); + end if; + end if; + end Sem_Object_Type_From_Value; + + -- LAST_DECL is set only if DECL is part of a list of declarations (they + -- share the same type and the same default value). + procedure Sem_Object_Declaration (Decl: Iir; Parent : Iir; Last_Decl : Iir) + is + Deferred_Const : constant Iir := Get_Deferred_Constant (Decl); + Atype: Iir; + Default_Value : Iir; + Staticness : Iir_Staticness; + begin + -- LRM08 12.2 Scope of declarations + -- Then scope of a declaration [...] extends from the beginning of the + -- declaration [...] + if Deferred_Const = Null_Iir then + Sem_Scopes.Add_Name (Decl); + Xref_Decl (Decl); + else + Xref_Ref (Decl, Deferred_Const); + end if; + + -- Analyze type and default value: + Atype := Get_Subtype_Indication (Decl); + if Last_Decl = Null_Iir then + Atype := Sem_Subtype_Indication (Atype); + Set_Subtype_Indication (Decl, Atype); + Atype := Get_Type_Of_Subtype_Indication (Atype); + if Atype = Null_Iir then + Atype := Create_Error_Type (Get_Type (Decl)); + end if; + + Default_Value := Get_Default_Value (Decl); + if Default_Value /= Null_Iir then + Default_Value := Sem_Expression (Default_Value, Atype); + if Default_Value = Null_Iir then + Default_Value := + Create_Error_Expr (Get_Default_Value (Decl), Atype); + end if; + Check_Read (Default_Value); + Default_Value := Eval_Expr_Check_If_Static (Default_Value, Atype); + end if; + else + pragma Assert (Atype = Null_Iir); + Default_Value := Get_Default_Value (Last_Decl); + if Is_Valid (Default_Value) then + Set_Is_Ref (Decl, True); + end if; + Atype := Get_Type (Last_Decl); + end if; + + Set_Type (Decl, Atype); + Set_Default_Value (Decl, Default_Value); + Set_Name_Staticness (Decl, Locally); + Set_Visible_Flag (Decl, True); + + -- LRM93 2.6 + -- The subtype indication given in the full declaration of the deferred + -- constant must conform to that given in the deferred constant + -- declaration. + if Deferred_Const /= Null_Iir + and then not Are_Trees_Equal (Get_Type (Decl), + Get_Type (Deferred_Const)) + then + Error_Msg_Sem + (+Decl, + "subtype indication doesn't conform with the deferred constant"); + end if; + + -- LRM93 4.3.1.3 + -- It is an error if a variable declaration declares a variable that is + -- of a file type. + -- + -- LRM93 4.3.1.1 + -- It is an error if a constant declaration declares a constant that is + -- of a file type, or an access type, or a composite type which has + -- subelement that is a file type of an access type. + -- + -- LRM93 4.3.1.2 + -- It is an error if a signal declaration declares a signal that is of + -- a file type [or an access type]. + case Get_Kind (Atype) is + when Iir_Kind_File_Type_Definition => + Error_Msg_Sem (+Decl, "%n cannot be of type file", +Decl); + when Iir_Kind_Error => + null; + when others => + if Get_Kind (Decl) /= Iir_Kind_Variable_Declaration then + Check_Signal_Type (Decl); + end if; + end case; + + if Is_Valid (Default_Value) + and then not Eval_Is_In_Bound (Default_Value, Atype) + and then Get_Kind (Default_Value) /= Iir_Kind_Overflow_Literal + then + Warning_Msg_Sem + (Warnid_Runtime_Error, +Decl, + "default value constraints don't match object type ones"); + Default_Value := Build_Overflow (Default_Value, Atype); + Set_Default_Value (Decl, Default_Value); + end if; + + case Get_Kind (Decl) is + when Iir_Kind_Constant_Declaration => + -- LRM93 4.3.1.1 + -- If the assignment symbol ":=" followed by an expression is not + -- present in a constant declaration, then the declaration + -- declares a deferred constant. + -- Such a constant declaration may only appear in a package + -- declaration. + if Deferred_Const /= Null_Iir then + Set_Deferred_Declaration (Decl, Deferred_Const); + Set_Deferred_Declaration (Deferred_Const, Decl); + end if; + if Default_Value = Null_Iir then + if Deferred_Const /= Null_Iir then + Error_Msg_Sem + (+Decl, + "full constant declaration must have a default value"); + else + Set_Deferred_Declaration_Flag (Decl, True); + end if; + if Get_Kind (Parent) /= Iir_Kind_Package_Declaration then + Error_Msg_Sem + (+Decl, "a constant must have a default value"); + end if; + Set_Expr_Staticness (Decl, Globally); + else + -- LRM93 7.4.1: a locally static primary is defined: + -- A constant (other than deferred constant) explicitly + -- declared by a constant declaration and initialized + -- with a locally static expression. + -- Note: the staticness of the full declaration may be locally. + if False and Deferred_Const /= Null_Iir then + -- This is a deferred constant. + Staticness := Globally; + else + Staticness := Min (Get_Expr_Staticness (Default_Value), + Get_Type_Staticness (Atype)); + -- What about expr staticness of c in: + -- constant c : bit_vector (a to b) := "01"; + -- where a and b are not locally static ? + --Staticness := Get_Expr_Staticness (Default_Value); + + -- LRM 7.4.2 (Globally static primaries) + -- 5. a constant + if Staticness < Globally then + Staticness := Globally; + end if; + end if; + Set_Expr_Staticness (Decl, Staticness); + end if; + + when Iir_Kind_Signal_Declaration => + -- LRM93 4.3.1.2 + -- It is also an error if a guarded signal of a scalar type is + -- neither a resolved signal nor a subelement of a resolved + -- signal. + if Get_Guarded_Signal_Flag (Decl) + and then not Get_Resolved_Flag (Atype) + then + Error_Msg_Sem (+Decl, "guarded %n must be resolved", +Decl); + end if; + Set_Expr_Staticness (Decl, None); + Set_Has_Disconnect_Flag (Decl, False); + Set_Type_Has_Signal (Atype); + + when Iir_Kind_Variable_Declaration => + -- GHDL: restriction for shared variables are checked during + -- parse. + if Flags.Vhdl_Std >= Vhdl_00 then + declare + Base_Type : constant Iir := Get_Base_Type (Atype); + Is_Protected : constant Boolean := + Get_Kind (Base_Type) = Iir_Kind_Protected_Type_Declaration; + begin + -- LRM00 4.3.1.3 + -- The base type of the subtype indication of a + -- shared variable declaration must be a protected type. + if Get_Shared_Flag (Decl) and not Is_Protected then + Error_Msg_Sem_Relaxed + (Decl, Warnid_Shared, + "type of a shared variable must be a protected type"); + end if; + + -- LRM00 4.3.1.3 Variable declarations + -- If a given variable appears (directly or indirectly) + -- within a protected type body, then the base type + -- denoted by the subtype indication of the variable + -- declarations must not be a protected type defined by + -- the protected type body. + -- FIXME: indirectly ? + if Is_Protected + and then Get_Kind (Parent) = Iir_Kind_Protected_Type_Body + and then Base_Type + = Get_Protected_Type_Declaration (Parent) + then + Error_Msg_Sem (+Decl, "variable type must not be of the " + & "protected type body"); + end if; + end; + end if; + Set_Expr_Staticness (Decl, None); + when others => + Error_Kind ("sem_object_declaration", Decl); + end case; + + case Get_Kind (Decl) is + when Iir_Kind_Constant_Declaration => + -- LRM93 3.2.1.1 + -- For a constant declared by an object declaration, the index + -- ranges are defined by the initial value, if the subtype of the + -- constant is unconstrained; otherwise they are defined by this + -- subtype. + if Default_Value /= Null_Iir then + Sem_Object_Type_From_Value (Decl, Default_Value); + end if; + + when Iir_Kind_Variable_Declaration + | Iir_Kind_Signal_Declaration => + -- LRM93 3.2.1.1 / LRM08 5.3.2.2 + -- For a variable or signal declared by an object declaration, the + -- subtype indication of the corressponding object declaration + -- must define a constrained array subtype. + if not Is_Fully_Constrained_Type (Atype) then + Error_Msg_Sem + (+Decl, + "declaration of %n with unconstrained %n is not allowed", + (+Decl, +Atype)); + if Default_Value /= Null_Iir then + Error_Msg_Sem (+Decl, "(even with a default value)"); + end if; + end if; + + when others => + Error_Kind ("sem_object_declaration(2)", Decl); + end case; + end Sem_Object_Declaration; + + procedure Sem_File_Declaration (Decl: Iir_File_Declaration; Last_Decl : Iir) + is + Atype: Iir; + Logical_Name: Iir; + Open_Kind : Iir; + begin + Sem_Scopes.Add_Name (Decl); + Set_Expr_Staticness (Decl, None); + Xref_Decl (Decl); + + -- Try to find a type. + Atype := Get_Subtype_Indication (Decl); + if Atype /= Null_Iir then + Atype := Sem_Subtype_Indication (Atype); + Set_Subtype_Indication (Decl, Atype); + Atype := Get_Type_Of_Subtype_Indication (Atype); + if Atype = Null_Iir then + Atype := Create_Error_Type (Get_Type (Decl)); + end if; + else + Atype := Get_Type (Last_Decl); + end if; + Set_Type (Decl, Atype); + + -- LRM93 4.3.1.4 + -- The subtype indication of a file declaration must define a file + -- subtype. + if Get_Kind (Atype) /= Iir_Kind_File_Type_Definition then + Error_Msg_Sem (+Decl, "file subtype expected for a file declaration"); + return; + end if; + + Logical_Name := Get_File_Logical_Name (Decl); + -- LRM93 4.3.1.4 + -- The file logical name must be an expression of predefined type + -- STRING. + if Logical_Name /= Null_Iir then + Logical_Name := Sem_Expression (Logical_Name, String_Type_Definition); + if Logical_Name /= Null_Iir then + Check_Read (Logical_Name); + Set_File_Logical_Name (Decl, Logical_Name); + end if; + end if; + + Open_Kind := Get_File_Open_Kind (Decl); + if Open_Kind /= Null_Iir then + Open_Kind := + Sem_Expression (Open_Kind, File_Open_Kind_Type_Definition); + if Open_Kind /= Null_Iir then + Check_Read (Open_Kind); + Set_File_Open_Kind (Decl, Open_Kind); + end if; + else + -- LRM93 4.3.1.4 + -- If a file open kind expression is not included in the file open + -- information of a given file declaration, then the default value + -- of READ_MODE is used during elaboration of the file declaration. + -- + -- LRM87 4.3.1.4 + -- The default mode is IN, if no mode is specified. + if Get_Mode (Decl) = Iir_Unknown_Mode then + if Flags.Vhdl_Std = Vhdl_87 then + Set_Mode (Decl, Iir_In_Mode); + else + null; + -- Set_File_Open_Kind (Decl, File_Open_Kind_Read_Mode); + end if; + end if; + end if; + Name_Visible (Decl); + + -- LRM 93 2.2 + -- If a pure function is the parent of a given procedure, then + -- that procedure must not contain a reference to an explicitly + -- declared file object [...] + -- + -- A pure function must not contain a reference to an explicitly + -- declared file. + + -- Note: this check is also performed when a file is referenced. + -- But a file can be declared without being explicitly referenced. + declare + Parent : Iir; + Spec : Iir; + begin + Parent := Get_Parent (Decl); + case Get_Kind (Parent) is + when Iir_Kind_Function_Body => + Spec := Get_Subprogram_Specification (Parent); + if Get_Pure_Flag (Spec) then + Error_Msg_Sem_Relaxed + (Decl, Warnid_Pure, + "cannot declare a file in a pure function"); + end if; + when Iir_Kind_Procedure_Body => + Spec := Get_Subprogram_Specification (Parent); + Set_Purity_State (Spec, Impure); + Set_Impure_Depth (Parent, Iir_Depth_Impure); + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Error_Kind ("sem_file_declaration", Parent); + when others => + null; + end case; + end; + end Sem_File_Declaration; + + procedure Sem_Attribute_Declaration (Decl: Iir_Attribute_Declaration) + is + A_Type : Iir; + Ident : Name_Id; + begin + -- LRM93 4.4 + -- The identifier is said to be the designator of the attribute. + Ident := Get_Identifier (Decl); + if Ident in Std_Names.Name_Id_Attributes + or else (Flags.Vhdl_Std = Vhdl_87 + and then Ident in Std_Names.Name_Id_Vhdl87_Attributes) + or else (Flags.Vhdl_Std > Vhdl_87 + and then Ident in Std_Names.Name_Id_Vhdl93_Attributes) + then + Error_Msg_Sem (+Decl, "predefined attribute %i overriden", +Decl); + end if; + Sem_Scopes.Add_Name (Decl); + Xref_Decl (Decl); + + A_Type := Sem_Type_Mark (Get_Type_Mark (Decl)); + Set_Type_Mark (Decl, A_Type); + A_Type := Get_Type (A_Type); + Set_Type (Decl, A_Type); + + -- LRM93 4.4 Attribute declarations. + -- It is an error if the type mark denotes an access type, a file type, + -- a protected type, or a composite type with a subelement that is + -- an access type, a file type, or a protected type. + -- The subtype need not be constrained. + Check_Signal_Type (Decl); + Name_Visible (Decl); + end Sem_Attribute_Declaration; + + procedure Sem_Component_Declaration (Component: Iir_Component_Declaration) + is + begin + Sem_Scopes.Add_Name (Component); + Xref_Decl (Component); + + -- LRM 10.1 Declarative region + -- 6. A component declaration. + Open_Declarative_Region; + + Sem_Interface_Chain + (Get_Generic_Chain (Component), Generic_Interface_List); + Sem_Interface_Chain + (Get_Port_Chain (Component), Port_Interface_List); + + Close_Declarative_Region; + + Name_Visible (Component); + end Sem_Component_Declaration; + + procedure Sem_Object_Alias_Declaration (Alias: Iir_Object_Alias_Declaration) + is + N_Name: constant Iir := Get_Name (Alias); + N_Type: Iir; + Name_Type : Iir; + begin + -- LRM93 4.3.3.1 Object Aliases. + -- 1. A signature may not appear in a declaration of an object alias. + -- FIXME: todo. + -- + -- 2. The name must be a static name that denotes an object. + if Get_Name_Staticness (N_Name) < Globally then + Error_Msg_Sem (+Alias, "aliased name must be a static name"); + end if; + + -- LRM93 4.3.3.1 + -- The base type of the name specified in an alias declaration must be + -- the same as the base type of the type mark in the subtype indication + -- (if the subtype indication is present); + Name_Type := Get_Type (N_Name); + N_Type := Get_Subtype_Indication (Alias); + if N_Type = Null_Iir then + Set_Type (Alias, Name_Type); + N_Type := Name_Type; + else + -- FIXME: must be analyzed before calling Name_Visibility. + N_Type := Sem_Subtype_Indication (N_Type); + Set_Subtype_Indication (Alias, N_Type); + N_Type := Get_Type_Of_Subtype_Indication (N_Type); + if N_Type /= Null_Iir then + Set_Type (Alias, N_Type); + if Get_Base_Type (N_Type) /= Get_Base_Type (Name_Type) then + Error_Msg_Sem + (+Alias, "base type of aliased name and name mismatch"); + end if; + end if; + + -- LRM08 6.6.2 Object aliases + -- The following rules apply yo object aliases: + -- b) If the name is an external name, a subtype indication shall not + -- appear in the alias declaration. + if Get_Kind (N_Name) in Iir_Kinds_External_Name then + Error_Msg_Sem + (+Alias, + "subtype indication not allowed in alias of external name"); + end if; + end if; + + -- LRM93 4.3.3.1 + -- This type must not be a multi-dimensional array type. + if Get_Kind (N_Type) in Iir_Kinds_Array_Type_Definition then + if not Is_One_Dimensional_Array_Type (N_Type) then + Error_Msg_Sem + (+Alias, + "aliased name must not be a multi-dimensional array type"); + end if; + if Get_Type_Staticness (N_Type) = Locally + and then Get_Type_Staticness (Name_Type) = Locally + and then Eval_Discrete_Type_Length + (Get_Nth_Element (Get_Index_Subtype_List (N_Type), 0)) + /= Eval_Discrete_Type_Length + (Get_Nth_Element (Get_Index_Subtype_List (Name_Type), 0)) + then + Error_Msg_Sem + (+Alias, "number of elements not matching in type and name"); + end if; + end if; + + Set_Name_Staticness (Alias, Get_Name_Staticness (N_Name)); + Set_Expr_Staticness (Alias, Get_Expr_Staticness (N_Name)); + if Is_Signal_Object (N_Name) then + Set_Type_Has_Signal (N_Type); + end if; + end Sem_Object_Alias_Declaration; + + function Signature_Match (N_Entity : Iir; Sig : Iir_Signature) + return Boolean + is + List : constant Iir_Flist := Get_Type_Marks_List (Sig); + Inter : Iir; + El : Iir; + begin + case Get_Kind (N_Entity) is + when Iir_Kind_Enumeration_Literal => + -- LRM93 2.3.2 Signatures + -- * Similarly, a signature is said to match the parameter and + -- result type profile of a given enumeration literal if + -- the signature matches the parameter and result type profile + -- of the subprogram equivalent to the enumeration literal, + -- defined in Section 3.1.1 + if Get_Return_Type_Mark (Sig) = Null_Iir then + return False; + end if; + return List = Null_Iir_Flist + and then (Get_Type (N_Entity) + = Get_Type (Get_Return_Type_Mark (Sig))); + when Iir_Kind_Function_Declaration + | Iir_Kind_Interface_Function_Declaration => + -- LRM93 2.3.2 Signatures + -- * if the reserved word RETURN is present, the subprogram is + -- a function and the base type of the type mark following + -- the reserved word in the signature is the same as the base + -- type of the return type of the function, [...] + if Get_Return_Type_Mark (Sig) = Null_Iir then + return False; + end if; + if Get_Type (Get_Return_Type_Mark (Sig)) /= + Get_Base_Type (Get_Return_Type (N_Entity)) + then + return False; + end if; + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Interface_Procedure_Declaration => + -- LRM93 2.3.2 Signatures + -- * [...] or the reserved word RETURN is absent and the + -- subprogram is a procedure. + if Get_Return_Type_Mark (Sig) /= Null_Iir then + return False; + end if; + when others => + -- LRM93 2.3.2 Signatures + -- A signature distinguishes between overloaded subprograms and + -- overloaded enumeration literals based on their parameter + -- and result type profiles. + return False; + end case; + + -- LRM93 2.3.2 Signature + -- * the number of type marks prior the reserved word RETURN, if any, + -- matches the number of formal parameters of the subprogram; + -- * at each parameter position, the base type denoted by the type + -- mark of the signature is the same as the base type of the + -- corresponding formal parameter of the subprogram; [and finally, ] + Inter := Get_Interface_Declaration_Chain (N_Entity); + if List = Null_Iir_Flist then + return Inter = Null_Iir; + end if; + for I in Flist_First .. Flist_Last (List) loop + El := Get_Nth_Element (List, I); + if Inter = Null_Iir then + -- More type marks in the signature than in the interface. + return False; + end if; + if Get_Base_Type (Get_Type (Inter)) /= Get_Type (El) then + return False; + end if; + Inter := Get_Chain (Inter); + end loop; + -- Match only if the number of type marks is the same. + return Inter = Null_Iir; + end Signature_Match; + + -- Extract from NAME the named entity whose profile matches with SIG. + function Sem_Signature (Name : Iir; Sig : Iir_Signature) return Iir + is + List : constant Iir_Flist := Get_Type_Marks_List (Sig); + Res : Iir; + El : Iir; + Error : Boolean; + Ov_List : Iir_List; + Ov_It : List_Iterator; + begin + -- Sem signature. + if List /= Null_Iir_Flist then + for I in Flist_First .. Flist_Last (List) loop + El := Get_Nth_Element (List, I); + El := Sem_Type_Mark (El); + Set_Nth_Element (List, I, El); + + -- Reuse the Type field of the name for the base type. This is + -- a deviation from the use of Type in a name, but restricted to + -- analysis of signatures. + Set_Type (El, Get_Base_Type (Get_Type (El))); + end loop; + end if; + El := Get_Return_Type_Mark (Sig); + if El /= Null_Iir then + El := Sem_Type_Mark (El); + Set_Return_Type_Mark (Sig, El); + -- Likewise. + Set_Type (El, Get_Base_Type (Get_Type (El))); + end if; + + -- FIXME: what to do in case of error ? + Res := Null_Iir; + Error := False; + if Is_Overload_List (Name) then + Ov_List := Get_Overload_List (Name); + Ov_It := List_Iterate (Ov_List); + while Is_Valid (Ov_It) loop + El := Get_Element (Ov_It); + if Signature_Match (El, Sig) then + if Res = Null_Iir then + Res := El; + else + Error := True; + Error_Msg_Sem + (+Sig, + "cannot resolve signature, many matching subprograms:", + Cont => True); + Error_Msg_Sem (+Res, "found: %n", (1 => +Res), Cont => True); + end if; + if Error then + Error_Msg_Sem (+El, "found: %n", +El); + end if; + end if; + Next (Ov_It); + end loop; + + -- Free the overload list (with a workaround as only variables can + -- be free). + declare + Name_Ov : Iir; + begin + Name_Ov := Name; + Free_Overload_List (Name_Ov); + end; + else + if Signature_Match (Name, Sig) then + Res := Name; + end if; + end if; + + if Error then + return Null_Iir; + end if; + if Res = Null_Iir then + Error_Msg_Sem + (+Sig, "cannot resolve signature, no matching subprogram"); + end if; + + return Res; + end Sem_Signature; + + -- Create implicit aliases for an alias ALIAS of a type or of a subtype. + procedure Add_Aliases_For_Type_Alias (Alias : Iir) + is + N_Entity : constant Iir := Get_Named_Entity (Get_Name (Alias)); + Def : constant Iir := Get_Base_Type (Get_Type (N_Entity)); + Type_Decl : constant Iir := Get_Type_Declarator (Def); + Last : Iir; + El : Iir; + Enum_List : Iir_Flist; + + -- Append an implicit alias + procedure Add_Implicit_Alias (Decl : Iir) + is + N_Alias : constant Iir_Non_Object_Alias_Declaration := + Create_Iir (Iir_Kind_Non_Object_Alias_Declaration); + N_Name : constant Iir := Create_Iir (Iir_Kind_Simple_Name); + begin + -- Create the name (can be in fact a character literal or a symbol + -- operator). + Location_Copy (N_Name, Alias); + Set_Identifier (N_Name, Get_Identifier (Decl)); + Set_Named_Entity (N_Name, Decl); + + Location_Copy (N_Alias, Alias); + Set_Identifier (N_Alias, Get_Identifier (Decl)); + Set_Name (N_Alias, N_Name); + Set_Parent (N_Alias, Get_Parent (Alias)); + Set_Implicit_Alias_Flag (N_Alias, True); + + Sem_Scopes.Add_Name (N_Alias); + Set_Visible_Flag (N_Alias, True); + + -- Append in the declaration chain. + Set_Chain (N_Alias, Get_Chain (Last)); + Set_Chain (Last, N_Alias); + Last := N_Alias; + end Add_Implicit_Alias; + begin + Last := Alias; + + if Get_Kind (Def) = Iir_Kind_Enumeration_Type_Definition then + -- LRM93 4.3.3.2 Non-Object Aliases + -- 3. If the name denotes an enumeration type, then one + -- implicit alias declaration for each of the + -- literals of the type immediatly follows the alias + -- declaration for the enumeration type; [...] + -- + -- LRM08 6.6.3 Nonobject aliases + -- c) If the name denotes an enumeration type or a subtype of an + -- enumeration type, then one implicit alias declaration for each + -- of the literals of the base type immediately follows the + -- alias declaration for the enumeration type; [...] + Enum_List := Get_Enumeration_Literal_List (Def); + for I in Flist_First .. Flist_Last (Enum_List) loop + El := Get_Nth_Element (Enum_List, I); + -- LRM93 4.3.3.2 Non-Object Aliases + -- [...] each such implicit declaration has, as its alias + -- designator, the simple name or character literal of the + -- literal, and has, as its name, a name constructed by taking + -- the name of the alias for the enumeration type and + -- substituting the simple name or character literal being + -- aliased for the simple name of the type. Each implicit + -- alias has a signature that matches the parameter and result + -- type profile of the literal being aliased. + -- + -- LRM08 6.6.3 Nonobject aliases + -- [...] each such implicit declaration has, as its alias + -- designator, the simple name or character literal of the + -- literal and has, as its name, a name constructed by taking + -- the name of the alias for the enumeration type or subtype + -- and substituing the simple name or character literal being + -- aliased for the simple name of the type or subtype. Each + -- implicit alias has a signature that matches the parameter + -- and result type profile of the literal being aliased. + Add_Implicit_Alias (El); + end loop; + end if; + + -- LRM93 4.3.3.2 Non-Object Aliases + -- 4. Alternatively, if the name denotes a physical type + -- [...] + -- GHDL: this is not possible, since a physical type is + -- anonymous (LRM93 is buggy on this point). + -- + -- LRM08 6.6.3 Nonobject aliases + -- d) Alternatively, if the name denotes a subtype of a physical type, + -- [...] + if Get_Kind (Def) = Iir_Kind_Physical_Type_Definition then + -- LRM08 6.3.3 Nonobject aliases + -- [...] then one implicit alias declaration for each of the + -- units of the base type immediately follows the alias + -- declaration for the physical type; each such implicit + -- declaration has, as its alias designator, the simple name of + -- the unit and has, as its name, a name constructed by taking + -- the name of the alias for the subtype of the physical type + -- and substituting the simple name of the unit being aliased for + -- the simple name of the subtype. + El := Get_Unit_Chain (Def); + while El /= Null_Iir loop + Add_Implicit_Alias (El); + El := Get_Chain (El); + end loop; + end if; + + -- LRM93 4.3.3.2 Non-Object Aliases + -- 5. Finally, if the name denotes a type, then implicit + -- alias declarations for each predefined operator + -- for the type immediatly follow the explicit alias + -- declaration for the type, and if present, any + -- implicit alias declarations for literals or units + -- of the type. + -- Each implicit alias has a signature that matches the + -- parameter and result type profule of the implicit + -- operator being aliased. + -- + -- LRM08 6.6.3 Nonobject aliases + -- e) Finally, if the name denotes a type of a subtype, then implicit + -- alias declarations for each predefined operation for the type + -- immediately follow the explicit alias declaration for the type or + -- subtype and, if present, any implicit alias declarations for + -- literals or units of the type. Each implicit alias has a + -- signature that matches the parameter and result type profile of + -- the implicit operation being aliased. + El := Get_Chain (Type_Decl); + while El /= Null_Iir loop + if Is_Implicit_Subprogram (El) + and then Is_Operation_For_Type (El, Def) + then + Add_Implicit_Alias (El); + El := Get_Chain (El); + else + exit; + end if; + end loop; + end Add_Aliases_For_Type_Alias; + + procedure Sem_Non_Object_Alias_Declaration + (Alias : Iir_Non_Object_Alias_Declaration) + is + use Std_Names; + N_Entity : constant Iir := Get_Named_Entity (Get_Name (Alias)); + Id : Name_Id; + begin + case Get_Kind (N_Entity) is + when Iir_Kinds_Subprogram_Declaration + | Iir_Kinds_Interface_Subprogram_Declaration => + -- LRM93 4.3.3.2 Non-Object Aliases + -- 2. A signature is required if the name denotes a subprogram + -- (including an operator) or enumeration literal. + if Get_Alias_Signature (Alias) = Null_Iir then + Error_Msg_Sem (+Alias, "signature required for subprogram"); + end if; + when Iir_Kind_Enumeration_Literal => + if Get_Alias_Signature (Alias) = Null_Iir then + Error_Msg_Sem + (+Alias, "signature required for enumeration literal"); + end if; + when Iir_Kind_Type_Declaration => + Add_Aliases_For_Type_Alias (Alias); + when Iir_Kind_Subtype_Declaration => + -- LRM08 6.6.3 Nonobject aliases + -- ... or a subtype ... + if Flags.Vhdl_Std >= Vhdl_08 then + Add_Aliases_For_Type_Alias (Alias); + end if; + when Iir_Kinds_Object_Declaration => + raise Internal_Error; + when Iir_Kind_Attribute_Declaration + | Iir_Kind_Component_Declaration => + null; + when Iir_Kind_Library_Declaration => + -- Not explicitly allowed before vhdl-08. + null; + when Iir_Kind_Terminal_Declaration => + null; + when Iir_Kind_Base_Attribute => + Error_Msg_Sem (+Alias, "base attribute not allowed in alias"); + return; + when others => + Error_Kind ("sem_non_object_alias_declaration", N_Entity); + end case; + + Id := Get_Identifier (Alias); + + case Id is + when Name_Characters => + -- LRM 4.3.3 Alias declarations + -- If the alias designator is a character literal, the + -- name must denote an enumeration literal. + if Get_Kind (N_Entity) /= Iir_Kind_Enumeration_Literal then + Error_Msg_Sem + (+Alias, + "alias of a character must denote an enumeration literal"); + return; + end if; + when Name_Id_Operators + | Name_Shift_Operators + | Name_Word_Operators => + -- LRM 4.3.3 Alias declarations + -- If the alias designator is an operator symbol, the + -- name must denote a function, and that function then + -- overloads the operator symbol. In this latter case, + -- the operator symbol and the function both must meet the + -- requirements of 2.3.1. + if Get_Kind (N_Entity) /= Iir_Kind_Function_Declaration then + Error_Msg_Sem + (+Alias, "alias of an operator must denote a function"); + return; + end if; + Check_Operator_Requirements (Id, N_Entity); + when others => + null; + end case; + end Sem_Non_Object_Alias_Declaration; + + function Sem_Alias_Declaration (Alias : Iir) return Iir + is + Name : Iir; + Sig : Iir_Signature; + N_Entity : Iir; + Res : Iir; + begin + Xref_Decl (Alias); + + Name := Get_Name (Alias); + case Get_Kind (Name) is + when Iir_Kind_Signature => + Sig := Name; + Name := Get_Signature_Prefix (Sig); + Sem_Name (Name); + Set_Signature_Prefix (Sig, Name); + when Iir_Kind_Error => + pragma Assert (Flags.Flag_Force_Analysis); + return Alias; + when others => + Sem_Name (Name); + Sig := Null_Iir; + end case; + + N_Entity := Get_Named_Entity (Name); + if N_Entity = Error_Mark then + return Alias; + end if; + + if Is_Overload_List (N_Entity) then + if Sig = Null_Iir then + Error_Msg_Sem + (+Alias, "signature required for alias of a subprogram"); + return Alias; + end if; + end if; + + if Sig /= Null_Iir then + N_Entity := Sem_Signature (N_Entity, Sig); + end if; + if N_Entity = Null_Iir then + return Alias; + end if; + + Set_Named_Entity (Name, N_Entity); + Name := Finish_Sem_Name (Name); + Set_Name (Alias, Name); + + if Is_Object_Name (N_Entity) then + -- Object alias declaration. + + Sem_Scopes.Add_Name (Alias); + Name_Visible (Alias); + + if Sig /= Null_Iir then + Error_Msg_Sem (+Sig, "signature not allowed for object alias"); + end if; + Sem_Object_Alias_Declaration (Alias); + return Alias; + else + -- Non object alias declaration. + + if Get_Subtype_Indication (Alias) /= Null_Iir then + Error_Msg_Sem + (+Alias, + "subtype indication shall not appear in a nonobject alias"); + end if; + + Res := Create_Iir (Iir_Kind_Non_Object_Alias_Declaration); + Location_Copy (Res, Alias); + Set_Parent (Res, Get_Parent (Alias)); + Set_Chain (Res, Get_Chain (Alias)); + Set_Identifier (Res, Get_Identifier (Alias)); + Set_Name (Res, Get_Name (Alias)); + Set_Alias_Signature (Res, Sig); + + if Is_Valid (Sig) then + -- The prefix is owned by the non_object_alias_declaration. + Set_Signature_Prefix (Sig, Null_Iir); + end if; + + Sem_Scopes.Add_Name (Res); + Name_Visible (Res); + + Free_Iir (Alias); + + if Get_Kind (Name) in Iir_Kinds_Denoting_And_External_Name then + Sem_Non_Object_Alias_Declaration (Res); + else + Error_Msg_Sem + (+Name, "name of nonobject alias is not a name"); + + -- Create a simple name to an error node. + N_Entity := Create_Error (Name); + Name := Create_Iir (Iir_Kind_Simple_Name); + Location_Copy (Name, N_Entity); + Set_Identifier (Name, Get_Identifier (Res)); -- Better idea ? + Set_Named_Entity (Name, N_Entity); + Set_Base_Name (Name, Name); + Set_Name (Res, Name); + end if; + + return Res; + end if; + end Sem_Alias_Declaration; + + procedure Sem_Group_Template_Declaration + (Decl : Iir_Group_Template_Declaration) is + begin + Sem_Scopes.Add_Name (Decl); + Sem_Scopes.Name_Visible (Decl); + Xref_Decl (Decl); + end Sem_Group_Template_Declaration; + + procedure Sem_Group_Declaration (Group : Iir_Group_Declaration) + is + use Vhdl.Tokens; + + Constituent_List : Iir_Flist; + Template : Iir_Group_Template_Declaration; + Template_Name : Iir; + Class, Prev_Class : Token_Type; + El : Iir; + El_Name : Iir; + El_Entity : Iir_Entity_Class; + begin + Sem_Scopes.Add_Name (Group); + Xref_Decl (Group); + + Template_Name := Sem_Denoting_Name (Get_Group_Template_Name (Group)); + Set_Group_Template_Name (Group, Template_Name); + Template := Get_Named_Entity (Template_Name); + if Get_Kind (Template) /= Iir_Kind_Group_Template_Declaration then + Error_Class_Match (Template_Name, "group template"); + return; + end if; + Constituent_List := Get_Group_Constituent_List (Group); + El_Entity := Get_Entity_Class_Entry_Chain (Template); + Prev_Class := Tok_Eof; + for I in Flist_First .. Flist_Last (Constituent_List) loop + El := Get_Nth_Element (Constituent_List, I); + + Sem_Name (El); + + if El_Entity = Null_Iir then + Error_Msg_Sem + (+Group, "too many elements in group constituent list"); + exit; + end if; + + Class := Get_Entity_Class (El_Entity); + if Class = Tok_Box then + -- LRM93 4.6 + -- An entity class entry that includes a box (<>) allows zero + -- or more group constituents to appear in this position in the + -- corresponding group declaration. + Class := Prev_Class; + else + Prev_Class := Class; + El_Entity := Get_Chain (El_Entity); + end if; + + El_Name := Get_Named_Entity (El); + if Is_Error (El_Name) then + null; + elsif Is_Overload_List (El_Name) then + Error_Overload (El_Name); + else + El := Finish_Sem_Name (El); + Set_Nth_Element (Constituent_List, I, El); + El_Name := Get_Named_Entity (El); + + -- Statements are textually afer the group declaration. To avoid + -- adding a flag on each node with a base_name, this field is + -- cleared, as we don't care about base name. + if Class = Tok_Label then + Set_Is_Forward_Ref (El, True); + end if; + Set_Base_Name (El, Null_Iir); + + -- LRM93 4.7 + -- It is an error if the class of any group constituent in the + -- group constituent list is not the same as the class specified + -- by the corresponding entity class entry in the entity class + -- entry list of the group template. + if Get_Entity_Class_Kind (El_Name) /= Class then + Error_Msg_Sem (+El, "constituent not of class %t", +Class); + end if; + end if; + end loop; + + -- End of entity_class list reached or zero or more constituent allowed. + if not (El_Entity = Null_Iir + or else Get_Entity_Class (El_Entity) = Tok_Box) + then + Error_Msg_Sem + (+Group, "not enough elements in group constituent list"); + end if; + Set_Visible_Flag (Group, True); + end Sem_Group_Declaration; + + function Sem_Scalar_Nature_Definition (Def : Iir; Decl : Iir) return Iir + is + function Sem_Scalar_Nature_Typemark (T : Iir; Name : String) return Iir + is + Res : Iir; + begin + Res := Sem_Type_Mark (T); + Res := Get_Type (Res); + if Is_Error (Res) then + return Real_Type_Definition; + end if; + -- LRM93 3.5.1 + -- The type marks must denote floating point types + case Get_Kind (Res) is + when Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Floating_Type_Definition => + return Res; + when others => + Error_Msg_Sem (+T, Name & "type must be a floating point type"); + return Real_Type_Definition; + end case; + end Sem_Scalar_Nature_Typemark; + + Tm : Iir; + Ref : Iir; + begin + Tm := Get_Across_Type (Def); + Tm := Sem_Scalar_Nature_Typemark (Tm, "across"); + Set_Across_Type (Def, Tm); + + Tm := Get_Through_Type (Def); + Tm := Sem_Scalar_Nature_Typemark (Tm, "through"); + Set_Through_Type (Def, Tm); + + -- Declare the reference + Ref := Get_Reference (Def); + Set_Nature (Ref, Def); + Set_Chain (Ref, Get_Chain (Decl)); + Set_Chain (Decl, Ref); + + return Def; + end Sem_Scalar_Nature_Definition; + + function Sem_Nature_Definition (Def : Iir; Decl : Iir) return Iir + is + begin + case Get_Kind (Def) is + when Iir_Kind_Scalar_Nature_Definition => + return Sem_Scalar_Nature_Definition (Def, Decl); + when others => + Error_Kind ("sem_nature_definition", Def); + return Null_Iir; + end case; + end Sem_Nature_Definition; + + procedure Sem_Nature_Declaration (Decl : Iir) + is + Def : Iir; + begin + Def := Get_Nature (Decl); + if Def /= Null_Iir then + Sem_Scopes.Add_Name (Decl); + Xref_Decl (Decl); + + Def := Sem_Nature_Definition (Def, Decl); + if Def /= Null_Iir then + Set_Nature_Declarator (Def, Decl); + Sem_Scopes.Name_Visible (Decl); + end if; + end if; + end Sem_Nature_Declaration; + + procedure Sem_Terminal_Declaration (Decl : Iir; Last_Decl : Iir) + is + Def, Nature : Iir; + begin + Sem_Scopes.Add_Name (Decl); + Xref_Decl (Decl); + + Def := Get_Nature (Decl); + + if Def = Null_Iir then + Nature := Get_Nature (Last_Decl); + else + Nature := Sem_Subnature_Indication (Def); + end if; + + if Nature /= Null_Iir then + Set_Nature (Decl, Nature); + Sem_Scopes.Name_Visible (Decl); + end if; + end Sem_Terminal_Declaration; + + procedure Sem_Branch_Quantity_Declaration (Decl : Iir; Last_Decl : Iir) + is + Plus_Name : Iir; + Minus_Name : Iir; + Branch_Type : Iir; + Value : Iir; + Is_Second : Boolean; + begin + Sem_Scopes.Add_Name (Decl); + Xref_Decl (Decl); + + Plus_Name := Get_Plus_Terminal (Decl); + if Plus_Name = Null_Iir then + -- List of identifier. + Is_Second := True; + Plus_Name := Get_Plus_Terminal (Last_Decl); + Minus_Name := Get_Minus_Terminal (Last_Decl); + Value := Get_Default_Value (Last_Decl); + else + Is_Second := False; + Plus_Name := Sem_Terminal_Name (Plus_Name); + Minus_Name := Get_Minus_Terminal (Decl); + if Minus_Name /= Null_Iir then + Minus_Name := Sem_Terminal_Name (Minus_Name); + end if; + Value := Get_Default_Value (Decl); + end if; + Set_Plus_Terminal (Decl, Plus_Name); + Set_Minus_Terminal (Decl, Minus_Name); + case Get_Kind (Decl) is + when Iir_Kind_Across_Quantity_Declaration => + Branch_Type := Get_Across_Type (Get_Nature (Plus_Name)); + when Iir_Kind_Through_Quantity_Declaration => + Branch_Type := Get_Through_Type (Get_Nature (Plus_Name)); + when others => + raise Program_Error; + end case; + Set_Type (Decl, Branch_Type); + + if not Is_Second and then Value /= Null_Iir then + Value := Sem_Expression (Value, Branch_Type); + end if; + Set_Default_Value (Decl, Value); + + -- TODO: tolerance + + Sem_Scopes.Name_Visible (Decl); + end Sem_Branch_Quantity_Declaration; + + procedure Sem_Declaration_Chain (Parent : Iir) + is + Decl : Iir; + Kind : Iir_Kind; + Attr_Spec_Chain : Iir; + + -- New declaration chain (declarations like implicit signals may be + -- added, some like aliases may mutate). + Last_Decl : Iir; + + -- Used for list of identifiers in object declarations to get the type + -- and default value for the following declarations. + Last_Obj_Decl : Iir; + + -- If IS_GLOBAL is set, then declarations may be seen outside of unit. + -- This must be set for entities and packages (except when + -- Flags.Flag_Whole_Analyze is set). + Is_Global : Boolean; + begin + case Get_Kind (Parent) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Declaration => + Is_Global := not Flags.Flag_Whole_Analyze; + when others => + Is_Global := False; + end case; + + -- Due to implicit declarations, the list can grow during sem. + Decl := Get_Declaration_Chain (Parent); + Last_Decl := Null_Iir; + Attr_Spec_Chain := Null_Iir; + Last_Obj_Decl := Null_Iir; + + while Decl /= Null_Iir loop + Kind := Get_Kind (Decl); + case Kind is + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration => + Sem_Type_Declaration (Decl, Is_Global); + when Iir_Kind_Subtype_Declaration => + Sem_Subtype_Declaration (Decl, Is_Global); + when Iir_Kind_Signal_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Declaration => + Sem_Object_Declaration (Decl, Parent, Last_Obj_Decl); + when Iir_Kind_File_Declaration => + Sem_File_Declaration (Decl, Last_Obj_Decl); + when Iir_Kind_Attribute_Declaration => + Sem_Attribute_Declaration (Decl); + when Iir_Kind_Attribute_Specification => + Sem_Attribute_Specification (Decl, Parent); + if Get_Entity_Name_List (Decl) in Iir_Flists_All_Others then + Set_Attribute_Specification_Chain (Decl, Attr_Spec_Chain); + Attr_Spec_Chain := Decl; + end if; + when Iir_Kind_Component_Declaration => + Sem_Component_Declaration (Decl); + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if Is_Implicit_Subprogram (Decl) then + Sem_Scopes.Add_Name (Decl); + -- Implicit subprogram are already visible. + else + Sem_Subprogram_Declaration (Decl); + if Is_Global + and then Get_Kind (Decl) = Iir_Kind_Function_Declaration + and then Is_A_Resolution_Function (Decl, Null_Iir) + then + Set_Resolution_Function_Flag (Decl, True); + end if; + end if; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Sem_Subprogram_Body (Decl); + when Iir_Kind_Non_Object_Alias_Declaration => + -- Added by Sem_Alias_Declaration. Need to check that no + -- existing attribute specification apply to them. + null; + when Iir_Kind_Object_Alias_Declaration => + Decl := Sem_Alias_Declaration (Decl); + -- An alias may add new alias declarations. Do not skip + -- them: check that no existing attribute specifications + -- apply to them. + when Iir_Kind_Use_Clause => + Sem_Use_Clause (Decl); + when Iir_Kind_Configuration_Specification => + null; + when Iir_Kind_Disconnection_Specification => + Sem_Disconnection_Specification (Decl); + when Iir_Kind_Group_Template_Declaration => + Sem_Group_Template_Declaration (Decl); + when Iir_Kind_Group_Declaration => + Sem_Group_Declaration (Decl); + when Iir_Kinds_Signal_Attribute => + -- Added by sem, so nothing to do. + null; + when Iir_Kind_Protected_Type_Body => + Sem_Protected_Type_Body (Decl); + + when Iir_Kind_Package_Declaration => + Sem_Package_Declaration (Decl); + when Iir_Kind_Package_Body => + Sem_Package_Body (Decl); + when Iir_Kind_Package_Instantiation_Declaration => + Sem_Package_Instantiation_Declaration (Decl); + + when Iir_Kind_Nature_Declaration => + Sem_Nature_Declaration (Decl); + when Iir_Kind_Terminal_Declaration => + Sem_Terminal_Declaration (Decl, Last_Obj_Decl); + when Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration => + Sem_Branch_Quantity_Declaration (Decl, Last_Obj_Decl); + + when Iir_Kind_Psl_Declaration => + Sem_Psl.Sem_Psl_Declaration (Decl); + when Iir_Kind_Psl_Default_Clock => + Sem_Psl.Sem_Psl_Default_Clock (Decl); + + when others => + Error_Kind ("sem_declaration_chain", Decl); + end case; + + -- For object declarations, set Last_Obj_Decl; otherwise clear it. + case Kind is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Terminal_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration => + if Get_Has_Identifier_List (Decl) then + Last_Obj_Decl := Decl; + else + Last_Obj_Decl := Null_Iir; + end if; + when others => + Last_Obj_Decl := Null_Iir; + end case; + + if Attr_Spec_Chain /= Null_Iir then + Check_Post_Attribute_Specification (Attr_Spec_Chain, Decl); + end if; + + -- Insert *before* DECL pending implicit signal declarations created + -- for DECL after LAST_DECL. This updates LAST_DECL. + Insert_Pending_Implicit_Declarations (Parent, Last_Decl); + + if Last_Decl = Null_Iir then + -- Append now to handle expand names. + Set_Declaration_Chain (Parent, Decl); + else + Set_Chain (Last_Decl, Decl); + end if; + Last_Decl := Decl; + Decl := Get_Chain (Decl); + end loop; + + -- Keep the point of insertion for implicit signal declarations. + End_Of_Declarations_For_Implicit_Declarations (Parent, Last_Decl); + end Sem_Declaration_Chain; + + procedure Check_Full_Declaration (Decls_Parent : Iir; Decl: Iir) + is + El: Iir; + + -- If set, emit a warning if a declaration is not used. + Check_Unused : Boolean; + begin + -- LRM 3.5 Protected types. + -- Each protected type declaration appearing immediatly within a given + -- declaration region must have exactly one corresponding protected type + -- body appearing immediatly within the same declarative region and + -- textually subsequent to the protected type declaration. + + -- LRM 3.3.1 Incomplete type declarations + -- For each incomplete type declaration, there must be a corresponding + -- full type declaration with the same identifier. This full type + -- declaration must occur later and immediatly within the same + -- declarative part as the incomplete type declaration to which it + -- correspinds. + + -- LRM 4.3.1.1 Constant declarations + -- If the assignment symbol ":=" followed by an expression is not + -- present in a constant declaration, then the declaration declares a + -- deferred constant. Such a constant declaration must appear in a + -- package declaration. The corresponding full constant declaration, + -- which defines the value of the constant, must appear in the body of + -- the package (see 2.6). + + -- LRM 2.2 Subprogram bodies + -- If both a declaration and a body are given, [...]. Furthermore, + -- both the declaration and the body must occur immediatly within the + -- same declaration region. + + -- Set Check_Unused. + Check_Unused := False; + if Is_Warning_Enabled (Warnid_Unused) then + case Get_Kind (Decl) is + when Iir_Kind_Entity_Declaration => + -- May be used in architecture. + null; + when Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement => + -- Might be used in a configuration. + -- FIXME: create a second level of warning. + null; + when Iir_Kind_Generate_Statement_Body => + -- Might be used in a configuration. + null; + when Iir_Kind_Package_Body + | Iir_Kind_Protected_Type_Body => + -- Check only for declarations of the body. + if Decls_Parent = Decl then + Check_Unused := True; + end if; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Check_Unused := True; + when others => + -- Note: Check_Full_Declaration is not called + -- for package declarations or protected type declarations. + Error_Kind ("check_full_declaration", Decl); + end case; + end if; + + El := Get_Declaration_Chain (Decls_Parent); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Constant_Declaration => + if Get_Deferred_Declaration_Flag (El) then + if Get_Deferred_Declaration (El) = Null_Iir then + Error_Msg_Sem + (+Decl, + "missing value for constant declared at %l", +El); + end if; + end if; + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if not Is_Implicit_Subprogram (El) + and then Get_Subprogram_Body (El) = Null_Iir + then + Error_Msg_Sem + (+Decl, "missing body for %n declared at %l", (+El, +El)); + end if; + when Iir_Kind_Type_Declaration => + declare + Def : constant Iir := Get_Type_Definition (El); + begin + if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition + and then Is_Null (Get_Complete_Type_Definition (Def)) + then + Error_Msg_Sem + (+El, "missing full type declaration for %n", +El); + elsif Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration + and then Get_Protected_Type_Body (Def) = Null_Iir + then + Error_Msg_Sem + (+El, "missing protected type body for %n", +El); + end if; + end; + when Iir_Kind_Package_Declaration => + if Is_Null (Get_Package_Origin (El)) + and then Get_Need_Body (El) + and then Get_Package_Body (El) = Null_Iir + then + Error_Msg_Sem (+El, "missing package body for %n", +El); + end if; + when others => + null; + end case; + + if Check_Unused then + -- All subprograms declared in the specification (package or + -- protected type) have only their *body* in the body. + -- Therefore, they don't appear as declaration in body. + -- Only private subprograms appears as declarations. + case Get_Kind (El) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if not Get_Use_Flag (El) + and then not Is_Implicit_Subprogram (El) + and then not Is_Second_Subprogram_Specification (El) + then + Warning_Msg_Sem (Warnid_Unused, +El, + "%n is never referenced", +El); + end if; + when others => + null; + end case; + end if; + + El := Get_Chain (El); + end loop; + end Check_Full_Declaration; + + procedure Sem_Iterator (Iterator : Iir_Iterator_Declaration; + Staticness : Iir_Staticness) + is + It_Range: constant Iir := Get_Discrete_Range (Iterator); + It_Type : Iir; + A_Range: Iir; + begin + Xref_Decl (Iterator); + + A_Range := Sem_Discrete_Range_Integer (It_Range); + if A_Range = Null_Iir then + Set_Type (Iterator, Create_Error_Type (It_Range)); + return; + end if; + + Set_Discrete_Range (Iterator, Null_Iir); + + It_Type := Range_To_Subtype_Indication (A_Range); + Set_Subtype_Indication (Iterator, It_Type); + Set_Type (Iterator, Get_Type_Of_Subtype_Indication (It_Type)); + + Set_Expr_Staticness (Iterator, Staticness); + end Sem_Iterator; +end Vhdl.Sem_Decls; diff --git a/src/vhdl/vhdl-sem_decls.ads b/src/vhdl/vhdl-sem_decls.ads new file mode 100644 index 000000000..99609b5e3 --- /dev/null +++ b/src/vhdl/vhdl-sem_decls.ads @@ -0,0 +1,105 @@ +-- Semantic analysis. +-- 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 Iirs; use Iirs; + +package Vhdl.Sem_Decls is + -- Analyze an interface chain. + procedure Sem_Interface_Chain (Interface_Chain: Iir; + Interface_Kind : Interface_Kind_Type); + + -- Analyze declarations of PARENT. + procedure Sem_Declaration_Chain (Parent : Iir); + + -- Check all declarations of DECLS_PARENT are complete + -- This checks subprograms, deferred constants, incomplete types and + -- protected types. + -- + -- DECL is the declaration that contains the declaration_list DECLS_PARENT. + -- (location of errors). + -- DECL is different from DECLS_PARENT for package bodies and protected + -- type bodies. + -- + -- Also, report unused declarations if DECL = DECLS_PARENT. + -- As a consequence, Check_Full_Declaration must be called after analyze + -- of statements, if any. + procedure Check_Full_Declaration (Decls_Parent : Iir; Decl: Iir); + + procedure Sem_Iterator (Iterator : Iir_Iterator_Declaration; + Staticness : Iir_Staticness); + + -- Extract from NAME the named entity whose profile matches SIG. If NAME + -- is an overload list, it is destroyed. + function Sem_Signature (Name : Iir; Sig : Iir_Signature) return Iir; + + -- If the type of DECL is unconstrained, create a contrained subtype + -- either locally or globally static (according to VALUE). + -- This is to apply rules of LRM93 3.2.1.1 Index constraints and + -- discrete ranges. + procedure Sem_Object_Type_From_Value (Decl : Iir; Value : Iir); + + -- Mark SUBPRG as used. If SUBPRG is an instance, its generic is also + -- marked. + procedure Mark_Subprogram_Used (Subprg : Iir); + + -- The attribute signals ('stable, 'quiet and 'transaction) are + -- implicitely declared. + -- Note: guard signals are also implicitly declared but with a guard + -- expression, which is at a known location. + -- Since these signals need resources and are not easily located (can be + -- nearly in every expression), it is useful to add a node into a + -- declaration list to declare them. + -- However, only a few declaration_list can declare signals. These + -- declarations lists must register and unregister themselves with + -- push_declarative_region_with_signals and + -- pop_declarative_region_with_signals. + type Implicit_Signal_Declaration_Type is private; + + procedure Push_Signals_Declarative_Part + (Cell: out Implicit_Signal_Declaration_Type; Decls_Parent : Iir); + + procedure Pop_Signals_Declarative_Part + (Cell: in Implicit_Signal_Declaration_Type); + + -- Declare an implicit signal. + procedure Add_Declaration_For_Implicit_Signal (Sig : Iir); + +private + type Implicit_Signal_Declaration_Type is record + -- Declaration or statement than will contain implicit declarations. + Decls_Parent : Iir; + + -- Set to the signal_attribute_declaration when created (ie when the + -- first attribute signal is added). + Implicit_Decl : Iir; + + -- Last attribute signal inserted in the current Implicit_Decl. + Last_Attribute_Signal : Iir; + + -- If True, declarations of DECLS_PARENT have already been analyzed. + -- So implicit declarations are appended to the parent, and the last + -- declaration is LAST_DECL. + -- If False, declarations are being analyzed. Implicit declarations + -- are appended to IMPLICIT_DECL/LAST_ATTRIBUTE_SIGNAL and will be + -- inserted before the current declaration. + Decls_Analyzed : Boolean; + + -- Last declaration in the region. If an implicit_decl is createed, it + -- will be appended to LAST_DECL. + Last_Decl : Iir; + end record; +end Vhdl.Sem_Decls; diff --git a/src/vhdl/vhdl-sem_expr.adb b/src/vhdl/vhdl-sem_expr.adb new file mode 100644 index 000000000..9ac79c601 --- /dev/null +++ b/src/vhdl/vhdl-sem_expr.adb @@ -0,0 +1,5229 @@ +-- Semantic analysis. +-- 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 Grt.Algos; +with Std_Package; use Std_Package; +with Errorout; use Errorout; +with Flags; use Flags; +with Vhdl.Sem_Scopes; use Vhdl.Sem_Scopes; +with Vhdl.Sem_Names; use Vhdl.Sem_Names; +with Vhdl.Sem; +with Name_Table; +with Str_Table; +with Iirs_Utils; use Iirs_Utils; +with Evaluation; use Evaluation; +with Iir_Chains; use Iir_Chains; +with Vhdl.Sem_Types; +with Vhdl.Sem_Stmts; use Vhdl.Sem_Stmts; +with Vhdl.Sem_Assocs; use Vhdl.Sem_Assocs; +with Vhdl.Sem_Decls; +with Xrefs; use Xrefs; + +package body Vhdl.Sem_Expr is + + -- Replace type of TARGET by A_TYPE. + -- If TARGET has already a type, it must be an overload list, and in this + -- case, this list is freed, or it must be A_TYPE. + -- A_TYPE can't be an overload list. + -- + -- This procedure can be called in the second pass, when the type is known. + procedure Replace_Type (Target: Iir; A_Type: Iir) + is + Old_Type: Iir; + begin + pragma Assert (not Is_Overload_List (A_Type)); + + Old_Type := Get_Type (Target); + if Old_Type /= Null_Iir then + if Is_Overload_List (Old_Type) then + Free_Iir (Old_Type); + elsif Old_Type = A_Type then + return; + else + -- Cannot replace an existing type by another one. + raise Internal_Error; + end if; + end if; + if A_Type = Null_Iir then + return; + end if; + Set_Type (Target, A_Type); + end Replace_Type; + + -- Return true if EXPR is overloaded, ie has several meanings. + function Is_Overloaded (Expr : Iir) return Boolean + is + Expr_Type : constant Iir := Get_Type (Expr); + begin + return Expr_Type = Null_Iir or else Is_Overload_List (Expr_Type); + end Is_Overloaded; + + -- Return the common type of base types LEFT and RIGHT. + -- LEFT are RIGHT must be really base types (not subtypes). + -- Roughly speaking, it returns LEFT (= RIGHT) if LEFT = RIGHT (ie, same + -- type), null otherwise. + -- However, it handles implicite conversions of universal types. + function Get_Common_Basetype (Left: Iir; Right: Iir) + return Iir is + begin + if Left = Right then + return Left; + end if; + case Get_Kind (Left) is + when Iir_Kind_Integer_Type_Definition => + if Right = Convertible_Integer_Type_Definition then + return Left; + elsif Left = Convertible_Integer_Type_Definition + and then Get_Kind (Right) = Iir_Kind_Integer_Type_Definition + then + return Right; + end if; + when Iir_Kind_Floating_Type_Definition => + if Right = Convertible_Real_Type_Definition then + return Left; + elsif Left = Convertible_Real_Type_Definition + and then Get_Kind (Right) = Iir_Kind_Floating_Type_Definition + then + return Right; + end if; + when others => + null; + end case; + return Null_Iir; + end Get_Common_Basetype; + + -- LEFT are RIGHT must be really a type (not a subtype). + function Are_Basetypes_Compatible (Left: Iir; Right: Iir) + return Compatibility_Level is + begin + if Left = Right then + return Fully_Compatible; + end if; + case Get_Kind (Left) is + when Iir_Kind_Integer_Type_Definition => + if Right = Convertible_Integer_Type_Definition then + if Left = Universal_Integer_Type_Definition then + return Fully_Compatible; + else + return Via_Conversion; + end if; + elsif Left = Convertible_Integer_Type_Definition + and then Get_Kind (Right) = Iir_Kind_Integer_Type_Definition + then + if Right = Universal_Integer_Type_Definition then + return Fully_Compatible; + else + return Via_Conversion; + end if; + end if; + when Iir_Kind_Floating_Type_Definition => + if Right = Convertible_Real_Type_Definition then + if Left = Universal_Real_Type_Definition then + return Fully_Compatible; + else + return Via_Conversion; + end if; + elsif Left = Convertible_Real_Type_Definition + and then Get_Kind (Right) = Iir_Kind_Floating_Type_Definition + then + if Right = Universal_Real_Type_Definition then + return Fully_Compatible; + else + return Via_Conversion; + end if; + end if; + when others => + null; + end case; + return Not_Compatible; + end Are_Basetypes_Compatible; + + function Are_Types_Compatible (Left: Iir; Right: Iir) + return Compatibility_Level is + begin + return Are_Basetypes_Compatible (Get_Base_Type (Left), + Get_Base_Type (Right)); + end Are_Types_Compatible; + + function Are_Nodes_Compatible (Left: Iir; Right: Iir) + return Compatibility_Level is + begin + return Are_Types_Compatible (Get_Type (Left), Get_Type (Right)); + end Are_Nodes_Compatible; + + -- Return TRUE iif LEFT_TYPE and RIGHT_TYPES are compatible. RIGHT_TYPES + -- may be an overload list. + function Compatibility_Types1 (Left_Type : Iir; Right_Types : Iir) + return Compatibility_Level + is + El : Iir; + Right_List : Iir_List; + It : List_Iterator; + Level : Compatibility_Level; + begin + pragma Assert (not Is_Overload_List (Left_Type)); + + if Is_Overload_List (Right_Types) then + Right_List := Get_Overload_List (Right_Types); + Level := Not_Compatible; + It := List_Iterate (Right_List); + while Is_Valid (It) loop + El := Get_Element (It); + Level := Compatibility_Level'Max + (Level, Are_Types_Compatible (Left_Type, El)); + if Level = Fully_Compatible then + return Fully_Compatible; + end if; + Next (It); + end loop; + return Level; + else + return Are_Types_Compatible (Left_Type, Right_Types); + end if; + end Compatibility_Types1; + + -- Return compatibility for nodes LEFT and RIGHT. + -- LEFT is expected to be an interface of a function definition. + -- Type of RIGHT can be an overload_list + -- RIGHT might be implicitly converted to LEFT. + function Compatibility_Nodes (Left : Iir; Right : Iir) + return Compatibility_Level + is + Left_Type : constant Iir := Get_Base_Type (Get_Type (Left)); + Right_Type : constant Iir := Get_Type (Right); + begin + -- Check. + case Get_Kind (Left_Type) is + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Record_Type_Definition + | Iir_Kind_File_Type_Definition + | Iir_Kind_Physical_Type_Definition + | Iir_Kind_Access_Type_Definition + | Iir_Kind_Array_Type_Definition => + null; + when others => + Error_Kind ("compatibility_nodes", Left_Type); + end case; + + return Compatibility_Types1 (Left_Type, Right_Type); + end Compatibility_Nodes; + + function Is_String_Type (A_Type : Iir) return Boolean + is + Base_Type : constant Iir := Get_Base_Type (A_Type); + El_Bt : Iir; + begin + -- LRM 7.3.1 + -- [...] the type of the literal must be a one-dimensional array ... + if not Is_One_Dimensional_Array_Type (Base_Type) then + return False; + end if; + -- LRM 7.3.1 + -- ... of a character type ... + El_Bt := Get_Base_Type (Get_Element_Subtype (Base_Type)); + if Get_Kind (El_Bt) /= Iir_Kind_Enumeration_Type_Definition then + return False; + end if; + -- FIXME: character type + return True; + end Is_String_Type; + + -- Return TRUE iff A_TYPE can be the type of string or bit string literal + -- EXPR. EXPR is needed to distinguish between string and bit string + -- for VHDL87 rule about the type of a bit string. + function Is_String_Literal_Type (A_Type : Iir; Expr : Iir) return Boolean + is + El_Bt : Iir; + begin + if not Is_String_Type (A_Type) then + return False; + end if; + El_Bt := Get_Base_Type (Get_Element_Subtype (A_Type)); + -- LRM87 7.3.1 + -- ... (for string literals) or of type BIT (for bit string literals). + if Flags.Vhdl_Std = Vhdl_87 + and then Get_Bit_String_Base (Expr) /= Base_None + and then El_Bt /= Bit_Type_Definition + then + return False; + end if; + return True; + end Is_String_Literal_Type; + + -- Return TRUE iff A_TYPE can be the type of an aggregate. + function Is_Aggregate_Type (A_Type : Iir) return Boolean is + begin + -- LRM 7.3.2 Aggregates + -- [...] the type of the aggregate must be a composite type. + case Get_Kind (Get_Base_Type (A_Type)) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Record_Type_Definition => + return True; + when others => + return False; + end case; + end Is_Aggregate_Type; + + -- Return TRUE iff A_TYPE can be the type of a null literal. + function Is_Null_Literal_Type (A_Type : Iir) return Boolean is + begin + -- LRM 7.3.1 Literals + -- The literal NULL represents the null access value for any access + -- type. + return + Get_Kind (Get_Base_Type (A_Type)) = Iir_Kind_Access_Type_Definition; + end Is_Null_Literal_Type; + + -- Return TRUE iff A_TYPE can be the type of allocator EXPR. Note that + -- the allocator must have been analyzed. + function Is_Allocator_Type (A_Type : Iir; Expr : Iir) return Boolean + is + Base_Type : constant Iir := Get_Base_Type (A_Type); + Designated_Type : Iir; + begin + -- LRM 7.3.6 Allocators + -- [...] the value returned is of an access type having the named + -- designated type. + + if Get_Kind (Base_Type) /= Iir_Kind_Access_Type_Definition then + return False; + end if; + Designated_Type := Get_Allocator_Designated_Type (Expr); + pragma Assert (Designated_Type /= Null_Iir); + -- Cheat: there is no allocators on universal types. + return Get_Base_Type (Get_Designated_Type (Base_Type)) + = Get_Base_Type (Designated_Type); + end Is_Allocator_Type; + + -- Return TRUE iff the type of EXPR is compatible with A_TYPE + function Is_Expr_Compatible (A_Type : Iir; Expr : Iir) + return Compatibility_Level + is + Expr_Type : constant Iir := Get_Type (Expr); + Is_Compatible : Boolean; + begin + if Expr_Type /= Null_Iir then + return Compatibility_Types1 (A_Type, Expr_Type); + end if; + + case Get_Kind (Expr) is + when Iir_Kind_Aggregate => + Is_Compatible := Is_Aggregate_Type (A_Type); + when Iir_Kind_String_Literal8 => + Is_Compatible := Is_String_Literal_Type (A_Type, Expr); + when Iir_Kind_Null_Literal => + Is_Compatible := Is_Null_Literal_Type (A_Type); + when Iir_Kind_Allocator_By_Expression + | Iir_Kind_Allocator_By_Subtype => + Is_Compatible := Is_Allocator_Type (A_Type, Expr); + when Iir_Kind_Parenthesis_Expression => + return Is_Expr_Compatible (A_Type, Get_Expression (Expr)); + when others => + -- Error while EXPR was typed. FIXME: should create an ERROR + -- node? + Is_Compatible := False; + end case; + if Is_Compatible then + return Fully_Compatible; + else + return Not_Compatible; + end if; + end Is_Expr_Compatible; + + function Check_Is_Expression (Expr : Iir; Loc : Iir) return Iir + is + begin + if Expr = Null_Iir then + return Null_Iir; + end if; + case Get_Kind (Expr) is + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kinds_Subtype_Definition + | Iir_Kind_Design_Unit + | Iir_Kind_Architecture_Body + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kinds_Concurrent_Statement + | Iir_Kinds_Sequential_Statement + | Iir_Kind_Library_Declaration + | Iir_Kind_Library_Clause + | Iir_Kind_Component_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute + | Iir_Kind_Element_Declaration + | Iir_Kind_Attribute_Declaration + | Iir_Kind_Psl_Declaration + | Iir_Kind_Signature => + Error_Msg_Sem (+Loc, "%n not allowed in an expression", +Expr); + return Null_Iir; + when Iir_Kind_Function_Declaration => + return Expr; + when Iir_Kind_Overload_List => + return Expr; + when Iir_Kinds_Literal + | Iir_Kind_Character_Literal + | Iir_Kind_Simple_Aggregate + | Iir_Kind_Unit_Declaration + | Iir_Kind_Enumeration_Literal => + return Expr; + when Iir_Kinds_External_Name => + return Expr; + when Iir_Kinds_Object_Declaration + | Iir_Kind_Aggregate + | Iir_Kind_Allocator_By_Expression + | Iir_Kind_Allocator_By_Subtype + | Iir_Kind_Qualified_Expression => + return Expr; + when Iir_Kinds_Quantity_Declaration => + return Expr; + when Iir_Kinds_Dyadic_Operator + | Iir_Kinds_Monadic_Operator => + return Expr; + when Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kinds_Expression_Attribute + | Iir_Kind_Attribute_Value + | Iir_Kind_Parenthesis_Expression + | Iir_Kind_Type_Conversion + | Iir_Kind_Function_Call => + return Expr; + when Iir_Kind_Psl_Endpoint_Declaration => + return Expr; + when Iir_Kind_Simple_Name + | Iir_Kind_Parenthesis_Name + | Iir_Kind_Attribute_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Selected_By_All_Name => + return Expr; + when Iir_Kind_Error => + return Expr; + when others => + Error_Kind ("check_is_expression", Expr); + --N := Get_Type (Expr); + --return Expr; + end case; + end Check_Is_Expression; + + -- Find a type compatible with A_TYPE in TYPE_LIST (which can be an + -- overload list or a simple type) and return it. + -- In case of failure, return null. + function Search_Overloaded_Type (Type_List: Iir; A_Type: Iir) + return Iir + is + Type_List_List : Iir_List; + It : List_Iterator; + El: Iir; + Com : Iir; + Res : Iir; + begin + if not Is_Overload_List (Type_List) then + return Get_Common_Basetype (Get_Base_Type (Type_List), + Get_Base_Type (A_Type)); + else + Type_List_List := Get_Overload_List (Type_List); + Res := Null_Iir; + It := List_Iterate (Type_List_List); + while Is_Valid (It) loop + El := Get_Element (It); + Com := Get_Common_Basetype (Get_Base_Type (El), + Get_Base_Type (A_Type)); + if Com /= Null_Iir then + if Res = Null_Iir then + Res := Com; + else + -- Several compatible types. + return Null_Iir; + end if; + end if; + Next (It); + end loop; + return Res; + end if; + end Search_Overloaded_Type; + + -- LIST1, LIST2 are either a type node or an overload list of types. + -- Return THE type which is compatible with LIST1 are LIST2. + -- Return null_iir if there is no such type or if there are several types. + function Search_Compatible_Type (List1, List2 : Iir) return Iir + is + List1_List : Iir_List; + It : List_Iterator; + Res : Iir; + El : Iir; + Tmp : Iir; + begin + if Is_Overload_List (List1) then + List1_List := Get_Overload_List (List1); + Res := Null_Iir; + It := List_Iterate (List1_List); + while Is_Valid (It) loop + El := Get_Element (It); + Tmp := Search_Overloaded_Type (List2, El); + if Tmp /= Null_Iir then + if Res = Null_Iir then + Res := Tmp; + else + -- Several types match. + return Null_Iir; + end if; + end if; + Next (It); + end loop; + return Res; + else + return Search_Overloaded_Type (List2, List1); + end if; + end Search_Compatible_Type; + + -- Analyze the range expression EXPR. + -- If A_TYPE is not null_iir, EXPR is expected to be of type A_TYPE. + -- LRM93 3.2.1.1 + -- FIXME: avoid to run it on an already analyzed node, be careful + -- with range_type_expr. + function Sem_Simple_Range_Expression + (Expr: Iir_Range_Expression; A_Type: Iir; Any_Dir : Boolean) + return Iir_Range_Expression + is + Base_Type: Iir; + Left, Right: Iir; + Left_Type, Right_Type : Iir; + Expr_Type : Iir; + begin + Expr_Type := Get_Type (Expr); + Left := Get_Left_Limit_Expr (Expr); + Right := Get_Right_Limit_Expr (Expr); + + if Expr_Type = Null_Iir then + -- Pass 1. + + if A_Type = Null_Iir then + Base_Type := Null_Iir; + else + Base_Type := Get_Base_Type (A_Type); + end if; + + -- Analyze left and right bounds. + Right := Sem_Expression_Ov (Right, Base_Type); + Left := Sem_Expression_Ov (Left, Base_Type); + + if Left = Null_Iir or else Right = Null_Iir then + if A_Type /= Null_Iir then + -- Can continue with the error. + if Left = Null_Iir then + Left := Create_Error_Expr + (Get_Left_Limit_Expr (Expr), A_Type); + end if; + if Right = Null_Iir then + Right := Create_Error_Expr + (Get_Right_Limit_Expr (Expr), A_Type); + end if; + else + -- Error. + return Null_Iir; + end if; + end if; + + Left_Type := Get_Type (Left); + Right_Type := Get_Type (Right); + -- Check for string or aggregate literals + -- FIXME: improve error message + if Left_Type = Null_Iir then + Error_Msg_Sem (+Left, "bad expression for a scalar"); + return Null_Iir; + end if; + if Right_Type = Null_Iir then + Error_Msg_Sem (+Right, "bad expression for a scalar"); + return Null_Iir; + end if; + + if Is_Overload_List (Left_Type) + or else Is_Overload_List (Right_Type) + then + if Base_Type /= Null_Iir then + -- Cannot happen, since sem_expression_ov should resolve + -- ambiguties if a type is given. + raise Internal_Error; + end if; + + -- Try to find a common type. + Expr_Type := Search_Compatible_Type (Left_Type, Right_Type); + if Expr_Type = Null_Iir then + if Compatibility_Types1 (Universal_Integer_Type_Definition, + Left_Type) /= Not_Compatible + and then + Compatibility_Types1 (Universal_Integer_Type_Definition, + Right_Type) /= Not_Compatible + then + Expr_Type := Universal_Integer_Type_Definition; + elsif Compatibility_Types1 (Universal_Real_Type_Definition, + Left_Type) /= Not_Compatible + and then + Compatibility_Types1 (Universal_Real_Type_Definition, + Right_Type) /= Not_Compatible + then + Expr_Type := Universal_Real_Type_Definition; + else + -- FIXME: handle overload + Error_Msg_Sem + (+Expr, + "left and right expressions of range are not compatible"); + return Null_Iir; + end if; + end if; + Left := Sem_Expression (Left, Expr_Type); + Right := Sem_Expression (Right, Expr_Type); + if Left = Null_Iir or else Right = Null_Iir then + return Null_Iir; + end if; + else + Expr_Type := Get_Common_Basetype (Get_Base_Type (Left_Type), + Get_Base_Type (Right_Type)); + if Expr_Type = Null_Iir then + Error_Msg_Sem + (+Expr, + "left and right expressions of range are not compatible"); + return Null_Iir; + end if; + end if; + + -- The type of the range is known, finish analysis. + else + -- Second call. + + pragma Assert (A_Type /= Null_Iir); + + if Is_Overload_List (Expr_Type) then + -- FIXME: resolve overload + raise Internal_Error; + else + if Are_Types_Compatible (Expr_Type, A_Type) = Not_Compatible then + Error_Msg_Sem + (+Expr, "type of range doesn't match expected type"); + return Null_Iir; + end if; + + return Expr; + end if; + end if; + + Left := Eval_Expr_If_Static (Left); + Right := Eval_Expr_If_Static (Right); + + Set_Left_Limit_Expr (Expr, Left); + Set_Right_Limit_Expr (Expr, Right); + + Set_Left_Limit (Expr, Left); + Set_Right_Limit (Expr, Right); + + Set_Expr_Staticness (Expr, Min (Get_Expr_Staticness (Left), + Get_Expr_Staticness (Right))); + + if A_Type /= Null_Iir then + if Are_Types_Compatible (Expr_Type, A_Type) = Not_Compatible then + Error_Msg_Sem (+Expr, "type of range doesn't match expected type"); + return Null_Iir; + end if; + + -- Use A_TYPE for the type of the expression. + Expr_Type := A_Type; + end if; + + Set_Type (Expr, Expr_Type); + if Get_Kind (Expr_Type) + not in Iir_Kinds_Scalar_Type_And_Subtype_Definition + then + Error_Msg_Sem (+Expr, "type of range is not a scalar type"); + return Null_Iir; + end if; + + if Get_Expr_Staticness (Expr) = Locally + and then Get_Type_Staticness (Expr_Type) = Locally + and then Get_Kind (Expr_Type) in Iir_Kinds_Subtype_Definition + then + Eval_Check_Range (Expr, Expr_Type, Any_Dir); + end if; + + return Expr; + end Sem_Simple_Range_Expression; + + -- The result can be: + -- a subtype definition + -- a range attribute + -- a range type definition + -- LRM93 3.2.1.1 + -- FIXME: avoid to run it on an already analyzed node, be careful + -- with range_type_expr. + function Sem_Range_Expression (Expr: Iir; A_Type: Iir; Any_Dir : Boolean) + return Iir + is + Res : Iir; + Res_Type : Iir; + begin + case Get_Kind (Expr) is + when Iir_Kind_Range_Expression => + Res := Sem_Simple_Range_Expression (Expr, A_Type, Any_Dir); + if Res = Null_Iir then + return Null_Iir; + end if; + Res_Type := Get_Type (Res); + + when Iir_Kinds_Denoting_Name + | Iir_Kind_Attribute_Name + | Iir_Kind_Parenthesis_Name => + if Get_Named_Entity (Expr) = Null_Iir then + Sem_Name (Expr); + end if; + Res := Name_To_Range (Expr); + if Is_Error (Res) then + return Null_Iir; + end if; + + case Get_Kind (Res) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + pragma Assert (Get_Kind (Get_Named_Entity (Res)) + in Iir_Kinds_Type_Declaration); + Res_Type := Get_Type (Get_Named_Entity (Res)); + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + Res_Type := Get_Type (Res); + when others => + Error_Msg_Sem (+Expr, "name must denote a range"); + return Null_Iir; + end case; + if A_Type /= Null_Iir + and then Get_Base_Type (Res_Type) /= Get_Base_Type (A_Type) + then + Error_Not_Match (Expr, A_Type); + return Null_Iir; + end if; + + when others => + Error_Msg_Sem (+Expr, "range expression required"); + return Null_Iir; + end case; + + if Get_Kind (Res_Type) + not in Iir_Kinds_Scalar_Type_And_Subtype_Definition + then + Error_Msg_Sem (+Expr, "%n is not a range type", +Res); + return Null_Iir; + end if; + + Res := Eval_Range_If_Static (Res); + + if A_Type /= Null_Iir + and then Get_Type_Staticness (A_Type) = Locally + and then Get_Kind (A_Type) in Iir_Kinds_Subtype_Definition + then + if Get_Expr_Staticness (Res) = Locally then + Eval_Check_Range (Res, A_Type, Any_Dir); + end if; + end if; + return Res; + end Sem_Range_Expression; + + function Sem_Discrete_Range_Expression + (Expr: Iir; A_Type: Iir; Any_Dir : Boolean) + return Iir + is + Res : Iir; + Res_Type : Iir; + begin + if Get_Kind (Expr) = Iir_Kind_Subtype_Definition then + Res := Sem_Types.Sem_Subtype_Indication (Expr); + if Res = Null_Iir then + return Null_Iir; + end if; + + Res_Type := Res; + if A_Type /= Null_Iir + and then (Are_Types_Compatible + (A_Type, Get_Type_Of_Subtype_Indication (Res)) + = Not_Compatible) + then + -- A_TYPE is known when analyzing an index_constraint within + -- a subtype indication. + Error_Msg_Sem (+Expr, "subtype %n doesn't match expected type %n", + (+Res, +A_Type)); + -- FIXME: override type of RES ? + end if; + else + Res := Sem_Range_Expression (Expr, A_Type, Any_Dir); + + if Res = Null_Iir then + return Null_Iir; + end if; + + Res_Type := Get_Type (Res); + end if; + + -- Check the type is discrete. + if Get_Kind (Res_Type) not in Iir_Kinds_Discrete_Type_Definition then + if Get_Kind (Res_Type) /= Iir_Kind_Error then + -- FIXME: avoid that test with error. + if Get_Kind (Res) not in Iir_Kinds_Denoting_Name then + Error_Msg_Sem (+Res, "range is not discrete"); + else + Error_Msg_Sem + (+Expr, "%n is not a discrete range type", +Res); + end if; + end if; + return Null_Iir; + end if; + + return Res; + end Sem_Discrete_Range_Expression; + + function Sem_Discrete_Range_Integer (Expr: Iir) return Iir + is + Res : Iir; + Range_Type : Iir; + begin + Res := Sem_Discrete_Range_Expression (Expr, Null_Iir, True); + if Res = Null_Iir then + return Null_Iir; + end if; + if Get_Kind (Expr) /= Iir_Kind_Range_Expression then + return Res; + end if; + + Range_Type := Get_Type (Res); + if Range_Type = Convertible_Integer_Type_Definition then + -- LRM 3.2.1.1 Index constraints and discrete ranges + -- For a discrete range used in a constrained array + -- definition and defined by a range, an implicit + -- conversion to the predefined type INTEGER is assumed + -- if each bound is either a numeric literal or an + -- attribute, and the type of both bounds (prior to the + -- implicit conversion) is the type universal_integer. + + -- FIXME: catch phys/phys. + Set_Type (Res, Integer_Type_Definition); + if Get_Expr_Staticness (Res) = Locally then + Eval_Check_Range (Res, Integer_Subtype_Definition, True); + end if; + elsif Range_Type = Universal_Integer_Type_Definition then + if Vhdl_Std >= Vhdl_08 then + -- LRM08 5.3.2.2 + -- For a discrete range used in a constrained array definition + -- and defined by a range, an implicit conversion to the + -- predefined type INTEGER is assumed if the type of both bounds + -- (prior the implicit conversion) is the type universal_integer. + null; + elsif Vhdl_Std = Vhdl_93c or else Flag_Relaxed_Rules then + null; + elsif Vhdl_Std /= Vhdl_93 then + -- GHDL: this is not allowed, however often used: + -- eg: for i in 0 to v'length + 1 loop + -- eg: for i in -1 to 1 loop + + -- Be tolerant. + Warning_Msg_Sem (Warnid_Universal, +Res, + "universal integer bound must be numeric literal " + & "or attribute"); + else + Error_Msg_Sem (+Res, "universal integer bound must be numeric " + & "literal or attribute"); + end if; + Set_Type (Res, Integer_Type_Definition); + end if; + return Res; + end Sem_Discrete_Range_Integer; + + procedure Set_Function_Call_Staticness (Expr : Iir; Imp : Iir) + is + Staticness : Iir_Staticness; + begin + -- LRM93 7.4.1 (Locally Static Primaries) + -- 4. a function call whose function name denotes an implicitly + -- defined operator, and whose actual parameters are each + -- locally static expressions; + -- + -- LRM93 7.4.2 (Globally Static Primaries) + -- 9. a function call whose function name denotes a pure function, + -- and whose actual parameters are each globally static + -- expressions. + case Get_Kind (Expr) is + when Iir_Kinds_Monadic_Operator => + Staticness := Get_Expr_Staticness (Get_Operand (Expr)); + when Iir_Kinds_Dyadic_Operator => + Staticness := Min (Get_Expr_Staticness (Get_Left (Expr)), + Get_Expr_Staticness (Get_Right (Expr))); + when Iir_Kind_Function_Call => + Staticness := Locally; + declare + Assoc : Iir; + begin + Assoc := Get_Parameter_Association_Chain (Expr); + while Assoc /= Null_Iir loop + if Get_Kind (Assoc) + = Iir_Kind_Association_Element_By_Expression + then + Staticness := Min + (Get_Expr_Staticness (Get_Actual (Assoc)), + Staticness); + end if; + Assoc := Get_Chain (Assoc); + end loop; + end; + when Iir_Kind_Procedure_Call => + return; + when others => + Error_Kind ("set_function_call_staticness (1)", Expr); + end case; + + -- Staticness. + case Get_Kind (Imp) is + when Iir_Kind_Function_Declaration => + case Get_Implicit_Definition (Imp) is + when Iir_Predefined_Error => + raise Internal_Error; + when Iir_Predefined_Pure_Functions => + null; + when Iir_Predefined_Impure_Functions => + -- Predefined functions such as Now, Endfile are not static. + Staticness := None; + when Iir_Predefined_Explicit => + if Get_Pure_Flag (Imp) then + Staticness := Min (Staticness, Globally); + else + Staticness := None; + end if; + end case; + when Iir_Kind_Interface_Function_Declaration => + Staticness := None; + when others => + Error_Kind ("set_function_call_staticness", Imp); + end case; + Set_Expr_Staticness (Expr, Staticness); + end Set_Function_Call_Staticness; + + -- Add CALLEE in the callees list of SUBPRG (which must be a subprg decl). + procedure Add_In_Callees_List (Subprg : Iir; Callee : Iir) + is + Holder : constant Iir := Get_Callees_List_Holder (Subprg); + List : Iir_List; + begin + List := Get_Callees_List (Holder); + if List = Null_Iir_List then + List := Create_Iir_List; + Set_Callees_List (Holder, List); + end if; + -- FIXME: May use a flag in IMP to speed up the + -- add operation. + Add_Element (List, Callee); + end Add_In_Callees_List; + + -- Check purity rules when SUBPRG calls CALLEE. + -- Both SUBPRG and CALLEE are subprogram declarations. + -- Update purity_state/impure_depth of SUBPRG if it is a procedure. + procedure Sem_Call_Purity_Check (Subprg : Iir; Callee : Iir; Loc : Iir) is + begin + if Callee = Subprg then + return; + end if; + + -- Handle easy cases. + case Get_Kind (Subprg) is + when Iir_Kind_Function_Declaration => + if not Get_Pure_Flag (Subprg) then + return; + end if; + when Iir_Kind_Procedure_Declaration => + if Get_Purity_State (Subprg) = Impure then + return; + end if; + when Iir_Kinds_Process_Statement => + return; + when others => + Error_Kind ("sem_call_purity_check(0)", Subprg); + end case; + + case Get_Kind (Callee) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Interface_Function_Declaration => + if Get_Pure_Flag (Callee) then + -- Pure functions may be called anywhere. + return; + end if; + -- CALLEE is impure. + case Get_Kind (Subprg) is + when Iir_Kind_Function_Declaration => + Error_Pure (Semantic, Subprg, Callee, Loc); + when Iir_Kind_Procedure_Declaration => + Set_Purity_State (Subprg, Impure); + when others => + Error_Kind ("sem_call_purity_check(1)", Subprg); + end case; + when Iir_Kind_Procedure_Declaration => + declare + Depth : Iir_Int32; + Callee_Body : constant Iir := Get_Subprogram_Body (Callee); + Subprg_Body : constant Iir := Get_Subprogram_Body (Subprg); + begin + -- Get purity depth of callee, if possible. + case Get_Purity_State (Callee) is + when Pure => + return; + when Impure => + Depth := Iir_Depth_Impure; + when Maybe_Impure => + if Callee_Body = Null_Iir then + -- Cannot be 'maybe_impure' if no body! + raise Internal_Error; + end if; + Depth := Get_Impure_Depth (Callee_Body); + when Unknown => + -- Add in list. + Add_In_Callees_List (Subprg, Callee); + + if Callee_Body /= Null_Iir then + Depth := Get_Impure_Depth (Callee_Body); + else + return; + end if; + end case; + case Get_Kind (Subprg) is + when Iir_Kind_Function_Declaration => + if Depth = Iir_Depth_Impure then + Error_Pure (Semantic, Subprg, Callee, Loc); + else + if Depth < Get_Subprogram_Depth (Subprg) then + Error_Pure (Semantic, Subprg, Callee, Loc); + end if; + end if; + when Iir_Kind_Procedure_Declaration => + if Depth = Iir_Depth_Impure then + Set_Purity_State (Subprg, Impure); + -- FIXME: free callee list ? (wait state). + else + -- Set depth to the worst. + if Depth < Get_Impure_Depth (Subprg_Body) then + Set_Impure_Depth (Subprg_Body, Depth); + end if; + end if; + when others => + Error_Kind ("sem_call_purity_check(2)", Subprg); + end case; + end; + when Iir_Kind_Interface_Procedure_Declaration => + -- We have no idea about this procedure. + null; + when others => + Error_Kind ("sem_call_purity_check", Callee); + end case; + end Sem_Call_Purity_Check; + + procedure Sem_Call_Wait_Check (Subprg : Iir; Callee : Iir; Loc : Iir) + is + procedure Error_Wait is + begin + Error_Msg_Sem + (+Loc, "%n must not contain wait statement, but calls", + (1 => +Subprg), Cont => True); + Error_Msg_Sem + (+Callee, "%n which has (indirectly) a wait statement", +Callee); + --Error_Msg_Sem + -- ("(indirect) wait statement not allowed in " & Where, Loc); + end Error_Wait; + begin + pragma Assert (Get_Kind (Callee) = Iir_Kind_Procedure_Declaration); + + case Get_Wait_State (Callee) is + when False => + return; + when True => + null; + when Unknown => + Add_In_Callees_List (Subprg, Callee); + return; + end case; + + -- LRM 8.1 + -- It is an error if a wait statement appears [...] in a procedure that + -- has a parent that is a function subprogram. + -- + -- Furthermore, it is an error if a wait statement appears [...] in a + -- procedure that has a parent that is such a process statement. + case Get_Kind (Subprg) is + when Iir_Kind_Sensitized_Process_Statement => + Error_Wait; + return; + when Iir_Kind_Process_Statement => + return; + when Iir_Kind_Function_Declaration => + Error_Wait; + return; + when Iir_Kind_Procedure_Declaration => + if Is_Subprogram_Method (Subprg) then + Error_Wait; + else + Set_Wait_State (Subprg, True); + end if; + when others => + Error_Kind ("sem_call_wait_check", Subprg); + end case; + end Sem_Call_Wait_Check; + + procedure Sem_Call_All_Sensitized_Check + (Subprg : Iir; Callee : Iir; Loc : Iir) + is + begin + -- No need to deal with 'process (all)' if standard predates it. + if Vhdl_Std < Vhdl_08 then + return; + end if; + + -- If subprogram called is pure, then there is no signals reference. + case Get_Kind (Callee) is + when Iir_Kind_Function_Declaration => + if Get_Pure_Flag (Callee) then + return; + end if; + when Iir_Kind_Procedure_Declaration => + if Get_Purity_State (Callee) = Pure then + return; + end if; + when Iir_Kind_Interface_Function_Declaration + | Iir_Kind_Interface_Procedure_Declaration => + -- FIXME: how to compute sensitivity ? Recurse ? + return; + when others => + Error_Kind ("sem_call_all_sensitized_check", Callee); + end case; + + case Get_All_Sensitized_State (Callee) is + when Invalid_Signal => + case Get_Kind (Subprg) is + when Iir_Kind_Sensitized_Process_Statement => + if Get_Sensitivity_List (Subprg) = Iir_List_All then + -- LRM08 11.3 + -- + -- It is an error if a process statement with the + -- reserved word ALL as its process sensitivity list + -- is the parent of a subprogram declared in a design + -- unit other than that containing the process statement + -- and the subprogram reads an explicitly declared + -- signal that is not a formal signal parameter or + -- member of a formal signal parameter of the + -- subprogram or of any of its parents. Similarly, + -- it is an error if such subprogram reads an implicit + -- signal whose explicit ancestor is not a formal signal + -- parameter or member of a formal parameter of + -- the subprogram or of any of its parents. + Error_Msg_Sem (+Loc, "all-sensitized %n can't call %n", + (+Subprg, +Callee), Cont => True); + Error_Msg_Sem + (+Loc, + " (as this subprogram reads (indirectly) a signal)"); + end if; + when Iir_Kind_Process_Statement => + return; + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Set_All_Sensitized_State (Subprg, Invalid_Signal); + when others => + Error_Kind ("sem_call_all_sensitized_check", Subprg); + end case; + when Read_Signal => + -- Put this subprogram in callees list as it may read a signal. + -- Used by canon to build the sensitivity list. + Add_In_Callees_List (Subprg, Callee); + if Get_Kind (Subprg) in Iir_Kinds_Subprogram_Declaration then + if Get_All_Sensitized_State (Subprg) < Read_Signal then + Set_All_Sensitized_State (Subprg, Read_Signal); + end if; + end if; + when Unknown => + -- Put this subprogram in callees list as it may read a signal. + -- Used by canon to build the sensitivity list. + Add_In_Callees_List (Subprg, Callee); + when No_Signal => + null; + end case; + end Sem_Call_All_Sensitized_Check; + + -- Set IMP as the implementation to being called by EXPR. + -- If the context is a subprogram or a process (ie, if current_subprogram + -- is not NULL), then mark IMP as callee of current_subprogram, and + -- update states. + procedure Sem_Subprogram_Call_Finish (Expr : Iir; Imp : Iir) + is + Subprg : constant Iir := Get_Current_Subprogram; + begin + Set_Function_Call_Staticness (Expr, Imp); + Sem_Decls.Mark_Subprogram_Used (Imp); + + -- Check purity/wait/passive. + + if Subprg = Null_Iir then + -- Not inside a suprogram or a process. + return; + end if; + if Subprg = Imp then + -- Recursive call. + return; + end if; + + if Is_Implicit_Subprogram (Imp) then + -- FIXME: impure predefined functions. + null; + else + Sem_Call_Purity_Check (Subprg, Imp, Expr); + Sem_Call_All_Sensitized_Check (Subprg, Imp, Expr); + if Get_Kind (Imp) = Iir_Kind_Procedure_Declaration then + Sem_Call_Wait_Check (Subprg, Imp, Expr); + -- Check passive. + if Get_Passive_Flag (Imp) = False then + case Get_Kind (Subprg) is + when Iir_Kinds_Process_Statement => + if Get_Passive_Flag (Subprg) then + Error_Msg_Sem + (+Expr, "%n is passive, but calls non-passive %n", + (+Subprg, +Imp)); + end if; + when others => + null; + end case; + end if; + end if; + end if; + end Sem_Subprogram_Call_Finish; + + -- EXPR is a function or procedure call. + function Sem_Subprogram_Call_Stage1 + (Expr : Iir; A_Type : Iir; Is_Func_Call : Boolean) return Iir + is + Imp : Iir; + A_Func: Iir; + Imp_List: Iir_List; + New_List : Iir_List; + Assoc_Chain: Iir; + Inter_Chain : Iir; + Res_Type: Iir_List; + Imp_It : List_Iterator; + Inter: Iir; + Match : Compatibility_Level; + Match_Max : Compatibility_Level; + begin + -- Sem_Name has gathered all the possible names for the prefix of this + -- call. Reduce this list to only names that match the types. + Imp := Get_Implementation (Expr); + Imp_List := Get_Overload_List (Imp); + Assoc_Chain := Get_Parameter_Association_Chain (Expr); + Match_Max := Via_Conversion; + + New_List := Create_Iir_List; + Imp_It := List_Iterate (Imp_List); + while Is_Valid (Imp_It) loop + A_Func := Get_Element (Imp_It); + + case Get_Kind (A_Func) is + when Iir_Kinds_Functions_And_Literals + | Iir_Kind_Interface_Function_Declaration => + if not Is_Func_Call then + -- The identifier of a function call must be a function or + -- an enumeration literal. + goto Continue; + end if; + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Interface_Procedure_Declaration => + if Is_Func_Call then + -- The identifier of a procedure call must be a procedure. + goto Continue; + end if; + when others => + Error_Kind ("sem_subprogram_call_stage1", A_Func); + end case; + + -- Keep this interpretation only if compatible. + if A_Type = Null_Iir + or else (Compatibility_Nodes (A_Type, Get_Return_Type (A_Func)) + /= Not_Compatible) + then + Sem_Association_Chain + (Get_Interface_Declaration_Chain (A_Func), + Assoc_Chain, False, Missing_Parameter, Expr, Match); + if Match >= Match_Max then + -- Only previous interpretations were only Via_Conversion + -- compatible, and this one is fully compatible, discard + -- previous and future Via_Conversion interpretations. + if Match > Match_Max then + Destroy_Iir_List (New_List); + New_List := Create_Iir_List; + Match_Max := Match; + end if; + Append_Element (New_List, A_Func); + end if; + end if; + + << Continue >> null; + Next (Imp_It); + end loop; + Destroy_Iir_List (Imp_List); + Imp_List := New_List; + Set_Overload_List (Imp, Imp_List); + + -- Set_Implementation (Expr, Inter_List); + -- A set of possible functions to call is in INTER_LIST. + -- Create a set of possible return type in RES_TYPE. + case Get_Nbr_Elements (Imp_List) is + when 0 => + -- FIXME: display subprogram name. + Error_Msg_Sem + (+Expr, "cannot resolve overloading for subprogram call"); + return Null_Iir; + + when 1 => + -- Simple case: no overloading. + Inter := Get_First_Element (Imp_List); + Free_Overload_List (Imp); + Set_Implementation (Expr, Inter); + if Is_Func_Call then + Set_Type (Expr, Get_Return_Type (Inter)); + end if; + Inter_Chain := Get_Interface_Declaration_Chain (Inter); + Sem_Association_Chain + (Inter_Chain, Assoc_Chain, + True, Missing_Parameter, Expr, Match); + Set_Parameter_Association_Chain (Expr, Assoc_Chain); + pragma Assert (Match /= Not_Compatible); + Check_Subprogram_Associations (Inter_Chain, Assoc_Chain); + Sem_Subprogram_Call_Finish (Expr, Inter); + return Expr; + + when others => + if Is_Func_Call then + if A_Type /= Null_Iir then + -- Cannot find a single interpretation for a given + -- type. + Error_Overload (Expr); + Disp_Overload_List (Imp_List, Expr); + return Null_Iir; + end if; + + -- Create the list of types for the result. + Res_Type := Create_Iir_List; + Imp_It := List_Iterate (Imp_List); + while Is_Valid (Imp_It) loop + Add_Element + (Res_Type, Get_Return_Type (Get_Element (Imp_It))); + Next (Imp_It); + end loop; + + if Get_Nbr_Elements (Res_Type) = 1 then + -- several implementations but one profile. + Error_Overload (Expr); + Disp_Overload_List (Imp_List, Expr); + return Null_Iir; + end if; + Set_Type (Expr, Create_Overload_List (Res_Type)); + else + -- For a procedure call, the context does't help to resolve + -- overload. + Error_Overload (Expr); + Disp_Overload_List (Imp_List, Expr); + end if; + return Expr; + end case; + end Sem_Subprogram_Call_Stage1; + + -- For a procedure call, A_TYPE must be null. + -- Associations must have already been analyzed by sem_association_list. + function Sem_Subprogram_Call (Expr: Iir; A_Type: Iir) return Iir + is + Is_Func: constant Boolean := Get_Kind (Expr) = Iir_Kind_Function_Call; + Res_Type: Iir; + Res: Iir; + Inter_List: Iir; + Param_Chain : Iir; + Inter: Iir; + Assoc_Chain : Iir; + Match : Compatibility_Level; + Overload_List : Iir_List; + Overload_It : List_Iterator; + begin + if Is_Func then + Res_Type := Get_Type (Expr); + end if; + + if not Is_Func or else Res_Type = Null_Iir then + -- First call to sem_subprogram_call. + -- Create the list of possible implementations and possible + -- return types, according to arguments and A_TYPE. + + -- Select possible interpretations among all interpretations. + -- NOTE: the list of possible implementations was already created + -- during the transformation of iir_kind_parenthesis_name to + -- iir_kind_function_call. + Inter_List := Get_Implementation (Expr); + if Get_Kind (Inter_List) = Iir_Kind_Error then + return Null_Iir; + elsif Is_Overload_List (Inter_List) then + -- Subprogram name is overloaded. + return Sem_Subprogram_Call_Stage1 (Expr, A_Type, Is_Func); + else + -- Only one interpretation for the subprogram name. + if Is_Func then + if not Is_Function_Declaration (Inter_List) then + Error_Msg_Sem (+Expr, "name does not designate a function", + Cont => True); + Error_Msg_Sem (+Expr, "name is %n defined at %l", + (+Inter_List, +Inter_List)); + return Null_Iir; + end if; + else + if not Is_Procedure_Declaration (Inter_List) then + Error_Msg_Sem (+Expr, "name does not designate a procedure", + Cont => True); + Error_Msg_Sem (+Expr, "name is %n defined at %l", + (+Inter_List, +Inter_List)); + return Null_Iir; + end if; + end if; + + Assoc_Chain := Get_Parameter_Association_Chain (Expr); + Param_Chain := Get_Interface_Declaration_Chain (Inter_List); + Sem_Association_Chain + (Param_Chain, Assoc_Chain, + True, Missing_Parameter, Expr, Match); + Set_Parameter_Association_Chain (Expr, Assoc_Chain); + if Match = Not_Compatible then + -- No need to disp an error message, this is done by + -- sem_subprogram_arguments. + return Null_Iir; + end if; + if Is_Func then + Set_Type (Expr, Get_Return_Type (Inter_List)); + end if; + Check_Subprogram_Associations (Param_Chain, Assoc_Chain); + Set_Implementation (Expr, Inter_List); + Sem_Subprogram_Call_Finish (Expr, Inter_List); + return Expr; + end if; + end if; + + -- Second call to Sem_Function_Call (only for functions). + pragma Assert (Is_Func); + pragma Assert (A_Type /= Null_Iir); + + -- The implementation list was set. + -- The return type was set. + -- A_TYPE is not null, A_TYPE is *the* return type. + + Inter_List := Get_Implementation (Expr); + + -- Find a single implementation. + Res := Null_Iir; + if Is_Overload_List (Inter_List) then + -- INTER_LIST is a list of possible declaration to call. + -- Find one, based on the return type A_TYPE. + Overload_List := Get_Overload_List (Inter_List); + Overload_It := List_Iterate (Overload_List); + while Is_Valid (Overload_It) loop + Inter := Get_Element (Overload_It); + if Are_Basetypes_Compatible + (A_Type, Get_Base_Type (Get_Return_Type (Inter))) + /= Not_Compatible + then + if Res /= Null_Iir then + Error_Overload (Expr); + Disp_Overload_List (Overload_List, Expr); + return Null_Iir; + else + Res := Inter; + end if; + end if; + Next (Overload_It); + end loop; + else + if Are_Basetypes_Compatible + (A_Type, Get_Base_Type (Get_Return_Type (Inter_List))) + /= Not_Compatible + then + Res := Inter_List; + end if; + end if; + if Res = Null_Iir then + Error_Not_Match (Expr, A_Type); + return Null_Iir; + end if; + + -- Clean up. + if Res_Type /= Null_Iir and then Is_Overload_List (Res_Type) then + Free_Iir (Res_Type); + end if; + + if Is_Overload_List (Inter_List) then + Free_Iir (Inter_List); + end if; + + -- Simple case: this is not a call to a function, but an enumeration + -- literal. + if Get_Kind (Res) = Iir_Kind_Enumeration_Literal then + -- Free_Iir (Expr); + return Res; + end if; + + -- Set types. + Set_Type (Expr, Get_Return_Type (Res)); + Assoc_Chain := Get_Parameter_Association_Chain (Expr); + Param_Chain := Get_Interface_Declaration_Chain (Res); + Sem_Association_Chain + (Param_Chain, Assoc_Chain, True, Missing_Parameter, Expr, Match); + Set_Parameter_Association_Chain (Expr, Assoc_Chain); + if Match = Not_Compatible then + return Null_Iir; + end if; + Check_Subprogram_Associations (Param_Chain, Assoc_Chain); + Set_Implementation (Expr, Res); + Sem_Subprogram_Call_Finish (Expr, Res); + return Expr; + end Sem_Subprogram_Call; + + procedure Sem_Procedure_Call (Call : Iir_Procedure_Call; Stmt : Iir) + is + Imp: Iir; + Name : Iir; + Parameters_Chain : Iir; + Param : Iir; + Formal : Iir; + Prefix : Iir; + Inter : Iir; + begin + Name := Get_Prefix (Call); + -- FIXME: check for denoting name. + Sem_Name (Name); + + -- Return now if the procedure declaration wasn't found. + Imp := Get_Named_Entity (Name); + if Is_Error (Imp) then + return; + end if; + Set_Implementation (Call, Imp); + + Name_To_Method_Object (Call, Name); + Parameters_Chain := Get_Parameter_Association_Chain (Call); + if Sem_Actual_Of_Association_Chain (Parameters_Chain) = False then + return; + end if; + if Sem_Subprogram_Call (Call, Null_Iir) /= Call then + return; + end if; + Imp := Get_Implementation (Call); + if Is_Overload_List (Imp) then + -- Failed to resolve overload. + return; + end if; + Set_Named_Entity (Name, Imp); + Set_Prefix (Call, Finish_Sem_Name (Name)); + + -- LRM 2.1.1.2 Signal Parameters + -- A process statement contains a driver for each actual signal + -- associated with a formal signal parameter of mode OUT or INOUT in + -- a subprogram call. + -- Similarly, a subprogram contains a driver for each formal signal + -- parameter of mode OUT or INOUT declared in its subrogram + -- specification. + Param := Parameters_Chain; + Inter := Get_Interface_Declaration_Chain (Imp); + while Param /= Null_Iir loop + -- Association_Element_By_Individual duplicates existing + -- associations. + if Get_Kind (Param) /= Iir_Kind_Association_Element_By_Individual + then + Formal := Get_Formal (Param); + if Formal = Null_Iir then + Formal := Inter; + Inter := Get_Chain (Inter); + else + Formal := Get_Base_Name (Formal); + Inter := Null_Iir; + end if; + if Get_Kind (Formal) = Iir_Kind_Interface_Signal_Declaration + and then Get_Mode (Formal) in Iir_Out_Modes + then + Prefix := Name_To_Object (Get_Actual (Param)); + if Prefix /= Null_Iir then + case Get_Kind (Get_Object_Prefix (Prefix)) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + Prefix := Get_Longuest_Static_Prefix (Prefix); + Sem_Stmts.Sem_Add_Driver (Prefix, Stmt); + when others => + null; + end case; + end if; + end if; + end if; + Param := Get_Chain (Param); + end loop; + end Sem_Procedure_Call; + + -- List must be an overload list containing subprograms declarations. + -- Try to resolve overload and return the uniq interpretation if one, + -- NULL_IIR otherwise. + -- + -- If there are two functions, one primitive of a universal + -- type and the other not, return the primitive of the universal type. + -- This implements implicit type conversions rules. + -- Cf Sem_Names.Extract_Call_Without_Implicit_Conversion + -- + -- The typical case is the use of comparison operator with literals or + -- attributes, like: s'length = 0 + function Get_Non_Implicit_Subprogram (List : Iir_List) return Iir + is + It : List_Iterator; + El : Iir; + Res : Iir; + Ref_Type : Iir; + begin + -- Conditions: + -- 1. All the possible functions must return boolean. + -- 2. There is only one implicit function for universal or real. + Res := Null_Iir; + It := List_Iterate (List); + while Is_Valid (It) loop + El := Get_Element (It); + + -- Only comparison operators need this special handling. + if Get_Base_Type (Get_Return_Type (El)) /= Boolean_Type_Definition + then + return Null_Iir; + end if; + + if Is_Implicit_Subprogram (El) then + Ref_Type := Get_Type (Get_Interface_Declaration_Chain (El)); + if Ref_Type = Universal_Integer_Type_Definition + or Ref_Type = Universal_Real_Type_Definition + then + -- There could be only one such subprogram. + pragma Assert (Res = Null_Iir); + Res := El; + end if; + end if; + Next (It); + end loop; + return Res; + end Get_Non_Implicit_Subprogram; + + -- Honor the -fexplicit flag. + -- If LIST is composed of 2 declarations that matches the 'explicit' rule, + -- return the explicit declaration. + -- Otherwise, return NULL_IIR. + function Get_Explicit_Subprogram (List : Iir_List) return Iir + is + Sub1 : Iir; + Sub2 : Iir; + It : List_Iterator; + Res : Iir; + begin + if Get_Nbr_Elements (List) /= 2 then + return Null_Iir; + end if; + + It := List_Iterate (List); + Sub1 := Get_Element (It); + Next (It); + Sub2 := Get_Element (It); + Next (It); + pragma Assert (not Is_Valid (It)); + + -- One must be an implicit declaration, the other must be an explicit + -- declaration. + pragma Assert (Get_Kind (Sub1) = Iir_Kind_Function_Declaration); + pragma Assert (Get_Kind (Sub2) = Iir_Kind_Function_Declaration); + if Is_Implicit_Subprogram (Sub1) then + if Is_Implicit_Subprogram (Sub2) then + return Null_Iir; + end if; + Res := Sub2; + else + if not Is_Implicit_Subprogram (Sub2) then + return Null_Iir; + end if; + Res := Sub1; + end if; + + -- They must have the same profile. + if Get_Subprogram_Hash (Sub1) /= Get_Subprogram_Hash (Sub2) + or else not Is_Same_Profile (Sub1, Sub2) + then + return Null_Iir; + end if; + + -- They must be declared in a package. + if Get_Kind (Get_Parent (Sub1)) /= Iir_Kind_Package_Declaration + or else Get_Kind (Get_Parent (Sub2)) /= Iir_Kind_Package_Declaration + then + return Null_Iir; + end if; + + return Res; + end Get_Explicit_Subprogram; + + -- Set when the -fexplicit option was adviced. + Explicit_Advice_Given : Boolean := False; + + function Sem_Operator (Expr : Iir; Res_Type : Iir; Arity : Positive) + return Iir + is + Operator : Name_Id; + Left, Right: Iir; + Interpretation : Name_Interpretation_Type; + Decl : Iir; + Overload_List : Iir_List; + Overload : Iir; + Res_Type_List : Iir; + Full_Compat : Iir; + It : List_Iterator; + + -- LEFT and RIGHT must be set. + function Set_Uniq_Interpretation (Decl : Iir) return Iir + is + Interface_Chain : Iir; + Err : Boolean; + begin + Set_Type (Expr, Get_Return_Type (Decl)); + Interface_Chain := Get_Interface_Declaration_Chain (Decl); + Err := False; + if Is_Overloaded (Left) then + Left := Sem_Expression_Ov + (Left, Get_Base_Type (Get_Type (Interface_Chain))); + if Left = Null_Iir then + Err := True; + else + if Arity = 1 then + Set_Operand (Expr, Left); + else + Set_Left (Expr, Left); + end if; + end if; + end if; + Check_Read (Left); + if Arity = 2 then + if Is_Overloaded (Right) then + Right := Sem_Expression_Ov + (Right, + Get_Base_Type (Get_Type (Get_Chain (Interface_Chain)))); + if Right = Null_Iir then + Err := True; + else + Set_Right (Expr, Right); + end if; + end if; + Check_Read (Right); + end if; + Destroy_Iir_List (Overload_List); + if not Err then + Set_Implementation (Expr, Decl); + Sem_Subprogram_Call_Finish (Expr, Decl); + return Eval_Expr_If_Static (Expr); + else + return Expr; + end if; + end Set_Uniq_Interpretation; + + -- Note: operator and implementation node of expr must be set. + procedure Error_Operator_Overload (List : Iir_List) is + begin + Error_Msg_Sem (+Expr, "operator ""%i"" is overloaded", +Operator); + Disp_Overload_List (List, Expr); + end Error_Operator_Overload; + + Interface_Chain : Iir; + begin + if Arity = 1 then + Left := Get_Operand (Expr); + Right := Null_Iir; + else + Left := Get_Left (Expr); + Right := Get_Right (Expr); + end if; + Operator := Iirs_Utils.Get_Operator_Name (Expr); + + if Get_Type (Expr) = Null_Iir then + -- First pass. + -- Analyze operands. + -- FIXME: should try to analyze right operand even if analyze + -- of left operand has failed ?? + if Get_Type (Left) = Null_Iir then + Left := Sem_Expression_Ov (Left, Null_Iir); + if Left = Null_Iir then + return Null_Iir; + end if; + if Arity = 1 then + Set_Operand (Expr, Left); + else + Set_Left (Expr, Left); + end if; + end if; + if Arity = 2 and then Get_Type (Right) = Null_Iir then + Right := Sem_Expression_Ov (Right, Null_Iir); + if Right = Null_Iir then + return Null_Iir; + end if; + Set_Right (Expr, Right); + end if; + + Overload_List := Create_Iir_List; + + -- Try to find an implementation among user defined function + Interpretation := Get_Interpretation (Operator); + while Valid_Interpretation (Interpretation) loop + Decl := Get_Non_Alias_Declaration (Interpretation); + + -- It is compatible with operand types ? + pragma Assert (Is_Function_Declaration (Decl)); + + -- LRM08 12.3 Visibility + -- [...] or all visible declarations denote the same named entity. + -- + -- GHDL: If DECL has already been seen, then skip it. + if Get_Seen_Flag (Decl) then + goto Continue; + end if; + + -- Check return type. + if Res_Type /= Null_Iir + and then (Are_Types_Compatible (Res_Type, Get_Return_Type (Decl)) + = Not_Compatible) + then + goto Continue; + end if; + + Interface_Chain := Get_Interface_Declaration_Chain (Decl); + + -- Check arity. + + -- LRM93 2.5.2 Operator overloading + -- The subprogram specification of a unary operator must have + -- a single parameter [...] + -- The subprogram specification of a binary operator must have + -- two parameters [...] + -- + -- GHDL: So even in presence of default expression in a parameter, + -- a unary operation has to match with a binary operator. + if Iir_Chains.Get_Chain_Length (Interface_Chain) /= Arity then + goto Continue; + end if; + + -- Check operands. + if Is_Expr_Compatible (Get_Type (Interface_Chain), Left) + = Not_Compatible + then + goto Continue; + end if; + if Arity = 2 then + if Is_Expr_Compatible (Get_Type (Get_Chain (Interface_Chain)), + Right) + = Not_Compatible + then + goto Continue; + end if; + end if; + + -- Match. + Set_Seen_Flag (Decl, True); + Append_Element (Overload_List, Decl); + + << Continue >> null; + Interpretation := Get_Next_Interpretation (Interpretation); + end loop; + + -- Clear seen_flags. + It := List_Iterate (Overload_List); + while Is_Valid (It) loop + Set_Seen_Flag (Get_Element (It), False); + Next (It); + end loop; + + -- The list of possible implementations was computed. + case Get_Nbr_Elements (Overload_List) is + when 0 => + if Get_Kind (Expr) = Iir_Kind_Implicit_Condition_Operator then + -- TODO: display expression type. + Error_Msg_Sem (+Expr, "cannot convert expression to boolean " + & "(no ""??"" found)"); + else + Error_Msg_Sem (+Expr, + "no function declarations for %n", +Expr); + end if; + Destroy_Iir_List (Overload_List); + return Null_Iir; + + when 1 => + Decl := Get_First_Element (Overload_List); + return Set_Uniq_Interpretation (Decl); + + when others => + -- Preference for universal operator. + -- This roughly corresponds to: + -- + -- LRM 7.3.5 + -- An implicit conversion of a convertible universal operand + -- is applied if and only if the innermost complete context + -- determines a unique (numeric) target type for the implicit + -- conversion, and there is no legal interpretation of this + -- context without this conversion. + if Arity = 2 then + Decl := Get_Non_Implicit_Subprogram (Overload_List); + if Decl /= Null_Iir then + return Set_Uniq_Interpretation (Decl); + end if; + end if; + + Set_Implementation (Expr, Create_Overload_List (Overload_List)); + + -- Create the list of possible return types, if it is not yet + -- determined. + if Res_Type = Null_Iir then + Res_Type_List := Create_List_Of_Types (Overload_List); + if Is_Overload_List (Res_Type_List) then + -- There are many possible return types. + -- Try again. + Set_Type (Expr, Res_Type_List); + return Expr; + end if; + end if; + + -- The return type is known. + -- Search for explicit subprogram. + + -- It was impossible to find one solution. + Error_Operator_Overload (Overload_List); + + -- Give an advice. + if not Flags.Flag_Explicit + and then not Explicit_Advice_Given + and then Flags.Vhdl_Std < Vhdl_08 + then + Decl := Get_Explicit_Subprogram (Overload_List); + if Decl /= Null_Iir then + Error_Msg_Sem + (+Expr, "(you may want to use the -fexplicit option)"); + Explicit_Advice_Given := True; + end if; + end if; + + return Null_Iir; + end case; + else + -- Second pass + -- Find the uniq implementation for this call. + Overload := Get_Implementation (Expr); + Overload_List := Get_Overload_List (Overload); + Full_Compat := Null_Iir; + It := List_Iterate (Overload_List); + while Is_Valid (It) loop + Decl := Get_Element (It); + -- FIXME: wrong: compatibilty with return type and args. + if Are_Types_Compatible (Get_Return_Type (Decl), Res_Type) + /= Not_Compatible + then + if Full_Compat /= Null_Iir then + Error_Operator_Overload (Overload_List); + return Null_Iir; + else + Full_Compat := Decl; + end if; + end if; + Next (It); + end loop; + Free_Iir (Overload); + Overload := Get_Type (Expr); + Free_Overload_List (Overload); + return Set_Uniq_Interpretation (Full_Compat); + end if; + end Sem_Operator; + + -- Analyze LIT whose elements must be of type EL_TYPE, and return + -- the length. + -- FIXME: the errors are reported, but there is no mark of that. + function Sem_String_Literal (Str : Iir; El_Type : Iir) return Natural + is + function Find_Literal (Etype : Iir_Enumeration_Type_Definition; + C : Character) + return Iir_Enumeration_Literal + is + Id : constant Name_Id := Name_Table.Get_Identifier (C); + Inter : Name_Interpretation_Type; + Decl : Iir; + begin + Inter := Get_Interpretation (Id); + while Valid_Interpretation (Inter) loop + Decl := Get_Non_Alias_Declaration (Inter); + if Get_Kind (Decl) = Iir_Kind_Enumeration_Literal + and then Get_Type (Decl) = Etype + then + return Decl; + end if; + Inter := Get_Next_Interpretation (Inter); + end loop; + + -- LRM08 9.3 Operands + -- The character literals corresponding to the graphic characters + -- contained within a string literal or a bit string literal shall + -- be visible at the place of the string literal. + + -- Character C is not visible... + if Find_Name_In_Flist (Get_Enumeration_Literal_List (Etype), Id) + = Null_Iir + then + -- ... because it is not defined. + Error_Msg_Sem + (+Str, "type %n does not define character %c", (+Etype, +C)); + else + -- ... because it is not visible. + Error_Msg_Sem (+Str, "character %c of type %n is not visible", + (+C, +Etype)); + end if; + return Null_Iir; + end Find_Literal; + + type Characters_Pos is array (Character range <>) of Nat8; + Len : constant Nat32 := Get_String_Length (Str); + Id : constant String8_Id := Get_String8_Id (Str); + El : Iir; + Enum_Pos : Iir_Int32; + Ch : Character; + + -- Create a cache of literals, to speed-up a little bit the + -- search. + No_Pos : constant Nat8 := Nat8'Last; + Map : Characters_Pos (' ' .. Character'Last) := (others => No_Pos); + Res : Nat8; + begin + for I in 1 .. Len loop + Ch := Str_Table.Char_String8 (Id, I); + if Ch not in Map'Range then + -- Invalid character. + pragma Assert (Flags.Flag_Force_Analysis); + Res := 0; + else + Res := Map (Ch); + if Res = No_Pos then + El := Find_Literal (El_Type, Ch); + if El = Null_Iir then + Res := 0; + else + Enum_Pos := Get_Enum_Pos (El); + Res := Nat8 (Enum_Pos); + Map (Ch) := Res; + end if; + end if; + end if; + Str_Table.Set_Element_String8 (Id, I, Res); + end loop; + + -- LRM08 9.4.2 Locally static primaries + -- a) A literal of any type other than type TIME + Set_Expr_Staticness (Str, Locally); + + return Natural (Len); + end Sem_String_Literal; + + procedure Sem_String_Literal (Lit: Iir) + is + Lit_Type : constant Iir := Get_Type (Lit); + Lit_Base_Type : constant Iir := Get_Base_Type (Lit_Type); + + -- The subtype created for the literal. + N_Type: Iir; + -- type of the index of the array type. + Index_Type: Iir; + Len : Natural; + El_Type : Iir; + begin + El_Type := Get_Base_Type (Get_Element_Subtype (Lit_Base_Type)); + Len := Sem_String_Literal (Lit, El_Type); + + if Get_Constraint_State (Lit_Type) = Fully_Constrained then + -- The type of the context is constrained. + Index_Type := Get_Index_Type (Lit_Type, 0); + if Get_Type_Staticness (Index_Type) = Locally then + if Eval_Discrete_Type_Length (Index_Type) /= Iir_Int64 (Len) then + Error_Msg_Sem (+Lit, "string length does not match that of %n", + +Index_Type); + end if; + else + -- FIXME: emit a warning because of dubious construct (the type + -- of the string is not locally constrained) ? + null; + end if; + else + -- Context type is not constained. Set type of the string literal, + -- according to LRM93 7.3.2.2. + N_Type := Create_Unidim_Array_By_Length + (Lit_Base_Type, Iir_Int64 (Len), Lit); + Set_Type (Lit, N_Type); + Set_Literal_Subtype (Lit, N_Type); + end if; + end Sem_String_Literal; + + procedure Count_Choices (Info : out Choice_Info_Type; + Choice_Chain : Iir) + is + Choice : Iir; + S : Iir_Staticness; + begin + Info := (Nbr_Choices => 0, + Nbr_Alternatives => 0, + Others_Choice => Null_Iir, + Arr => null, + Annex_Arr => null); + Choice := Choice_Chain; + while Is_Valid (Choice) loop + case Iir_Kinds_Case_Choice (Get_Kind (Choice)) is + when Iir_Kind_Choice_By_Expression => + S := Get_Expr_Staticness (Get_Choice_Expression (Choice)); + pragma Assert (S = Get_Choice_Staticness (Choice)); + if S = Locally then + Info.Nbr_Choices := Info.Nbr_Choices + 1; + end if; + when Iir_Kind_Choice_By_Range => + S := Get_Expr_Staticness (Get_Choice_Range (Choice)); + pragma Assert (S = Get_Choice_Staticness (Choice)); + if S = Locally then + Info.Nbr_Choices := Info.Nbr_Choices + 1; + end if; + when Iir_Kind_Choice_By_Others => + Info.Others_Choice := Choice; + end case; + if not Get_Same_Alternative_Flag (Choice) then + Info.Nbr_Alternatives := Info.Nbr_Alternatives + 1; + end if; + Choice := Get_Chain (Choice); + end loop; + end Count_Choices; + + procedure Fill_Choices_Array (Info : in out Choice_Info_Type; + Choice_Chain : Iir) + is + Index : Natural; + Choice : Iir; + Expr : Iir; + begin + Info.Arr := new Iir_Array (1 .. Info.Nbr_Choices); + + -- Fill the array. + Index := 0; + Choice := Choice_Chain; + while Choice /= Null_Iir loop + case Iir_Kinds_Case_Choice (Get_Kind (Choice)) is + when Iir_Kind_Choice_By_Expression => + Expr := Get_Choice_Expression (Choice); + when Iir_Kind_Choice_By_Range => + Expr := Get_Choice_Range (Choice); + when Iir_Kind_Choice_By_Others => + Expr := Null_Iir; + end case; + if Is_Valid (Expr) and then Get_Expr_Staticness (Expr) = Locally + then + Index := Index + 1; + Info.Arr (Index) := Choice; + end if; + Choice := Get_Chain (Choice); + end loop; + + pragma Assert (Index = Info.Nbr_Choices); + end Fill_Choices_Array; + + procedure Swap_Choice_Info (Info : Choice_Info_Type; + From : Natural; To : Natural) + is + Tmp : Iir; + begin + Tmp := Info.Arr (To); + Info.Arr (To) := Info.Arr (From); + Info.Arr (From) := Tmp; + + if Info.Annex_Arr /= null then + declare + T : Int32; + begin + T := Info.Annex_Arr (To); + Info.Annex_Arr (To) := Info.Annex_Arr (From); + Info.Annex_Arr (From) := T; + end; + end if; + end Swap_Choice_Info; + + procedure Sort_String_Choices (Info : in out Choice_Info_Type) + is + -- Compare two elements of ARR. + -- Return true iff OP1 < OP2. + function Lt (Op1, Op2 : Natural) return Boolean is + begin + return Compare_String_Literals + (Get_Choice_Expression (Info.Arr (Op1)), + Get_Choice_Expression (Info.Arr (Op2))) + = Compare_Lt; + end Lt; + + procedure Swap (From : Natural; To : Natural) is + begin + Swap_Choice_Info (Info, From, To); + end Swap; + + procedure Str_Heap_Sort is + new Grt.Algos.Heap_Sort (Lt => Lt, Swap => Swap); + begin + Str_Heap_Sort (Info.Nbr_Choices); + end Sort_String_Choices; + + procedure Sem_String_Choices_Range (Choice_Chain : Iir; Sel : Iir) + is + -- Type of SEL. + Sel_Type : Iir; + + -- Type of the element of SEL. + Sel_El_Type : Iir; + -- Number of literals in the element type. + Sel_El_Length : Iir_Int64; + + -- Length of SEL (number of characters in SEL). + Sel_Length : Iir_Int64; + + -- True if length of a choice mismatches + Has_Length_Error : Boolean := False; + + El : Iir; + + Info : Choice_Info_Type; + + procedure Sem_Simple_Choice (Choice : Iir) + is + Expr : Iir; + Choice_Len : Iir_Int64; + begin + -- LRM93 8.8 + -- In such case, each choice appearing in any of the case statement + -- alternative must be a locally static expression whose value is of + -- the same length as that of the case expression. + Expr := Sem_Expression (Get_Choice_Expression (Choice), Sel_Type); + if Expr = Null_Iir then + Has_Length_Error := True; + return; + end if; + Set_Choice_Expression (Choice, Expr); + if Get_Expr_Staticness (Expr) < Locally then + Error_Msg_Sem (+Expr, "choice must be locally static expression"); + Has_Length_Error := True; + return; + end if; + Set_Choice_Staticness (Choice, Locally); + Expr := Eval_Expr (Expr); + Set_Choice_Expression (Choice, Expr); + if Get_Kind (Expr) = Iir_Kind_Overflow_Literal then + Error_Msg_Sem + (+Expr, "bound error during evaluation of choice expression"); + Has_Length_Error := True; + return; + end if; + + Choice_Len := Eval_Discrete_Type_Length + (Get_String_Type_Bound_Type (Get_Type (Expr))); + if Sel_Length = -1 then + Sel_Length := Choice_Len; + else + if Choice_Len /= Sel_Length then + Has_Length_Error := True; + Error_Msg_Sem (+Expr, "incorrect length for the choice value"); + return; + end if; + end if; + end Sem_Simple_Choice; + + function Eq (Op1, Op2 : Natural) return Boolean is + begin + return Compare_String_Literals + (Get_Choice_Expression (Info.Arr (Op1)), + Get_Choice_Expression (Info.Arr (Op2))) + = Compare_Eq; + end Eq; + begin + -- LRM93 8.8 + -- If the expression is of one-dimensional character array type, then + -- the expression must be one of the following: + -- FIXME: to complete. + Sel_Type := Get_Type (Sel); + if not Is_One_Dimensional_Array_Type (Sel_Type) then + Error_Msg_Sem + (+Sel, + "expression must be discrete or one-dimension array subtype"); + return; + end if; + if Get_Type_Staticness (Sel_Type) = Locally then + Sel_Length := Eval_Discrete_Type_Length + (Get_String_Type_Bound_Type (Sel_Type)); + else + -- LRM08 10.9 Case statement + -- If the expression is of a one-dimensional character array type and + -- is not described by either of the preceding two paragraphs, then + -- the values of all of the choices, except the OTHERS choice, if + -- present, shall be of the same length. + if Flags.Vhdl_Std >= Vhdl_08 then + Sel_Length := -1; + else + Error_Msg_Sem (+Sel, "array type must be locally static"); + return; + end if; + -- Use the base type so that the subtype of the choices is computed. + Sel_Type := Get_Base_Type (Sel_Type); + end if; + Sel_El_Type := Get_Element_Subtype (Sel_Type); + Sel_El_Length := Eval_Discrete_Type_Length (Sel_El_Type); + + El := Choice_Chain; + Info.Others_Choice := Null_Iir; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Choice_By_None => + raise Internal_Error; + when Iir_Kind_Choice_By_Range => + Error_Msg_Sem + (+El, "range choice are not allowed for non-discrete type"); + when Iir_Kind_Choice_By_Expression => + Sem_Simple_Choice (El); + when Iir_Kind_Choice_By_Others => + if Info.Others_Choice /= Null_Iir then + Error_Msg_Sem (+El, "duplicate others choice"); + elsif Get_Chain (El) /= Null_Iir then + Error_Msg_Sem + (+El, "choice others must be the last alternative"); + end if; + Info.Others_Choice := El; + when others => + Error_Kind ("sem_string_choices_range", El); + end case; + El := Get_Chain (El); + end loop; + + -- Null choices. + if Sel_Length = 0 then + return; + end if; + if Has_Length_Error then + return; + end if; + + -- LRM 8.8 + -- + -- If the expression is the name of an object whose subtype is locally + -- static, whether a scalar type or an array type, then each value of + -- the subtype must be represented once and only once in the set of + -- choices of the case statement and no other value is allowed; [...] + + -- 1. Allocate Arr, fill it and sort + Count_Choices (Info, Choice_Chain); + Fill_Choices_Array (Info, Choice_Chain); + Sort_String_Choices (Info); + + -- 2. Check for duplicate choices + for I in 1 .. Info.Nbr_Choices - 1 loop + if Eq (I, I + 1) then + Error_Msg_Sem + (+Info.Arr (I), + "duplicate choice with choice at %l", +Info.Arr (I + 1)); + exit; + end if; + end loop; + + -- 3. Free Arr + Free (Info.Arr); + + -- Check for missing choice. + -- Do not try to compute the expected number of choices as this can + -- easily overflow. + if Info.Others_Choice = Null_Iir then + declare + Nbr : Iir_Int64 := Iir_Int64 (Info.Nbr_Choices); + begin + for I in 1 .. Sel_Length loop + Nbr := Nbr / Sel_El_Length; + if Nbr = 0 then + Error_Msg_Sem (+Choice_Chain, "missing choice(s)"); + exit; + end if; + end loop; + end; + end if; + end Sem_String_Choices_Range; + + -- Get low limit of ASSOC. + -- First, get the expression of the association, then the low limit. + -- ASSOC may be either association_by_range (in this case the low limit + -- is to be fetched), or association_by_expression (and the low limit + -- is the expression). + function Get_Assoc_Low (Assoc : Iir) return Iir + is + Expr : Iir; + begin + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_Expression => + return Get_Choice_Expression (Assoc); + when Iir_Kind_Choice_By_Range => + Expr := Get_Choice_Range (Assoc); + case Get_Kind (Expr) is + when Iir_Kind_Range_Expression => + return Get_Low_Limit (Expr); + when others => + return Expr; + end case; + when others => + Error_Kind ("get_assoc_low", Assoc); + end case; + end Get_Assoc_Low; + + function Get_Assoc_High (Assoc : Iir) return Iir + is + Expr : Iir; + begin + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_Expression => + return Get_Choice_Expression (Assoc); + when Iir_Kind_Choice_By_Range => + Expr := Get_Choice_Range (Assoc); + case Get_Kind (Expr) is + when Iir_Kind_Range_Expression => + return Get_High_Limit (Expr); + when others => + return Expr; + end case; + when others => + Error_Kind ("get_assoc_high", Assoc); + end case; + end Get_Assoc_High; + + procedure Sort_Discrete_Choices (Info : in out Choice_Info_Type) + is + -- Compare two elements of ARR. + -- Return true iff OP1 < OP2. + function Lt (Op1, Op2 : Natural) return Boolean is + begin + return (Eval_Pos (Get_Assoc_Low (Info.Arr (Op1))) + < Eval_Pos (Get_Assoc_Low (Info.Arr (Op2)))); + end Lt; + + procedure Swap (From : Natural; To : Natural) is + begin + Swap_Choice_Info (Info, From, To); + end Swap; + + procedure Disc_Heap_Sort is + new Grt.Algos.Heap_Sort (Lt => Lt, Swap => Swap); + begin + Disc_Heap_Sort (Info.Nbr_Choices); + end Sort_Discrete_Choices; + + procedure Sem_Check_Continuous_Choices (Choice_Chain : Iir; + Choice_Type : Iir; + Low : out Iir; + High : out Iir; + Loc : Location_Type; + Is_Sub_Range : Boolean) + is + -- Nodes that can appear. + Info : Choice_Info_Type; + + Type_Has_Bounds : Boolean; + begin + -- Set TYPE_HAS_BOUNDS + case Get_Kind (Choice_Type) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition => + Type_Has_Bounds := True; + when Iir_Kind_Integer_Type_Definition => + Type_Has_Bounds := False; + when others => + Error_Kind ("sem_check_continuous_choices(3)", Choice_Type); + end case; + + -- Check the choices are within the bounds. + if Type_Has_Bounds + and then Get_Type_Staticness (Choice_Type) = Locally + then + declare + Choice : Iir; + Ok : Boolean; + Has_Err : Boolean; + Expr : Iir; + begin + Has_Err := False; + Choice := Choice_Chain; + while Choice /= Null_Iir loop + Ok := True; + case Iir_Kinds_Case_Choice (Get_Kind (Choice)) is + when Iir_Kind_Choice_By_Expression => + Expr := Get_Choice_Expression (Choice); + if Get_Expr_Staticness (Expr) = Locally then + Ok := Eval_Is_In_Bound (Expr, Choice_Type); + end if; + when Iir_Kind_Choice_By_Range => + Expr := Get_Choice_Range (Choice); + if Get_Expr_Staticness (Expr) = Locally then + Ok := Eval_Is_Range_In_Bound (Expr, Choice_Type, True); + end if; + when Iir_Kind_Choice_By_Others => + null; + end case; + if not Ok then + Error_Msg_Sem (+Choice, "%n out of index range", +Expr); + Has_Err := True; + end if; + Choice := Get_Chain (Choice); + end loop; + + -- In case of error (value not in range), don't try to extract + -- bounds or to sort values. + if Has_Err then + High := Null_Iir; + Low := Null_Iir; + return; + end if; + end; + end if; + + -- Compute the number of elements and sort. + Count_Choices (Info, Choice_Chain); + Fill_Choices_Array (Info, Choice_Chain); + Sort_Discrete_Choices (Info); + + for I in Info.Arr'Range loop + Set_Choice_Order (Info.Arr (I), Int32 (I)); + end loop; + + -- Set low and high bounds. + if Info.Nbr_Choices > 0 then + Low := Get_Assoc_Low (Info.Arr (Info.Arr'First)); + High := Get_Assoc_High (Info.Arr (Info.Arr'Last)); + else + Low := Null_Iir; + High := Null_Iir; + end if; + + -- Fourth: + -- check for lacking choice (if no others) + -- check for overlapping choices + declare + -- Emit an error message for absence of choices in position L to H + -- of index type BT at location LOC. + procedure Error_No_Choice (Bt : Iir; + L, H : Iir_Int64; + Loc : Location_Type) is + begin + if L = H then + Error_Msg_Sem (+Loc, "no choice for " & Disp_Discrete (Bt, L)); + else + Error_Msg_Sem + (+Loc, "no choices for " & Disp_Discrete (Bt, L) + & " to " & Disp_Discrete (Bt, H)); + end if; + end Error_No_Choice; + + -- Lowest and highest bounds. + Lb, Hb : Iir; + Pos : Iir_Int64; + Pos_Max : Iir_Int64; + E_Pos : Iir_Int64; + Choice : Iir; + Need_Others : Boolean; + + Bt : constant Iir := Get_Base_Type (Choice_Type); + begin + if not Is_Sub_Range + and then Get_Type_Staticness (Choice_Type) = Locally + and then Type_Has_Bounds + then + Get_Low_High_Limit (Get_Range_Constraint (Choice_Type), Lb, Hb); + else + Lb := Low; + Hb := High; + end if; + if Lb = Null_Iir or else Hb = Null_Iir then + -- Return now in case of error. + Free (Info.Arr); + return; + end if; + -- Checks all values between POS and POS_MAX are handled. + Pos := Eval_Pos (Lb); + Pos_Max := Eval_Pos (Hb); + if Pos > Pos_Max then + -- Null range. + Free (Info.Arr); + return; + end if; + Need_Others := False; + for I in Info.Arr'Range loop + Choice := Info.Arr (I); + E_Pos := Eval_Pos (Get_Assoc_Low (Choice)); + if E_Pos > Pos_Max then + -- Choice out of bound, already handled. + Error_No_Choice (Bt, Pos, Pos_Max, Get_Location (Choice)); + -- Avoid other errors. + Pos := Pos_Max + 1; + exit; + end if; + if Pos < E_Pos then + Need_Others := True; + if Info.Others_Choice = Null_Iir then + Error_No_Choice (Bt, Pos, E_Pos - 1, Get_Location (Choice)); + end if; + elsif Pos > E_Pos then + Need_Others := True; + if Pos = E_Pos + 1 then + Error_Msg_Sem + (+Choice, + "duplicate choice for " & Disp_Discrete (Bt, E_Pos)); + else + Error_Msg_Sem + (+Choice, "duplicate choices for " + & Disp_Discrete (Bt, E_Pos) + & " to " & Disp_Discrete (Bt, Pos)); + end if; + end if; + + if Get_Kind (Choice) = Iir_Kind_Choice_By_Range then + Pos := Eval_Pos (Get_Assoc_High (Choice)) + 1; + else + Pos := E_Pos + 1; + end if; + end loop; + if Pos /= Pos_Max + 1 then + Need_Others := True; + if Info.Others_Choice = Null_Iir then + Error_No_Choice (Bt, Pos, Pos_Max, Loc); + end if; + end if; + + if not Need_Others and then Info.Others_Choice /= Null_Iir then + Warning_Msg_Sem (Warnid_Others, +Info.Others_Choice, + "redundant 'others' choices"); + end if; + end; + + -- LRM93 7.3.2.2 Array aggregates + -- An others choice is locally static if the applicable index constraint + -- if locally static. + if Info.Nbr_Choices > 0 + and then Info.Others_Choice /= Null_Iir + and then Get_Type_Staticness (Choice_Type) /= Locally + then + Warning_Msg_Sem + (Warnid_Static, +Info.Others_Choice, + "'others' choice allowed only if the index constraint is static"); + end if; + + Free (Info.Arr); + end Sem_Check_Continuous_Choices; + + procedure Sem_Choices_Range (Choice_Chain : in out Iir; + Choice_Type : Iir; + Low : out Iir; + High : out Iir; + Loc : Location_Type; + Is_Sub_Range : Boolean; + Is_Case_Stmt : Boolean) + is + -- Number of positionnal choice. + Nbr_Pos : Iir_Int64; + + -- Number of named choices. + Nbr_Named : Natural; + + -- True if others choice is present. + Has_Others : Boolean; + + Has_Error : Boolean; + + Pos_Max : Iir_Int64; + El : Iir; + Prev_El : Iir; + + -- Staticness of the current choice. + Choice_Staticness : Iir_Staticness; + + -- Staticness of all the choices. + Staticness : Iir_Staticness; + + function Replace_By_Range_Choice (Name : Iir; Range_Type : Iir) + return Boolean + is + N_Choice : Iir; + Name1 : Iir; + begin + if Are_Types_Compatible (Range_Type, Choice_Type) = Not_Compatible + then + Error_Not_Match (Name, Choice_Type); + return False; + end if; + + Name1 := Finish_Sem_Name (Name); + N_Choice := Create_Iir (Iir_Kind_Choice_By_Range); + Location_Copy (N_Choice, El); + Set_Chain (N_Choice, Get_Chain (El)); + Set_Associated_Expr (N_Choice, Get_Associated_Expr (El)); + Set_Associated_Chain (N_Choice, Get_Associated_Chain (El)); + Set_Same_Alternative_Flag (N_Choice, Get_Same_Alternative_Flag (El)); + Set_Choice_Range (N_Choice, Eval_Range_If_Static (Name1)); + Set_Choice_Staticness (N_Choice, Get_Type_Staticness (Range_Type)); + Set_Element_Type_Flag (N_Choice, Get_Element_Type_Flag (El)); + Free_Iir (El); + + if Prev_El = Null_Iir then + Choice_Chain := N_Choice; + else + Set_Chain (Prev_El, N_Choice); + end if; + El := N_Choice; + + return True; + end Replace_By_Range_Choice; + + -- Analyze a simple (by expression or by range) choice. + -- Return FALSE in case of error. + function Sem_Simple_Choice return Boolean + is + Expr : Iir; + Ent : Iir; + begin + if Get_Kind (El) = Iir_Kind_Choice_By_Range then + Expr := Get_Choice_Range (El); + Expr := Sem_Discrete_Range_Expression (Expr, Choice_Type, True); + if Expr = Null_Iir then + return False; + end if; + Expr := Eval_Range_If_Static (Expr); + Set_Choice_Range (El, Expr); + else + Expr := Get_Choice_Expression (El); + case Get_Kind (Expr) is + when Iir_Kind_Selected_Name + | Iir_Kind_Simple_Name + | Iir_Kind_Character_Literal + | Iir_Kind_Parenthesis_Name + | Iir_Kind_Selected_By_All_Name + | Iir_Kind_Attribute_Name => + Sem_Name (Expr); + Ent := Get_Named_Entity (Expr); + if Ent = Error_Mark then + return False; + end if; + + -- So range or expression ? + -- FIXME: share code with sem_name for slice/index. + case Get_Kind (Ent) is + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute + | Iir_Kind_Range_Expression => + return Replace_By_Range_Choice (Expr, Ent); + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Type_Declaration => + Ent := Is_Type_Name (Expr); + Set_Expr_Staticness (Expr, Get_Type_Staticness (Ent)); + return Replace_By_Range_Choice (Expr, Ent); + when others => + Expr := Name_To_Expression + (Expr, Get_Base_Type (Choice_Type)); + end case; + when others => + Expr := + Sem_Expression_Ov (Expr, Get_Base_Type (Choice_Type)); + end case; + if Expr = Null_Iir then + return False; + end if; + Expr := Eval_Expr_If_Static (Expr); + Set_Choice_Expression (El, Expr); + end if; + Set_Choice_Staticness (El, Get_Expr_Staticness (Expr)); + return True; + end Sem_Simple_Choice; + begin + Low := Null_Iir; + High := Null_Iir; + + -- First: + -- Analyze the choices + -- compute the range of positionnal choices + -- compute the number of choice elements (extracted from lists). + -- check for others presence. + Nbr_Pos := 0; + Nbr_Named := 0; + Has_Others := False; + Has_Error := False; + Staticness := Locally; + El := Choice_Chain; + Prev_El := Null_Iir; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Choice_By_None => + Nbr_Pos := Nbr_Pos + 1; + when Iir_Kind_Choice_By_Expression + | Iir_Kind_Choice_By_Range => + if Sem_Simple_Choice then + Choice_Staticness := Get_Choice_Staticness (El); + Staticness := Min (Staticness, Choice_Staticness); + if Choice_Staticness /= Locally + and then Is_Case_Stmt + then + -- FIXME: explain why + Error_Msg_Sem (+El, "choice is not locally static"); + end if; + else + Has_Error := True; + end if; + Nbr_Named := Nbr_Named + 1; + when Iir_Kind_Choice_By_Name => + -- It is not possible to have such a choice in an array + -- aggregate. + -- Should have been caught previously. + raise Internal_Error; + when Iir_Kind_Choice_By_Others => + if Has_Others then + Error_Msg_Sem (+El, "duplicate others choice"); + elsif Get_Chain (El) /= Null_Iir then + Error_Msg_Sem + (+El, "choice others should be the last alternative"); + end if; + Has_Others := True; + when others => + Error_Kind ("sem_choices_range", El); + end case; + Prev_El := El; + El := Get_Chain (El); + end loop; + + if Has_Error then + -- Nothing can be done here... + return; + end if; + if Nbr_Pos > 0 and then Nbr_Named > 0 then + -- LRM93 7.3.2.2 + -- Apart from the final element with the single choice OTHERS, the + -- rest (if any) of the element associations of an array aggregate + -- must be either all positionnal or all named. + Error_Msg_Sem + (+Loc, "element associations must be all positional or all named"); + return; + end if; + + -- For a positional aggregate. + if Nbr_Pos > 0 then + -- Check number of elements match, but only if it is possible. + if Get_Type_Staticness (Choice_Type) /= Locally then + return; + end if; + Pos_Max := Eval_Discrete_Type_Length (Choice_Type); + if (not Has_Others and not Is_Sub_Range) + and then Nbr_Pos < Pos_Max + then + Error_Msg_Sem (+Loc, "not enough elements associated"); + elsif Nbr_Pos > Pos_Max then + Error_Msg_Sem (+Loc, "too many elements associated"); + end if; + return; + end if; + + -- Second: + -- Create the list of choices + if Nbr_Named = 0 and then Has_Others then + -- This is only a others association. + return; + end if; + if Staticness /= Locally then + -- Emit a message for aggregrate. The message has already been + -- emitted for a case stmt. + -- FIXME: what about individual associations? + if not Is_Case_Stmt then + -- LRM93 §7.3.2.2 + -- A named association of an array aggregate is allowed to have + -- a choice that is not locally static, or likewise a choice that + -- is a null range, only if the aggregate includes a single + -- element association and the element association has a single + -- choice. + if Nbr_Named > 1 or Has_Others then + Error_Msg_Sem (+Loc, "not static choice exclude others choice"); + end if; + end if; + return; + end if; + + Sem_Check_Continuous_Choices + (Choice_Chain, Choice_Type, Low, High, Loc, Is_Sub_Range); + end Sem_Choices_Range; + + -- Perform semantisation on a (sub)aggregate AGGR, which is of type + -- A_TYPE. + -- return FALSE is case of failure + function Sem_Record_Aggregate (Aggr: Iir_Aggregate; A_Type: Iir) + return boolean + is + El_List : constant Iir_Flist := Get_Elements_Declaration_List (A_Type); + + -- Type of the element. + El_Type : Iir; + + Matches: Iir_Array (0 .. Get_Nbr_Elements (El_List) - 1); + Ok : Boolean; + + -- Add a choice for element REC_EL. + -- Checks the element is not already associated. + -- Checks type of expression is compatible with type of element. + procedure Add_Match (El : Iir; Rec_El : Iir_Element_Declaration) + is + Ass_Type : Iir; + Pos : constant Natural := Natural (Get_Element_Position (Rec_El)); + begin + if Matches (Pos) /= Null_Iir then + Error_Msg_Sem (+El, "%n was already associated", +Matches (Pos)); + Ok := False; + return; + end if; + Matches (Pos) := El; + + -- LRM 7.3.2.1 Record aggregates + -- An element association with more than once choice, [...], is + -- only allowed if the elements specified are all of the same type. + Ass_Type := Get_Type (Rec_El); + if El_Type = Null_Iir then + El_Type := Ass_Type; + elsif Are_Types_Compatible (El_Type, Ass_Type) = Not_Compatible then + Error_Msg_Sem (+El, "elements are not of the same type"); + Ok := False; + end if; + end Add_Match; + + -- Analyze a simple choice: extract the record element corresponding + -- to the expression, and create a choice_by_name. + -- FIXME: should mutate the node. + function Sem_Simple_Choice (Ass : Iir) return Iir + is + Expr : constant Iir := Get_Choice_Expression (Ass); + N_El : Iir; + Aggr_El : Iir_Element_Declaration; + begin + if Get_Kind (Expr) /= Iir_Kind_Simple_Name then + Error_Msg_Sem (+Ass, "element association must be a simple name"); + Ok := False; + return Ass; + end if; + Aggr_El := Find_Name_In_Flist (El_List, Get_Identifier (Expr)); + if Aggr_El = Null_Iir then + Error_Msg_Sem (+Ass, "record has no such element %n", +Ass); + Ok := False; + return Ass; + end if; + Set_Named_Entity (Expr, Aggr_El); + Xref_Ref (Expr, Aggr_El); + + -- Was a choice_by_expression, now by_name. + N_El := Create_Iir (Iir_Kind_Choice_By_Name); + Location_Copy (N_El, Ass); + Set_Choice_Name (N_El, Expr); + Set_Associated_Expr (N_El, Get_Associated_Expr (Ass)); + Set_Associated_Chain (N_El, Get_Associated_Chain (Ass)); + Set_Chain (N_El, Get_Chain (Ass)); + Set_Same_Alternative_Flag (N_El, Get_Same_Alternative_Flag (Ass)); + + Free_Iir (Ass); + Add_Match (N_El, Aggr_El); + return N_El; + end Sem_Simple_Choice; + + Assoc_Chain : Iir; + El, Prev_El : Iir; + Expr: Iir; + Has_Named : Boolean; + Rec_El_Index : Natural; + Expr_Staticness : Iir_Staticness; + + -- True if at least one element constrains the subtype. For unbounded + -- records. + Add_Constraints : Boolean; + begin + -- Not yet handled. + Set_Aggregate_Expand_Flag (Aggr, False); + + Ok := True; + Assoc_Chain := Get_Association_Choices_Chain (Aggr); + Matches := (others => Null_Iir); + Expr_Staticness := Locally; + Add_Constraints := False; + + El_Type := Null_Iir; + Has_Named := False; + Rec_El_Index := 0; + Prev_El := Null_Iir; + El := Assoc_Chain; + while El /= Null_Iir loop + Expr := Get_Associated_Expr (El); + + -- If there is an associated expression with the choice, then the + -- choice is a new alternative, and has no expected type. + if not Get_Same_Alternative_Flag (El) then + pragma Assert (Expr /= Null_Iir); + El_Type := Null_Iir; + end if; + + case Get_Kind (El) is + when Iir_Kind_Choice_By_None => + if Has_Named then + Error_Msg_Sem + (+El, "positional association after named one"); + Ok := False; + elsif Rec_El_Index > Matches'Last then + Error_Msg_Sem (+El, "too many elements"); + exit; + else + Add_Match (El, Get_Nth_Element (El_List, Rec_El_Index)); + Rec_El_Index := Rec_El_Index + 1; + end if; + when Iir_Kind_Choice_By_Expression => + Has_Named := True; + El := Sem_Simple_Choice (El); + -- This creates a choice_by_name, which replaces the + -- choice_by_expression. + if Prev_El = Null_Iir then + Set_Association_Choices_Chain (Aggr, El); + else + Set_Chain (Prev_El, El); + end if; + when Iir_Kind_Choice_By_Others => + Has_Named := True; + if Get_Chain (El) /= Null_Iir then + Error_Msg_Sem + (+El, "choice others must be the last alternative"); + end if; + declare + Found : Boolean := False; + begin + for I in Matches'Range loop + if Matches (I) = Null_Iir then + Add_Match (El, Get_Nth_Element (El_List, I)); + Found := True; + end if; + end loop; + if not Found then + Error_Msg_Sem (+El, "no element for choice others"); + Ok := False; + end if; + end; + when others => + Error_Kind ("sem_record_aggregate", El); + end case; + + -- Analyze the expression associated. + if not Get_Same_Alternative_Flag (El) then + if El_Type /= Null_Iir then + -- Analyze the expression only if the choice is correct. + Expr := Sem_Expression (Expr, El_Type); + if Expr /= Null_Iir then + Set_Associated_Expr (El, Eval_Expr_If_Static (Expr)); + Expr_Staticness := Min (Expr_Staticness, + Get_Expr_Staticness (Expr)); + if not Add_Constraints + and then Is_Fully_Constrained_Type (Get_Type (Expr)) + and then not Is_Fully_Constrained_Type (El_Type) + then + Add_Constraints := True; + end if; + else + Ok := False; + end if; + else + -- This case is not possible unless there is an error. + pragma Assert (not Ok); + null; + end if; + end if; + + Prev_El := El; + El := Get_Chain (El); + end loop; + + -- Check for missing associations. + for I in Matches'Range loop + if Matches (I) = Null_Iir then + Error_Msg_Sem + (+Aggr, "no value for %n", +Get_Nth_Element (El_List, I)); + Ok := False; + end if; + end loop; + Set_Expr_Staticness (Aggr, Min (Get_Expr_Staticness (Aggr), + Expr_Staticness)); + + if Ok and Add_Constraints then + declare + Rec_Type : Iir; + Rec_El_List : Iir_Flist; + Rec_El : Iir; + Rec_El_Type : Iir; + New_Rec_El : Iir; + Constraint : Iir_Constraint; + Composite_Found : Boolean; + Staticness : Iir_Staticness; + begin + Rec_Type := Sem_Types.Copy_Subtype_Indication (Get_Type (Aggr)); + Rec_El_List := Get_Elements_Declaration_List (Rec_Type); + Constraint := Fully_Constrained; + Composite_Found := False; + Staticness := Locally; + for I in Flist_First .. Flist_Last (El_List) loop + El := Matches (I); + El_Type := Get_Type (Get_Associated_Expr (El)); + Rec_El := Get_Nth_Element (Rec_El_List, I); + Rec_El_Type := Get_Type (Rec_El); + if Is_Fully_Constrained_Type (El_Type) + and then not Is_Fully_Constrained_Type (Rec_El_Type) + then + Rec_El_Type := El_Type; + New_Rec_El := + Create_Iir (Iir_Kind_Record_Element_Constraint); + Location_Copy (New_Rec_El, Rec_El); + Set_Parent (New_Rec_El, Rec_Type); + Set_Identifier (New_Rec_El, Get_Identifier (Rec_El)); + pragma Assert (I = Natural (Get_Element_Position (Rec_El))); + Set_Element_Position (New_Rec_El, Iir_Index32 (I)); + Set_Nth_Element (Rec_El_List, I, New_Rec_El); + Set_Type (New_Rec_El, Rec_El_Type); + Append_Owned_Element_Constraint (Rec_Type, New_Rec_El); + end if; + Staticness := Min (Staticness, + Get_Type_Staticness (Rec_El_Type)); + Sem_Types.Update_Record_Constraint + (Constraint, Composite_Found, Rec_El_Type); + end loop; + Set_Type_Staticness (Rec_Type, Staticness); + Set_Constraint_State (Rec_Type, Constraint); + Set_Type (Aggr, Rec_Type); + Set_Literal_Subtype (Aggr, Rec_Type); + end; + end if; + + return Ok; + end Sem_Record_Aggregate; + + -- Information for each dimension of an aggregate. + type Array_Aggr_Info is record + -- False if one sub-aggregate has no others choices. + -- If FALSE, the dimension is constrained. + Has_Others : Boolean := True; + + -- True if one sub-aggregate is by named/by position. + Has_Named : Boolean := False; + + -- True if one sub-aggregate is dynamic. + Has_Dynamic : Boolean := False; + + -- LOW and HIGH limits for the dimension. + Low : Iir := Null_Iir; + High : Iir := Null_Iir; + + -- Minimum length of the dimension. This is a minimax. + Min_Length : Natural := 0; + + -- If not NULL_IIR, this is the bounds of the dimension. + -- If every dimension has bounds, then the aggregate is constrained. + Index_Subtype : Iir := Null_Iir; + + -- Number of associations in last-level (not for sub-aggregate). This + -- is used only to decide whether or not a static aggregate can be + -- expanded. + Nbr_Assocs : Natural := 0; + + -- True if there is an error. + Error : Boolean := False; + + -- True if one element doesn't match the bounds. + Has_Bound_Error : Boolean := False; + end record; + + type Array_Aggr_Info_Arr is array (Natural range <>) of Array_Aggr_Info; + + procedure Sem_Array_Aggregate_Elements + (Aggr : Iir; + A_Type : Iir; + Expr_Staticness : in out Iir_Staticness; + Info : in out Array_Aggr_Info) + is + Element_Type : constant Iir := Get_Element_Subtype (A_Type); + El : Iir; + El_Expr : Iir; + Expr : Iir; + El_Staticness : Iir_Staticness; + Assoc_Chain : Iir; + Res_Type : Iir; + + -- True if the type of the expression is the type of the aggregate. + Is_Array : Boolean; + + -- Null_Iir if the type of aggregagte elements myst be of the element + -- type. + Elements_Types : Iir; + Elements_Types_List : Iir_List; + begin + -- LRM93 7.3.2.2 Array aggregates + -- [...] the expression of each element association must be of the + -- element type. + + -- LRM08 9.3.3.3 Array aggregates + -- For an aggregate of a one-dimensional array type, [each choice shall + -- specify values of the index type], and the expression of each element + -- association shall be of either the element type or the type of the + -- aggregate. + if Flags.Vhdl_Std >= Vhdl_08 + and then Is_One_Dimensional_Array_Type (A_Type) + then + Elements_Types_List := Create_Iir_List; + Append_Element (Elements_Types_List, Element_Type); + Append_Element (Elements_Types_List, Get_Base_Type (A_Type)); + Elements_Types := Create_Overload_List (Elements_Types_List); + else + Elements_Types := Null_Iir; + end if; + + Assoc_Chain := Get_Association_Choices_Chain (Aggr); + + El := Assoc_Chain; + while El /= Null_Iir loop + if not Get_Same_Alternative_Flag (El) then + El_Expr := Get_Associated_Expr (El); + Is_Array := False; + + -- Directly analyze the expression with the type of the element + -- if it cannot be the type of the aggregate. + -- In VHDL-2008, also do it when the expression is an aggregate. + -- This is not in the LRM, but otherwise this would create a lot + -- of ambiguities when the element type is a composite type. Eg: + -- + -- type time_unit is record + -- val : time; + -- name : string (1 to 3); + -- end record; + -- type time_names_type is array (1 to 2) of time_unit; + -- constant time_names : time_names_type := + -- ((fs, "fs "), (ps, "ps ")); + -- + -- The type of the first sub-aggregate could be either time_unit + -- or time_names_type. Because it's determined by the context, + -- it is ambiguous. But there is no point in using aggregates + -- to specify a range of choices. + -- FIXME: fix LRM ? + if Elements_Types = Null_Iir + or else Get_Kind (El_Expr) = Iir_Kind_Aggregate + then + Expr := Sem_Expression (El_Expr, Element_Type); + else + Expr := Sem_Expression_Wildcard (El_Expr, Null_Iir); + if Expr /= Null_Iir then + Res_Type := Compatible_Types_Intersect + (Get_Type (Expr), Elements_Types); + if Res_Type = Null_Iir then + Error_Msg_Sem + (+Get_Associated_Expr (El), + "type of element not compatible with the " + & "expected type"); + Set_Type (El_Expr, Error_Type); + Expr := Null_Iir; + elsif Is_Overload_List (Res_Type) then + Error_Msg_Sem + (+Expr, "type of element is ambiguous"); + Free_Overload_List (Res_Type); + Set_Type (El_Expr, Error_Type); + Expr := Null_Iir; + else + pragma Assert (Is_Defined_Type (Res_Type)); + Is_Array := + Get_Base_Type (Res_Type) = Get_Base_Type (A_Type); + Expr := Sem_Expression_Wildcard (Expr, Res_Type); + end if; + end if; + end if; + + if Expr /= Null_Iir then + El_Staticness := Get_Expr_Staticness (Expr); + Expr := Eval_Expr_If_Static (Expr); + Set_Associated_Expr (El, Expr); + + if not Is_Static_Construct (Expr) then + Set_Aggregate_Expand_Flag (Aggr, False); + end if; + + if not Is_Array + and then not Eval_Is_In_Bound (Expr, Element_Type) + then + Info.Has_Bound_Error := True; + Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, + "element is out of the bounds"); + end if; + + Expr_Staticness := Min (Expr_Staticness, El_Staticness); + + Info.Nbr_Assocs := Info.Nbr_Assocs + 1; + else + Info.Error := True; + end if; + end if; + + Set_Element_Type_Flag (El, not Is_Array); + + if Is_Array then + -- LRM08 9.3.3.3 Array aggregates + -- If the type of the expression of an element association + -- is the type of the aggregate, then either the element + -- association shall be positional or the choice shall be + -- a discrete range. + + -- GHDL: must be checked for all associations, so do it outside + -- the above 'if' statement. + -- GHDL: improve error message. + case Get_Kind (El) is + when Iir_Kind_Choice_By_None + | Iir_Kind_Choice_By_Range => + null; + when Iir_Kind_Choice_By_Others => + Error_Msg_Sem + (+El, "expression for 'others' must be an element"); + when others => + Error_Msg_Sem + (+El, "positional association or " + & "discrete range choice required"); + end case; + end if; + + El := Get_Chain (El); + end loop; + + if Elements_Types /= Null_Iir then + Free_Overload_List (Elements_Types); + end if; + end Sem_Array_Aggregate_Elements; + + -- Analyze an array aggregate AGGR of *base type* A_TYPE. + -- The type of the array is computed into A_SUBTYPE. + -- DIM is the dimension index in A_TYPE. + -- Return FALSE in case of error. + procedure Sem_Array_Aggregate_1 (Aggr: Iir; + A_Type: Iir; + Infos : in out Array_Aggr_Info_Arr; + Constrained : Boolean; + Dim: Natural) + is + Index_List : constant Iir_Flist := Get_Index_Subtype_List (A_Type); + + -- Type of the index (this is also the type of the choices). + Index_Type : constant Iir := Get_Index_Type (Index_List, Dim - 1); + + Assoc_Chain : Iir; + Choice: Iir; + Is_Positional: Tri_State_Type; + Has_Positional_Choice: Boolean; + Low, High : Iir; + Has_Others : Boolean; + + Len : Natural; + + Index_Subtype_Constraint : Iir_Range_Expression; + Index_Constraint : Iir_Range_Expression; -- FIXME: 'range. + Dir : Iir_Direction; + Choice_Staticness : Iir_Staticness; + Len_Staticness : Iir_Staticness; + Expr_Staticness : Iir_Staticness; + + Info : Array_Aggr_Info renames Infos (Dim); + begin + -- Analyze aggregate elements. + if Constrained then + Expr_Staticness := Get_Type_Staticness (Index_Type); + if Expr_Staticness /= Locally then + -- Cannot be statically built as the bounds are not known and + -- must be checked at run-time. + Set_Aggregate_Expand_Flag (Aggr, False); + end if; + else + Expr_Staticness := Locally; + end if; + + if Dim = Get_Nbr_Elements (Index_List) then + -- A type has been found for AGGR, analyze AGGR as if it was + -- an aggregate with a subtype (and not a string). + if Get_Kind (Aggr) = Iir_Kind_Aggregate then + Sem_Array_Aggregate_Elements (Aggr, A_Type, Expr_Staticness, Info); + else + -- Nothing to do for a string. + null; + end if; + else + -- A sub-aggregate: recurse. + declare + Sub_Aggr : Iir; + begin + -- Here we know that AGGR is an aggregate because: + -- * either this is the first call (ie DIM = 1) and therefore + -- AGGR is an aggregate (an aggregate is being analyzed). + -- * or DIM > 1 and the use of strings is checked (just bellow). + Assoc_Chain := Get_Association_Choices_Chain (Aggr); + Choice := Assoc_Chain; + while Choice /= Null_Iir loop + if not Get_Same_Alternative_Flag (Choice) then + Sub_Aggr := Get_Associated_Expr (Choice); + case Get_Kind (Sub_Aggr) is + when Iir_Kind_Aggregate => + Sem_Array_Aggregate_1 + (Sub_Aggr, A_Type, Infos, Constrained, Dim + 1); + if not Get_Aggregate_Expand_Flag (Sub_Aggr) then + Set_Aggregate_Expand_Flag (Aggr, False); + end if; + when Iir_Kind_String_Literal8 => + if Dim + 1 = Get_Nbr_Elements (Index_List) then + Sem_Array_Aggregate_1 + (Sub_Aggr, A_Type, Infos, Constrained, Dim + 1); + else + Error_Msg_Sem + (+Sub_Aggr, "string literal not allowed here"); + Infos (Dim + 1).Error := True; + end if; + when others => + Error_Msg_Sem (+Sub_Aggr, "sub-aggregate expected"); + Infos (Dim + 1).Error := True; + end case; + end if; + + -- Always true for a sub-aggregate. + Set_Element_Type_Flag (Choice, True); + + Choice := Get_Chain (Choice); + end loop; + end; + end if; + Set_Expr_Staticness + (Aggr, Min (Expr_Staticness, Get_Expr_Staticness (Aggr))); + + -- Analyze choices. + Len_Staticness := Locally; + case Get_Kind (Aggr) is + when Iir_Kind_Aggregate => + Assoc_Chain := Get_Association_Choices_Chain (Aggr); + Sem_Choices_Range (Assoc_Chain, Index_Type, Low, High, + Get_Location (Aggr), not Constrained, False); + Set_Association_Choices_Chain (Aggr, Assoc_Chain); + + -- Update infos. + if Low /= Null_Iir + and then (Info.Low = Null_Iir + or else Eval_Pos (Low) < Eval_Pos (Info.Low)) + then + Info.Low := Low; + end if; + if High /= Null_Iir + and then (Info.High = Null_Iir + or else Eval_Pos (High) > Eval_Pos (Info.High)) + then + Info.High := High; + end if; + + -- Determine if the aggregate is positionnal or named; + -- and compute choice staticness. + Is_Positional := Unknown; + Choice_Staticness := Locally; + Has_Positional_Choice := False; + Has_Others := False; + Len := 0; + Choice := Assoc_Chain; + while Choice /= Null_Iir loop + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Range + | Iir_Kind_Choice_By_Expression => + Is_Positional := False; + Choice_Staticness := + Iirs.Min (Choice_Staticness, + Get_Choice_Staticness (Choice)); + -- FIXME: not true for range. + Len := Len + 1; + when Iir_Kind_Choice_By_None => + Has_Positional_Choice := True; + if Get_Element_Type_Flag (Choice) then + Len := Len + 1; + else + -- Extract length from associated expression. + declare + -- Always has an associated expr, as not named. + Expr : constant Iir := Get_Associated_Expr (Choice); + Expr_Type : constant Iir := Get_Type (Expr); + Expr_Index : Iir; + Index_Staticness : Iir_Staticness; + begin + if not Is_Error (Expr_Type) then + Expr_Index := Get_Index_Type (Expr_Type, 0); + Index_Staticness := + Get_Type_Staticness (Expr_Index); + case Index_Staticness is + when Locally => + Len := Len + Natural + (Eval_Discrete_Type_Length (Expr_Index)); + when Globally | None => + Len_Staticness := Iirs.Min + (Len_Staticness, Index_Staticness); + when Unknown => + -- Must have been caught by Is_Error. + raise Internal_Error; + end case; + end if; + end; + end if; + when Iir_Kind_Choice_By_Others => + if not Constrained then + Error_Msg_Sem (+Aggr, "'others' choice not allowed " + & "for an aggregate in this context"); + Infos (Dim).Error := True; + return; + end if; + Has_Others := True; + when others => + Error_Kind ("sem_array_aggregate", Choice); + end case; + -- LRM93 7.3.2.2 + -- Apart from the final element with the single choice + -- OTHERS, the rest (if any) of the element + -- associations of an array aggregate must be either + -- all positionnal or all named. + if Has_Positional_Choice then + if Is_Positional = False then + -- The error has already been emited + -- by sem_choices_range. + Infos (Dim).Error := True; + return; + end if; + Is_Positional := True; + end if; + Choice := Get_Chain (Choice); + end loop; + + Info.Min_Length := Integer'Max (Info.Min_Length, Len); + + if Choice_Staticness = Unknown then + -- This is possible when a choice is erroneous. + Infos (Dim).Error := True; + return; + end if; + + when Iir_Kind_String_Literal8 => + Len := Sem_String_Literal + (Aggr, Get_Base_Type (Get_Element_Subtype (A_Type))); + Assoc_Chain := Null_Iir; + Info.Min_Length := Integer'Max (Info.Min_Length, Len); + Is_Positional := True; + Has_Others := False; + Choice_Staticness := Locally; + Info.Nbr_Assocs := Info.Nbr_Assocs + Len; + + when others => + Error_Kind ("sem_array_aggregate(1)", Aggr); + end case; + + if Is_Positional = False then + Info.Has_Named := True; + end if; + if not Has_Others then + Info.Has_Others := False; + end if; + + -- LRM93 7.3.2.2 + -- A named association of an array aggregate is allowed to have a choice + -- that is not locally static, [or likewise a choice that is a null + -- range], only if the aggregate includes a single element association + -- and this element association has a single choice. + if Is_Positional = False and then Choice_Staticness /= Locally then + Choice := Assoc_Chain; + if not Is_Chain_Length_One (Assoc_Chain) or else + (Get_Kind (Choice) /= Iir_Kind_Choice_By_Expression + and then Get_Kind (Choice) /= Iir_Kind_Choice_By_Range) + then + Error_Msg_Sem (+Aggr, "non-locally static choice for an aggregate " + & "is allowed only if only choice"); + Infos (Dim).Error := True; + return; + end if; + Info.Has_Dynamic := True; + Set_Aggregate_Expand_Flag (Aggr, False); + end if; + + -- Compute bounds of the index if there is no index subtype. + if Info.Index_Subtype = Null_Iir and then Has_Others = False then + -- LRM93 7.3.2.2 + -- the direction of the index subtype of the aggregate is that of the + -- index subtype of the base type of the aggregate. + + if Is_Positional = True then + -- LRM93 7.3.2.2 + -- For a positionnal aggregate, [...] the leftmost bound is given + -- by S'LEFT where S is the index subtype of the base type of the + -- array; [...] the rightmost bound is determined by the direction + -- of the index subtype and the number of element. + if Get_Type_Staticness (Index_Type) = Locally + and then Len_Staticness = Locally + then + Info.Index_Subtype := Create_Range_Subtype_By_Length + (Index_Type, Iir_Int64 (Len), Get_Location (Aggr)); + end if; + else + -- Create an index subtype. + case Get_Kind (Index_Type) is + when Iir_Kind_Integer_Subtype_Definition => + Info.Index_Subtype := + Create_Iir (Iir_Kind_Integer_Subtype_Definition); + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + Info.Index_Subtype := + Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); + when others => + Error_Kind ("sem_array_aggregate(2)", Index_Type); + end case; + Location_Copy (Info.Index_Subtype, Aggr); + Set_Base_Type (Info.Index_Subtype, Get_Base_Type (Index_Type)); + Index_Constraint := Get_Range_Constraint (Index_Type); + + -- LRM93 7.3.2.2 + -- If the aggregate appears in one of the above contexts, then the + -- direction of the index subtype of the aggregate is that of the + -- corresponding constrained array subtype; [...] + Index_Subtype_Constraint := Create_Iir (Iir_Kind_Range_Expression); + Location_Copy (Index_Subtype_Constraint, Aggr); + Set_Range_Constraint + (Info.Index_Subtype, Index_Subtype_Constraint); + Set_Type_Staticness (Info.Index_Subtype, Choice_Staticness); + Set_Expr_Staticness (Index_Subtype_Constraint, Choice_Staticness); + Set_Type (Index_Subtype_Constraint, Index_Type); + if Get_Kind (Index_Constraint) = Iir_Kind_Range_Expression then + Dir := Get_Direction (Index_Constraint); + else + -- This is not correct, as the direction must be the one of + -- the corresponding constraint. But it may not be determined + -- at analysis time (if 'Range), and it doesn't really matter + -- because of implicit subtype conversion. So choose one + -- arbitrary direction. + Dir := Iir_To; + end if; + + -- LRM93 7.3.2.2 + -- For an aggregate that has named associations, the leftmost and + -- the rightmost bounds are determined by the direction of the + -- index subtype of the aggregate and the smallest and largest + -- choice given. + if Choice_Staticness = Locally then + if Low = Null_Iir or High = Null_Iir then + -- Avoid error propagation. + Set_Range_Constraint (Info.Index_Subtype, + Get_Range_Constraint (Index_Type)); + Free_Iir (Index_Subtype_Constraint); + else + Set_Direction (Index_Subtype_Constraint, Dir); + case Dir is + when Iir_To => + Set_Left_Limit (Index_Subtype_Constraint, Low); + Set_Right_Limit (Index_Subtype_Constraint, High); + when Iir_Downto => + Set_Left_Limit (Index_Subtype_Constraint, High); + Set_Right_Limit (Index_Subtype_Constraint, Low); + end case; + end if; + else + -- Dynamic aggregate. + Set_Aggregate_Expand_Flag (Aggr, False); + + declare + -- There is only one choice. + Choice : constant Iir := Assoc_Chain; + Expr : Iir; + begin + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Expression => + Expr := Get_Choice_Expression (Choice); + Set_Direction (Index_Subtype_Constraint, Dir); + Set_Left_Limit (Index_Subtype_Constraint, Expr); + Set_Right_Limit (Index_Subtype_Constraint, Expr); + when Iir_Kind_Choice_By_Range => + Expr := Get_Choice_Range (Choice); + Set_Range_Constraint (Info.Index_Subtype, Expr); + Set_Is_Ref (Info.Index_Subtype, True); + -- FIXME: avoid allocation-free. + Free_Iir (Index_Subtype_Constraint); + when others => + raise Internal_Error; + end case; + end; + end if; + end if; + --Set_Type_Staticness + -- (A_Subtype, Iirs.Min (Get_Type_Staticness (A_Subtype), + -- Get_Type_Staticness (Index_Subtype))); + --Append_Element (Get_Index_List (A_Subtype), Index_Subtype); + elsif Has_Others = False then + -- Check the subaggregate bounds are the same. + if Is_Positional = True then + if Eval_Pos (Eval_Discrete_Range_Left (Get_Range_Constraint + (Info.Index_Subtype))) + /= Eval_Pos (Eval_Discrete_Range_Left (Get_Range_Constraint + (Index_Type))) + then + Error_Msg_Sem (+Aggr, "subaggregate bounds mismatch"); + else + if Eval_Discrete_Type_Length (Info.Index_Subtype) + /= Iir_Int64 (Len) + then + Error_Msg_Sem (+Aggr, "subaggregate length mismatch"); + end if; + end if; + else + declare + L, H : Iir; + begin + Get_Low_High_Limit + (Get_Range_Constraint (Info.Index_Subtype), L, H); + if Eval_Pos (L) /= Eval_Pos (Low) + or else Eval_Pos (H) /= Eval_Pos (H) + then + Error_Msg_Sem (+Aggr, "subagregate bounds mismatch"); + end if; + end; + end if; + end if; + + Expr_Staticness := Min (Get_Expr_Staticness (Aggr), Choice_Staticness); + Set_Expr_Staticness (Aggr, Expr_Staticness); + end Sem_Array_Aggregate_1; + + -- Analyze an array aggregate whose type is AGGR_TYPE. + -- If CONSTRAINED is true, then the aggregate appears in one of the + -- context and can have an 'others' choice. + -- If CONSTRAINED is false, the aggregate can not have an 'others' choice. + -- Create a subtype for this aggregate. + -- Return NULL_IIR in case of error, or AGGR if not. + function Sem_Array_Aggregate + (Aggr : Iir; Aggr_Type : Iir; Constrained : Boolean) return Iir + is + A_Subtype: Iir; + Base_Type : Iir; + Index_List : constant Iir_Flist := Get_Index_Subtype_List (Aggr_Type); + Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); + Infos : Array_Aggr_Info_Arr (1 .. Nbr_Dim); + Aggr_Constrained : Boolean; + Info, Prev_Info : Iir_Aggregate_Info; + Type_Staticness : Iir_Staticness; + begin + -- By default, consider the aggregate can be statically built. + Set_Aggregate_Expand_Flag (Aggr, True); + + -- Analyze the aggregate. + Sem_Array_Aggregate_1 (Aggr, Aggr_Type, Infos, Constrained, 1); + + Aggr_Constrained := True; + for I in Infos'Range loop + -- Return now in case of error. + if Infos (I).Error then + Set_Aggregate_Expand_Flag (Aggr, False); + return Null_Iir; + end if; + if Infos (I).Index_Subtype = Null_Iir then + Aggr_Constrained := False; + end if; + end loop; + Base_Type := Get_Base_Type (Aggr_Type); + + -- Reuse AGGR_TYPE iff AGGR_TYPE is fully constrained + -- and statically match the subtype of the aggregate. + if Aggr_Constrained then + Type_Staticness := Locally; + for I in Infos'Range loop + Type_Staticness := Min + (Type_Staticness, Get_Type_Staticness (Infos (I).Index_Subtype)); + end loop; + + if Get_Constraint_State (Aggr_Type) = Fully_Constrained + and then Get_Type_Staticness (Aggr_Type) = Locally + and then Type_Staticness = Locally + then + Set_Type (Aggr, Aggr_Type); + else + A_Subtype := Create_Array_Subtype (Base_Type, Get_Location (Aggr)); + -- FIXME: extract element subtype ? + Set_Element_Subtype (A_Subtype, Get_Element_Subtype (Aggr_Type)); + Type_Staticness := Min (Type_Staticness, + Get_Type_Staticness (A_Subtype)); + for I in Infos'Range loop + Set_Nth_Element (Get_Index_Subtype_List (A_Subtype), I - 1, + Infos (I).Index_Subtype); + end loop; + Set_Type_Staticness (A_Subtype, Type_Staticness); + Set_Index_Constraint_Flag (A_Subtype, True); + -- FIXME: the element can be unconstrained. + Set_Constraint_State (A_Subtype, Fully_Constrained); + Set_Type (Aggr, A_Subtype); + Set_Literal_Subtype (Aggr, A_Subtype); + end if; + if Type_Staticness = Locally and then Get_Aggregate_Expand_Flag (Aggr) + then + -- Compute ratio of elements vs size of the aggregate to determine + -- if the aggregate can be expanded. + declare + Size : Iir_Int64; + begin + Size := 1; + for I in Infos'Range loop + Size := Size + * Eval_Discrete_Type_Length (Infos (I).Index_Subtype); + end loop; + Set_Aggregate_Expand_Flag + (Aggr, Infos (Nbr_Dim).Nbr_Assocs >= Natural (Size / 10)); + end; + else + Set_Aggregate_Expand_Flag (Aggr, False); + end if; + else + -- Free unused indexes subtype. + for I in Infos'Range loop + declare + St : constant Iir := Infos (I).Index_Subtype; + Rng : Iir; + begin + if St /= Null_Iir then + Rng := Get_Range_Constraint (St); + Free_Iir (Get_Right_Limit_Expr (Rng)); + Free_Iir (Rng); + Free_Iir (St); + end if; + end; + end loop; + + -- If bounds are not known, the aggregate cannot be statically built. + Set_Aggregate_Expand_Flag (Aggr, False); + end if; + + if Infos (Nbr_Dim).Has_Bound_Error then + return Build_Overflow (Aggr, Get_Type (Aggr)); + end if; + + Prev_Info := Null_Iir; + for I in Infos'Range loop + -- Create info and link. + Info := Create_Iir (Iir_Kind_Aggregate_Info); + if I = 1 then + Set_Aggregate_Info (Aggr, Info); + else + Set_Sub_Aggregate_Info (Prev_Info, Info); + end if; + Prev_Info := Info; + + -- Fill info. + Set_Aggr_Dynamic_Flag (Info, Infos (I).Has_Dynamic); + Set_Aggr_Named_Flag (Info, Infos (I).Has_Named); + Set_Aggr_Low_Limit (Info, Infos (I).Low); + Set_Aggr_High_Limit (Info, Infos (I).High); + Set_Aggr_Min_Length (Info, Iir_Int32 (Infos (I).Min_Length)); + Set_Aggr_Others_Flag (Info, Infos (I).Has_Others); + end loop; + return Aggr; + end Sem_Array_Aggregate; + + -- Analyze aggregate EXPR whose type is expected to be A_TYPE. + -- A_TYPE cannot be null_iir (this case is handled in sem_expression_ov) + -- If FORCE_CONSTRAINED is true, the aggregate type is constrained by the + -- context, even if its type isn't. This is to deal with cases like: + -- procedure set (v : out string) is + -- begin + -- v := (others => ' '); + -- end set; + -- but this is not allowed by: + -- LRM08 9.3.3.3 Array aggregates + -- e) As a value expression in an assignment statement, where the target + -- is a declared object (or member thereof), and either the subtype of + -- the target is a fully constrained array subtype or the target is a + -- slice name. + function Sem_Aggregate + (Expr: Iir_Aggregate; A_Type: Iir; Force_Constrained : Boolean) + return Iir_Aggregate + is + Force_Constrained2 : constant Boolean := + Force_Constrained and Flag_Relaxed_Rules; + begin + pragma Assert (A_Type /= Null_Iir); + + if Flags.Vhdl_Std >= Vhdl_08 then + -- An aggregate can be a locally static primary according to LRM08 + -- 9.4.2 Locally static primaries l) and m). + Set_Expr_Staticness (Expr, Locally); + else + -- An aggregate is at most globally static. + Set_Expr_Staticness (Expr, Globally); + end if; + + Set_Type (Expr, A_Type); -- FIXME: should free old type + case Get_Kind (A_Type) is + when Iir_Kind_Array_Subtype_Definition => + return Sem_Array_Aggregate + (Expr, A_Type, + Force_Constrained2 or else Get_Index_Constraint_Flag (A_Type)); + when Iir_Kind_Array_Type_Definition => + return Sem_Array_Aggregate (Expr, A_Type, Force_Constrained2); + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + if not Sem_Record_Aggregate (Expr, A_Type) then + return Null_Iir; + end if; + return Expr; + when Iir_Kind_Error => + return Null_Iir; + when others => + Error_Msg_Sem (+Expr, "type %n is not composite", +A_Type); + return Null_Iir; + end case; + end Sem_Aggregate; + + function Is_Physical_Literal_Zero (Lit : Iir) return Boolean is + begin + case Iir_Kinds_Physical_Literal (Get_Kind (Lit)) is + when Iir_Kind_Physical_Int_Literal => + return Get_Value (Lit) = 0; + when Iir_Kind_Physical_Fp_Literal => + return Get_Fp_Value (Lit) = 0.0; + end case; + end Is_Physical_Literal_Zero; + + -- Transform LIT into a physical_literal. + -- LIT can be either a not analyzed physical literal or + -- a simple name that is a physical unit. In the later case, a physical + -- literal is created. + function Sem_Physical_Literal (Lit: Iir) return Iir + is + Unit_Name : Iir; + Unit : Iir; + Unit_Type : Iir; + Res: Iir; + begin + case Get_Kind (Lit) is + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal => + Unit_Name := Get_Unit_Name (Lit); + Res := Lit; + when Iir_Kinds_Denoting_Name => + Res := Create_Iir (Iir_Kind_Physical_Int_Literal); + Location_Copy (Res, Lit); + Set_Value (Res, 1); + Set_Literal_Origin (Res, Lit); + Unit_Name := Lit; + when others => + Error_Kind ("sem_physical_literal", Lit); + end case; + if Is_Error (Unit_Name) then + return Create_Error_Expr (Res, Error_Mark); + end if; + + Unit_Name := Sem_Denoting_Name (Unit_Name); + Unit := Get_Named_Entity (Unit_Name); + if Get_Kind (Unit) /= Iir_Kind_Unit_Declaration then + if not Is_Error (Unit) then + Error_Class_Match (Unit_Name, "unit"); + end if; + Set_Named_Entity (Unit_Name, Create_Error_Name (Unit_Name)); + else + -- Physical unit is used. + Set_Use_Flag (Unit, True); + + if Get_Type (Unit) = Time_Type_Definition + and then Get_Value (Get_Physical_Literal (Unit)) = 0 + and then not Is_Physical_Literal_Zero (Res) + then + -- LRM08 5.2.4.2 Predefined physical types + -- It is an error if a given unit of type TIME appears anywhere + -- within the design hierarchy defining a model to be elaborated, + -- and if the position number of that unit is less than that of + -- the secondary unit selected as the resolution limit for type + -- TIME during the elaboration of the model, unless that unit is + -- part of a physical literal whose abstract literal is either + -- the integer value zero or the floating-point value zero. + Error_Msg_Sem + (+Res, "physical unit %i is below the time resolution", +Unit); + end if; + end if; + Set_Unit_Name (Res, Unit_Name); + Set_Physical_Unit (Res, Get_Named_Entity (Unit_Name)); + Unit_Type := Get_Type (Unit_Name); + Set_Type (Res, Unit_Type); + + -- LRM93 7.4.2 + -- 1. a literal of type TIME. + -- + -- LRM93 7.4.1 + -- 1. a literal of any type other than type TIME; + Set_Expr_Staticness (Res, Get_Expr_Staticness (Unit_Name)); + --Eval_Check_Constraints (Res); + return Res; + end Sem_Physical_Literal; + + -- Analyze an allocator by expression or an allocator by subtype. + function Sem_Allocator (Expr : Iir; A_Type : Iir) return Iir + is + Arg: Iir; + Arg_Type : Iir; + begin + Set_Expr_Staticness (Expr, None); + + Arg_Type := Get_Allocator_Designated_Type (Expr); + + if Arg_Type = Null_Iir then + -- Expression was not analyzed. + case Iir_Kinds_Allocator (Get_Kind (Expr)) is + when Iir_Kind_Allocator_By_Expression => + Arg := Get_Expression (Expr); + pragma Assert (Get_Kind (Arg) = Iir_Kind_Qualified_Expression); + Arg := Sem_Expression (Arg, Null_Iir); + if Arg = Null_Iir then + return Null_Iir; + end if; + Check_Read (Arg); + Set_Expression (Expr, Arg); + Arg_Type := Get_Type (Arg); + + when Iir_Kind_Allocator_By_Subtype => + -- Analyze subtype indication. + Arg := Get_Subtype_Indication (Expr); + Arg := Sem_Types.Sem_Subtype_Indication (Arg); + Set_Subtype_Indication (Expr, Arg); + Arg := Get_Type_Of_Subtype_Indication (Arg); + if Arg = Null_Iir or else Is_Error (Arg) then + return Null_Iir; + end if; + if Is_Anonymous_Type_Definition (Arg) then + Set_Allocator_Subtype (Expr, Get_Subtype_Indication (Expr)); + end if; + + -- LRM93 7.3.6 + -- If an allocator includes a subtype indication and if the + -- type of the object created is an array type, then the + -- subtype indication must either denote a constrained + -- subtype or include an explicit index constraint. + if not Is_Fully_Constrained_Type (Arg) then + Error_Msg_Sem + (+Expr, "allocator of unconstrained %n is not allowed", + +Arg); + end if; + -- LRM93 7.3.6 + -- A subtype indication that is part of an allocator must + -- not include a resolution function. + if Is_Anonymous_Type_Definition (Arg) + and then Get_Kind (Arg) /= Iir_Kind_Access_Subtype_Definition + and then Get_Resolution_Indication (Arg) /= Null_Iir + then + Error_Msg_Sem (+Expr, "subtype indication must not include" + & " a resolution function"); + end if; + Arg_Type := Arg; + end case; + Set_Allocator_Designated_Type (Expr, Arg_Type); + end if; + + -- LRM 7.3.6 Allocators + -- The type of the access value returned by an allocator must be + -- determinable solely from the context, but using the fact that the + -- value returned is of an access type having the named designated + -- type. + if A_Type = Null_Iir then + -- Type of the context is not yet known. + return Expr; + else + if not Is_Allocator_Type (A_Type, Expr) then + if Get_Kind (A_Type) /= Iir_Kind_Access_Type_Definition then + if Get_Kind (A_Type) /= Iir_Kind_Error then + Error_Msg_Sem (+Expr, "expected type is not an access type"); + end if; + else + Error_Not_Match (Expr, A_Type); + end if; + return Null_Iir; + end if; + Set_Type (Expr, A_Type); + return Expr; + end if; + end Sem_Allocator; + + function Sem_Qualified_Expression (Expr : Iir; A_Type : Iir) return Iir + is + N_Type: Iir; + Res: Iir; + begin + N_Type := Sem_Type_Mark (Get_Type_Mark (Expr)); + Set_Type_Mark (Expr, N_Type); + N_Type := Get_Type (N_Type); + Set_Type (Expr, N_Type); + if A_Type /= Null_Iir + and then Are_Types_Compatible (A_Type, N_Type) = Not_Compatible + then + Error_Not_Match (Expr, A_Type); + return Null_Iir; + end if; + Res := Sem_Expression (Get_Expression (Expr), N_Type); + if Res = Null_Iir then + return Null_Iir; + end if; + Check_Read (Res); + Set_Expression (Expr, Res); + + -- LRM93 7.4.1 Locally static primaries + -- h) A qualified expression whose operand is a locally static + -- expression. + -- + -- LRM08 9.4.2 Locally static primaries + -- i) A qualified expression whose type mark denotes a locally static + -- subtype and whose operand is a locally static expression. + -- + -- We always use the vhdl08, because it is weird to have locally + -- static expression with a non-locally static subtype. + Set_Expr_Staticness (Expr, Min (Get_Expr_Staticness (Res), + Get_Type_Staticness (N_Type))); + + -- When possible, use the type of the expression as the type of the + -- qualified expression. + -- TODO: also handle unbounded subtypes, but only if this is a proper + -- subtype. + case Get_Kind (N_Type) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Record_Type_Definition => + Set_Type (Expr, Get_Type (Res)); + when others => + null; + end case; + + return Expr; + end Sem_Qualified_Expression; + + function Is_Signal_Parameter (Obj : Iir) return Boolean is + begin + return Get_Kind (Obj) = Iir_Kind_Interface_Signal_Declaration + and then + Get_Kind (Get_Parent (Obj)) in Iir_Kinds_Subprogram_Declaration; + end Is_Signal_Parameter; + + function Can_Interface_Be_Read (Inter : Iir) return Boolean is + begin + case Get_Mode (Inter) is + when Iir_In_Mode + | Iir_Inout_Mode + | Iir_Buffer_Mode => + -- LRM08 6.5.3 Interface object declarations + -- - in. The value of the interface object is allowed + -- to be read, [...] + -- - inout or buffer. Reading and updating the value of + -- the interface object is allowed. [...] + null; + when Iir_Out_Mode => + -- LRM93 4.3.2 Interface declarations + -- - out. The value of the interface object is allowed to be + -- updated, but it must not be read. + -- + -- LRM08 6.5.3 Interface object declarations + -- - out. The value of the interface object is allowed + -- [to be updated and,] provided it is not a signal + -- parameter, read. + if Vhdl_Std < Vhdl_08 or else Is_Signal_Parameter (Inter) then + return False; + end if; + when Iir_Linkage_Mode => + -- LRM08 6.5.3 Interface object declarations + -- - linkage. Reading and updating the value of the + -- interface object is allowed, but only by appearing + -- as an actual corresponding to an interface object + -- of mode LINKAGE. No other reading or updating is + -- permitted. + return False; + when Iir_Unknown_Mode => + raise Internal_Error; + end case; + return True; + end Can_Interface_Be_Read; + + function Can_Interface_Be_Updated (Inter : Iir) return Boolean is + begin + case Get_Mode (Inter) is + when Iir_In_Mode => + -- LRM08 6.5.3 Interface object declarations + -- - in. The value of the interface object is allowed to be read, + -- but it shall not be updated. + return False; + when Iir_Out_Mode => + -- LRM08 6.5.3 Interface object declarations + -- - out. The value of the interface object is allowed + -- to be updated [and, ...] + return True; + when Iir_Inout_Mode + | Iir_Buffer_Mode => + -- LRM08 6.5.3 Interface object declarations + -- - inout or buffer. Reading and updating the value of the + -- interface is allowed. + return True; + when Iir_Linkage_Mode => + -- LRM08 6.5.3 Interface object declarations + -- - linkage. Reading and updating the value of the + -- interface object is allowed, but only by appearing + -- as an actual corresponding to an interface object + -- of mode LINKAGE. No other reading or updating is + -- permitted. + return False; + when Iir_Unknown_Mode => + raise Internal_Error; + end case; + end Can_Interface_Be_Updated; + + procedure Check_Read_Aggregate (Aggr : Iir) + is + pragma Unreferenced (Aggr); + begin + -- FIXME: todo. + null; + end Check_Read_Aggregate; + + -- Check EXPR can be read. + procedure Check_Read (Expr : Iir) + is + Obj : Iir; + begin + if Expr = Null_Iir then + return; + end if; + + Obj := Expr; + loop + case Get_Kind (Obj) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Attribute_Value + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Guard_Signal_Declaration => + return; + when Iir_Kinds_Quantity_Declaration => + return; + when Iir_Kinds_External_Name => + return; + when Iir_Kind_Psl_Endpoint_Declaration => + return; + when Iir_Kind_File_Declaration + | Iir_Kind_Interface_File_Declaration => + -- LRM 4.3.2 Interface declarations + -- The value of an object is said to be read [...] + -- - When the object is a file and a READ operation is + -- performed on the file. + return; + when Iir_Kind_Object_Alias_Declaration => + Obj := Get_Name (Obj); + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_Variable_Declaration => + if not Can_Interface_Be_Read (Obj) then + Error_Msg_Sem (+Expr, "%n cannot be read", +Obj); + end if; + return; + when Iir_Kind_Enumeration_Literal + | Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal + | Iir_Kind_String_Literal8 + | Iir_Kind_Character_Literal + | Iir_Kind_Integer_Literal + | Iir_Kind_Floating_Point_Literal + | Iir_Kind_Null_Literal + | Iir_Kind_Unit_Declaration + | Iir_Kind_Simple_Aggregate + | Iir_Kind_Overflow_Literal => + return; + when Iir_Kinds_Monadic_Operator + | Iir_Kinds_Dyadic_Operator + | Iir_Kind_Function_Call => + return; + when Iir_Kind_Parenthesis_Expression => + Obj := Get_Expression (Obj); + when Iir_Kind_Qualified_Expression => + return; + when Iir_Kind_Type_Conversion + | Iir_Kind_Allocator_By_Expression + | Iir_Kind_Allocator_By_Subtype + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Dereference + | Iir_Kind_Attribute_Name => + return; + when Iir_Kinds_Scalar_Type_Attribute + | Iir_Kinds_Type_Attribute + | Iir_Kinds_Array_Attribute + | Iir_Kind_Image_Attribute + | Iir_Kind_Value_Attribute + | Iir_Kinds_Name_Attribute + | Iir_Kinds_Signal_Attribute + | Iir_Kinds_Signal_Value_Attribute => + return; + when Iir_Kind_Aggregate => + Check_Read_Aggregate (Obj); + return; + when Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Selected_Element => + -- FIXME: speed up using Base_Name + -- Obj := Get_Base_Name (Obj); + Obj := Get_Prefix (Obj); + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Obj := Get_Named_Entity (Obj); + when Iir_Kind_Error => + return; + when others => + Error_Kind ("check_read", Obj); + end case; + end loop; + end Check_Read; + + procedure Check_Update (Expr : Iir) + is + pragma Unreferenced (Expr); + begin + null; + end Check_Update; + + -- Emit an error if the constant EXPR is deferred and cannot be used in + -- the current context. + procedure Check_Constant_Restriction (Expr : Iir; Loc : Iir) + is + Lib : Iir; + Cur_Lib : Iir; + begin + -- LRM93 §2.6 + -- Within a package declaration that contains the declaration + -- of a deferred constant, and within the body of that package, + -- before the end of the corresponding full declaration, the + -- use of a name that denotes the deferred constant is only + -- allowed in the default expression for a local generic, + -- local port or formal parameter. + if Get_Deferred_Declaration_Flag (Expr) = False + or else Get_Deferred_Declaration (Expr) /= Null_Iir + then + -- The constant declaration is not deferred + -- or the it has been fully declared. + return; + end if; + + Lib := Get_Parent (Expr); + Cur_Lib := Get_Library_Unit (Sem.Get_Current_Design_Unit); + if (Get_Kind (Cur_Lib) = Iir_Kind_Package_Declaration + and then Lib = Cur_Lib) + or else (Get_Kind (Cur_Lib) = Iir_Kind_Package_Body + and then Get_Package (Cur_Lib) = Lib) + then + Error_Msg_Sem (+Loc, "invalid use of a deferred constant"); + end if; + end Check_Constant_Restriction; + + -- Set semantic to EXPR. + -- Replace simple_name with the referenced node, + -- Set type to nodes, + -- Resolve overloading + + -- If A_TYPE is not null, then EXPR must be of type A_TYPE. + -- Return null in case of error. + function Sem_Expression_Ov (Expr: Iir; A_Type1: Iir) return Iir + is + A_Type: Iir; + begin +-- -- Avoid to run sem_expression_ov when a node was already analyzed +-- -- except to resolve overload. +-- if Get_Type (Expr) /= Null_Iir then +-- -- EXPR was already analyzed. +-- if A_Type1 = null or else not Is_Overload_List (Get_Type (Expr)) then +-- -- This call to sem_expression_ov do not add any informations. +-- Check_Restrictions (Expr, Restriction); +-- return Expr; +-- end if; +-- -- This is an overload list that will be reduced. +-- end if; + + -- A_TYPE must be a type definition and not a subtype. + if A_Type1 /= Null_Iir then + A_Type := Get_Base_Type (A_Type1); + if A_Type /= A_Type1 then + raise Internal_Error; + end if; + else + A_Type := Null_Iir; + end if; + + case Get_Kind (Expr) is + when Iir_Kind_Selected_Name + | Iir_Kind_Simple_Name + | Iir_Kind_Character_Literal + | Iir_Kind_Parenthesis_Name + | Iir_Kind_Selected_By_All_Name + | Iir_Kind_Attribute_Name => + declare + E : Iir; + begin + E := Get_Named_Entity (Expr); + if E = Null_Iir then + Sem_Name (Expr); + E := Get_Named_Entity (Expr); + pragma Assert (E /= Null_Iir); + end if; + if E = Error_Mark then + return Null_Iir; + end if; + if Get_Kind (E) = Iir_Kind_Constant_Declaration + and then not Deferred_Constant_Allowed + then + Check_Constant_Restriction (E, Expr); + end if; + E := Name_To_Expression (Expr, A_Type); + return E; + end; + + when Iir_Kinds_External_Name => + Sem_External_Name (Expr); + return Expr; + + when Iir_Kinds_Monadic_Operator => + return Sem_Operator (Expr, A_Type, 1); + + when Iir_Kinds_Dyadic_Operator => + return Sem_Operator (Expr, A_Type, 2); + + when Iir_Kind_Enumeration_Literal + | Iir_Kinds_Object_Declaration => + -- All these case have already a type. + if Get_Type (Expr) = Null_Iir then + return Null_Iir; + end if; + if A_Type /= Null_Iir + and then Are_Basetypes_Compatible + (A_Type, Get_Base_Type (Get_Type (Expr))) = Not_Compatible + then + Error_Not_Match (Expr, A_Type); + return Null_Iir; + end if; + return Expr; + + when Iir_Kind_Integer_Literal => + Set_Expr_Staticness (Expr, Locally); + if A_Type = Null_Iir then + Set_Type (Expr, Convertible_Integer_Type_Definition); + return Expr; + elsif Get_Kind (A_Type) = Iir_Kind_Integer_Type_Definition then + Set_Type (Expr, A_Type); + return Expr; + else + Error_Not_Match (Expr, A_Type); + return Null_Iir; + end if; + + when Iir_Kind_Floating_Point_Literal => + Set_Expr_Staticness (Expr, Locally); + if A_Type = Null_Iir then + Set_Type (Expr, Convertible_Real_Type_Definition); + return Expr; + elsif Get_Kind (A_Type) = Iir_Kind_Floating_Type_Definition then + Set_Type (Expr, A_Type); + return Expr; + else + Error_Not_Match (Expr, A_Type); + return Null_Iir; + end if; + + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal + | Iir_Kind_Unit_Declaration => + declare + Res: Iir; + Res_Type : Iir; + begin + Res := Sem_Physical_Literal (Expr); + Res_Type := Get_Type (Res); + if Is_Null (Res_Type) then + return Null_Iir; + end if; + if A_Type /= Null_Iir and then Res_Type /= A_Type then + Error_Not_Match (Res, A_Type); + return Null_Iir; + end if; + return Res; + end; + + when Iir_Kind_String_Literal8 => + -- LRM93 7.3.1 Literals + -- The type of a string or bit string literal must be + -- determinable solely from the context in whcih the literal + -- appears, excluding the literal itself [...] + if A_Type = Null_Iir then + return Expr; + end if; + + if not Is_String_Literal_Type (A_Type, Expr) then + Error_Not_Match (Expr, A_Type); + return Null_Iir; + else + Replace_Type (Expr, A_Type); + Sem_String_Literal (Expr); + return Expr; + end if; + + when Iir_Kind_Null_Literal => + Set_Expr_Staticness (Expr, Locally); + -- GHDL: the LRM doesn't explain how the type of NULL is + -- determined. Use the same rule as string or aggregates. + if A_Type = Null_Iir then + return Expr; + end if; + if not Is_Null_Literal_Type (A_Type) then + Error_Msg_Sem (+Expr, "null literal can only be access type"); + return Null_Iir; + else + Set_Type (Expr, A_Type); + return Expr; + end if; + + when Iir_Kind_Aggregate => + -- LRM93 7.3.2 Aggregates + -- The type of an aggregate must be determinable solely from the + -- context in which the aggregate appears, excluding the aggregate + -- itself but [...] + if A_Type = Null_Iir then + return Expr; + else + return Sem_Aggregate (Expr, A_Type, False); + end if; + + when Iir_Kind_Parenthesis_Expression => + declare + Sub_Expr : Iir; + begin + Sub_Expr := Get_Expression (Expr); + Sub_Expr := Sem_Expression_Ov (Sub_Expr, A_Type1); + if Sub_Expr = Null_Iir then + return Null_Iir; + end if; + Set_Expression (Expr, Sub_Expr); + Set_Type (Expr, Get_Type (Sub_Expr)); + Set_Expr_Staticness (Expr, Get_Expr_Staticness (Sub_Expr)); + return Expr; + end; + + when Iir_Kind_Qualified_Expression => + return Sem_Qualified_Expression (Expr, A_Type); + + when Iir_Kind_Allocator_By_Expression + | Iir_Kind_Allocator_By_Subtype => + return Sem_Allocator (Expr, A_Type); + + when Iir_Kind_Procedure_Declaration => + Error_Msg_Sem (+Expr, "%n cannot be used as an expression", +Expr); + return Null_Iir; + + when Iir_Kind_Range_Expression => + -- Can only happen in case of parse error, as a range is not an + -- expression. + pragma Assert (Flags.Flag_Force_Analysis); + declare + Res : Iir; + begin + Res := Sem_Simple_Range_Expression (Expr, A_Type, True); + return Create_Error_Expr (Res, A_Type); + end; + + when Iir_Kind_Error => + -- Always ok. + return Expr; + + when others => + Error_Kind ("sem_expression_ov", Expr); + return Null_Iir; + end case; + end Sem_Expression_Ov; + + function Is_Expr_Not_Analyzed (Expr : Iir) return Boolean is + begin + return Get_Type (Expr) = Null_Iir; + end Is_Expr_Not_Analyzed; + + function Is_Expr_Fully_Analyzed (Expr : Iir) return Boolean is + begin + return Is_Defined_Type (Get_Type (Expr)); + end Is_Expr_Fully_Analyzed; + + function Get_Wildcard_Type (Wildcard : Iir; Atype : Iir) return Iir is + begin + if Atype in Iir_Wildcard_Types then + -- Special wildcard vs wildcard. + case Iir_Wildcard_Types (Wildcard) is + when Wildcard_Any_Type => + return Atype; + when Wildcard_Any_Aggregate_Type => + case Iir_Wildcard_Types (Atype) is + when Wildcard_Any_Type + | Wildcard_Any_Aggregate_Type => + return Wildcard_Any_Aggregate_Type; + when Wildcard_Any_String_Type => + return Wildcard_Any_String_Type; + when Wildcard_Any_Access_Type => + return Null_Iir; + end case; + when Wildcard_Any_String_Type => + case Iir_Wildcard_Types (Atype) is + when Wildcard_Any_Type + | Wildcard_Any_Aggregate_Type + | Wildcard_Any_String_Type => + return Wildcard_Any_String_Type; + when Wildcard_Any_Access_Type => + return Null_Iir; + end case; + when Wildcard_Any_Access_Type => + case Iir_Wildcard_Types (Atype) is + when Wildcard_Any_Type + | Wildcard_Any_Access_Type => + return Wildcard_Any_Access_Type; + when Wildcard_Any_Aggregate_Type + | Wildcard_Any_String_Type => + return Null_Iir; + end case; + end case; + else + case Iir_Wildcard_Types (Wildcard) is + when Wildcard_Any_Type => + -- Match with any type. + return Atype; + when Wildcard_Any_Aggregate_Type => + if Is_Aggregate_Type (Atype) then + return Atype; + end if; + when Wildcard_Any_String_Type => + if Is_String_Type (Atype) then + return Atype; + end if; + when Wildcard_Any_Access_Type => + if Get_Kind (Get_Base_Type (Atype)) + = Iir_Kind_Access_Type_Definition + then + return Atype; + end if; + end case; + return Null_Iir; + end if; + end Get_Wildcard_Type; + + function Compatible_Types_Intersect_Single (T1, T2 : Iir) return Iir is + begin + if T1 = T2 then + return T1; + end if; + if T1 in Iir_Wildcard_Types then + return Get_Wildcard_Type (T1, T2); + elsif T2 in Iir_Wildcard_Types then + return Get_Wildcard_Type (T2, T1); + else + return Get_Common_Basetype (Get_Base_Type (T1), Get_Base_Type (T2)); + end if; + end Compatible_Types_Intersect_Single; + + function Compatible_Types_Intersect_Single_List (A_Type, Types_List : Iir) + return Iir + is + Types_List_List : Iir_List; + It : List_Iterator; + El: Iir; + Com : Iir; + Res : Iir; + begin + if not Is_Overload_List (Types_List) then + return Compatible_Types_Intersect_Single (A_Type, Types_List); + else + Types_List_List := Get_Overload_List (Types_List); + Res := Null_Iir; + It := List_Iterate (Types_List_List); + while Is_Valid (It) loop + El := Get_Element (It); + Com := Compatible_Types_Intersect_Single (El, A_Type); + if Com /= Null_Iir then + Add_Result (Res, Com); + end if; + Next (It); + end loop; + return Res; + end if; + end Compatible_Types_Intersect_Single_List; + + function Compatible_Types_Intersect (List1, List2 : Iir) return Iir + is + List1_List : Iir_List; + It1 : List_Iterator; + Res : Iir; + El : Iir; + Tmp : Iir; + begin + if List1 = Null_Iir or else List2 = Null_Iir then + return Null_Iir; + end if; + + if Is_Overload_List (List1) then + List1_List := Get_Overload_List (List1); + Res := Null_Iir; + It1 := List_Iterate (List1_List); + while Is_Valid (It1) loop + El := Get_Element (It1); + Tmp := Compatible_Types_Intersect_Single_List (El, List2); + if Tmp /= Null_Iir then + Add_Result (Res, Tmp); + end if; + Next (It1); + end loop; + return Res; + else + return Compatible_Types_Intersect_Single_List (List1, List2); + end if; + end Compatible_Types_Intersect; + + function Sem_Expression_Wildcard + (Expr : Iir; Atype : Iir; Force_Constrained : Boolean := False) + return Iir + is + Expr_Type : constant Iir := Get_Type (Expr); + Atype_Defined : constant Boolean := Is_Defined_Type (Atype); + Expr_Type_Defined : constant Boolean := Is_Defined_Type (Expr_Type); + begin + if Expr_Type /= Null_Iir then + -- EXPR is at least partially analyzed. + if Expr_Type_Defined or else not Atype_Defined then + -- Nothing to do if: + -- - Expression is already fully analyzed: caller has to merge + -- types + -- - Expression is partially analyzed but ATYPE is not defined: + -- caller has to merge types. + return Expr; + end if; + end if; + + case Get_Kind (Expr) is + when Iir_Kind_Aggregate => + if Atype_Defined then + return Sem_Aggregate (Expr, Atype, Force_Constrained); + else + pragma Assert (Expr_Type = Null_Iir); + Set_Type (Expr, Wildcard_Any_Aggregate_Type); + end if; + return Expr; + + when Iir_Kind_String_Literal8 => + if Atype_Defined then + if not Is_String_Literal_Type (Atype, Expr) then + Error_Not_Match (Expr, Atype); + Set_Type (Expr, Error_Type); + else + Set_Type (Expr, Atype); + Sem_String_Literal (Expr); + end if; + else + pragma Assert (Expr_Type = Null_Iir); + Set_Type (Expr, Wildcard_Any_String_Type); + end if; + return Expr; + + when Iir_Kind_Null_Literal => + if Atype_Defined then + if not Is_Null_Literal_Type (Atype) then + Error_Not_Match (Expr, Atype); + Set_Type (Expr, Error_Type); + else + Set_Type (Expr, Atype); + Set_Expr_Staticness (Expr, Locally); + end if; + else + pragma Assert (Expr_Type = Null_Iir); + Set_Type (Expr, Wildcard_Any_Access_Type); + end if; + return Expr; + + when Iir_Kind_Allocator_By_Expression + | Iir_Kind_Allocator_By_Subtype => + if Atype_Defined then + if not Is_Null_Literal_Type (Atype) then + Error_Not_Match (Expr, Atype); + Set_Type (Expr, Error_Type); + else + return Sem_Allocator (Expr, Atype); + end if; + else + pragma Assert (Expr_Type = Null_Iir); + Set_Type (Expr, Wildcard_Any_Access_Type); + end if; + return Expr; + + when Iir_Kind_Parenthesis_Expression => + declare + Sub_Expr : Iir; + Ntype : Iir; + begin + Sub_Expr := Get_Expression (Expr); + if Atype_Defined then + -- Very important: loose the subtype due to + -- LRM93 7.3.2.2 Array aggregate. + Ntype := Get_Base_Type (Atype); + else + Ntype := Atype; + end if; + Sub_Expr := Sem_Expression_Wildcard (Sub_Expr, Ntype); + if Sub_Expr /= Null_Iir then + Set_Expression (Expr, Sub_Expr); + Set_Type (Expr, Get_Type (Sub_Expr)); + Set_Expr_Staticness (Expr, Get_Expr_Staticness (Sub_Expr)); + else + Set_Type (Expr, Error_Type); + end if; + end; + return Expr; + + when others => + if Atype_Defined then + return Sem_Expression_Ov (Expr, Get_Base_Type (Atype)); + else + declare + Res : Iir; + Res_Type : Iir; + Prev_Res_Type : Iir; + begin + pragma Assert (Expr_Type = Null_Iir); + if Atype in Iir_Wildcard_Types then + -- Analyze without known type. + Res := Sem_Expression_Ov (Expr, Null_Iir); + if Res = Null_Iir or else Is_Error (Res) then + Set_Type (Expr, Error_Type); + return Expr; + end if; + Prev_Res_Type := Get_Type (Res); + + -- Filter possible type. + Res_Type := Compatible_Types_Intersect_Single_List + (Atype, Prev_Res_Type); + + if Res_Type = Null_Iir then + -- No matching type. This is an error. + Error_Not_Match (Expr, Atype); + Set_Type (Expr, Error_Type); + elsif Is_Defined_Type (Res_Type) then + -- Known and defined matching type. + if Res_Type /= Prev_Res_Type then + -- Need to refine analysis. + Res := Sem_Expression_Ov (Expr, Res_Type); + end if; + else + -- Matching but not defined type (overload). + Set_Type (Expr, Res_Type); + end if; + if Is_Overload_List (Prev_Res_Type) then + Free_Overload_List (Prev_Res_Type); + end if; + return Res; + else + pragma Assert (Atype = Null_Iir); + return Sem_Expression_Ov (Expr, Atype); + end if; + end; + end if; + end case; + end Sem_Expression_Wildcard; + + procedure Merge_Wildcard_Type (Expr : Iir; Atype : in out Iir) + is + Result_Type : Iir; + Expr_Type : Iir; + begin + if Is_Error (Expr) then + return; + end if; + + -- Use the base type; EXPR may define its own subtype (like in + -- qualified expression with forwarding) which must not be referenced + -- above it. In any case, that also makes sense: we need to deal with + -- types, not with subtypes. + Expr_Type := Get_Base_Type (Get_Type (Expr)); + + pragma Assert (Expr_Type /= Null_Iir); + Result_Type := Compatible_Types_Intersect (Atype, Expr_Type); + if Atype /= Null_Iir and then Is_Overload_List (Atype) then + Free_Overload_List (Atype); + end if; + if Result_Type /= Null_Iir then + if Is_Defined_Type (Atype) then + -- If ATYPE was already defined, keep it. So that subtypes + -- are kept (this is needed for aggregates and always helpful). + null; + else + Atype := Result_Type; + end if; + else + Atype := Result_Type; + end if; + end Merge_Wildcard_Type; + + -- If A_TYPE is not null, then EXPR must be of type A_TYPE. + -- Return null in case of error. + function Sem_Expression (Expr: Iir; A_Type: Iir) return Iir + is + A_Type1: Iir; + Res: Iir; + Expr_Type : Iir; + begin + if Check_Is_Expression (Expr, Expr) = Null_Iir then + return Null_Iir; + end if; + + -- Can't try to run sem_expression_ov when a node was already analyzed + Expr_Type := Get_Type (Expr); + if Expr_Type /= Null_Iir and then not Is_Overload_List (Expr_Type) then + -- Checks types. + -- This is necessary when the first call to sem_expression was done + -- with A_TYPE set to NULL_IIR and results in setting the type of + -- EXPR. + if A_Type /= Null_Iir + and then Are_Types_Compatible (Expr_Type, A_Type) = Not_Compatible + then + Error_Not_Match (Expr, A_Type); + return Null_Iir; + end if; + return Expr; + end if; + + -- A_TYPE must be a type definition and not a subtype. + if A_Type /= Null_Iir then + A_Type1 := Get_Base_Type (A_Type); + else + A_Type1 := Null_Iir; + end if; + + case Get_Kind (Expr) is + when Iir_Kind_Aggregate => + Res := Sem_Aggregate (Expr, A_Type, False); + when Iir_Kind_String_Literal8 => + if A_Type = Null_Iir then + Res := Sem_Expression_Ov (Expr, Null_Iir); + else + if not Is_String_Literal_Type (A_Type, Expr) then + Error_Not_Match (Expr, A_Type); + return Null_Iir; + end if; + Set_Type (Expr, A_Type); + Sem_String_Literal (Expr); + return Expr; + end if; + when others => + Res := Sem_Expression_Ov (Expr, A_Type1); + end case; + + if Res /= Null_Iir and then Is_Overloaded (Res) then + -- FIXME: clarify between overload and not determinable from the + -- context. + Error_Overload (Expr); + if Get_Type (Res) /= Null_Iir then + Disp_Overload_List (Get_Overload_List (Get_Type (Res)), Expr); + end if; + return Null_Iir; + end if; + return Res; + end Sem_Expression; + + function Sem_Composite_Expression (Expr : Iir) return Iir + is + Res : Iir; + begin + Res := Sem_Expression_Ov (Expr, Null_Iir); + if Res = Null_Iir or else Get_Type (Res) = Null_Iir then + return Res; + elsif Is_Overload_List (Get_Type (Res)) then + declare + List : constant Iir_List := Get_Overload_List (Get_Type (Res)); + It : List_Iterator; + Res_Type : Iir; + Atype : Iir; + begin + Res_Type := Null_Iir; + It := List_Iterate (List); + while Is_Valid (It) loop + Atype := Get_Element (It); + if Is_Aggregate_Type (Atype) then + Add_Result (Res_Type, Atype); + end if; + Next (It); + end loop; + + if Res_Type = Null_Iir then + Error_Overload (Expr); + return Null_Iir; + elsif Is_Overload_List (Res_Type) then + Error_Overload (Expr); + Disp_Overload_List (Get_Overload_List (Res_Type), Expr); + Free_Overload_List (Res_Type); + return Null_Iir; + else + return Sem_Expression_Ov (Expr, Res_Type); + end if; + end; + else + -- Either an error (already handled) or not overloaded. Type + -- matching will be done later (when the target is analyzed). + return Res; + end if; + end Sem_Composite_Expression; + + -- EXPR must be an expression with type is an overload list. + -- Extract and finish the analysis of the expression that is of universal + -- type, if there is one and if all types are either integer types or + -- floating point types. + -- This is used to get rid of implicit conversions. + function Sem_Favour_Universal_Type (Expr : Iir) return Iir + is + Expr_Type : constant Iir := Get_Type (Expr); + Type_List : constant Iir_List := Get_Overload_List (Expr_Type); + -- Extract kind (from the first element). + First_El : constant Iir := Get_First_Element (Type_List); + Kind : constant Iir_Kind := Get_Kind (Get_Base_Type (First_El)); + Res : Iir; + El : Iir; + + It : List_Iterator; + begin + Res := Null_Iir; + + It := List_Iterate (Type_List); + while Is_Valid (It) loop + El := Get_Element (It); + if Get_Kind (Get_Base_Type (El)) /= Kind then + -- Must be of the same kind. + Res := Null_Iir; + exit; + end if; + if El = Universal_Integer_Type_Definition + or El = Convertible_Integer_Type_Definition + or El = Universal_Real_Type_Definition + or El = Convertible_Real_Type_Definition + then + if Res = Null_Iir then + Res := El; + else + Res := Null_Iir; + exit; + end if; + end if; + Next (It); + end loop; + + if Res = Null_Iir then + Error_Overload (Expr); + Disp_Overload_List (Type_List, Expr); + return Null_Iir; + end if; + + return Sem_Expression_Ov (Expr, Res); + end Sem_Favour_Universal_Type; + + function Sem_Expression_Universal (Expr : Iir) return Iir + is + Expr1 : Iir; + Expr_Type : Iir; + begin + Expr1 := Sem_Expression_Wildcard (Expr, Wildcard_Any_Type); + Expr_Type := Get_Type (Expr1); + if Is_Error (Expr_Type) then + return Null_Iir; + end if; + if not Is_Overload_List (Expr_Type) then + return Expr1; + else + return Sem_Favour_Universal_Type (Expr1); + end if; + end Sem_Expression_Universal; + + function Sem_Case_Expression (Expr : Iir) return Iir + is + Expr1 : Iir; + Expr_Type : Iir; + El : Iir; + Res : Iir; + List : Iir_List; + It : List_Iterator; + begin + Expr1 := Sem_Expression_Ov (Expr, Null_Iir); + if Expr1 = Null_Iir then + return Null_Iir; + end if; + Expr_Type := Get_Type (Expr1); + if Expr_Type = Null_Iir then + -- Possible only if the type cannot be determined without the + -- context (aggregate or string literal). + Error_Msg_Sem + (+Expr, "cannot determine the type of choice expression"); + if Get_Kind (Expr1) = Iir_Kind_Aggregate then + Error_Msg_Sem + (+Expr, "(use a qualified expression of the form T'(xxx).)"); + end if; + return Null_Iir; + end if; + if not Is_Overload_List (Expr_Type) then + return Expr1; + end if; + + -- In case of overload, try to find one match. + -- FIXME: match only character types. + + -- LRM93 8.8 Case statement + -- This type must be determinable independently of the context in which + -- the expression occurs, but using the fact that the expression must be + -- of a discrete type or a one-dimensional character array type. + List := Get_Overload_List (Expr_Type); + Res := Null_Iir; + It := List_Iterate (List); + while Is_Valid (It) loop + El := Get_Element (It); + if Get_Kind (El) in Iir_Kinds_Discrete_Type_Definition + or else Is_One_Dimensional_Array_Type (El) + then + if Res = Null_Iir then + Res := El; + else + Error_Overload (Expr1); + Disp_Overload_List (List, Expr1); + return Null_Iir; + end if; + end if; + Next (It); + end loop; + if Res = Null_Iir then + Error_Overload (Expr1); + Disp_Overload_List (List, Expr1); + return Null_Iir; + end if; + return Sem_Expression_Ov (Expr1, Get_Base_Type (Res)); + end Sem_Case_Expression; + + function Insert_Condition_Operator (Cond : Iir) return Iir + is + Op : Iir; + Res : Iir; + begin + Op := Create_Iir (Iir_Kind_Implicit_Condition_Operator); + Location_Copy (Op, Cond); + Set_Operand (Op, Cond); + + Res := Sem_Operator (Op, Boolean_Type_Definition, 1); + Check_Read (Res); + return Res; + end Insert_Condition_Operator; + + function Sem_Condition (Cond : Iir) return Iir + is + Res : Iir; + begin + -- This function fully analyze COND, so it supposes COND is not yet + -- analyzed. + pragma Assert (Is_Expr_Not_Analyzed (Cond)); + + if Vhdl_Std < Vhdl_08 then + Res := Sem_Expression (Cond, Boolean_Type_Definition); + + Check_Read (Res); + return Res; + else + -- LRM08 9.2.9 + -- If, without overload resolution (see 12.5), the expression is + -- of type BOOLEAN defined in package STANDARD, or if, assuming a + -- rule requiring the expression to be of type BOOLEAN defined in + -- package STANDARD, overload resolution can determine at least one + -- interpretation of each constituent of the innermost complete + -- context including the expression, then the condition operator is + -- not applied. + + Res := Sem_Expression_Ov (Cond, Null_Iir); + + if Res = Null_Iir then + -- Error occurred. + return Res; + end if; + + if not Is_Overloaded (Res) then + -- Only one result. Operator "??" is not applied if the result + -- is of type boolean. + if Are_Types_Compatible (Get_Type (Res), Boolean_Type_Definition) + /= Not_Compatible + then + Check_Read (Res); + return Res; + end if; + elsif Get_Type (Res) /= Null_Iir then + -- Many interpretations. + declare + Res_List : constant Iir_List := + Get_Overload_List (Get_Type (Res)); + It : List_Iterator; + El : Iir; + Nbr_Booleans : Natural; + begin + Nbr_Booleans := 0; + + -- Extract boolean interpretations. + It := List_Iterate (Res_List); + while Is_Valid (It) loop + El := Get_Element (It); + if Are_Types_Compatible (El, Boolean_Type_Definition) + /= Not_Compatible + then + Nbr_Booleans := Nbr_Booleans + 1; + end if; + Next (It); + end loop; + + if Nbr_Booleans >= 1 then + -- There is one or more boolean interpretations: keep them. + -- In case of multiple boolean interpretations, an error + -- message will be generated. + Res := Sem_Expression_Ov (Cond, Boolean_Type_Definition); + Check_Read (Res); + return Res; + end if; + end; + end if; + + -- LRM08 9.2.9 + -- Otherwise, the condition operator is implicitely applied, and the + -- type of the expresion with the implicit application shall be + -- BOOLEAN defined in package STANDARD. + + return Insert_Condition_Operator (Res); + end if; + end Sem_Condition; + +end Vhdl.Sem_Expr; diff --git a/src/vhdl/vhdl-sem_expr.ads b/src/vhdl/vhdl-sem_expr.ads new file mode 100644 index 000000000..4e96aa5be --- /dev/null +++ b/src/vhdl/vhdl-sem_expr.ads @@ -0,0 +1,270 @@ +-- Semantic analysis. +-- 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 Ada.Unchecked_Deallocation; +with Types; use Types; +with Iirs; use Iirs; + +package Vhdl.Sem_Expr is + -- Set semantic to EXPR. + -- Replace simple_name with the referenced node, + -- Set type to nodes, + -- Resolve overloading + + Deferred_Constant_Allowed : Boolean := False; + + -- Analyze an expression (other than a range) with a possible overloading. + -- Sem_expression_ov (and therefore sem_expression) must be called *once* + -- for each expression node with A_TYPE1 not null and at most *once* with + -- A_TYPE1 null. + -- + -- When A_TYPE1 is null, sem_expression_ov find all possible types + -- of the expression. If there is only one possible type (ie, overloading + -- is non-existant or solved), then the type of the expression is set, + -- and the node is completly analyzed. Sem_expression_ov must not + -- be called for such a node. + -- If there is several possible types (ie overloaded), then the type is + -- set with a list of overload. To finishes the semantisation, + -- sem_expression_ov must be called again with A_TYPE1 set to the + -- expected type. + -- + -- If A_TYPE1 is set, sem_expression_ov must finishes the analyze of the + -- expression, and set its type, which is not necessary a base type. + -- A_TYPE1 must be a base type. + -- + -- In case of error, it displays a message and return null_iir. + -- In case of success, it returns the analyzed expression, which can + -- be different from EXPR (eg, a character literal is transformed into an + -- enumeration literal). + function Sem_Expression_Ov (Expr: Iir; A_Type1: Iir) return Iir; + + -- If A_TYPE is not null, then EXPR must be of type A_TYPE. + -- Return null in case of error. + function Sem_Expression (Expr: Iir; A_Type: Iir) return Iir; + + -- Same as Sem_Expression, but also implicitly choose an universal type + -- if overloaded. + function Sem_Expression_Universal (Expr : Iir) return Iir; + + -- Same as Sem_Expression but specialized for a case expression. + -- (Handle specific overloading rules). + function Sem_Case_Expression (Expr : Iir) return Iir; + + -- Sem COND as a condition. COND must have not been analyzed. + -- In VHDL08, this follows 9.2.9 Condition operator. + -- In VHDL87 and 93, type of COND must be a boolean. + -- A check is made that COND can be read. + function Sem_Condition (Cond : Iir) return Iir; + + -- Insert a call to condition operator. + function Insert_Condition_Operator (Cond : Iir) return Iir; + + -- Same as Sem_Expression but knowing that the type of EXPR must be a + -- composite type. Used for expressions in assignment statement when the + -- target is an aggregate. + function Sem_Composite_Expression (Expr : Iir) return Iir; + + -- Return True iif INTER is allowed to be read. Follow rules of + -- LRM08 6.5.2 Interface object declarations. + function Can_Interface_Be_Read (Inter : Iir) return Boolean; + + -- Return True iif INTER is allowed to be updated. Follow rules of + -- LRM08 6.5.2 Interface object declarations. + function Can_Interface_Be_Updated (Inter : Iir) return Boolean; + + -- Check EXPR can be read. + procedure Check_Read (Expr : Iir); + + -- Check EXPR can be updated. + procedure Check_Update (Expr : Iir); + + -- For a procedure call, A_TYPE must be null. + function Sem_Subprogram_Call (Expr: Iir; A_Type: Iir) return Iir; + + -- If EXPR is a node for an expression, then return EXPR. + -- Otherwise, emit an error message using LOC as location + -- and return NULL_IIR. + -- If EXPR is NULL_IIR, NULL_IIR is silently returned. + function Check_Is_Expression (Expr : Iir; Loc : Iir) return Iir; + + -- Analyze a procedure_call or a concurrent_procedure_call_statement. + -- A procedure call is not an expression but because most of the code + -- for procedure call is common with function call, procedure calls are + -- handled in this package. + procedure Sem_Procedure_Call (Call : Iir_Procedure_Call; Stmt : Iir); + + -- Analyze a range (ie a range attribute or a range expression). If + -- ANY_DIR is true, the range can't be a null range (slice vs subtype, + -- used in static evaluation). A_TYPE may be Null_Iir. + -- Return Null_Iir in case of error, or EXPR analyzed (and evaluated if + -- possible). + function Sem_Range_Expression (Expr: Iir; A_Type: Iir; Any_Dir : Boolean) + return Iir; + + -- Analyze a discrete range. If ANY_DIR is true, the range can't be a + -- null range (slice vs subtype -- used in static evaluation). A_TYPE may + -- be Null_Iir. Return Null_Iir in case of error. + function Sem_Discrete_Range_Expression + (Expr: Iir; A_Type: Iir; Any_Dir: Boolean) return Iir; + + -- Analyze a discrete range and convert to integer if both bounds are + -- universal integer types, according to rules of LRM 3.2.1.1 + function Sem_Discrete_Range_Integer (Expr: Iir) return Iir; + + -- Transform LIT into a physical_literal. + -- LIT can be either a not analyzed physical literal or + -- a simple name that is a physical unit. In the later case, a physical + -- literal is created. + function Sem_Physical_Literal (Lit: Iir) return Iir; + + type Annex_Array is array (Natural range <>) of Int32; + type Annex_Array_Acc is access Annex_Array; + procedure Free_Annex_Array is new Ada.Unchecked_Deallocation + (Annex_Array, Annex_Array_Acc); + + -- Various info and sorted array for choices. + type Choice_Info_Type is record + -- Number of choices by expression or by range. + Nbr_Choices : Natural; + + -- Number of alternatives + Nbr_Alternatives : Natural; + + -- Set to the others choice is present. + Others_Choice : Iir; + + -- Array of sorted choices. + Arr : Iir_Array_Acc; + + -- Allocated and deallocated by the user. If not null, it will be + -- reordered when ARR is sorted. + Annex_Arr : Annex_Array_Acc; + end record; + + -- Compute the number of locally static choices (excluding others) and + -- set Has_Others. + procedure Count_Choices (Info : out Choice_Info_Type; Choice_Chain : Iir); + + -- Allocate and fill INFO.ARR. + procedure Fill_Choices_Array (Info : in out Choice_Info_Type; + Choice_Chain : Iir); + + -- Sort INFO.ARR. Only for one-dimensional strings. + procedure Sort_String_Choices (Info : in out Choice_Info_Type); + + -- Likewise for discrete choices. + procedure Sort_Discrete_Choices (Info : in out Choice_Info_Type); + + -- CHOICES_CHAIN is a chain of choices (none, expression, range or + -- others). It is an in-out as it may be mutated (from expression to + -- range). + -- If IS_SUB_RANGE is true, then SUB_TYPE may not be fully convered, + -- otherwise, SUB_TYPE must be fully covered. + -- This is used when the subtype of an aggregate must be determined. + -- SUB_TYPE is the discrete subtype. + -- Emit a message if: + -- * the SUB_TYPE is not fully covered by the choices + -- * the choices are not mutually exclusif (an element is present twice) + -- * OTHERS is not the last choice, or is present several times. + -- + -- If there is at least one named choice, LOW and HIGH are set with the + -- lowest and highest index. + -- If LOW and HIGH are set, they are locally static. + -- + -- Unidimensional strings are not handled here but by + -- sem_string_choices_range. + -- + -- TODO: + -- * be smarter if only positional choices (do not create the list). + -- * smarter messages. + procedure Sem_Choices_Range (Choice_Chain : in out Iir; + Choice_Type : Iir; + Low : out Iir; + High : out Iir; + Loc : Location_Type; + Is_Sub_Range : Boolean; + Is_Case_Stmt : Boolean); + + -- Check that the values of CHOICE_CHAIN are a continuous range, and + -- extract the lower LOW and upper HIGH bound (useful to create the + -- corresponding subtype). The values must be of type SUB_TYPE, and if + -- IS_SUB_RANGE True, they must be within SUB_TYPE. + -- The choices must be locally static. + -- If REORDER_CHOICES is true, CHOICE_CHAIN is ordered. + procedure Sem_Check_Continuous_Choices (Choice_Chain : Iir; + Choice_Type : Iir; + Low : out Iir; + High : out Iir; + Loc : Location_Type; + Is_Sub_Range : Boolean); + + -- Analyze CHOICE_LIST when the choice expression SEL is of a + -- one-dimensional character array type. + procedure Sem_String_Choices_Range (Choice_Chain : Iir; Sel : Iir); + + type Compatibility_Level is + (Not_Compatible, Via_Conversion, Fully_Compatible); + + -- LEFT are RIGHT must be really a type (not a subtype). + function Are_Basetypes_Compatible (Left: Iir; Right: Iir) + return Compatibility_Level; + + -- Return TRUE iif types of LEFT and RIGHT are compatible. + function Are_Nodes_Compatible (Left: Iir; Right: Iir) + return Compatibility_Level; + + -- Return TRUE iff the type of EXPR is compatible with A_TYPE + function Is_Expr_Compatible (A_Type : Iir; Expr : Iir) + return Compatibility_Level; + + -- LIST1, LIST2 are either a type node or an overload list of types. + -- Return THE type which is compatible with LIST1 are LIST2. + -- Return null_iir if there is no such type or if there are several types. + function Search_Compatible_Type (List1, List2 : Iir) return Iir; + + -- Return the intersection of LIST1 and LIST2. + -- This function accept wildcard types. + function Compatible_Types_Intersect (List1, List2 : Iir) return Iir; + + -- Return True if an expression is not analyzed (its type is not set). + -- All expressions from the parser are not analyzed. + function Is_Expr_Not_Analyzed (Expr : Iir) return Boolean; + pragma Inline (Is_Expr_Not_Analyzed); + + -- Return True if an expression is fully analyzed: its type is set to + -- either a type definition, or to an error type. + -- Some expressions can be partially analyzed: either set to an overload + -- list or to a wildcard type. + function Is_Expr_Fully_Analyzed (Expr : Iir) return Boolean; + pragma Inline (Is_Expr_Fully_Analyzed); + + -- Analyze EXPR using ATYPE. + -- If EXPR is not analyzed, EXPR is analyzed using type constraints from + -- ATYPE. + -- If ATYPE is a defined type (neither an overload list nor a wildcard + -- type), EXPR will be fully analyzed (possibly with an error). + -- If EXPR is partially or fully analyzed, ATYPE must not be null_iir and + -- it is checked with the types of EXPR. EXPR may become fully analyzed. + function Sem_Expression_Wildcard + (Expr : Iir; Atype : Iir; Force_Constrained : Boolean := False) + return Iir; + + -- To be used after Sem_Expression_Wildcard to update list ATYPE of + -- possible types. + procedure Merge_Wildcard_Type (Expr : Iir; Atype : in out Iir); +end Vhdl.Sem_Expr; diff --git a/src/vhdl/vhdl-sem_inst.adb b/src/vhdl/vhdl-sem_inst.adb new file mode 100644 index 000000000..8d73a7a2d --- /dev/null +++ b/src/vhdl/vhdl-sem_inst.adb @@ -0,0 +1,1217 @@ +-- Package (and subprograms) instantiations + +-- When a package is instantiated, we need to 'duplicate' its declaration. +-- This looks useless for analysis but it isn't: a type from a package +-- instantiated twice declares two different types. Without duplication, we +-- need to attach to each declaration its instance, which looks more expansive +-- that duplicating the declaration. +-- +-- Furthermore, for generic type interface, it looks a good idea to duplicate +-- the body (macro expansion). +-- +-- Duplicating is not trivial: internal links must be kept and external +-- links preserved. A table is used to map nodes from the uninstantiated +-- package to its duplicated node. Links from instantiated declaration to +-- the original declaration are also stored in that table. + +with Tables; +with Nodes; +with Nodes_Meta; +with Types; use Types; +with Files_Map; +with Iirs_Utils; use Iirs_Utils; +with Errorout; use Errorout; +with Vhdl.Sem_Utils; + +package body Vhdl.Sem_Inst is + -- Table of origin. This is an extension of vhdl nodes to track the + -- origin of a node. If a node has a non-null origin, then the node was + -- instantiated for the origin node. + -- + -- Furthermore, during instantiation, we need to keep track of instantiated + -- nodes (ie nodes created by instantiation) used by references. As an + -- instance cannot be uninstantiated, there is no collisions, as soon as + -- such entries are cleaned after instantiation. + -- + -- As an example, here are declarations of an uninstantiated package: + -- type Nat is range 0 to 1023; + -- constant N : Nat := 5; + -- A node Nat1 will be created from node Nat (an integer type definition). + -- The origin of Nat1 is Nat and this is true forever. During + -- instantiation, the instance of Nat is Nat1, so that the type of N will + -- be set to Nat1. + package Origin_Table is new Tables + (Table_Component_Type => Iir, + Table_Index_Type => Iir, + Table_Low_Bound => 2, + Table_Initial => 1024); + + procedure Expand_Origin_Table + is + use Nodes; + Last : constant Iir := Iirs.Get_Last_Node; + El : constant Iir := Origin_Table.Last; + begin + if El < Last then + Origin_Table.Set_Last (Last); + Origin_Table.Table (El + 1 .. Last) := (others => Null_Iir); + end if; + end Expand_Origin_Table; + + -- This is the public function; the table may not have been extended. + function Get_Origin (N : Iir) return Iir + is + -- Make the '<=' operator visible. + use Nodes; + begin + if N <= Origin_Table.Last then + return Origin_Table.Table (N); + else + return Null_Iir; + end if; + end Get_Origin; + + -- This is the private function: the table *must* have been extended. + function Get_Instance (N : Iir) return Iir + is + -- Make '<=' operator visible for the assert. + use Nodes; + begin + pragma Assert (N <= Origin_Table.Last); + return Origin_Table.Table (N); + end Get_Instance; + + procedure Set_Origin (N : Iir; Orig : Iir) is + begin + -- As nodes are created, we need to expand origin table. + Expand_Origin_Table; + + pragma Assert (Orig = Null_Iir + or else Origin_Table.Table (N) = Null_Iir); + Origin_Table.Table (N) := Orig; + end Set_Origin; + + type Instance_Entry_Type is record + -- Node + N : Iir; + + -- Old value in Origin_Table. + Old_Origin : Iir; + end record; + + type Instance_Index_Type is new Natural; + + -- Table of previous values in Origin_Table. The first purpose of this + -- table is to be able to revert the calls to Set_Instance, so that a unit + -- can be instantiated several times. Keeping the nodes that have been + -- instantiated is cheaper than walking the tree a second time. + -- The second purpose of this table is to be able to have uninstantiated + -- packages in instantiated packages. In that case, the slot in + -- Origin_Table cannot be the origin and the instance at the same time and + -- has to be saved. + package Prev_Instance_Table is new Tables + (Table_Component_Type => Instance_Entry_Type, + Table_Index_Type => Instance_Index_Type, + Table_Low_Bound => 1, + Table_Initial => 256); + + -- The instance of ORIG is now N. So during instantiation, a reference + -- to ORIG will be replaced by a reference to N. The previous instance + -- of ORIG is saved. + procedure Set_Instance (Orig : Iir; N : Iir) + is + use Nodes; + begin + pragma Assert (Orig <= Origin_Table.Last); + + -- Save the old entry + Prev_Instance_Table.Append + (Instance_Entry_Type'(N => Orig, + Old_Origin => Origin_Table.Table (Orig))); + + -- Set the entry. + Origin_Table.Table (Orig) := N; + end Set_Instance; + + procedure Restore_Origin (Mark : Instance_Index_Type) is + begin + for I in reverse Mark + 1 .. Prev_Instance_Table.Last loop + declare + El : Instance_Entry_Type renames Prev_Instance_Table.Table (I); + begin + Origin_Table.Table (El.N) := El.Old_Origin; + end; + end loop; + Prev_Instance_Table.Set_Last (Mark); + end Restore_Origin; + + -- The virtual file for the instance. + Instance_File : Source_File_Entry; + + -- True if currently instantiated a shared generic. + Is_Within_Shared_Instance : Boolean := False; + + -- Get the new location. + function Relocate (Loc : Location_Type) return Location_Type is + begin + if Instance_File /= No_Source_File_Entry then + -- For Instantiate. + return Files_Map.Instance_Relocate (Instance_File, Loc); + else + -- For Copy_Tree. + return Loc; + end if; + end Relocate; + + procedure Create_Relocation (Inst : Iir; Orig : Iir) + is + use Files_Map; + Orig_File : Source_File_Entry; + Pos : Source_Ptr; + begin + Location_To_File_Pos (Get_Location (Orig), Orig_File, Pos); + Instance_File := Create_Instance_Source_File + (Orig_File, Get_Location (Inst), Inst); + end Create_Relocation; + + function Instantiate_Iir (N : Iir; Is_Ref : Boolean) return Iir; + + -- Instantiate a list. Simply create a new list and instantiate nodes of + -- that list. + function Instantiate_Iir_List (L : Iir_List; Is_Ref : Boolean) + return Iir_List + is + Res : Iir_List; + It : List_Iterator; + El : Iir; + begin + case L is + when Null_Iir_List + | Iir_List_All => + return L; + when others => + Res := Create_Iir_List; + It := List_Iterate (L); + while Is_Valid (It) loop + El := Get_Element (It); + Append_Element (Res, Instantiate_Iir (El, Is_Ref)); + Next (It); + end loop; + return Res; + end case; + end Instantiate_Iir_List; + + function Instantiate_Iir_Flist (L : Iir_Flist; Is_Ref : Boolean) + return Iir_Flist + is + Res : Iir_Flist; + El : Iir; + begin + case L is + when Null_Iir_Flist + | Iir_Flist_All + | Iir_Flist_Others => + return L; + when others => + Res := Create_Iir_Flist (Get_Nbr_Elements (L)); + for I in Flist_First .. Flist_Last (L) loop + El := Get_Nth_Element (L, I); + Set_Nth_Element (Res, I, Instantiate_Iir (El, Is_Ref)); + end loop; + return Res; + end case; + end Instantiate_Iir_Flist; + + -- Instantiate a chain. This is a special case to reduce stack depth. + function Instantiate_Iir_Chain (N : Iir) return Iir + is + First : Iir; + Last : Iir; + Next_N : Iir; + Next_R : Iir; + begin + if N = Null_Iir then + return Null_Iir; + end if; + + First := Instantiate_Iir (N, False); + Last := First; + Next_N := Get_Chain (N); + while Next_N /= Null_Iir loop + Next_R := Instantiate_Iir (Next_N, False); + Set_Chain (Last, Next_R); + Last := Next_R; + Next_N := Get_Chain (Next_N); + end loop; + + return First; + end Instantiate_Iir_Chain; + + procedure Instantiate_Iir_Field + (Res : Iir; N : Iir; F : Nodes_Meta.Fields_Enum) + is + use Nodes_Meta; + begin + case Get_Field_Type (F) is + when Type_Iir => + declare + S : constant Iir := Get_Iir (N, F); + R : Iir; + begin + case Get_Field_Attribute (F) is + when Attr_None => + R := Instantiate_Iir (S, False); + when Attr_Ref => + R := Instantiate_Iir (S, True); + when Attr_Maybe_Ref => + R := Instantiate_Iir (S, Get_Is_Ref (N)); + when Attr_Forward_Ref => + -- Must be explicitely handled in Instantiate_Iir, as it + -- requires special handling. + raise Internal_Error; + when Attr_Maybe_Forward_Ref => + if Get_Is_Forward_Ref (N) then + -- Likewise: must be explicitely handled. + raise Internal_Error; + else + R := Instantiate_Iir (S, True); + end if; + when Attr_Chain => + R := Instantiate_Iir_Chain (S); + when Attr_Chain_Next => + R := Null_Iir; + when Attr_Of_Ref | Attr_Of_Maybe_Ref => + -- Can only appear in list. + raise Internal_Error; + end case; + Set_Iir (Res, F, R); + end; + when Type_Iir_List => + declare + S : constant Iir_List := Get_Iir_List (N, F); + R : Iir_List; + Ref : Boolean; + begin + case Get_Field_Attribute (F) is + when Attr_None => + Ref := False; + when Attr_Of_Ref => + Ref := True; + when Attr_Of_Maybe_Ref => + Ref := Get_Is_Ref (N); + when others => + -- Ref is specially handled in Instantiate_Iir. + -- Others cannot appear for lists. + raise Internal_Error; + end case; + R := Instantiate_Iir_List (S, Ref); + Set_Iir_List (Res, F, R); + end; + when Type_Iir_Flist => + declare + S : constant Iir_Flist := Get_Iir_Flist (N, F); + R : Iir_Flist; + Ref : Boolean; + begin + case Get_Field_Attribute (F) is + when Attr_None => + Ref := False; + when Attr_Of_Ref => + Ref := True; + when Attr_Of_Maybe_Ref => + Ref := Get_Is_Ref (N); + when others => + -- Ref is specially handled in Instantiate_Iir. + -- Others cannot appear for lists. + raise Internal_Error; + end case; + R := Instantiate_Iir_Flist (S, Ref); + Set_Iir_Flist (Res, F, R); + end; + when Type_PSL_NFA + | Type_PSL_Node => + -- TODO + raise Internal_Error; + when Type_String8_Id => + Set_String8_Id (Res, F, Get_String8_Id (N, F)); + when Type_Source_Ptr => + Set_Source_Ptr (Res, F, Get_Source_Ptr (N, F)); + when Type_Source_File_Entry => + Set_Source_File_Entry (Res, F, Get_Source_File_Entry (N, F)); + when Type_Date_Type + | Type_Date_State_Type + | Type_Time_Stamp_Id + | Type_File_Checksum_Id => + -- Can this happen ? + raise Internal_Error; + when Type_Number_Base_Type => + Set_Number_Base_Type (Res, F, Get_Number_Base_Type (N, F)); + when Type_Iir_Constraint => + Set_Iir_Constraint (Res, F, Get_Iir_Constraint (N, F)); + when Type_Iir_Mode => + Set_Iir_Mode (Res, F, Get_Iir_Mode (N, F)); + when Type_Iir_Index32 => + Set_Iir_Index32 (Res, F, Get_Iir_Index32 (N, F)); + when Type_Iir_Int64 => + Set_Iir_Int64 (Res, F, Get_Iir_Int64 (N, F)); + when Type_Boolean => + Set_Boolean (Res, F, Get_Boolean (N, F)); + when Type_Iir_Staticness => + Set_Iir_Staticness (Res, F, Get_Iir_Staticness (N, F)); + when Type_Iir_All_Sensitized => + Set_Iir_All_Sensitized (Res, F, Get_Iir_All_Sensitized (N, F)); + when Type_Iir_Signal_Kind => + Set_Iir_Signal_Kind (Res, F, Get_Iir_Signal_Kind (N, F)); + when Type_Tri_State_Type => + Set_Tri_State_Type (Res, F, Get_Tri_State_Type (N, F)); + when Type_Iir_Pure_State => + Set_Iir_Pure_State (Res, F, Get_Iir_Pure_State (N, F)); + when Type_Iir_Delay_Mechanism => + Set_Iir_Delay_Mechanism (Res, F, Get_Iir_Delay_Mechanism (N, F)); + when Type_Iir_Predefined_Functions => + Set_Iir_Predefined_Functions + (Res, F, Get_Iir_Predefined_Functions (N, F)); + when Type_Iir_Direction => + Set_Iir_Direction (Res, F, Get_Iir_Direction (N, F)); + when Type_Iir_Int32 => + Set_Iir_Int32 (Res, F, Get_Iir_Int32 (N, F)); + when Type_Int32 => + Set_Int32 (Res, F, Get_Int32 (N, F)); + when Type_Iir_Fp64 => + Set_Iir_Fp64 (Res, F, Get_Iir_Fp64 (N, F)); + when Type_Token_Type => + Set_Token_Type (Res, F, Get_Token_Type (N, F)); + when Type_Name_Id => + Set_Name_Id (Res, F, Get_Name_Id (N, F)); + end case; + end Instantiate_Iir_Field; + + function Instantiate_Iir (N : Iir; Is_Ref : Boolean) return Iir + is + Res : Iir; + begin + -- Nothing to do for null node. + if N = Null_Iir then + return Null_Iir; + end if; + + -- For a reference, do not create a new node. + if Is_Ref then + Res := Get_Instance (N); + if Res /= Null_Iir then + -- There is an instance for N. + return Res; + else + -- Reference outside the instance. + return N; + end if; + end if; + + declare + use Nodes_Meta; + Kind : constant Iir_Kind := Get_Kind (N); + Fields : constant Fields_Array := Get_Fields (Kind); + F : Fields_Enum; + begin + -- In general, Get_Instance (N) is Null_Iir. There are two + -- exceptions: + -- - N is also an instance (instance within an uninstantiated + -- package). As instances and origin share the same table, + -- Get_Instance returns the origin. During instantiation, the old + -- value of Origin is saved so this case is correctly handled. + -- - N is shared, so it was already instantiated. This happends only + -- for interface_constant of implicit operators. In that case, + -- multiple instances are created for the same node, which is not + -- ideal. That's still ok (if no infos are attached to the + -- interface) and is the price to pay for this optimization. + + -- Create a new node. + Res := Create_Iir (Kind); + + -- The origin of this new node is N. + Set_Origin (Res, N); + + -- And the instance of N is RES. + Set_Instance (N, Res); + + Set_Location (Res, Relocate (Get_Location (N))); + + for I in Fields'Range loop + F := Fields (I); + + -- Fields that are handled specially. + case F is + when Field_Index_Subtype_List => + -- Index_Subtype_List is always a reference, so retrieve + -- the instance of the referenced list. This is a special + -- case because there is no origins for list. + declare + List : Iir_Flist; + begin + case Kind is + when Iir_Kind_Array_Type_Definition => + List := Get_Index_Subtype_Definition_List (Res); + when Iir_Kind_Array_Subtype_Definition => + List := Get_Index_Constraint_List (Res); + if List = Null_Iir_Flist then + List := Get_Index_Subtype_List + (Get_Denoted_Type_Mark (Res)); + end if; + when others => + -- All the nodes where Index_Subtype_List appears + -- are handled above. + raise Internal_Error; + end case; + Set_Index_Subtype_List (Res, List); + end; + + when Field_Simple_Aggregate_List => + Set_Simple_Aggregate_List + (Res, Get_Simple_Aggregate_List (N)); + + when Field_Subprogram_Body => + -- This is a forward reference. Not yet solved. + Set_Subprogram_Body (Res, Null_Iir); + + when Field_Subprogram_Specification => + -- Resolve it. + Instantiate_Iir_Field (Res, N, F); + + -- Set body. + pragma Assert (Kind_In (Res, Iir_Kind_Procedure_Body, + Iir_Kind_Function_Body)); + declare + Spec : constant Iir := Get_Subprogram_Specification (Res); + begin + pragma Assert (Get_Subprogram_Body (Spec) = Null_Iir); + Set_Subprogram_Body (Spec, Res); + end; + + when Field_Incomplete_Type_Ref_Chain => + if Get_Kind (Res) = Iir_Kind_Access_Type_Definition then + -- Link + declare + Def : constant Iir := Get_Named_Entity + (Get_Designated_Subtype_Indication (Res)); + begin + if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition + then + Set_Incomplete_Type_Ref_Chain + (Res, Get_Incomplete_Type_Ref_Chain (Def)); + Set_Incomplete_Type_Ref_Chain (Def, Res); + end if; + end; + end if; + + when Field_Designated_Type => + null; + when Field_Designated_Subtype_Indication => + Instantiate_Iir_Field (Res, N, F); + -- The designated type will be patched later if it is an + -- incomplete type definition + Set_Designated_Type + (Res, Get_Type (Get_Designated_Subtype_Indication (Res))); + + when Field_Complete_Type_Definition => + -- Will be set by the declaration of the complete type + null; + when Field_Incomplete_Type_Declaration => + Instantiate_Iir_Field (Res, N, F); + declare + Res_Decl : constant Iir := + Get_Incomplete_Type_Declaration (Res); + N_Decl : constant Iir := + Get_Incomplete_Type_Declaration (N); + Res_Complete : Iir; + N_Def, Res_Def : Iir; + N_El, Next_N_El : Iir; + Res_El, Next_Res_El : Iir; + begin + if Is_Valid (N_Decl) then + -- N/RES completes a type declaration. + N_Def := Get_Type_Definition (N_Decl); + Res_Def := Get_Type_Definition (Res_Decl); + -- Set Complete_Type_Definition + Res_Complete := Get_Type (Res); + Set_Complete_Type_Definition (Res_Def, Res_Complete); + -- Rebuild the list and patch designated types + N_El := N_Def; + Res_El := Res_Def; + loop + Next_N_El := Get_Incomplete_Type_Ref_Chain (N_El); + exit when Is_Null (Next_N_El); + Next_Res_El := Get_Instance (Next_N_El); + Set_Designated_Type (Next_Res_El, Res_Complete); + Set_Incomplete_Type_Ref_Chain (Res_El, Next_Res_El); + N_El := Next_N_El; + end loop; + end if; + end; + + when Field_Deferred_Declaration => + if not Get_Deferred_Declaration_Flag (N) + and then Is_Valid (Get_Deferred_Declaration (N)) + then + -- This is the completion. + declare + Incomplete_Decl_N : constant Iir := + Get_Deferred_Declaration (N); + Incomplete_Decl_Res : constant Iir := + Get_Instance (Incomplete_Decl_N); + begin + pragma Assert (Is_Valid (Incomplete_Decl_Res)); + Set_Deferred_Declaration (Res, Incomplete_Decl_Res); + Set_Deferred_Declaration (Incomplete_Decl_Res, Res); + end; + end if; + + when Field_Protected_Type_Body => + null; + when Field_Protected_Type_Declaration => + Instantiate_Iir_Field (Res, N, F); + Set_Protected_Type_Body + (Get_Protected_Type_Declaration (Res), Res); + + when Field_Package_Body => + null; + when Field_Package => + Instantiate_Iir_Field (Res, N, F); + declare + Pkg : constant Iir := Get_Package (Res); + begin + -- The current node can be the body of a package; in that + -- case set the forward link. + -- Or it can be the body of an instantiated package; in + -- that case there is no forward link. + if Get_Kind (Pkg) = Iir_Kind_Package_Declaration then + Set_Package_Body (Get_Package (Res), Res); + end if; + end; + + when Field_Instance_Package_Body => + -- Do not instantiate the body of a package while + -- instantiating a shared package. + if not Is_Within_Shared_Instance then + Instantiate_Iir_Field (Res, N, F); + end if; + + when Field_Subtype_Definition => + -- TODO + null; + + when Field_Instance_Source_File => + Set_Instance_Source_File + (Res, Files_Map.Create_Instance_Source_File + (Get_Instance_Source_File (N), + Get_Location (Res), Res)); + + when Field_Generic_Chain + | Field_Declaration_Chain => + if Kind = Iir_Kind_Package_Instantiation_Declaration then + declare + Prev_Instance_File : constant Source_File_Entry := + Instance_File; + begin + -- Also relocate the instantiated declarations. + Instance_File := Get_Instance_Source_File (Res); + pragma Assert (Instance_File /= No_Source_File_Entry); + Instantiate_Iir_Field (Res, N, F); + Instance_File := Prev_Instance_File; + end; + else + Instantiate_Iir_Field (Res, N, F); + end if; + + when others => + -- Common case. + Instantiate_Iir_Field (Res, N, F); + end case; + end loop; + + -- TODO: other forward references: + -- incomplete constant + -- incomplete type + -- attribute_value + + return Res; + end; + end Instantiate_Iir; + + -- As the scope generic interfaces extends beyond the immediate scope (see + -- LRM08 12.2 Scope of declarations), they must be instantiated. + function Instantiate_Generic_Chain (Inst : Iir; Inters : Iir) return Iir + is + Inter : Iir; + First : Iir; + Last : Iir; + Res : Iir; + begin + First := Null_Iir; + Last := Null_Iir; + + Inter := Inters; + while Inter /= Null_Iir loop + -- Create a copy of the interface. FIXME: is it really needed ? + Res := Create_Iir (Get_Kind (Inter)); + Set_Location (Res, Relocate (Get_Location (Inter))); + + Set_Parent (Res, Inst); + Set_Identifier (Res, Get_Identifier (Inter)); + Set_Visible_Flag (Res, Get_Visible_Flag (Inter)); + + Set_Origin (Res, Inter); + Set_Instance (Inter, Res); + + case Get_Kind (Res) is + when Iir_Kind_Interface_Constant_Declaration => + Set_Type (Res, Get_Type (Inter)); + Set_Subtype_Indication (Res, Null_Iir); -- Not owner + Set_Mode (Res, Get_Mode (Inter)); + Set_Has_Mode (Res, Get_Has_Mode (Inter)); + Set_Has_Class (Res, Get_Has_Class (Inter)); + Set_Has_Identifier_List (Res, Get_Has_Identifier_List (Inter)); + Set_Expr_Staticness (Res, Get_Expr_Staticness (Inter)); + Set_Name_Staticness (Res, Get_Name_Staticness (Inter)); + Set_Default_Value (Res, Get_Default_Value (Inter)); + Set_Is_Ref (Res, True); + when Iir_Kind_Interface_Package_Declaration => + Set_Uninstantiated_Package_Decl + (Res, Get_Uninstantiated_Package_Decl (Inter)); + Set_Generic_Chain + (Res, + Instantiate_Generic_Chain (Res, Get_Generic_Chain (Inter))); + Set_Declaration_Chain + (Res, Instantiate_Iir_Chain (Get_Declaration_Chain (Inter))); + when Iir_Kind_Interface_Type_Declaration => + Set_Type (Res, Get_Type (Inter)); + when Iir_Kinds_Interface_Subprogram_Declaration => + Sem_Utils.Compute_Subprogram_Hash (Res); + when others => + Error_Kind ("instantiate_generic_chain", Res); + end case; + + -- Append + if First = Null_Iir then + First := Res; + else + Set_Chain (Last, Res); + end if; + Last := Res; + + Inter := Get_Chain (Inter); + end loop; + + return First; + end Instantiate_Generic_Chain; + + procedure Set_Instance_On_Chain (Chain : Iir; Inst_Chain : Iir); + procedure Set_Instance_On_Iir_List (N : Iir_List; Inst : Iir_List); + procedure Set_Instance_On_Iir_Flist (N : Iir_Flist; Inst : Iir_Flist); + + procedure Set_Instance_On_Iir (N : Iir; Inst : Iir) is + begin + if N = Null_Iir then + pragma Assert (Inst = Null_Iir); + return; + end if; + pragma Assert (Inst /= Null_Iir); + + declare + use Nodes_Meta; + Kind : constant Iir_Kind := Get_Kind (N); + Fields : constant Fields_Array := Get_Fields (Kind); + F : Fields_Enum; + begin + pragma Assert (Get_Kind (Inst) = Kind); + + if Kind = Iir_Kind_Interface_Constant_Declaration + and then Get_Identifier (N) = Null_Identifier + then + -- Anonymous constant interface declarations are the only nodes + -- that can be shared. Handle that very special case. + return; + end if; + + -- pragma Assert (Get_Instance (N) = Null_Iir); + Set_Instance (N, Inst); + + for I in Fields'Range loop + F := Fields (I); + + case Get_Field_Type (F) is + when Type_Iir => + declare + S : constant Iir := Get_Iir (N, F); + S_Inst : constant Iir := Get_Iir (Inst, F); + begin + case Get_Field_Attribute (F) is + when Attr_None => + Set_Instance_On_Iir (S, S_Inst); + when Attr_Ref + | Attr_Forward_Ref + | Attr_Maybe_Forward_Ref => + null; + when Attr_Maybe_Ref => + if not Get_Is_Ref (N) then + Set_Instance_On_Iir (S, S_Inst); + end if; + when Attr_Chain => + Set_Instance_On_Chain (S, S_Inst); + when Attr_Chain_Next => + null; + when Attr_Of_Ref | Attr_Of_Maybe_Ref => + -- Can only appear in list. + raise Internal_Error; + end case; + end; + when Type_Iir_List => + declare + S : constant Iir_List := Get_Iir_List (N, F); + S_Inst : constant Iir_List := Get_Iir_List (Inst, F); + begin + case Get_Field_Attribute (F) is + when Attr_None => + Set_Instance_On_Iir_List (S, S_Inst); + when Attr_Of_Maybe_Ref => + if not Get_Is_Ref (N) then + Set_Instance_On_Iir_List (S, S_Inst); + end if; + when Attr_Of_Ref + | Attr_Ref + | Attr_Forward_Ref => + null; + when others => + -- Ref is specially handled in Instantiate_Iir. + -- Others cannot appear for lists. + raise Internal_Error; + end case; + end; + when Type_Iir_Flist => + declare + S : constant Iir_Flist := Get_Iir_Flist (N, F); + S_Inst : constant Iir_Flist := Get_Iir_Flist (Inst, F); + begin + case Get_Field_Attribute (F) is + when Attr_None => + Set_Instance_On_Iir_Flist (S, S_Inst); + when Attr_Of_Maybe_Ref => + if not Get_Is_Ref (N) then + Set_Instance_On_Iir_Flist (S, S_Inst); + end if; + when Attr_Of_Ref + | Attr_Ref + | Attr_Forward_Ref => + null; + when others => + -- Ref is specially handled in Instantiate_Iir. + -- Others cannot appear for lists. + raise Internal_Error; + end case; + end; + when others => + null; + end case; + end loop; + end; + end Set_Instance_On_Iir; + + procedure Set_Instance_On_Iir_List (N : Iir_List; Inst : Iir_List) + is + El : Iir; + El_Inst : Iir; + It, It_Inst : List_Iterator; + begin + case N is + when Null_Iir_List + | Iir_List_All => + pragma Assert (Inst = N); + return; + when others => + It := List_Iterate (N); + It_Inst := List_Iterate (Inst); + while Is_Valid (It) loop + pragma Assert (Is_Valid (It_Inst)); + El := Get_Element (It); + El_Inst := Get_Element (It_Inst); + + Set_Instance_On_Iir (El, El_Inst); + + Next (It); + Next (It_Inst); + end loop; + pragma Assert (not Is_Valid (It_Inst)); + end case; + end Set_Instance_On_Iir_List; + + procedure Set_Instance_On_Iir_Flist (N : Iir_Flist; Inst : Iir_Flist) + is + El : Iir; + El_Inst : Iir; + begin + case N is + when Null_Iir_Flist + | Iir_Flist_All + | Iir_Flist_Others => + pragma Assert (Inst = N); + return; + when others => + pragma Assert (Get_Nbr_Elements (N) = Get_Nbr_Elements (Inst)); + for I in Flist_First .. Flist_Last (N) loop + El := Get_Nth_Element (N, I); + El_Inst := Get_Nth_Element (Inst, I); + + Set_Instance_On_Iir (El, El_Inst); + end loop; + end case; + end Set_Instance_On_Iir_Flist; + + procedure Set_Instance_On_Chain (Chain : Iir; Inst_Chain : Iir) + is + El : Iir; + Inst_El : Iir; + begin + El := Chain; + Inst_El := Inst_Chain; + while El /= Null_Iir loop + pragma Assert (Inst_El /= Null_Iir); + Set_Instance_On_Iir (El, Inst_El); + El := Get_Chain (El); + Inst_El := Get_Chain (Inst_El); + end loop; + pragma Assert (Inst_El = Null_Iir); + end Set_Instance_On_Chain; + + -- In the instance, replace references (and inner references) to interface + -- package declaration to the associated package. + procedure Instantiate_Generic_Map_Chain (Inst : Iir; Pkg : Iir) + is + pragma Unreferenced (Pkg); + Assoc : Iir; + Inter : Iir; + begin + Assoc := Get_Generic_Map_Aspect_Chain (Inst); + Inter := Get_Generic_Chain (Inst); + while Is_Valid (Assoc) loop + -- Replace formal reference to the instance. + -- Cf Get_association_Interface + declare + Formal : Iir; + begin + Formal := Get_Formal (Assoc); + if Is_Valid (Formal) then + loop + case Get_Kind (Formal) is + when Iir_Kind_Simple_Name + | Iir_Kind_Operator_Symbol => + Set_Named_Entity + (Formal, Get_Instance (Get_Named_Entity (Formal))); + exit; + when Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element => + Formal := Get_Prefix (Formal); + when others => + Error_Kind ("instantiate_generic_map_chain", Formal); + end case; + end loop; + end if; + end; + + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression + | Iir_Kind_Association_Element_By_Individual + | Iir_Kind_Association_Element_Open => + null; + when Iir_Kind_Association_Element_Package => + declare + Sub_Inst : constant Iir := + Get_Named_Entity (Get_Actual (Assoc)); + Sub_Pkg_Inter : constant Iir := + Get_Association_Interface (Assoc, Inter); + Sub_Pkg : constant Iir := Get_Origin (Sub_Pkg_Inter); + begin + -- Replace references of interface package to references + -- to the actual package. + Set_Instance (Sub_Pkg, Sub_Inst); + Set_Instance_On_Chain (Get_Generic_Chain (Sub_Pkg), + Get_Generic_Chain (Sub_Inst)); + Set_Instance_On_Chain (Get_Declaration_Chain (Sub_Pkg), + Get_Declaration_Chain (Sub_Inst)); + end; + when Iir_Kind_Association_Element_Type => + -- Replace the incomplete interface type by the actual subtype + -- indication. + declare + Inter_Type_Def : constant Iir := + Get_Type (Get_Association_Interface (Assoc, Inter)); + Actual_Type : constant Iir := Get_Actual_Type (Assoc); + begin + Set_Instance (Inter_Type_Def, Actual_Type); + end; + when Iir_Kind_Association_Element_Subprogram => + -- Replace the interface subprogram by the subprogram. + declare + Inter_Subprg : constant Iir := + Get_Association_Interface (Assoc, Inter); + Actual_Subprg : constant Iir := + Get_Named_Entity (Get_Actual (Assoc)); + begin + Set_Instance (Get_Origin (Inter_Subprg), Actual_Subprg); + end; + when others => + Error_Kind ("instantiate_generic_map_chain", Assoc); + end case; + Next_Association_Interface (Assoc, Inter); + end loop; + end Instantiate_Generic_Map_Chain; + + function Copy_Tree (Orig : Iir) return Iir + is + Prev_Instance_File : constant Source_File_Entry := Instance_File; + Mark : constant Instance_Index_Type := Prev_Instance_Table.Last; + Res : Iir; + begin + Instance_File := No_Source_File_Entry; + + -- Be sure Get_Origin_Priv can be called on existing nodes. + Expand_Origin_Table; + + Res := Instantiate_Iir (Orig, False); + + Instance_File := Prev_Instance_File; + Restore_Origin (Mark); + + return Res; + end Copy_Tree; + + procedure Instantiate_Package_Declaration (Inst : Iir; Pkg : Iir) + is + Header : constant Iir := Get_Package_Header (Pkg); + Prev_Instance_File : constant Source_File_Entry := Instance_File; + Mark : constant Instance_Index_Type := Prev_Instance_Table.Last; + Prev_Within_Shared_Instance : constant Boolean := + Is_Within_Shared_Instance; + begin + Create_Relocation (Inst, Pkg); + Set_Instance_Source_File (Inst, Instance_File); + + -- Be sure Get_Origin_Priv can be called on existing nodes. + Expand_Origin_Table; + + -- For Parent: the instance of PKG is INST. + Set_Origin (Pkg, Inst); + + Is_Within_Shared_Instance := not Get_Macro_Expanded_Flag (Pkg); + + Set_Generic_Chain + (Inst, Instantiate_Generic_Chain (Inst, Get_Generic_Chain (Header))); + Instantiate_Generic_Map_Chain (Inst, Pkg); + Set_Declaration_Chain + (Inst, Instantiate_Iir_Chain (Get_Declaration_Chain (Pkg))); + + Set_Origin (Pkg, Null_Iir); + + Instance_File := Prev_Instance_File; + Restore_Origin (Mark); + + Is_Within_Shared_Instance := Prev_Within_Shared_Instance; + end Instantiate_Package_Declaration; + + function Instantiate_Package_Body (Inst : Iir) return Iir + is + Pkg : constant Iir := Get_Uninstantiated_Package_Decl (Inst); + Prev_Instance_File : constant Source_File_Entry := Instance_File; + Mark : constant Instance_Index_Type := Prev_Instance_Table.Last; + Res : Iir; + begin + Create_Relocation (Inst, Pkg); + + -- Be sure Get_Origin_Priv can be called on existing nodes. + Expand_Origin_Table; + + -- References to package specification (and its declarations) will + -- be redirected to the package instantiation. + Set_Instance (Pkg, Inst); + declare + Pkg_Hdr : constant Iir := Get_Package_Header (Pkg); + Pkg_El : Iir; + Inst_El : Iir; + Inter_El : Iir; + Inter : Iir; + begin + -- In the body, references to interface object are redirected to the + -- instantiated interface objects. + Pkg_El := Get_Generic_Chain (Pkg_Hdr); + Inst_El := Get_Generic_Chain (Inst); + while Is_Valid (Pkg_El) loop + if Get_Kind (Pkg_El) in Iir_Kinds_Interface_Object_Declaration then + Set_Instance (Pkg_El, Inst_El); + end if; + Pkg_El := Get_Chain (Pkg_El); + Inst_El := Get_Chain (Inst_El); + end loop; + + -- In the body, references to interface type are substitued to the + -- mapped type. + Inst_El := Get_Generic_Map_Aspect_Chain (Inst); + Inter_El := Get_Generic_Chain (Inst); + while Is_Valid (Inst_El) loop + case Get_Kind (Inst_El) is + when Iir_Kind_Association_Element_Type => + Inter := Get_Association_Interface (Inst_El, Inter_El); + Set_Instance (Get_Type (Get_Origin (Inter)), + Get_Actual_Type (Inst_El)); + -- Implicit operators. + declare + Imp_Inter : Iir; + Imp_Assoc : Iir; + begin + Imp_Assoc := Get_Subprogram_Association_Chain (Inst_El); + Imp_Inter := Get_Interface_Type_Subprograms + (Get_Origin (Inter)); + while Is_Valid (Imp_Inter) and Is_Valid (Imp_Assoc) loop + Set_Instance + (Imp_Inter, + Get_Named_Entity (Get_Actual (Imp_Assoc))); + Imp_Inter := Get_Chain (Imp_Inter); + Imp_Assoc := Get_Chain (Imp_Assoc); + end loop; + end; + + when Iir_Kind_Association_Element_Subprogram => + Inter := Get_Association_Interface (Inst_El, Inter_El); + Set_Instance (Get_Origin (Inter), + Get_Named_Entity (Get_Actual (Inst_El))); + + when Iir_Kind_Association_Element_By_Expression + | Iir_Kind_Association_Element_By_Individual + | Iir_Kind_Association_Element_Open => + null; + when others => + -- TODO. + raise Internal_Error; + end case; + Next_Association_Interface (Inst_El, Inter_El); + end loop; + end; + Set_Instance_On_Chain + (Get_Declaration_Chain (Pkg), Get_Declaration_Chain (Inst)); + + -- Instantiate the body. + Res := Instantiate_Iir (Get_Package_Body (Pkg), False); + Set_Identifier (Res, Get_Identifier (Inst)); + + -- Restore. + Instance_File := Prev_Instance_File; + Restore_Origin (Mark); + + return Res; + end Instantiate_Package_Body; + + procedure Substitute_On_Iir_List (L : Iir_List; E : Iir; Rep : Iir); + + procedure Substitute_On_Iir (N : Iir; E : Iir; Rep : Iir) is + begin + if N = Null_Iir then + return; + end if; + + pragma Assert (N /= E); + + declare + use Nodes_Meta; + Kind : constant Iir_Kind := Get_Kind (N); + Fields : constant Fields_Array := Get_Fields (Kind); + F : Fields_Enum; + begin + for I in Fields'Range loop + F := Fields (I); + + case Get_Field_Type (F) is + when Type_Iir => + declare + S : constant Iir := Get_Iir (N, F); + begin + if S = E then + -- Substitute + Set_Iir (N, F, Rep); + pragma Assert (Get_Field_Attribute (F) = Attr_Ref); + else + case Get_Field_Attribute (F) is + when Attr_None => + Substitute_On_Iir (S, E, Rep); + when Attr_Ref + | Attr_Forward_Ref + | Attr_Maybe_Forward_Ref => + null; + when Attr_Maybe_Ref => + if not Get_Is_Ref (N) then + Substitute_On_Iir (S, E, Rep); + end if; + when Attr_Chain => + Substitute_On_Chain (S, E, Rep); + when Attr_Chain_Next => + null; + when Attr_Of_Ref | Attr_Of_Maybe_Ref => + -- Can only appear in list. + raise Internal_Error; + end case; + end if; + end; + when Type_Iir_List => + declare + S : constant Iir_List := Get_Iir_List (N, F); + begin + case Get_Field_Attribute (F) is + when Attr_None => + Substitute_On_Iir_List (S, E, Rep); + when Attr_Of_Maybe_Ref => + if not Get_Is_Ref (N) then + Substitute_On_Iir_List (S, E, Rep); + end if; + when Attr_Of_Ref + | Attr_Ref + | Attr_Forward_Ref => + null; + when others => + -- Ref is specially handled in Instantiate_Iir. + -- Others cannot appear for lists. + raise Internal_Error; + end case; + end; + when others => + null; + end case; + end loop; + end; + end Substitute_On_Iir; + + procedure Substitute_On_Iir_List (L : Iir_List; E : Iir; Rep : Iir) + is + It : List_Iterator; + begin + case L is + when Null_Iir_List + | Iir_List_All => + return; + when others => + It := List_Iterate (L); + while Is_Valid (It) loop + Substitute_On_Iir (Get_Element (It), E, Rep); + Next (It); + end loop; + end case; + end Substitute_On_Iir_List; + + procedure Substitute_On_Chain (Chain : Iir; E : Iir; Rep : Iir) + is + El : Iir; + begin + El := Chain; + while Is_Valid (El) loop + Substitute_On_Iir (El, E, Rep); + El := Get_Chain (El); + end loop; + end Substitute_On_Chain; + +end Vhdl.Sem_Inst; diff --git a/src/vhdl/vhdl-sem_inst.ads b/src/vhdl/vhdl-sem_inst.ads new file mode 100644 index 000000000..48d72b770 --- /dev/null +++ b/src/vhdl/vhdl-sem_inst.ads @@ -0,0 +1,36 @@ +-- Package (and subprograms) instantiations + +-- When a package is instantiated, we need to 'duplicate' its declaration. +-- This looks useless for analysis but it isn't: a type from a package +-- instantiated twice declares two different types. Without duplication, we +-- need to attach to each declaration its instance, which looks more expansive +-- that duplicating the declaration. +-- +-- Furthermore, for generic type interface, it looks a good idea to duplicate +-- the body (macro expansion). +-- +-- Duplicating is not trivial: internal links must be kept and external +-- links preserved. A table is used to map nodes from the uninstantiated +-- package to its duplicated node. Links from instantiated declaration to +-- the original declaration are also stored in that table. + +with Iirs; use Iirs; + +package Vhdl.Sem_Inst is + -- Return the origin of node N, the node from which N was instantiated. + -- If N is not an instance, this function returns Null_Iir. + function Get_Origin (N : Iir) return Iir; + + -- Create declaration chain and generic declarations for INST from PKG. + procedure Instantiate_Package_Declaration (Inst : Iir; Pkg : Iir); + + -- Return the instantiation of the body for INST, ie macro-expand the + -- body. INST has the form of a generic-mapped package. + function Instantiate_Package_Body (Inst : Iir) return Iir; + + -- In CHAIN, substitute all references to E by REP. + procedure Substitute_On_Chain (Chain : Iir; E : Iir; Rep : Iir); + + -- Deep copy of ORIG. Doesn't change location. + function Copy_Tree (Orig : Iir) return Iir; +end Vhdl.Sem_Inst; diff --git a/src/vhdl/vhdl-sem_lib.adb b/src/vhdl/vhdl-sem_lib.adb new file mode 100644 index 000000000..4b2319c09 --- /dev/null +++ b/src/vhdl/vhdl-sem_lib.adb @@ -0,0 +1,411 @@ +-- VHDL libraries handling. +-- Copyright (C) 2018 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 Flags; +with Name_Table; +with Files_Map; +with Iirs_Utils; use Iirs_Utils; +with Errorout; use Errorout; +with Libraries; use Libraries; +with Vhdl.Scanner; +with Vhdl.Parse; +with Vhdl.Disp_Tree; +with Vhdl.Disp_Vhdl; +with Vhdl.Sem; +with Post_Sems; +with Vhdl.Canon; +with Nodes_GC; + +package body Vhdl.Sem_Lib is + procedure Error_Lib_Msg (Msg : String; Arg1 : Earg_Type) is + begin + Report_Msg (Msgid_Error, Library, No_Location, Msg, (1 => Arg1)); + end Error_Lib_Msg; + + function Load_File (File : Source_File_Entry) return Iir_Design_File + is + Res : Iir_Design_File; + begin + Vhdl.Scanner.Set_File (File); + if Vhdl.Scanner.Detect_Encoding_Errors then + -- Don't even try to parse such a file. The BOM will be interpreted + -- as an identifier, which is not valid at the beginning of a file. + Res := Null_Iir; + else + Res := Vhdl.Parse.Parse_Design_File; + end if; + Vhdl.Scanner.Close_File; + + if Res /= Null_Iir then + Set_Parent (Res, Work_Library); + Set_Design_File_Filename (Res, Files_Map.Get_File_Name (File)); + Set_Design_File_Source (Res, File); + end if; + return Res; + end Load_File; + + -- parse a file. + -- Return a design_file without putting it into the library + -- (because it was not analyzed). + function Load_File_Name (File_Name: Name_Id) return Iir_Design_File + is + Fe : Source_File_Entry; + begin + Fe := Files_Map.Read_Source_File (Local_Directory, File_Name); + if Fe = No_Source_File_Entry then + Error_Msg_Option ("cannot open " & Name_Table.Image (File_Name)); + return Null_Iir; + end if; + return Load_File (Fe); + end Load_File_Name; + + procedure Finish_Compilation + (Unit : Iir_Design_Unit; Main : Boolean := False) + is + Lib_Unit : Iir; + begin + Lib_Unit := Get_Library_Unit (Unit); + if (Main or Flags.Dump_All) and then Flags.Dump_Parse then + Vhdl.Disp_Tree.Disp_Tree (Unit); + end if; + + if Flags.Check_Ast_Level > 0 then + Nodes_GC.Check_Tree (Unit); + end if; + + if Flags.Verbose then + Report_Msg (Msgid_Note, Semantic, +Lib_Unit, + "analyze %n", (1 => +Lib_Unit)); + end if; + + Sem.Semantic (Unit); + + if (Main or Flags.Dump_All) and then Flags.Dump_Sem then + Vhdl.Disp_Tree.Disp_Tree (Unit); + end if; + + if Errorout.Nbr_Errors > 0 then + return; + end if; + + if (Main or Flags.List_All) and then Flags.List_Sem then + Vhdl.Disp_Vhdl.Disp_Vhdl (Unit); + end if; + + if Flags.Check_Ast_Level > 0 then + Nodes_GC.Check_Tree (Unit); + end if; + + -- Post checks + ---------------- + + Post_Sems.Post_Sem_Checks (Unit); + + if Errorout.Nbr_Errors > 0 then + return; + end if; + + -- Canonalisation. + ------------------ + + if Flags.Verbose then + Report_Msg (Msgid_Note, Semantic, +Lib_Unit, + "canonicalize %n", (1 => +Lib_Unit)); + end if; + + Vhdl.Canon.Canonicalize (Unit); + + if (Main or Flags.Dump_All) and then Flags.Dump_Canon then + Vhdl.Disp_Tree.Disp_Tree (Unit); + end if; + + if Errorout.Nbr_Errors > 0 then + return; + end if; + + if (Main or Flags.List_All) and then Flags.List_Canon then + Vhdl.Disp_Vhdl.Disp_Vhdl (Unit); + end if; + + if Flags.Check_Ast_Level > 0 then + Nodes_GC.Check_Tree (Unit); + end if; + end Finish_Compilation; + + procedure Free_Dependence_List (Design : Iir_Design_Unit) + is + List : Iir_List; + begin + List := Get_Dependence_List (Design); + if List /= Null_Iir_List then + Free_Recursive_List (List); + Destroy_Iir_List (List); + end if; + end Free_Dependence_List; + + procedure Load_Parse_Design_Unit (Design_Unit: Iir_Design_Unit; Loc : Iir) + is + use Vhdl.Scanner; + Design_File : constant Iir_Design_File := Get_Design_File (Design_Unit); + Fe : Source_File_Entry; + Line, Off: Natural; + Pos: Source_Ptr; + Res: Iir; + begin + -- The unit must not be loaded. + pragma Assert (Get_Date_State (Design_Unit) = Date_Disk); + + Fe := Get_Design_File_Source (Design_File); + if Fe = No_Source_File_Entry then + -- Load the file in memory. + Fe := Files_Map.Read_Source_File + (Get_Design_File_Directory (Design_File), + Get_Design_File_Filename (Design_File)); + if Fe = No_Source_File_Entry then + Error_Lib_Msg ("cannot load %n", +Get_Library_Unit (Design_Unit)); + raise Compilation_Error; + end if; + Set_Design_File_Source (Design_File, Fe); + + -- Check if the file has changed. + if not Files_Map.Is_Eq + (Files_Map.Get_File_Checksum (Fe), Get_File_Checksum (Design_File)) + then + Error_Msg_Sem (+Loc, "file %i has changed and must be reanalysed", + +Get_Design_File_Filename (Design_File)); + raise Compilation_Error; + end if; + end if; + + if Get_Date (Design_Unit) = Date_Obsolete then + Error_Msg_Sem (+Loc, "%n has been obsoleted", + +Get_Library_Unit (Design_Unit)); + raise Compilation_Error; + end if; + + -- Set the position of the lexer + Set_File (Fe); + Pos := Get_Design_Unit_Source_Pos (Design_Unit); + Line := Natural (Get_Design_Unit_Source_Line (Design_Unit)); + Off := Natural (Get_Design_Unit_Source_Col (Design_Unit)); + Files_Map.File_Add_Line_Number (Get_Current_Source_File, Line, Pos); + Set_Current_Position (Pos + Source_Ptr (Off)); + + -- Parse + Scan; + Res := Vhdl.Parse.Parse_Design_Unit; + Close_File; + if Res = Null_Iir then + raise Compilation_Error; + end if; + + Set_Date_State (Design_Unit, Date_Parse); + + -- FIXME: check the library unit read is the one expected. + + -- Move the unit in the library: keep the design_unit of the library, + -- but replace the library_unit by the one that has been parsed. Do + -- not forget to relocate parents. + Iirs_Utils.Free_Recursive (Get_Library_Unit (Design_Unit)); + Set_Library_Unit (Design_Unit, Get_Library_Unit (Res)); + Set_Design_Unit (Get_Library_Unit (Res), Design_Unit); + Set_Parent (Get_Library_Unit (Res), Design_Unit); + declare + Item : Iir; + begin + Item := Get_Context_Items (Res); + Set_Context_Items (Design_Unit, Item); + while Is_Valid (Item) loop + Set_Parent (Item, Design_Unit); + Item := Get_Chain (Item); + end loop; + end; + Location_Copy (Design_Unit, Res); + Free_Dependence_List (Design_Unit); + Set_Dependence_List (Design_Unit, Get_Dependence_List (Res)); + Set_Dependence_List (Res, Null_Iir_List); + Free_Iir (Res); + end Load_Parse_Design_Unit; + + procedure Error_Obsolete (Loc : Iir; Msg : String; Args : Earg_Arr) is + begin + if not Flags.Flag_Elaborate_With_Outdated then + if Loc = Null_Iir then + Error_Msg_Sem (Command_Line_Location, Msg, Args); + else + Error_Msg_Sem (+Loc, Msg, Args); + end if; + end if; + end Error_Obsolete; + + -- Check if one of its dependency makes this unit obsolete. + function Check_Obsolete_Dependence (Design_Unit : Iir; Loc : Iir) + return Boolean + is + List : constant Iir_List := Get_Dependence_List (Design_Unit); + Du_Ts : constant Time_Stamp_Id := + Get_Analysis_Time_Stamp (Get_Design_File (Design_Unit)); + U_Ts : Time_Stamp_Id; + El : Iir; + It : List_Iterator; + begin + if List = Null_Iir_List then + return False; + end if; + + It := List_Iterate (List); + while Is_Valid (It) loop + El := Get_Element (It); + if Get_Kind (El) = Iir_Kind_Design_Unit then + U_Ts := Get_Analysis_Time_Stamp (Get_Design_File (El)); + if Files_Map.Is_Gt (U_Ts, Du_Ts) then + Error_Obsolete + (Loc, "%n is obsoleted by %n", (+Design_Unit, +El)); + return True; + end if; + end if; + Next (It); + end loop; + + return False; + end Check_Obsolete_Dependence; + + procedure Explain_Obsolete (Design_Unit : Iir_Design_Unit; Loc : Iir) + is + List : Iir_List; + It : List_Iterator; + El : Iir; + begin + pragma Assert (Get_Date_State (Design_Unit) = Date_Analyze); + pragma Assert (Get_Date (Design_Unit) = Date_Obsolete); + + List := Get_Dependence_List (Design_Unit); + if List = Null_Iir_List then + -- Argh, we don't know why. + Error_Obsolete (Loc, "%n is obsolete", (1 => +Design_Unit)); + return; + end if; + + It := List_Iterate (List); + while Is_Valid (It) loop + El := Get_Element (It); + if Get_Date (El) = Date_Obsolete then + Error_Obsolete (Loc, "%n is obsoleted by %n", (+Design_Unit, +El)); + return; + end if; + Next (It); + end loop; + end Explain_Obsolete; + + -- Load, parse, analyze, back-end a design_unit if necessary. + procedure Load_Design_Unit (Design_Unit : Iir_Design_Unit; Loc : Iir) + is + Warnings : Warnings_Setting; + begin + if Get_Date (Design_Unit) = Date_Replacing then + Error_Msg_Sem (+Loc, "circular reference of %n", +Design_Unit); + return; + end if; + + if Get_Date_State (Design_Unit) = Date_Disk then + Load_Parse_Design_Unit (Design_Unit, Loc); + end if; + + if Get_Date_State (Design_Unit) = Date_Parse then + -- Analyze the design unit. + + if Get_Date (Design_Unit) = Date_Analyzed then + -- Work-around for an internal check in sem. + -- FIXME: to be removed ? + Set_Date (Design_Unit, Date_Parsed); + end if; + + -- Avoid infinite recursion, if the unit is self-referenced. + Set_Date_State (Design_Unit, Date_Analyze); + + -- Disable all warnings. Warnings are emitted only when the unit + -- is analyzed. + Save_Warnings_Setting (Warnings); + Disable_All_Warnings; + + -- Analyze unit. + Finish_Compilation (Design_Unit); + + -- Restore warnings. + Restore_Warnings_Setting (Warnings); + + -- Check if one of its dependency makes this unit obsolete. + -- FIXME: to do when the dependency is added ? + if not Flags.Flag_Elaborate_With_Outdated + and then Check_Obsolete_Dependence (Design_Unit, Loc) + then + Set_Date (Design_Unit, Date_Obsolete); + return; + end if; + end if; + + case Get_Date (Design_Unit) is + when Date_Parsed => + raise Internal_Error; + when Date_Analyzing => + -- Self-referenced unit. + return; + when Date_Analyzed => + -- FIXME: Accept it silently ? + -- Note: this is used when Flag_Elaborate_With_Outdated is set. + -- This is also used by anonymous configuration declaration. + null; + when Date_Uptodate => + return; + when Date_Valid => + null; + when Date_Obsolete => + if not Flags.Flag_Elaborate_With_Outdated then + Explain_Obsolete (Design_Unit, Loc); + end if; + when others => + raise Internal_Error; + end case; + end Load_Design_Unit; + + function Load_Primary_Unit + (Library: Iir_Library_Declaration; Name: Name_Id; Loc : Iir) + return Iir_Design_Unit + is + Design_Unit: Iir_Design_Unit; + begin + Design_Unit := Find_Primary_Unit (Library, Name); + if Design_Unit /= Null_Iir then + Load_Design_Unit (Design_Unit, Loc); + end if; + return Design_Unit; + end Load_Primary_Unit; + + -- Load an secondary unit and analyse it. + function Load_Secondary_Unit + (Primary: Iir_Design_Unit; Name: Name_Id; Loc : Iir) + return Iir_Design_Unit + is + Design_Unit: Iir_Design_Unit; + begin + Design_Unit := Find_Secondary_Unit (Primary, Name); + if Design_Unit /= Null_Iir then + Load_Design_Unit (Design_Unit, Loc); + end if; + return Design_Unit; + end Load_Secondary_Unit; +end Vhdl.Sem_Lib; diff --git a/src/vhdl/vhdl-sem_lib.ads b/src/vhdl/vhdl-sem_lib.ads new file mode 100644 index 000000000..812279b90 --- /dev/null +++ b/src/vhdl/vhdl-sem_lib.ads @@ -0,0 +1,58 @@ +-- VHDL libraries handling. +-- Copyright (C) 2018 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 Types; use Types; +with Iirs; use Iirs; + +package Vhdl.Sem_Lib is + -- Start the analyse a file (ie load and parse it). + -- The file is read from the current directory (unless FILE_NAME is an + -- absolute path). + -- Emit an error if the file cannot be opened. + -- Return NULL_IIR in case of parse error. + function Load_File_Name (File_Name: Name_Id) return Iir_Design_File; + function Load_File (File : Source_File_Entry) return Iir_Design_File; + + -- Load, parse, analyze, back-end a design_unit if necessary. + -- Check Design_Unit is not obsolete. + -- LOC is the location where the design unit was needed, in case of error. + procedure Load_Design_Unit (Design_Unit: Iir_Design_Unit; Loc : Iir); + + -- Load and parse DESIGN_UNIT. + -- Contrary to Load_Design_Unit, the design_unit is not analyzed. + -- Also, the design_unit must not have been already loaded. + -- Used almost only by Load_Design_Unit. + procedure Load_Parse_Design_Unit (Design_Unit: Iir_Design_Unit; Loc : Iir); + + -- Load an already analyzed primary unit NAME from library LIBRARY + -- and compile it. + -- Return NULL_IIR if not found (ie, NAME does not correspond to a + -- library unit identifier). + function Load_Primary_Unit + (Library: Iir_Library_Declaration; Name: Name_Id; Loc : Iir) + return Iir_Design_Unit; + + -- Load an secondary unit of primary unit PRIMARY and analyse it. + -- NAME must be set only for an architecture. + function Load_Secondary_Unit + (Primary: Iir_Design_Unit; Name: Name_Id; Loc : Iir) + return Iir_Design_Unit; + + -- Analyze UNIT. + procedure Finish_Compilation + (Unit : Iir_Design_Unit; Main : Boolean := False); +end Vhdl.Sem_Lib; diff --git a/src/vhdl/vhdl-sem_names.adb b/src/vhdl/vhdl-sem_names.adb new file mode 100644 index 000000000..d72af8c28 --- /dev/null +++ b/src/vhdl/vhdl-sem_names.adb @@ -0,0 +1,4313 @@ +-- Semantic analysis. +-- 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 Evaluation; use Evaluation; +with Iirs_Utils; use Iirs_Utils; +with Errorout; use Errorout; +with Flags; use Flags; +with Name_Table; +with Std_Package; use Std_Package; +with Types; use Types; +with Iir_Chains; use Iir_Chains; +with Std_Names; +with Vhdl.Sem; +with Vhdl.Sem_Lib; use Vhdl.Sem_Lib; +with Vhdl.Sem_Scopes; use Vhdl.Sem_Scopes; +with Vhdl.Sem_Expr; use Vhdl.Sem_Expr; +with Vhdl.Sem_Stmts; use Vhdl.Sem_Stmts; +with Vhdl.Sem_Decls; use Vhdl.Sem_Decls; +with Vhdl.Sem_Assocs; use Vhdl.Sem_Assocs; +with Vhdl.Sem_Specs; +with Vhdl.Sem_Types; +with Vhdl.Sem_Psl; +with Xrefs; use Xrefs; + +package body Vhdl.Sem_Names is + -- Finish the analyze of NAME using RES as named entity. + -- This is called when the analyze is finished and an uniq + -- interpretation has been determined (RES). + -- + -- Error messages are emitted here. + function Finish_Sem_Name (Name : Iir; Res : Iir) return Iir; + + -- Return the fully analyzed name of NAME. + function Name_To_Analyzed_Name (Name : Iir) return Iir; + + procedure Error_Overload (Expr: Iir) is + begin + if Is_Error (Expr) then + -- Avoid error storm. + return; + end if; + Error_Msg_Sem (+Expr, "can't resolve overload for %n", +Expr); + end Error_Overload; + + procedure Disp_Overload_List (List : Iir_List; Loc : Iir) + is + El : Iir; + It : List_Iterator; + begin + Error_Msg_Sem (+Loc, "possible interpretations are:", Cont => True); + It := List_Iterate (List); + while Is_Valid (It) loop + El := Get_Element (It); + case Get_Kind (El) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Error_Msg_Sem (+El, Disp_Subprg (El)); + when Iir_Kind_Function_Call => + El := Get_Implementation (El); + Error_Msg_Sem (+El, Disp_Subprg (El)); + when others => + Error_Msg_Sem (+El, "%n", +El); + end case; + Next (It); + end loop; + end Disp_Overload_List; + + -- Create an overload list. + -- must be destroyed with free_iir. + function Get_Overload_List return Iir_Overload_List + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Overload_List); + return Res; + end Get_Overload_List; + + function Create_Overload_List (List : Iir_List) return Iir_Overload_List + is + Res : Iir_Overload_List; + begin + Res := Get_Overload_List; + Set_Overload_List (Res, List); + return Res; + end Create_Overload_List; + + procedure Free_Overload_List (N : in out Iir_Overload_List) + is + List : Iir_List; + begin + List := Get_Overload_List (N); + Destroy_Iir_List (List); + Free_Iir (N); + N := Null_Iir; + end Free_Overload_List; + + function Simplify_Overload_List (List : Iir_List) return Iir + is + Res : Iir; + L1 : Iir_List; + begin + case Get_Nbr_Elements (List) is + when 0 => + L1 := List; + Destroy_Iir_List (L1); + return Null_Iir; + when 1 => + L1 := List; + Res := Get_First_Element (List); + Destroy_Iir_List (L1); + return Res; + when others => + return Create_Overload_List (List); + end case; + end Simplify_Overload_List; + + -- Return true if AN_IIR is an overload list. + function Is_Overload_List (An_Iir: Iir) return Boolean is + begin + return Get_Kind (An_Iir) = Iir_Kind_Overload_List; + end Is_Overload_List; + + function Is_Defined_Type (Atype : Iir) return Boolean is + begin + return Atype /= Null_Iir + and then not Kind_In (Get_Kind (Atype), + Iir_Kind_Overload_List, + Iir_Kind_Wildcard_Type_Definition); + end Is_Defined_Type; + + -- From the list LIST of function or enumeration literal, extract the + -- list of (return) types. + -- If there is only one type, return it. + -- If there is no types, return NULL. + -- Otherwise, return the list as an overload list. + function Create_List_Of_Types (List : Iir_List) + return Iir + is + Res_List : Iir_List; + Decl : Iir; + It : List_Iterator; + begin + -- Create the list of possible return types. + Res_List := Create_Iir_List; + It := List_Iterate (List); + while Is_Valid (It) loop + Decl := Get_Element (It); + case Get_Kind (Decl) is + when Iir_Kind_Function_Declaration => + Add_Element (Res_List, Get_Return_Type (Decl)); + when Iir_Kind_Enumeration_Literal + | Iir_Kind_Function_Call + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Selected_Element => + Add_Element (Res_List, Get_Type (Decl)); + when others => + Error_Kind ("create_list_of_types", Decl); + end case; + Next (It); + end loop; + return Simplify_Overload_List (Res_List); + end Create_List_Of_Types; + + procedure Add_Result (Res : in out Iir; Decl : Iir) + is + Nres : Iir; + Nres_List : Iir_List; + begin + if Decl = Null_Iir then + return; + end if; + if Res = Null_Iir then + Res := Decl; + elsif Is_Overload_List (Res) then + Append_Element (Get_Overload_List (Res), Decl); + else + Nres_List := Create_Iir_List; + Nres := Create_Overload_List (Nres_List); + Append_Element (Nres_List, Res); + Append_Element (Nres_List, Decl); + Res := Nres; + end if; + end Add_Result; + + -- Extract from overload list RES the function call without implicit + -- conversion. Return Null_Iir if there is no function call, or if there + -- is an expressions that isn't a function call, or if there is more than + -- one function call without implicit conversion. + -- Cf Sem_Expr.Get_Non_Implicit_Subprogram + function Extract_Call_Without_Implicit_Conversion (Res : Iir) return Iir + is + pragma Assert (Is_Overload_List (Res)); + List : constant Iir_List := Get_Overload_List (Res); + It : List_Iterator; + Call : Iir; + El : Iir; + Imp : Iir; + Inter : Iir; + begin + Call := Null_Iir; + It := List_Iterate (List); + while Is_Valid (It) loop + El := Get_Element (It); + if Get_Kind (El) = Iir_Kind_Function_Call then + Imp := Get_Implementation (El); + Inter := Get_Interface_Declaration_Chain (Imp); + if Get_Type (Inter) = Universal_Integer_Type_Definition + or else Get_Type (Inter) = Universal_Real_Type_Definition + then + -- The type of the first interface is a universal type. So, + -- there were no implicit conversions. Once there is an + -- implicit conversion, the only way to 'convert' to a + -- universal type is through T'Pos, which has to be resolved. + -- Note: there are no interface of convertible types. + -- GHDL: this is not proven... + if Call /= Null_Iir then + -- More than one call without implicit conversion. + return Null_Iir; + else + Call := El; + end if; + end if; + else + return Null_Iir; + end if; + Next (It); + end loop; + + return Call; + end Extract_Call_Without_Implicit_Conversion; + + -- Move elements of result list LIST to result list RES. + -- Destroy LIST if necessary. + procedure Add_Result_List (Res : in out Iir; List : Iir); + pragma Unreferenced (Add_Result_List); + + procedure Add_Result_List (Res : in out Iir; List : Iir) + is + El : Iir; + List_List : Iir_List; + Res_List : Iir_List; + It : List_Iterator; + begin + if Res = Null_Iir then + Res := List; + elsif List = Null_Iir then + null; + elsif not Is_Overload_List (List) then + Add_Result (Res, List); + else + if not Is_Overload_List (Res) then + El := Res; + Res := Get_Overload_List; + Append_Element (Get_Overload_List (Res), El); + end if; + List_List := Get_Overload_List (List); + Res_List := Get_Overload_List (Res); + It := List_Iterate (List_List); + while Is_Valid (It) loop + Append_Element (Res_List, Get_Element (It)); + Next (It); + end loop; + Free_Iir (List); + end if; + end Add_Result_List; + + -- Free interpretations of LIST except KEEP (which can be Null_Iir to free + -- the whole list). + procedure Sem_Name_Free_Result (List : Iir; Keep : Iir) + is + procedure Sem_Name_Free (El : Iir) is + begin + case Get_Kind (El) is + when Iir_Kind_Function_Call + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element => + Sem_Name_Free (Get_Prefix (El)); + Free_Iir (El); + when Iir_Kind_Attribute_Name => + Free_Iir (El); + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Enumeration_Literal => + null; + when Iir_Kind_Interface_Function_Declaration + | Iir_Kind_Interface_Procedure_Declaration => + null; + when Iir_Kinds_Denoting_Name => + null; + when others => + Error_Kind ("sem_name_free", El); + end case; + end Sem_Name_Free; + + El : Iir; + List_List : Iir_List; + It : List_Iterator; + begin + if List = Null_Iir then + return; + elsif not Is_Overload_List (List) then + if List /= Keep then + Sem_Name_Free (List); + end if; + else + List_List := Get_Overload_List (List); + It := List_Iterate (List_List); + while Is_Valid (It) loop + El := Get_Element (It); + if El /= Keep then + Sem_Name_Free (El); + end if; + Next (It); + end loop; + Free_Iir (List); + end if; + end Sem_Name_Free_Result; + + procedure Free_Parenthesis_Name (Name : Iir; Res : Iir) + is + Chain, Next_Chain : Iir; + begin + pragma Assert (Get_Kind (Res) /= Iir_Kind_Function_Call); + Chain := Get_Association_Chain (Name); + while Chain /= Null_Iir loop + Next_Chain := Get_Chain (Chain); + Free_Iir (Chain); + Chain := Next_Chain; + end loop; + Free_Iir (Name); + end Free_Parenthesis_Name; + + -- Find all named declaration whose identifier is ID in DECL_LIST and + -- return it. + -- The result can be NULL (if no such declaration exist), + -- a declaration, or an overload_list containing all declarations. + function Find_Declarations_In_List + (Decl: Iir; Name : Iir_Selected_Name; Keep_Alias : Boolean) + return Iir + is + Res: Iir := Null_Iir; + + -- If indentifier of DECL is ID, then add DECL in the result. + procedure Handle_Decl (Decl : Iir; Id : Name_Id) is + begin + -- Use_clauses may appear in a declaration list. + case Get_Kind (Decl) is + when Iir_Kind_Use_Clause + | Iir_Kind_Anonymous_Type_Declaration => + return; + when Iir_Kind_Non_Object_Alias_Declaration => + if Get_Identifier (Decl) = Id then + if Keep_Alias then + Add_Result (Res, Decl); + else + Add_Result (Res, Get_Named_Entity (Get_Name (Decl))); + end if; + end if; + when others => + -- Consider only visible declarations (case of an implicit + -- declaration that is overriden by explicit one). + if Get_Identifier (Decl) = Id and Get_Visible_Flag (Decl) then + Add_Result (Res, Decl); + end if; + end case; + end Handle_Decl; + + procedure Iterator_Decl is new Sem_Scopes.Iterator_Decl + (Arg_Type => Name_Id, Handle_Decl => Handle_Decl); + --procedure Iterator_Decl_List is new Sem_Scopes.Iterator_Decl_List + -- (Arg_Type => Name_Id, Handle_Decl => Iterator_Decl); + procedure Iterator_Decl_Chain is new Sem_Scopes.Iterator_Decl_Chain + (Arg_Type => Name_Id, Handle_Decl => Iterator_Decl); + + Id : constant Name_Id := Get_Identifier (Name); + begin + case Get_Kind (Decl) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Iterator_Decl_Chain (Get_Interface_Declaration_Chain (Decl), Id); + when Iir_Kind_Entity_Declaration => + Iterator_Decl_Chain (Get_Generic_Chain (Decl), Id); + Iterator_Decl_Chain (Get_Port_Chain (Decl), Id); + when Iir_Kind_Architecture_Body => + null; + when Iir_Kind_If_Generate_Statement + | Iir_Kind_For_Generate_Statement => + null; + when Iir_Kind_Package_Declaration => + declare + Header : constant Iir := Get_Package_Header (Decl); + begin + if Is_Valid (Header) + and then Get_Is_Within_Flag (Decl) + then + Iterator_Decl_Chain (Get_Generic_Chain (Header), Id); + end if; + end; + when Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Interface_Package_Declaration => + -- Generics are not visible in selected name. + null; + -- Iterator_Decl_Chain (Get_Generic_Chain (Decl), Id); + when Iir_Kind_Block_Statement => + declare + Header : constant Iir := Get_Block_Header (Decl); + begin + if Header /= Null_Iir then + Iterator_Decl_Chain (Get_Generic_Chain (Header), Id); + Iterator_Decl_Chain (Get_Port_Chain (Header), Id); + end if; + end; + when Iir_Kind_For_Loop_Statement => + Handle_Decl (Get_Parameter_Specification (Decl), Id); + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + null; + when others => + Error_Kind ("find_declarations_in_list", Decl); + end case; + + case Get_Kind (Decl) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + declare + Decl_Body : constant Iir := Get_Subprogram_Body (Decl); + begin + Iterator_Decl_Chain + (Get_Declaration_Chain (Decl_Body), Id); + Iterator_Decl_Chain + (Get_Sequential_Statement_Chain (Decl_Body), Id); + end; + when Iir_Kind_Architecture_Body + | Iir_Kind_Entity_Declaration + | Iir_Kind_Block_Statement => + Iterator_Decl_Chain (Get_Declaration_Chain (Decl), Id); + Iterator_Decl_Chain (Get_Concurrent_Statement_Chain (Decl), Id); + when Iir_Kind_For_Generate_Statement => + declare + Bod : constant Iir := Get_Generate_Statement_Body (Decl); + begin + Iterator_Decl_Chain (Get_Declaration_Chain (Bod), Id); + Iterator_Decl_Chain (Get_Concurrent_Statement_Chain (Bod), Id); + end; + when Iir_Kind_If_Generate_Statement => + declare + Clause : Iir; + Bod : Iir; + begin + -- Look only in the current generate_statement_body + Clause := Decl; + while Clause /= Null_Iir loop + Bod := Get_Generate_Statement_Body (Clause); + if Get_Is_Within_Flag (Bod) then + Iterator_Decl_Chain + (Get_Declaration_Chain (Bod), Id); + Iterator_Decl_Chain + (Get_Concurrent_Statement_Chain (Bod), Id); + exit; + end if; + Clause := Get_Generate_Else_Clause (Clause); + end loop; + end; + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Interface_Package_Declaration => + Iterator_Decl_Chain (Get_Declaration_Chain (Decl), Id); + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Iterator_Decl_Chain (Get_Declaration_Chain (Decl), Id); + Iterator_Decl_Chain (Get_Sequential_Statement_Chain (Decl), Id); + when Iir_Kind_For_Loop_Statement => + null; + when others => + Error_Kind ("find_declarations_in_list", Decl); + end case; + --if Res = Null_Iir then + -- Error_Msg_Sem ("""" & Name_Table.Image (Id) & """ not defined in " + -- & Disp_Node (Decl), Name); + --end if; + return Res; + end Find_Declarations_In_List; + + -- Create an implicit_dereference node if PREFIX is of type access. + -- Return PREFIX otherwise. + -- PARENT is used if an implicit dereference node is created, to copy + -- location from. + function Insert_Implicit_Dereference (Prefix : Iir; Parent : Iir) + return Iir + is + Prefix_Type : Iir; + Res : Iir_Implicit_Dereference; + begin + Prefix_Type := Get_Type (Prefix); + + case Get_Kind (Prefix_Type) is + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + null; + when others => + return Prefix; + end case; + Check_Read (Prefix); + Res := Create_Iir (Iir_Kind_Implicit_Dereference); + Location_Copy (Res, Parent); + Set_Type (Res, Get_Designated_Type (Prefix_Type)); + Set_Prefix (Res, Prefix); + Set_Base_Name (Res, Res); + Set_Expr_Staticness (Res, None); + return Res; + end Insert_Implicit_Dereference; + + -- If PREFIX is a function specification that cannot be converted to a + -- function call (because of lack of association), return FALSE. + function Maybe_Function_Call (Prefix : Iir) return Boolean + is + Inter : Iir; + begin + if Get_Kind (Prefix) /= Iir_Kind_Function_Declaration then + return True; + end if; + Inter := Get_Interface_Declaration_Chain (Prefix); + while Inter /= Null_Iir loop + if Get_Default_Value (Inter) = Null_Iir then + return False; + end if; + Inter := Get_Chain (Inter); + end loop; + return True; + end Maybe_Function_Call; + + procedure Name_To_Method_Object (Call : Iir; Name : Iir) + is + Prefix : Iir; + Obj : Iir; + begin + if Get_Kind (Name) /= Iir_Kind_Selected_Name then + return; + end if; + + Prefix := Get_Prefix (Name); + Obj := Get_Named_Entity (Prefix); + if Obj /= Null_Iir + and then Kind_In (Obj, Iir_Kind_Variable_Declaration, + Iir_Kind_Interface_Variable_Declaration) + and then Get_Type (Obj) /= Null_Iir + then + if Get_Kind (Get_Type (Obj)) /= Iir_Kind_Protected_Type_Declaration + then + Error_Msg_Sem + (+Prefix, "type of the prefix should be a protected type"); + return; + end if; + Set_Method_Object (Call, Obj); + end if; + end Name_To_Method_Object; + + -- NAME is the name of the function (and not the parenthesis name) + function Sem_As_Function_Call (Name : Iir; Spec : Iir; Assoc_Chain : Iir) + return Iir_Function_Call + is + Call : Iir_Function_Call; + begin + -- Check. + pragma Assert (Get_Kind (Name) in Iir_Kinds_Denoting_Name); + + Call := Create_Iir (Iir_Kind_Function_Call); + Location_Copy (Call, Name); + if Get_Kind (Name) = Iir_Kind_Parenthesis_Name then + Set_Prefix (Call, Get_Prefix (Name)); + else + Set_Prefix (Call, Name); + end if; + Name_To_Method_Object (Call, Name); + Set_Implementation (Call, Spec); + Set_Parameter_Association_Chain (Call, Assoc_Chain); + Set_Type (Call, Get_Return_Type (Spec)); + Set_Base_Name (Call, Call); + return Call; + end Sem_As_Function_Call; + + -- If SPEC is a function specification, then return a function call, + -- else return SPEC. + function Maybe_Insert_Function_Call (Name : Iir; Spec : Iir) return Iir + is + begin + if Get_Kind (Spec) = Iir_Kind_Function_Declaration then + return Sem_As_Function_Call (Name, Spec, Null_Iir); + else + return Spec; + end if; + end Maybe_Insert_Function_Call; + + -- If PTR_TYPE is not NULL_IIR, then return an implciti dereference to + -- PREFIX, else return PREFIX. + function Maybe_Insert_Dereference (Prefix : Iir; Ptr_Type : Iir) return Iir + is + Id : Iir; + begin + if Ptr_Type /= Null_Iir then + Id := Create_Iir (Iir_Kind_Implicit_Dereference); + Location_Copy (Id, Prefix); + Set_Type (Id, Get_Designated_Type (Ptr_Type)); + Set_Prefix (Id, Prefix); + Set_Base_Name (Id, Id); + return Id; + else + return Prefix; + end if; + end Maybe_Insert_Dereference; + + procedure Finish_Sem_Indexed_Name (Expr : Iir) + is + Prefix : constant Iir := Get_Prefix (Expr); + Prefix_Type : constant Iir := Get_Type (Prefix); + Index_List : constant Iir_Flist := Get_Index_List (Expr); + Index_Subtype : Iir; + Index : Iir; + Expr_Staticness : Iir_Staticness; + begin + Expr_Staticness := Locally; + + -- LRM93 §6.4: there must be one such expression for each index + -- position of the array and each expression must be of the + -- type of the corresponding index. + -- Loop on the indexes. + for I in Flist_First .. Flist_Last (Index_List) loop + Index := Get_Nth_Element (Index_List, I); + Index_Subtype := Get_Index_Type (Prefix_Type, I); + -- The index_subtype can be an unconstrained index type. + Index := Check_Is_Expression (Index, Index); + if Index /= Null_Iir then + Index := Sem_Expression (Index, Get_Base_Type (Index_Subtype)); + end if; + if Index /= Null_Iir then + if Get_Expr_Staticness (Index) = Locally + and then Get_Type_Staticness (Index_Subtype) = Locally + then + Index := Eval_Expr_Check (Index, Index_Subtype); + end if; + Set_Nth_Element (Index_List, I, Index); + Expr_Staticness := Min (Expr_Staticness, + Get_Expr_Staticness (Index)); + else + Expr_Staticness := None; + end if; + end loop; + + Set_Type (Expr, Get_Element_Subtype (Prefix_Type)); + + -- LRM93 6.1 + -- a name is said to be a static name iff: + -- The name is an indexed name whose prefix is a static name + -- and every expression that appears as part of the name is a + -- static expression. + -- + -- a name is said to be a locally static name iif: + -- The name is an indexed name whose prefix is a locally + -- static name and every expression that appears as part + -- of the name is a locally static expression. + Set_Name_Staticness + (Expr, Min (Expr_Staticness, Get_Name_Staticness (Prefix))); + + -- An indexed name cannot be locally static. + if Flags.Vhdl_Std < Vhdl_08 then + Expr_Staticness := Min (Globally, Expr_Staticness); + end if; + Set_Expr_Staticness + (Expr, Min (Expr_Staticness, Get_Expr_Staticness (Prefix))); + + Set_Base_Name (Expr, Get_Base_Name (Prefix)); + end Finish_Sem_Indexed_Name; + + procedure Finish_Sem_Dereference (Res : Iir) is + begin + Set_Base_Name (Res, Res); + Check_Read (Get_Prefix (Res)); + Set_Expr_Staticness (Res, None); + Set_Name_Staticness (Res, None); + end Finish_Sem_Dereference; + + procedure Finish_Sem_Slice_Name (Name : Iir_Slice_Name) + is + -- The prefix of the slice + Prefix : constant Iir := Get_Prefix (Name); + Prefix_Type : constant Iir := Get_Type (Prefix); + Prefix_Base_Type : Iir; + Prefix_Bt : constant Iir := Get_Base_Type (Prefix_Type); + Index_List: Iir_Flist; + Index_Type: Iir; + Suffix: Iir; + Slice_Type : Iir; + Expr_Type : Iir; + Staticness : Iir_Staticness; + Prefix_Rng : Iir; + begin + Set_Base_Name (Name, Get_Base_Name (Prefix)); + + -- LRM93 §6.5: the prefix of an indexed name must be appropriate + -- for an array type. + if Get_Kind (Prefix_Bt) /= Iir_Kind_Array_Type_Definition then + Error_Msg_Sem (+Name, "slice can only be applied to an array"); + return; + end if; + + -- LRM93 §6.5: + -- The prefix of a slice must be appropriate for a + -- one-dimensionnal array object. + Index_List := Get_Index_Subtype_List (Prefix_Type); + if Get_Nbr_Elements (Index_List) /= 1 then + Error_Msg_Sem + (+Name, "slice prefix must be an one-dimensional array"); + return; + end if; + + Index_Type := Get_Index_Type (Index_List, 0); + Prefix_Rng := Eval_Static_Range (Index_Type); + + -- LRM93 6.5 + -- It is an error if either the bounds of the discrete range does not + -- belong to the index range of the prefixing array, *unless* the slice + -- is a null slice. + -- + -- LRM93 6.5 + -- The slice is a null slice if the discrete range is a null range. + + -- LRM93 §6.5: + -- The bounds of the discrete range [...] must be of the + -- type of the index of the array. + Suffix := Sem_Discrete_Range_Expression + (Get_Suffix (Name), Index_Type, False); + if Suffix = Null_Iir then + return; + end if; + Suffix := Eval_Range_If_Static (Suffix); + Set_Suffix (Name, Suffix); + + -- LRM93 §6.5: + -- It is an error if the direction of the discrete range is not + -- the same as that of the index range of the array denoted + -- by the prefix of the slice name. + + -- Check this only if the type is a constrained type. + if Get_Kind (Prefix_Type) = Iir_Kind_Array_Subtype_Definition + and then Get_Index_Constraint_Flag (Prefix_Type) + and then Get_Expr_Staticness (Suffix) = Locally + and then Prefix_Rng /= Null_Iir + and then Get_Direction (Suffix) /= Get_Direction (Prefix_Rng) + then + if False and then Flags.Vhdl_Std = Vhdl_87 then + -- emit a warning for a null slice. + Warning_Msg_Sem (Warnid_Runtime_Error, +Name, + "direction mismatch results in a null slice"); + + end if; + Error_Msg_Sem (+Name, "direction of the range mismatch"); + end if; + + -- LRM93 §7.4.1 + -- A slice is never a locally static expression. + case Get_Kind (Suffix) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Suffix := Get_Type (Suffix); + Staticness := Get_Type_Staticness (Suffix); + when Iir_Kind_Range_Expression + | Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + Staticness := Get_Expr_Staticness (Suffix); + when others => + Error_Kind ("finish_sem_slice_name", Suffix); + end case; + Set_Expr_Staticness + (Name, Min (Min (Staticness, Get_Expr_Staticness (Prefix)), Globally)); + Set_Name_Staticness + (Name, Min (Staticness, Get_Name_Staticness (Prefix))); + + -- The type of the slice is a subtype of the base type whose + -- range contraint is the slice itself. + if Get_Kind (Suffix) in Iir_Kinds_Discrete_Type_Definition then + Slice_Type := Suffix; + else + case Get_Kind (Get_Base_Type (Index_Type)) is + when Iir_Kind_Integer_Type_Definition => + Slice_Type := Create_Iir (Iir_Kind_Integer_Subtype_Definition); + when Iir_Kind_Enumeration_Type_Definition => + Slice_Type := + Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); + when others => + Error_Kind ("sem_expr: slice_name", Get_Base_Type (Index_Type)); + end case; + Set_Range_Constraint (Slice_Type, Suffix); + Set_Is_Ref (Slice_Type, True); + Set_Type_Staticness (Slice_Type, Staticness); + Set_Base_Type (Slice_Type, Get_Base_Type (Index_Type)); + Set_Location (Slice_Type, Get_Location (Suffix)); + end if; + + Expr_Type := Create_Iir (Iir_Kind_Array_Subtype_Definition); + Set_Location (Expr_Type, Get_Location (Suffix)); + Set_Index_Subtype_List (Expr_Type, Create_Iir_Flist (1)); + Set_Index_Constraint_List (Expr_Type, + Get_Index_Subtype_List (Expr_Type)); + Prefix_Base_Type := Get_Base_Type (Prefix_Type); + Set_Base_Type (Expr_Type, Prefix_Base_Type); + Set_Signal_Type_Flag (Expr_Type, + Get_Signal_Type_Flag (Prefix_Base_Type)); + Set_Nth_Element (Get_Index_Subtype_List (Expr_Type), 0, Slice_Type); + Set_Element_Subtype (Expr_Type, Get_Element_Subtype (Prefix_Type)); + if Get_Kind (Prefix_Type) = Iir_Kind_Array_Subtype_Definition then + Set_Resolution_Indication + (Expr_Type, Sem_Types.Copy_Resolution_Indication (Prefix_Type)); + else + Set_Resolution_Indication (Expr_Type, Null_Iir); + end if; + Set_Type_Staticness + (Expr_Type, Min (Get_Type_Staticness (Prefix_Type), + Get_Type_Staticness (Slice_Type))); + Set_Type (Name, Expr_Type); + Set_Slice_Subtype (Name, Expr_Type); + Set_Index_Constraint_Flag (Expr_Type, True); + Set_Constraint_State (Expr_Type, Fully_Constrained); + if Is_Signal_Object (Prefix) then + Sem_Types.Set_Type_Has_Signal (Expr_Type); + end if; + end Finish_Sem_Slice_Name; + + -- PREFIX is the name denoting the function declaration, and its analysis + -- is already finished. + procedure Finish_Sem_Function_Call (Call : Iir; Prefix : Iir) + is + Rtype : Iir; + begin + Set_Prefix (Call, Prefix); + Set_Implementation (Call, Get_Named_Entity (Prefix)); + + -- LRM08 8.1 Names + -- The name is a simple name or selected name that does NOT denote a + -- function call [...] + -- + -- GHDL: so function calls are never static names. + Set_Name_Staticness (Call, None); + + -- FIXME: modify sem_subprogram_call to avoid such a type swap. + Rtype := Get_Type (Call); + Set_Type (Call, Null_Iir); + if Sem_Subprogram_Call (Call, Null_Iir) = Null_Iir then + Set_Type (Call, Rtype); + end if; + end Finish_Sem_Function_Call; + + function Function_Declaration_To_Call (Name : Iir) return Iir + is + Expr : Iir; + begin + Expr := Get_Named_Entity (Name); + if Maybe_Function_Call (Expr) then + Expr := Sem_As_Function_Call (Name, Expr, Null_Iir); + pragma Assert (Get_Kind (Expr) = Iir_Kind_Function_Call); + Finish_Sem_Function_Call (Expr, Name); + return Expr; + else + Error_Msg_Sem (+Name, "%n requires parameters", +Expr); + Set_Type (Name, Get_Type (Expr)); + Set_Expr_Staticness (Name, None); + Set_Named_Entity (Name, Create_Error_Expr (Expr, Get_Type (Expr))); + return Name; + end if; + end Function_Declaration_To_Call; + + function Sem_Type_Mark (Name : Iir; Incomplete : Boolean := False) + return Iir + is + Atype : Iir; + Res : Iir; + begin + -- The name must not have been analyzed. + pragma Assert (Get_Type (Name) = Null_Iir); + + if Is_Error (Name) then + Set_Type (Name, Name); + return Name; + end if; + + -- Analyze the name (if not already done). + Res := Get_Named_Entity (Name); + if Res = Null_Iir then + Sem_Name (Name); + Res := Get_Named_Entity (Name); + end if; + if Res /= Null_Iir and then Is_Overload_List (Res) then + Error_Msg_Sem (+Name, "name does not denote a type mark"); + return Create_Error_Type (Name); + end if; + Res := Finish_Sem_Name (Name); + + -- LRM87 14.1 Predefined attributes + if Get_Kind (Res) = Iir_Kind_Base_Attribute then + Error_Msg_Sem + (+Name, "'Base attribute cannot be used as a type mark"); + end if; + + Atype := Name_To_Type_Definition (Res); + + if Is_Error (Atype) then + if Get_Kind (Res) in Iir_Kinds_Denoting_Name then + Set_Named_Entity (Res, Atype); + else + return Create_Error_Type (Name); + end if; + elsif not Incomplete then + if Get_Kind (Atype) = Iir_Kind_Incomplete_Type_Definition then + Error_Msg_Sem + (+Name, "invalid use of an incomplete type definition"); + Atype := Create_Error_Type (Name); + Set_Named_Entity (Res, Atype); + end if; + end if; + + Set_Type (Res, Atype); + + return Res; + end Sem_Type_Mark; + + -- Return Globally if the prefix of NAME is a globally static name. + function Get_Object_Type_Staticness (Name : Iir) return Iir_Staticness + is + Base : constant Iir := Get_Base_Name (Name); + Parent : Iir; + begin + if Get_Kind (Base) in Iir_Kinds_Dereference then + return None; + end if; + + Parent := Get_Parent (Base); + loop + case Get_Kind (Parent) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Block_Header + | Iir_Kind_Component_Declaration + | Iir_Kinds_Process_Statement + | Iir_Kind_Generate_Statement_Body + | Iir_Kind_Design_Unit => + -- Globally static. + return Globally; + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Protected_Type_Body => + -- Possibly nested construct. + Parent := Get_Parent (Parent); + when Iir_Kinds_Subprogram_Declaration + | Iir_Kinds_Subprogram_Body + | Iir_Kinds_Interface_Subprogram_Declaration => + -- Not globally static. + return None; + when others => + Error_Kind ("get_object_type_staticness", Parent); + end case; + end loop; + end Get_Object_Type_Staticness; + + procedure Finish_Sem_Array_Attribute + (Attr_Name : Iir; Attr : Iir; Param : Iir) + is + Parameter : Iir; + Prefix_Type : Iir; + Index_Type : Iir; + Prefix : Iir; + Prefix_Name : Iir; + Staticness : Iir_Staticness; + begin + -- LRM93 14.1 + -- Parameter: A locally static expression of type universal_integer, the + -- value of which must not exceed the dimensionality of A. If omitted, + -- it defaults to 1. + if Param = Null_Iir then + Parameter := Null_Iir; + else + Parameter := Sem_Expression + (Param, Universal_Integer_Type_Definition); + if Parameter /= Null_Iir then + if Get_Expr_Staticness (Parameter) /= Locally then + Error_Msg_Sem (+Parameter, "parameter must be locally static"); + end if; + else + -- Don't forget there is a parameter, so the attribute cannot + -- be reanalyzed with a default parameter. + Parameter := Error_Mark; + end if; + end if; + + -- See Sem_Array_Attribute_Name for comments about the prefix. + Prefix_Name := Get_Prefix (Attr_Name); + if Is_Type_Name (Prefix_Name) /= Null_Iir then + Prefix := Sem_Type_Mark (Prefix_Name); + else + Prefix := Finish_Sem_Name (Prefix_Name, Get_Prefix (Attr)); + -- Convert function declaration to call. + if Get_Kind (Prefix) in Iir_Kinds_Denoting_Name + and then + (Get_Kind (Get_Named_Entity (Prefix)) + = Iir_Kind_Function_Declaration) + then + Prefix := Function_Declaration_To_Call (Prefix); + end if; + end if; + Set_Prefix (Attr, Prefix); + + Prefix_Type := Get_Type (Prefix); + if Is_Error (Prefix_Type) then + return; + end if; + + declare + Dim : Iir_Int64; + Indexes_List : constant Iir_Flist := + Get_Index_Subtype_List (Prefix_Type); + begin + if Is_Null (Parameter) + or else Get_Expr_Staticness (Parameter) /= Locally + then + Dim := 1; + else + Dim := Get_Value (Parameter); + end if; + if Dim < 1 or else Dim > Iir_Int64 (Get_Nbr_Elements (Indexes_List)) + then + Error_Msg_Sem (+Attr, "parameter value out of bound"); + Dim := 1; + end if; + Index_Type := Get_Index_Type (Indexes_List, Natural (Dim - 1)); + end; + + case Get_Kind (Attr) is + when Iir_Kind_Left_Array_Attribute + | Iir_Kind_Right_Array_Attribute + | Iir_Kind_High_Array_Attribute + | Iir_Kind_Low_Array_Attribute => + Set_Type (Attr, Index_Type); + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + Set_Type (Attr, Index_Type); + when Iir_Kind_Length_Array_Attribute => + Set_Type (Attr, Convertible_Integer_Type_Definition); + when Iir_Kind_Ascending_Array_Attribute => + Set_Type (Attr, Boolean_Type_Definition); + when others => + raise Internal_Error; + end case; + + pragma Assert (Get_Parameter (Attr) = Null_Iir); + + Set_Parameter (Attr, Parameter); + + -- If the corresponding type is known, save it so that it is not + -- necessary to extract it from the object. + if Get_Kind (Prefix_Type) = Iir_Kind_Array_Subtype_Definition + and then Get_Constraint_State (Prefix_Type) = Fully_Constrained + then + Set_Index_Subtype (Attr, Index_Type); + end if; + + -- LRM08 9.4.2 Locally static primaries + -- g) A predefined attribute that is a function, [other than ... and + -- other than ...], whose prefix is either a locally static subtype + -- or is an object that is of a locally static subtype, and whose + -- actual parameter (if any) is a locally static expression. + -- + -- LRM08 9.4.3 Globally static primaries + -- l) A predefined attribute that is a function, [other than ... and + -- other than ...], whose prefix is appropriate for a globally + -- static attribute, and whose actual parameter (if any) is a + -- globally static expression. + -- + -- A prefix is appropriate for a globally static attribute if it denotes + -- a signal, a constant, a type or subtype, a globally static function + -- call, a variable that is not of an access type, or a variable of an + -- access type whose designated subtype is fully constrained. + + -- LRM93 7.4.1 + -- A locally static range is either [...], or a range of the first form + -- whose prefix denotes either a locally static subtype or an object + -- that is of a locally static subtype. + + -- LRM93 7.4.2 + -- A globally static range is either [...], or a range of the first form + -- whose prefix denotes either a globally static subtype or an object + -- that is of a globally static subtype. + -- + -- A globally static subtype is either a globally static scalar subtype, + -- a globally static array subtype, [...] + -- + -- A globally static array subtype is a constrained array subtype + -- formed by imposing on an unconstrained array type a globally static + -- index constraint. + + Staticness := Get_Type_Staticness (Prefix_Type); + if Is_Object_Name (Prefix) then + Staticness := Iir_Staticness'Max + (Staticness, Get_Object_Type_Staticness (Prefix)); + end if; + Set_Expr_Staticness (Attr, Staticness); + end Finish_Sem_Array_Attribute; + + procedure Finish_Sem_Scalar_Type_Attribute + (Attr_Name : Iir; Attr : Iir; Param : Iir) + is + Prefix : Iir; + Prefix_Type : Iir; + Prefix_Bt : Iir; + Parameter : Iir; + Param_Type : Iir; + begin + if Param = Null_Iir then + Error_Msg_Sem (+Attr, "%n requires a parameter", +Attr); + return; + end if; + + Prefix := Finish_Sem_Name (Get_Prefix (Attr)); + Free_Iir (Attr_Name); + Set_Prefix (Attr, Prefix); + + Prefix_Type := Get_Type (Prefix); + Prefix_Bt := Get_Base_Type (Prefix_Type); + + case Get_Kind (Attr) is + when Iir_Kind_Pos_Attribute => + -- LRM93 14.1 + -- Parameter: An expression whose type is the base type of T. + Parameter := Sem_Expression (Param, Prefix_Bt); + when Iir_Kind_Val_Attribute => + -- LRM93 14.1 + -- Parameter: An expression of any integer type. + Param_Type := Get_Type (Param); + if Is_Overload_List (Param_Type) then + Parameter := Sem_Expression + (Param, Universal_Integer_Type_Definition); + else + if Get_Kind (Get_Base_Type (Param_Type)) + /= Iir_Kind_Integer_Type_Definition + then + Error_Msg_Sem (+Attr, "parameter must be an integer"); + return; + end if; + Parameter := Param; + end if; + when Iir_Kind_Succ_Attribute + | Iir_Kind_Pred_Attribute + | Iir_Kind_Leftof_Attribute + | Iir_Kind_Rightof_Attribute => + -- LRM93 14.1 + -- Parameter: An expression whose type is the base type of T. + Parameter := Sem_Expression (Param, Prefix_Bt); + when Iir_Kind_Image_Attribute => + -- LRM93 14.1 + -- Parameter: An expression whose type is the base type of T. + Parameter := Sem_Expression (Param, Prefix_Bt); + when Iir_Kind_Value_Attribute => + -- Parameter: An expression of type string. + Parameter := Sem_Expression (Param, String_Type_Definition); + when others => + raise Internal_Error; + end case; + pragma Assert (Get_Parameter (Attr) = Null_Iir); + if Parameter = Null_Iir then + Set_Parameter (Attr, Param); + Set_Expr_Staticness (Attr, None); + return; + end if; + Set_Parameter (Attr, Parameter); + Set_Expr_Staticness (Attr, Min (Get_Type_Staticness (Prefix_Type), + Get_Expr_Staticness (Parameter))); + Set_Name_Staticness (Attr, Get_Expr_Staticness (Attr)); + end Finish_Sem_Scalar_Type_Attribute; + + procedure Finish_Sem_Signal_Attribute + (Attr_Name : Iir; Attr : Iir; Parameter : Iir) + is + Param : Iir; + Prefix : Iir; + Prefix_Name : Iir; + begin + Prefix_Name := Get_Prefix (Attr_Name); + Prefix := Finish_Sem_Name (Prefix_Name, Get_Prefix (Attr)); + Set_Prefix (Attr, Prefix); + Free_Iir (Attr_Name); + + if Parameter = Null_Iir then + return; + end if; + if Get_Kind (Attr) = Iir_Kind_Transaction_Attribute then + Error_Msg_Sem (+Attr, "'transaction does not allow a parameter"); + else + Param := Sem_Expression (Parameter, Time_Subtype_Definition); + if Param /= Null_Iir then + -- LRM93 14.1 + -- Parameter: A static expression of type TIME [that evaluate + -- to a nonnegative value.] + if Get_Expr_Staticness (Param) = None then + Error_Msg_Sem + (+Param, "parameter of signal attribute must be static"); + end if; + Set_Parameter (Attr, Param); + end if; + end if; + end Finish_Sem_Signal_Attribute; + + function Is_Type_Abstract_Numeric (Atype : Iir) return Boolean is + begin + case Get_Kind (Atype) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Floating_Type_Definition => + return True; + when others => + return False; + end case; + end Is_Type_Abstract_Numeric; + + function Are_Types_Closely_Related (Type1, Type2 : Iir) return Boolean + is + Base_Type1 : constant Iir := Get_Base_Type (Type1); + Base_Type2 : constant Iir := Get_Base_Type (Type2); + Ant1, Ant2 : Boolean; + Index_List1, Index_List2 : Iir_Flist; + El1, El2 : Iir; + begin + -- LRM 7.3.5 + -- In particular, a type is closely related to itself. + if Base_Type1 = Base_Type2 then + return True; + end if; + + -- LRM 7.3.5 + -- a) Abstract Numeric Types: Any abstract numeric type is closely + -- related to any other abstract numeric type. + Ant1 := Is_Type_Abstract_Numeric (Type1); + Ant2 := Is_Type_Abstract_Numeric (Type2); + if Ant1 and Ant2 then + return True; + end if; + if Ant1 or Ant2 then + return False; + end if; + + -- LRM 7.3.5 + -- b) Array Types: Two array types are closely related if and only if + -- The types have the same dimensionality; For each index position, + -- the index types are either the same or are closely related; and + -- The element types are the same. + -- + -- No other types are closely related. + if not (Get_Kind (Base_Type1) = Iir_Kind_Array_Type_Definition + and then Get_Kind (Base_Type2) = Iir_Kind_Array_Type_Definition) + then + return False; + end if; + Index_List1 := Get_Index_Subtype_List (Base_Type1); + Index_List2 := Get_Index_Subtype_List (Base_Type2); + if Get_Nbr_Elements (Index_List1) /= Get_Nbr_Elements (Index_List2) then + return False; + end if; + if Get_Base_Type (Get_Element_Subtype (Base_Type1)) + /= Get_Base_Type (Get_Element_Subtype (Base_Type2)) + then + return False; + end if; + for I in Flist_First .. Flist_Last (Index_List1) loop + El1 := Get_Index_Type (Index_List1, I); + El2 := Get_Index_Type (Index_List2, I); + if not Are_Types_Closely_Related (El1, El2) then + return False; + end if; + end loop; + return True; + end Are_Types_Closely_Related; + + function Sem_Type_Conversion + (Name : Iir; Type_Mark : Iir; Actual : Iir; In_Formal : Boolean) + return Iir + is + Conv_Type : constant Iir := Get_Type (Type_Mark); + Conv : Iir_Type_Conversion; + Expr : Iir; + Staticness : Iir_Staticness; + begin + Conv := Create_Iir (Iir_Kind_Type_Conversion); + Location_Copy (Conv, Name); + Set_Type_Mark (Conv, Type_Mark); + Set_Type (Conv, Conv_Type); + Set_Expression (Conv, Actual); + + -- Default staticness in case of error. + Set_Expr_Staticness (Conv, None); + + -- Bail out if no actual (or invalid one). + if Actual = Null_Iir then + return Conv; + end if; + + -- LRM93 7.3.5 + -- Furthermore, the operand of a type conversion is not allowed to be + -- the literal null, an allocator, an aggregate, or a string literal. + case Get_Kind (Actual) is + when Iir_Kind_Null_Literal + | Iir_Kind_Aggregate + | Iir_Kind_String_Literal8 + | Iir_Kinds_Allocator => + Error_Msg_Sem + (+Actual, "%n cannot be a type conversion operand", +Actual); + return Conv; + when Iir_Kind_Range_Expression => + -- Try to nicely handle expression like NAME (A to B). + Error_Msg_Sem + (+Actual, "subtype indication not allowed in an expression"); + return Conv; + when Iir_Kind_Error => + return Conv; + when others => + null; + end case; + + -- LRM93 7.3.5 + -- The type of the operand of a type conversion must be + -- determinable independent of the context (in particular, + -- independent of the target type). + Expr := Sem_Expression_Universal (Actual); + if Expr = Null_Iir then + return Conv; + end if; + Set_Expression (Conv, Expr); + + -- LRM93 7.4.1 Locally Static Primaries. + -- 9. a type conversion whose expression is a locally static expression. + -- LRM93 7.4.2 Globally Static Primaries. + -- 14. a type conversion whose expression is a globally static + -- expression. + Staticness := Get_Expr_Staticness (Expr); + + -- If the type mark is not locally static, the expression cannot + -- be locally static. This was clarified in VHDL 08, but a type + -- mark that denotes an unconstrained array type, does not prevent + -- the expression from being static. + if Get_Kind (Conv_Type) not in Iir_Kinds_Array_Type_Definition + or else Get_Constraint_State (Conv_Type) = Fully_Constrained + then + Staticness := Min (Staticness, Get_Type_Staticness (Conv_Type)); + end if; + + -- LRM87 7.4 Static Expressions + -- A type conversion is not a locally static expression. + if Flags.Vhdl_Std = Vhdl_87 then + Staticness := Min (Globally, Staticness); + end if; + Set_Expr_Staticness (Conv, Staticness); + + if not Are_Types_Closely_Related (Conv_Type, Get_Type (Expr)) then + -- FIXME: should explain why the types are not closely related. + Error_Msg_Sem + (+Conv, + "conversion not allowed between not closely related types"); + -- Avoid error storm in evaluation. + Set_Expr_Staticness (Conv, None); + else + -- Unless the type conversion appears in the formal part of an + -- association, the expression must be readable. + if not In_Formal then + Check_Read (Expr); + end if; + end if; + return Conv; + end Sem_Type_Conversion; + + -- OBJ is an 'impure' object (variable, signal or file) referenced at + -- location LOC. + -- Check the pure rules (LRM08 4 Subprograms and packages, + -- LRM08 4.3 Subprograms bodies). + procedure Sem_Check_Pure (Loc : Iir; Obj : Iir) + is + procedure Update_Impure_Depth (Subprg_Spec : Iir; Depth : Iir_Int32) + is + Bod : constant Iir := Get_Subprogram_Body (Subprg_Spec); + begin + if Bod = Null_Iir then + return; + end if; + if Depth < Get_Impure_Depth (Bod) then + Set_Impure_Depth (Bod, Depth); + end if; + end Update_Impure_Depth; + + procedure Error_Pure (Subprg : Iir; Obj : Iir) + is + begin + Error_Msg_Sem_Relaxed + (Loc, Warnid_Pure, + "reference to %n violate pure rule for %n", (+Obj, +Subprg)); + end Error_Pure; + + Subprg : constant Iir := Sem_Stmts.Get_Current_Subprogram; + Subprg_Body : Iir; + Parent : Iir; + Decl : Iir; + begin + -- Apply only in subprograms. + if Subprg = Null_Iir then + return; + end if; + case Get_Kind (Subprg) is + when Iir_Kinds_Process_Statement => + return; + when Iir_Kind_Procedure_Declaration => + -- Exit now if already known as impure. + if Get_Purity_State (Subprg) = Impure then + return; + end if; + when Iir_Kind_Function_Declaration => + -- Exit now if impure. + if Get_Pure_Flag (Subprg) = False then + return; + end if; + when others => + Error_Kind ("sem_check_pure", Subprg); + end case; + + -- Follow aliases. + if Get_Kind (Obj) = Iir_Kind_Object_Alias_Declaration then + Decl := Get_Object_Prefix (Get_Name (Obj)); + else + Decl := Obj; + end if; + + -- Not all objects are impure. + case Get_Kind (Decl) is + when Iir_Kind_Object_Alias_Declaration => + raise Program_Error; + when Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_File_Declaration => + null; + when Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration => + -- When referenced as a formal name (FIXME: this is an + -- approximation), the rules don't apply. + if not Get_Is_Within_Flag (Get_Parent (Decl)) then + return; + end if; + when Iir_Kind_File_Declaration => + -- LRM 93 2.2 + -- If a pure function is the parent of a given procedure, then + -- that procedure must not contain a reference to an explicitly + -- declared file object [...] + -- + -- A pure function must not contain a reference to an explicitly + -- declared file. + if Get_Kind (Subprg) = Iir_Kind_Function_Declaration then + Error_Pure (Subprg, Obj); + else + Set_Purity_State (Subprg, Impure); + Set_Impure_Depth (Get_Subprogram_Body (Subprg), + Iir_Depth_Impure); + end if; + return; + when others => + return; + end case; + + -- DECL is declared in the immediate declarative part of the subprogram. + Parent := Get_Parent (Decl); + Subprg_Body := Get_Subprogram_Body (Subprg); + if Parent = Subprg or else Parent = Subprg_Body then + return; + end if; + + -- Function. + if Get_Kind (Subprg) = Iir_Kind_Function_Declaration then + Error_Pure (Subprg, Obj); + return; + end if; + + case Get_Kind (Parent) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Block_Statement + | Iir_Kind_If_Generate_Statement + | Iir_Kind_For_Generate_Statement + | Iir_Kind_Generate_Statement_Body + | Iir_Kinds_Process_Statement + | Iir_Kind_Protected_Type_Body => + -- The procedure is impure. + Set_Purity_State (Subprg, Impure); + Set_Impure_Depth (Subprg_Body, Iir_Depth_Impure); + return; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Update_Impure_Depth + (Subprg, + Get_Subprogram_Depth (Get_Subprogram_Specification (Parent))); + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Update_Impure_Depth (Subprg, Get_Subprogram_Depth (Parent)); + when others => + Error_Kind ("sem_check_pure(2)", Parent); + end case; + end Sem_Check_Pure; + + -- Set All_Sensitized_State to False iff OBJ is a signal declaration + -- and the current subprogram is in a package body. + procedure Sem_Check_All_Sensitized (Obj : Iir) + is + Subprg : Iir; + begin + -- We cares only of signals. + if Get_Kind (Obj) /= Iir_Kind_Signal_Declaration then + return; + end if; + -- We cares only of subprograms. Give up if we are in a process. + Subprg := Sem_Stmts.Get_Current_Subprogram; + if Subprg = Null_Iir + or else Get_Kind (Subprg) not in Iir_Kinds_Subprogram_Declaration + then + return; + end if; + if Get_Kind (Get_Library_Unit (Sem.Get_Current_Design_Unit)) + = Iir_Kind_Package_Body + then + Set_All_Sensitized_State (Subprg, Invalid_Signal); + else + Set_All_Sensitized_State (Subprg, Read_Signal); + end if; + end Sem_Check_All_Sensitized; + + -- Free overload list of NAME but keep RES interpretation. + procedure Free_Old_Entity_Name (Name : Iir; Res : Iir) + is + Old_Res : constant Iir := Get_Named_Entity (Name); + begin + if Old_Res /= Null_Iir and then Old_Res /= Res then + pragma Assert (Is_Overload_List (Old_Res)); + Sem_Name_Free_Result (Old_Res, Res); + end if; + Set_Named_Entity (Name, Res); + end Free_Old_Entity_Name; + + function Finish_Sem_Denoting_Name (Name : Iir; Res : Iir) return Iir is + begin + case Iir_Kinds_Denoting_Name (Get_Kind (Name)) is + when Iir_Kind_Simple_Name + | Iir_Kind_Character_Literal + | Iir_Kind_Operator_Symbol => + Set_Base_Name (Name, Res); + Xref_Ref (Name, Res); + return Name; + when Iir_Kind_Selected_Name => + declare + Prefix, Res_Prefix : Iir; + Old_Res : Iir; + begin + Xref_Ref (Name, Res); + Prefix := Name; + Res_Prefix := Res; + loop + Prefix := Get_Prefix (Prefix); + Res_Prefix := Get_Parent (Res_Prefix); + + -- Get the parent for expanded_name, may skip some parents. + case Get_Kind (Res_Prefix) is + when Iir_Kind_Design_Unit => + Res_Prefix := + Get_Library (Get_Design_File (Res_Prefix)); + when others => + null; + end case; + + pragma Assert (Get_Kind (Prefix) in Iir_Kinds_Denoting_Name); + Xref_Ref (Prefix, Res_Prefix); + + -- Cannot use Free_Old_Entity_Name as a prefix may not be + -- the parent (for protected subprogram calls). + Old_Res := Get_Named_Entity (Prefix); + if Is_Overload_List (Old_Res) then + Free_Iir (Old_Res); + Set_Named_Entity (Prefix, Res_Prefix); + end if; + + exit when Get_Kind (Prefix) /= Iir_Kind_Selected_Name; + end loop; + end; + return Name; + when Iir_Kind_Reference_Name => + -- Not in the sources. + raise Internal_Error; + end case; + end Finish_Sem_Denoting_Name; + + function Finish_Sem_Name_1 (Name : Iir; Res : Iir) return Iir + is + Prefix : Iir; + Name_Prefix : Iir; + Name_Res : Iir; + begin + case Get_Kind (Res) is + when Iir_Kinds_Library_Unit => + return Finish_Sem_Denoting_Name (Name, Res); + when Iir_Kinds_Sequential_Statement + | Iir_Kinds_Concurrent_Statement => + -- Label or part of an expanded name (for process, block + -- and generate). + return Finish_Sem_Denoting_Name (Name, Res); + when Iir_Kinds_Object_Declaration + | Iir_Kinds_Quantity_Declaration + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Unit_Declaration + | Iir_Kind_Psl_Endpoint_Declaration => + Name_Res := Finish_Sem_Denoting_Name (Name, Res); + Set_Base_Name (Name_Res, Res); + Set_Name_Staticness (Name_Res, Get_Name_Staticness (Res)); + Set_Expr_Staticness (Name_Res, Get_Expr_Staticness (Res)); + Sem_Check_Pure (Name_Res, Res); + Sem_Check_All_Sensitized (Res); + Set_Type (Name_Res, Get_Type (Res)); + return Name_Res; + when Iir_Kind_Attribute_Value => + pragma Assert (Get_Kind (Name) = Iir_Kind_Attribute_Name); + Prefix := Finish_Sem_Name (Get_Prefix (Name)); + Set_Prefix (Name, Prefix); + if Get_Is_Forward_Ref (Prefix) then + Set_Base_Name (Prefix, Null_Iir); + end if; + Set_Base_Name (Name, Res); + Set_Type (Name, Get_Type (Res)); + Set_Name_Staticness (Name, Get_Name_Staticness (Res)); + Set_Expr_Staticness (Name, Get_Expr_Staticness (Res)); + return Name; + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Component_Declaration + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration + | Iir_Kind_Attribute_Declaration + | Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kind_Library_Declaration + | Iir_Kind_Interface_Package_Declaration + | Iir_Kind_Interface_Type_Declaration => + Name_Res := Finish_Sem_Denoting_Name (Name, Res); + Set_Base_Name (Name_Res, Res); + return Name_Res; + when Iir_Kind_Function_Declaration + | Iir_Kind_Interface_Function_Declaration => + Name_Res := Finish_Sem_Denoting_Name (Name, Res); + Set_Type (Name_Res, Get_Return_Type (Res)); + return Name_Res; + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Interface_Procedure_Declaration => + return Finish_Sem_Denoting_Name (Name, Res); + when Iir_Kind_Type_Conversion => + pragma Assert (Get_Kind (Name) = Iir_Kind_Parenthesis_Name); + Set_Type_Mark (Res, Sem_Type_Mark (Get_Prefix (Name))); + Free_Parenthesis_Name (Name, Res); + return Res; + when Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Slice_Name + | Iir_Kind_Dereference => + -- Fall through. + null; + when Iir_Kind_Implicit_Dereference => + -- The name may not have a prefix. + Prefix := Finish_Sem_Name_1 (Name, Get_Prefix (Res)); + Set_Prefix (Res, Prefix); + Finish_Sem_Dereference (Res); + return Res; + when Iir_Kind_Function_Call => + case Get_Kind (Name) is + when Iir_Kind_Parenthesis_Name => + -- Usual case. + Prefix := Finish_Sem_Name + (Get_Prefix (Name), Get_Implementation (Res)); + Finish_Sem_Function_Call (Res, Prefix); + Free_Iir (Name); + when Iir_Kinds_Denoting_Name => + -- Call without association list. + Prefix := Finish_Sem_Name (Name, Get_Implementation (Res)); + Finish_Sem_Function_Call (Res, Prefix); + when others => + Error_Kind ("Finish_Sem_Name(function call)", Name); + end case; + return Res; + when Iir_Kinds_Array_Attribute => + if Get_Parameter (Res) = Null_Iir then + Finish_Sem_Array_Attribute (Name, Res, Null_Iir); + end if; + if Get_Kind (Name) = Iir_Kind_Attribute_Name then + Free_Iir (Name); + else + Free_Iir (Get_Prefix (Name)); + Free_Parenthesis_Name (Name, Res); + end if; + return Res; + when Iir_Kinds_Scalar_Type_Attribute + | Iir_Kind_Image_Attribute + | Iir_Kind_Value_Attribute => + if Get_Parameter (Res) = Null_Iir then + Finish_Sem_Scalar_Type_Attribute (Name, Res, Null_Iir); + else + Free_Parenthesis_Name (Name, Res); + end if; + return Res; + when Iir_Kind_Subtype_Attribute => + null; + when Iir_Kinds_Signal_Value_Attribute => + null; + when Iir_Kinds_Signal_Attribute => + if Get_Parameter (Res) = Null_Iir then + Finish_Sem_Signal_Attribute (Name, Res, Null_Iir); + else + Free_Parenthesis_Name (Name, Res); + end if; + return Res; + when Iir_Kinds_Type_Attribute + | Iir_Kind_Base_Attribute => + pragma Assert (Get_Kind (Name) = Iir_Kind_Attribute_Name); + Free_Iir (Name); + return Res; + when Iir_Kind_Simple_Name_Attribute + | Iir_Kind_Path_Name_Attribute + | Iir_Kind_Instance_Name_Attribute => + Free_Iir (Name); + return Res; + when Iir_Kinds_External_Name => + pragma Assert (Name = Res); + return Res; + when Iir_Kind_Psl_Expression => + return Res; + when Iir_Kind_Psl_Declaration => + return Name; + when Iir_Kind_Element_Declaration => + -- Certainly an error! + return Name; + when Iir_Kind_Error => + return Name; + when others => + Error_Kind ("finish_sem_name_1", Res); + end case; + + -- The name has a prefix, finish it. + Prefix := Get_Prefix (Res); + Name_Prefix := Get_Prefix (Name); + Prefix := Finish_Sem_Name_1 (Name_Prefix, Prefix); + Set_Prefix (Res, Prefix); + + case Get_Kind (Res) is + when Iir_Kind_Indexed_Name => + Finish_Sem_Indexed_Name (Res); + Free_Parenthesis_Name (Name, Res); + when Iir_Kind_Slice_Name => + Finish_Sem_Slice_Name (Res); + Free_Parenthesis_Name (Name, Res); + when Iir_Kind_Selected_Element => + pragma Assert (Get_Kind (Name) = Iir_Kind_Selected_Name); + Xref_Ref (Res, Get_Named_Entity (Res)); + Set_Name_Staticness (Res, Get_Name_Staticness (Prefix)); + Set_Expr_Staticness (Res, Get_Expr_Staticness (Prefix)); + Set_Base_Name (Res, Get_Base_Name (Prefix)); + Free_Iir (Name); + when Iir_Kind_Dereference => + pragma Assert (Get_Kind (Name) = Iir_Kind_Selected_By_All_Name); + Finish_Sem_Dereference (Res); + Free_Iir (Name); + when Iir_Kinds_Signal_Value_Attribute + | Iir_Kind_Subtype_Attribute => + Sem_Name_Free_Result (Name, Res); + when others => + Error_Kind ("finish_sem_name_1(2)", Res); + end case; + return Res; + end Finish_Sem_Name_1; + + function Finish_Sem_Name (Name : Iir; Res : Iir) return Iir is + begin + if Get_Kind (Res) /= Iir_Kind_Implicit_Dereference then + -- There is no corresponding name for implicit_dereference (because + -- it is implicit). + -- Free overload list (but keep RES interpretation) for other cases. + Free_Old_Entity_Name (Name, Res); + end if; + + return Finish_Sem_Name_1 (Name, Res); + end Finish_Sem_Name; + + function Finish_Sem_Name (Name : Iir) return Iir is + begin + return Finish_Sem_Name_1 (Name, Get_Named_Entity (Name)); + end Finish_Sem_Name; + + -- LRM93 6.2 + -- The evaluation of a simple name has no other effect than to determine + -- the named entity denoted by the name. + -- + -- NAME may be a simple name, a strig literal or a character literal. + -- GHDL: set interpretation of NAME (possibly an overload list) or + -- error_mark for unknown names. + -- If SOFT is TRUE, then no error message is reported in case of failure. + procedure Sem_Simple_Name (Name : Iir; Keep_Alias : Boolean; Soft : Boolean) + is + Id : constant Name_Id := Get_Identifier (Name); + Interpretation: Name_Interpretation_Type; + Res: Iir; + Res_List : Iir_List; + Res_It : List_Iterator; + N : Natural; + begin + Interpretation := Get_Interpretation (Id); + + if not Valid_Interpretation (Interpretation) then + -- Unknown name. + if not Soft then + Interpretation := Get_Interpretation_Raw (Id); + if Valid_Interpretation (Interpretation) + and then Is_Conflict_Declaration (Interpretation) + then + Error_Msg_Sem + (+Name, "no declaration for %i (due to conflicts)", +Name); + else + Error_Msg_Sem (+Name, "no declaration for %i", +Name); + end if; + end if; + Res := Error_Mark; + elsif not Valid_Interpretation (Get_Next_Interpretation (Interpretation)) + then + -- One simple interpretation. + Res := Get_Declaration (Interpretation); + + -- For a design unit, return the library unit + if Get_Kind (Res) = Iir_Kind_Design_Unit then + -- FIXME: should replace interpretation ? + Load_Design_Unit (Res, Name); + Sem.Add_Dependence (Res); + Res := Get_Library_Unit (Res); + end if; + + -- Check visibility. + if not Get_Visible_Flag (Res) then + if Flag_Relaxed_Rules + and then Get_Kind (Res) in Iir_Kinds_Object_Declaration + and then Valid_Interpretation (Get_Under_Interpretation (Id)) + then + Res := Get_Declaration (Get_Under_Interpretation (Id)); + else + if not Soft then + Error_Msg_Sem (+Name, "%n is not visible here", +Res); + end if; + -- Even if a named entity was found, return an error_mark. + -- Indeed, the named entity found is certainly the one being + -- analyzed, and the analyze may be uncomplete. + Res := Error_Mark; + end if; + end if; + + if not Keep_Alias + and then Get_Kind (Res) = Iir_Kind_Non_Object_Alias_Declaration + then + Set_Alias_Declaration (Name, Res); + Res := Get_Named_Entity (Get_Name (Res)); + end if; + else + -- Name is overloaded. + Res_List := Create_Iir_List; + N := 0; + -- The SEEN_FLAG is used to get only one meaning which can be reached + -- through several paths (such as aliases). + while Valid_Interpretation (Interpretation) loop + if Keep_Alias then + Res := Get_Declaration (Interpretation); + else + Res := Get_Non_Alias_Declaration (Interpretation); + end if; + if not Get_Seen_Flag (Res) then + Set_Seen_Flag (Res, True); + N := N + 1; + Append_Element (Res_List, Res); + end if; + Interpretation := Get_Next_Interpretation (Interpretation); + end loop; + + -- FIXME: there can be only one element (a function and its alias!). + + -- Clear SEEN_FLAG. + Res_It := List_Iterate (Res_List); + while Is_Valid (Res_It) loop + Set_Seen_Flag (Get_Element (Res_It), False); + Next (Res_It); + end loop; + + Res := Create_Overload_List (Res_List); + end if; + + Set_Named_Entity (Name, Res); + end Sem_Simple_Name; + + -- LRM93 §6.3 + -- Selected Names. + procedure Sem_Selected_Name + (Name: Iir; Keep_Alias : Boolean := False; Soft : Boolean := False) + is + Suffix : constant Name_Id := Get_Identifier (Name); + Prefix_Name : constant Iir := Get_Prefix (Name); + Prefix_Loc : constant Location_Type := Get_Location (Prefix_Name); + + Prefix: Iir; + Res : Iir; + + -- Analyze SUB_NAME.NAME as an expanded name (ie, NAME is declared + -- within SUB_NAME). This is possible only if the expanded name is + -- analyzed within the context of SUB_NAME. + procedure Sem_As_Expanded_Name (Sub_Name : Iir) + is + Sub_Res : Iir; + begin + if Get_Is_Within_Flag (Sub_Name) then + Sub_Res := Find_Declarations_In_List (Sub_Name, Name, Keep_Alias); + if Sub_Res /= Null_Iir then + Add_Result (Res, Sub_Res); + end if; + end if; + end Sem_As_Expanded_Name; + + -- LRM93 6.3 + -- For a selected name that is used to denote a record element, + -- the suffix must be a simple name denoting an element of a + -- record object or value. The prefix must be appropriate for the + -- type of this object or value. + -- + -- Analyze SUB_NAME.NAME as a selected element. + procedure Sem_As_Selected_Element (Sub_Name : Iir) + is + Name_Type : Iir; + Ptr_Type : Iir; + Rec_El : Iir; + R : Iir; + Se : Iir; + begin + Name_Type := Get_Type (Sub_Name); + if Kind_In (Name_Type, Iir_Kind_Access_Type_Definition, + Iir_Kind_Access_Subtype_Definition) + then + Ptr_Type := Name_Type; + Name_Type := Get_Designated_Type (Name_Type); + else + Ptr_Type := Null_Iir; + end if; + + -- Only records have elements. + if not Kind_In (Name_Type, Iir_Kind_Record_Type_Definition, + Iir_Kind_Record_Subtype_Definition) + then + return; + end if; + + Rec_El := Find_Name_In_Flist + (Get_Elements_Declaration_List (Name_Type), Suffix); + if Rec_El = Null_Iir then + -- No such element in the record type. + return; + end if; + + if not Maybe_Function_Call (Sub_Name) then + return; + end if; + + R := Maybe_Insert_Function_Call (Prefix_Name, Sub_Name); + R := Maybe_Insert_Dereference (R, Ptr_Type); + + Se := Create_Iir (Iir_Kind_Selected_Element); + Location_Copy (Se, Name); + Set_Prefix (Se, R); + Set_Type (Se, Get_Type (Rec_El)); + Set_Identifier (Se, Suffix); + Set_Named_Entity (Se, Rec_El); + Set_Base_Name (Se, Get_Object_Prefix (R, False)); + Add_Result (Res, Se); + end Sem_As_Selected_Element; + + procedure Error_Selected_Element (Prefix_Type : Iir) + is + Base_Type : Iir; + begin + Base_Type := Get_Base_Type (Prefix_Type); + if Get_Kind (Base_Type) = Iir_Kind_Access_Type_Definition then + Base_Type := Get_Base_Type (Get_Designated_Type (Base_Type)); + end if; + if Get_Kind (Base_Type) /= Iir_Kind_Record_Type_Definition then + Error_Msg_Sem + (+Name, "%n does not designate a record", +Prefix); + else + Error_Msg_Sem + (+Name, "no element %i in %n", (+Suffix, +Base_Type)); + end if; + end Error_Selected_Element; + + procedure Sem_As_Protected_Item (Sub_Name : Iir) + is + Prot_Type : constant Iir := Get_Type (Sub_Name); + Method : Iir; + begin + -- LRM98 12.3 Visibility + -- s) For a subprogram declared immediately within a given protected + -- type declaration: at the place of the suffix in a selected + -- name whose prefix denotes an object of the protected type. + Method := Get_Declaration_Chain (Prot_Type); + while Method /= Null_Iir loop + case Get_Kind (Method) is + when Iir_Kind_Function_Declaration | + Iir_Kind_Procedure_Declaration => + if Get_Identifier (Method) = Suffix then + Add_Result (Res, Method); + end if; + when Iir_Kind_Attribute_Specification + | Iir_Kind_Use_Clause => + null; + when others => + -- Declarations not allowed in protected types. + -- Just ignore them. + null; + end case; + Method := Get_Chain (Method); + end loop; + end Sem_As_Protected_Item; + + procedure Error_Protected_Item (Prot_Type : Iir) is + begin + Error_Msg_Sem (+Name, "no method %i in %n", (+Suffix, +Prot_Type)); + end Error_Protected_Item; + + -- Emit an error message if unit is not found in library LIB. + procedure Error_Unit_Not_Found (Lib : Iir) + is + use Std_Names; + begin + Error_Msg_Sem (+Name, "unit %i not found in %n", (+Suffix, +Lib)); + + -- Give an advice for common synopsys packages. + if Get_Identifier (Lib) = Name_Ieee then + if Suffix = Name_Std_Logic_Arith + or else Suffix = Name_Std_Logic_Signed + or else Suffix = Name_Std_Logic_Unsigned + then + Error_Msg_Sem + (+Name, + " (use --ieee=synopsys for non-standard synopsys packages)"); + elsif Suffix = Name_Std_Logic_Textio then + Error_Msg_Sem + (+Name, " (use --ieee=synopsys or --std=08 for " + & "this non-standard synopsys package)"); + end if; + end if; + end Error_Unit_Not_Found; + begin + -- Analyze prefix. + if Soft then + Sem_Name_Soft (Prefix_Name); + else + Sem_Name (Prefix_Name); + end if; + Prefix := Get_Named_Entity (Prefix_Name); + if Is_Error (Prefix) then + Set_Named_Entity (Name, Prefix); + return; + end if; + + Res := Null_Iir; + + case Get_Kind (Prefix) is + when Iir_Kind_Overload_List => + -- LRM93 6.3 + -- If, according to the visibility rules, there is at + -- least one possible interpretation of the prefix of a + -- selected name as the name of an enclosing entity + -- interface, architecture, subprogram, block statement, + -- process statement, generate statement, or loop + -- statement, then the only interpretations considered are + -- those of the immediately preceding paragraph. + -- + -- In this case, the selected name is always interpreted + -- as an expanded name. In particular, no interpretations + -- of the prefix as a function call are considered. + declare + Prefix_List : Iir_List; + It : List_Iterator; + El : Iir; + begin + -- So, first try as expanded name. + Prefix_List := Get_Overload_List (Prefix); + It := List_Iterate (Prefix_List); + while Is_Valid (It) loop + El := Get_Element (It); + case Get_Kind (El) is + when Iir_Kind_Function_Call + | Iir_Kind_Selected_Element => + -- Not an expanded name. + null; + when others => + Sem_As_Expanded_Name (El); + end case; + Next (It); + end loop; + + -- If no expanded name are found, try as selected element. + if Res = Null_Iir then + It := List_Iterate (Prefix_List); + while Is_Valid (It) loop + El := Get_Element (It); + case Get_Kind (El) is + when Iir_Kind_Procedure_Declaration => + -- A procedure cannot be the prefix of a selected + -- element. + null; + when others => + Sem_As_Selected_Element (El); + end case; + Next (It); + end loop; + end if; + end; + if Res = Null_Iir and then not Soft then + Error_Msg_Sem + (+Name, "no suffix %i for overloaded selected name", +Suffix); + end if; + when Iir_Kind_Library_Declaration => + -- LRM93 6.3 + -- An expanded name denotes a primary unit constained in a design + -- library if the prefix denotes the library and the suffix is the + -- simple name if a primary unit whose declaration is contained + -- in that library. + -- An expanded name is not allowed for a secondary unit, + -- particularly for an architecture body. + -- GHDL: FIXME: error message more explicit + Res := Load_Primary_Unit (Prefix, Suffix, Name); + if Res /= Null_Iir then + Sem.Add_Dependence (Res); + Res := Get_Library_Unit (Res); + elsif not Soft then + Error_Unit_Not_Found (Prefix); + end if; + when Iir_Kind_Process_Statement + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Architecture_Body + | Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Interface_Package_Declaration + | Iir_Kind_If_Generate_Statement + | Iir_Kind_For_Generate_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_For_Loop_Statement => + -- LRM93 §6.3 + -- An expanded name denotes a named entity declared immediatly + -- within a named construct if the prefix that is an entity + -- interface, an architecture, a subprogram, a block statement, + -- a process statement, a generate statement, or a loop + -- statement, and the suffix is the simple name, character + -- literal, or operator symbol of an named entity whose + -- declaration occurs immediatly within that construct. + if Get_Kind (Prefix) = Iir_Kind_Design_Unit then + Load_Design_Unit (Prefix, Name); + Sem.Add_Dependence (Prefix); + Prefix := Get_Library_Unit (Prefix); + -- Modified only for xrefs, since a design_unit points to + -- the first context clause, while a library unit points to + -- the identifier. + Set_Named_Entity (Get_Prefix (Name), Prefix); + end if; + + Res := Find_Declarations_In_List (Prefix, Name, Keep_Alias); + + if Res = Null_Iir then + if not Soft then + Error_Msg_Sem + (+Name, "no declaration for %i in %n", (+Suffix, +Prefix)); + end if; + else + -- LRM93 6.3 + -- This form of expanded name is only allowed within the + -- construct itself. + -- FIXME: LRM08 12.3 Visibility h) + if not Kind_In (Prefix, + Iir_Kind_Package_Declaration, + Iir_Kind_Package_Instantiation_Declaration) + and then not Get_Is_Within_Flag (Prefix) + then + if not Soft then + Error_Msg_Sem + (+Prefix_Loc, + "an expanded name is only allowed " + & "within the construct"); + end if; + -- Hum, keep res. + elsif Get_Kind (Prefix) = Iir_Kind_Package_Declaration + and then not Get_Is_Within_Flag (Prefix) + and then Is_Uninstantiated_Package (Prefix) + then + -- LRM08 12.3 f) Visibility + -- For a declaration given in a package declaration, other + -- than in a package declaration that defines an + -- uninstantiated package: [...] + if not Soft then + Error_Msg_Sem + (+Prefix_Loc, + "cannot refer a declaration in an " + & "uninstantiated package"); + end if; + end if; + end if; + when Iir_Kind_Function_Declaration => + Sem_As_Expanded_Name (Prefix); + if Res = Null_Iir then + Sem_As_Selected_Element (Prefix); + end if; + if Res = Null_Iir and then not Soft then + Error_Selected_Element (Get_Return_Type (Prefix)); + end if; + when Iir_Kinds_Object_Declaration + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Attribute_Value + | Iir_Kind_Function_Call => + if Get_Kind (Get_Type (Prefix)) + = Iir_Kind_Protected_Type_Declaration + then + Sem_As_Protected_Item (Prefix); + if Res = Null_Iir and then not Soft then + Error_Protected_Item (Prefix); + end if; + else + Sem_As_Selected_Element (Prefix); + if Res = Null_Iir and then not Soft then + Error_Selected_Element (Get_Type (Prefix)); + end if; + end if; + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Concurrent_Procedure_Call_Statement + | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Slice_Name + | Iir_Kind_Procedure_Call_Statement + | Iir_Kind_Attribute_Declaration + | Iir_Kind_Type_Conversion => + if not Soft then + Error_Msg_Sem + (+Prefix_Loc, "%n cannot be selected by name", +Prefix); + end if; + + when Iir_Kind_Error => + -- Let's propagate the error. + null; + + when others => + Error_Kind ("sem_selected_name(2)", Prefix); + end case; + if Res = Null_Iir then + Res := Error_Mark; + end if; + Set_Named_Entity (Name, Res); + end Sem_Selected_Name; + + -- If ASSOC_LIST has one element, which is an expression without formal, + -- return the actual, else return NULL_IIR. + function Get_One_Actual (Assoc_Chain : Iir) return Iir + is + Assoc : Iir; + begin + -- Only one actual ? + if Assoc_Chain = Null_Iir or else Get_Chain (Assoc_Chain) /= Null_Iir + then + return Null_Iir; + end if; + + -- Not 'open' association element ? + Assoc := Assoc_Chain; + if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Expression then + return Null_Iir; + end if; + + -- Not an association (ie no formal) ? + if Get_Formal (Assoc) /= Null_Iir then + return Null_Iir; + end if; + + return Get_Actual (Assoc); + end Get_One_Actual; + + function Slice_Or_Index (Actual : Iir) return Iir_Kind is + begin + -- But it may be a slice name. + case Get_Kind (Actual) is + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Type_Declaration + | Iir_Kind_Range_Expression => + return Iir_Kind_Slice_Name; + when others => + if Is_Range_Attribute_Name (Actual) then + return Iir_Kind_Slice_Name; + end if; + end case; + -- By default, this is an indexed name. + return Iir_Kind_Indexed_Name; + end Slice_Or_Index; + + -- Check whether association chain ASSOCS may be interpreted as indexes. + function Index_Or_Not (Assocs : Iir) return Iir_Kind + is + El : Iir; + begin + El := Assocs; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Association_Element_By_Expression => + if Get_Formal (El) /= Null_Iir then + return Iir_Kind_Error; + end if; + when others => + -- Only expression are allowed. + return Iir_Kind_Error; + end case; + El := Get_Chain (El); + end loop; + return Iir_Kind_Indexed_Name; + end Index_Or_Not; + + function Sem_Index_Specification (Name : Iir_Parenthesis_Name; Itype : Iir) + return Iir + is + Actual : Iir; + Kind : Iir_Kind; + Res : Iir; + begin + -- FIXME: reuse Sem_Name for the whole analysis ? + + Actual := Get_One_Actual (Get_Association_Chain (Name)); + if Actual = Null_Iir then + Error_Msg_Sem (+Name, "only one index specification is allowed"); + return Null_Iir; + end if; + case Get_Kind (Actual) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Sem_Name (Actual); + Kind := Slice_Or_Index (Get_Named_Entity (Actual)); + -- FIXME: analyze to be finished. + --Maybe_Finish_Sem_Name (Actual); + when others => + Kind := Slice_Or_Index (Actual); + end case; + + Res := Create_Iir (Kind); + Location_Copy (Res, Name); + case Kind is + when Iir_Kind_Indexed_Name => + Actual := Sem_Expression (Actual, Itype); + if Actual = Null_Iir then + return Null_Iir; + end if; + Check_Read (Actual); + if Get_Expr_Staticness (Actual) < Globally then + Error_Msg_Sem (+Name, "index must be a static expression"); + end if; + Set_Index_List (Res, Create_Iir_Flist (1)); + Set_Nth_Element (Get_Index_List (Res), 0, Actual); + when Iir_Kind_Slice_Name => + Actual := Sem_Discrete_Range_Expression (Actual, Itype, False); + if Actual = Null_Iir then + return Null_Iir; + end if; + if Get_Expr_Staticness (Actual) < Globally then + Error_Msg_Sem (+Name, "index must be a static expression"); + end if; + Set_Suffix (Res, Actual); + when others => + raise Internal_Error; + end case; + Free_Parenthesis_Name (Name, Res); + return Res; + end Sem_Index_Specification; + + procedure Sem_Parenthesis_Name (Name : Iir_Parenthesis_Name) + is + Prefix_Name : constant Iir := Get_Prefix (Name); + Prefix: Iir; + Res : Iir; + Res_Prefix : Iir; + Assoc_Chain : Iir; + + Slice_Index_Kind : Iir_Kind; + + -- If FINISH is TRUE, then display error message in case of error. + function Sem_As_Indexed_Or_Slice_Name (Sub_Name : Iir; Finish : Boolean) + return Iir + is + Base_Type : Iir; + Ptr_Type : Iir; + P : Iir; + R : Iir; + begin + if Slice_Index_Kind = Iir_Kind_Error then + if Finish then + Error_Msg_Sem (+Name, "prefix is not a function name"); + end if; + -- No way. + return Null_Iir; + end if; + + -- Only values can be indexed or sliced. + -- Catch errors such as slice of a type conversion. + if Name_To_Value (Sub_Name) = Null_Iir + and then not Is_Function_Declaration (Sub_Name) + then + if Finish then + Error_Msg_Sem + (+Name, "prefix is not an array value (found %n)", +Sub_Name); + end if; + return Null_Iir; + end if; + + -- Extract type of prefix, handle possible implicit deference. + Base_Type := Get_Base_Type (Get_Type (Sub_Name)); + if Get_Kind (Base_Type) = Iir_Kind_Access_Type_Definition then + Ptr_Type := Base_Type; + Base_Type := Get_Base_Type (Get_Designated_Type (Base_Type)); + else + Ptr_Type := Null_Iir; + end if; + + if Get_Kind (Base_Type) /= Iir_Kind_Array_Type_Definition then + if Finish and then not Is_Error (Base_Type) then + Error_Msg_Sem (+Name, "type of prefix is not an array"); + end if; + return Null_Iir; + end if; + if Get_Nbr_Elements (Get_Index_Subtype_List (Base_Type)) /= + Get_Chain_Length (Assoc_Chain) + then + if Finish then + Error_Msg_Sem + (+Name, "number of indexes mismatches array dimension"); + end if; + return Null_Iir; + end if; + + -- For indexed names, discard type incompatibilities between indexes + -- and array type indexes. + -- The FINISH = True case will be handled by Finish_Sem_Indexed_Name. + if Slice_Index_Kind = Iir_Kind_Indexed_Name and then not Finish then + declare + Type_Index_List : constant Iir_Flist := + Get_Index_Subtype_List (Base_Type); + Type_Index : Iir; + Assoc : Iir; + begin + Assoc := Assoc_Chain; + for I in Natural loop + -- Assoc and Type_Index_List have the same length as this + -- was checked just above. + exit when Assoc = Null_Iir; + if Get_Kind (Assoc) + /= Iir_Kind_Association_Element_By_Expression + then + return Null_Iir; + end if; + Type_Index := Get_Index_Type (Type_Index_List, I); + if Is_Expr_Compatible (Type_Index, Get_Actual (Assoc)) + = Not_Compatible + then + return Null_Iir; + end if; + Assoc := Get_Chain (Assoc); + end loop; + end; + end if; + + if not Maybe_Function_Call (Sub_Name) then + if Finish then + Error_Msg_Sem (+Name, "missing parameters for function call"); + end if; + return Null_Iir; + end if; + + P := Maybe_Insert_Function_Call (Prefix_Name, Sub_Name); + P := Maybe_Insert_Dereference (P, Ptr_Type); + + R := Create_Iir (Slice_Index_Kind); + Location_Copy (R, Name); + Set_Prefix (R, P); + Set_Base_Name (R, Get_Object_Prefix (P)); + + case Slice_Index_Kind is + when Iir_Kind_Slice_Name => + Set_Suffix (R, Get_Actual (Assoc_Chain)); + Set_Type (R, Get_Base_Type (Get_Type (P))); + when Iir_Kind_Indexed_Name => + declare + Idx_El : Iir; + Idx_List : Iir_List; + begin + Idx_List := Create_Iir_List; + Idx_El := Assoc_Chain; + while Idx_El /= Null_Iir loop + Append_Element (Idx_List, Get_Actual (Idx_El)); + Idx_El := Get_Chain (Idx_El); + end loop; + Set_Index_List (R, List_To_Flist (Idx_List)); + end; + Set_Type (R, Get_Element_Subtype (Base_Type)); + when others => + raise Internal_Error; + end case; + + return R; + end Sem_As_Indexed_Or_Slice_Name; + + -- Sem parenthesis name when the prefix is a function declaration. + -- Can be either a function call (and the expression is the actual) or + -- a slice/index of the result of a call without actual. + procedure Sem_Parenthesis_Function (Sub_Name : Iir) + is + Used : Boolean; + R : Iir; + Match : Compatibility_Level; + Call : Iir; + begin + Used := False; + + -- A function call. + if Is_Function_Declaration (Sub_Name) then + Sem_Association_Chain + (Get_Interface_Declaration_Chain (Sub_Name), + Assoc_Chain, False, Missing_Parameter, Name, Match); + if Match /= Not_Compatible then + Call := Sem_As_Function_Call + (Prefix_Name, Sub_Name, Assoc_Chain); + Add_Result (Res, Call); + Add_Result (Res_Prefix, Sub_Name); + Used := True; + end if; + end if; + + -- A slice/index of a call (without parameters). + if not Is_Procedure_Declaration (Sub_Name) then + R := Sem_As_Indexed_Or_Slice_Name (Sub_Name, False); + if R /= Null_Iir then + Add_Result (Res, R); + Add_Result (Res_Prefix, Sub_Name); + Used := True; + end if; + end if; + + if not Used then + Sem_Name_Free_Result (Sub_Name, Null_Iir); + end if; + end Sem_Parenthesis_Function; + + procedure Error_Parenthesis_Function (Spec : Iir) + is + Match : Compatibility_Level; + begin + Error_Msg_Sem (+Name, "cannot match %n with actuals", +Prefix); + -- Display error message. + Sem_Association_Chain + (Get_Interface_Declaration_Chain (Spec), + Assoc_Chain, True, Missing_Parameter, Name, Match); + end Error_Parenthesis_Function; + + Actual : Iir; + Actual_Expr : Iir; + begin + -- The prefix is a function name, a type mark or an array. + Sem_Name (Prefix_Name); + Prefix := Get_Named_Entity (Prefix_Name); + if Prefix = Error_Mark then + Set_Named_Entity (Name, Error_Mark); + return; + end if; + Res := Null_Iir; + + Assoc_Chain := Get_Association_Chain (Name); + Actual := Get_One_Actual (Assoc_Chain); + + if Kind_In (Prefix, + Iir_Kind_Type_Declaration, Iir_Kind_Subtype_Declaration) + then + -- A type conversion. The prefix is a type mark. + declare + In_Formal : Boolean; + begin + if Actual = Null_Iir then + -- More than one actual. Keep only the first. + Error_Msg_Sem + (+Name, "type conversion allows only one expression"); + In_Formal := False; + else + In_Formal := Get_In_Formal_Flag (Assoc_Chain); + end if; + + -- This is certainly the easiest case: the prefix is not + -- overloaded, so the result can be computed. + Set_Named_Entity + (Name, Sem_Type_Conversion (Name, Prefix, Actual, In_Formal)); + end; + return; + end if; + + -- Select between slice or indexed name. + Actual_Expr := Null_Iir; + if Actual /= Null_Iir then + -- Only one actual: can be a slice or an index + if Get_Kind (Actual) in Iir_Kinds_Name + or else Get_Kind (Actual) = Iir_Kind_Attribute_Name + then + -- Maybe a discrete range name. + Sem_Name (Actual); + Actual_Expr := Get_Named_Entity (Actual); + if Actual_Expr = Error_Mark then + Set_Named_Entity (Name, Actual_Expr); + return; + end if; + -- Decides between sliced or indexed name to actual. + Slice_Index_Kind := Slice_Or_Index (Actual_Expr); + elsif Get_Kind (Actual) = Iir_Kind_Range_Expression then + -- This can only be a slice. + Slice_Index_Kind := Iir_Kind_Slice_Name; + -- Actual_Expr := + -- Sem_Discrete_Range_Expression (Actual, Null_Iir, False); + -- Set_Actual (Assoc_Chain, Actual_Expr); + else + -- Any other expression: an indexed name. + Slice_Index_Kind := Iir_Kind_Indexed_Name; + end if; + else + -- More than one actual: an indexed name. + + -- FIXME: improve error message for multi-dim slice ? + Slice_Index_Kind := Index_Or_Not (Assoc_Chain); + end if; + + -- Analyze actuals if not already done (done for slices). + if Slice_Index_Kind /= Iir_Kind_Slice_Name then + if Sem_Actual_Of_Association_Chain (Assoc_Chain) = False then + Actual := Null_Iir; + else + Actual := Get_One_Actual (Assoc_Chain); + end if; + end if; + + Res_Prefix := Null_Iir; + + case Get_Kind (Prefix) is + when Iir_Kind_Overload_List => + declare + El : Iir; + Prefix_List : Iir_List; + It : List_Iterator; + begin + Prefix_List := Get_Overload_List (Prefix); + It := List_Iterate (Prefix_List); + while Is_Valid (It) loop + El := Get_Element (It); + Sem_Parenthesis_Function (El); + Next (It); + end loop; + -- Some prefixes may have been removed, replace with the + -- rebuilt prefix list. + Free_Overload_List (Prefix); + Set_Named_Entity (Prefix_Name, Res_Prefix); + end; + if Res = Null_Iir then + Error_Msg_Sem + (+Name, "no overloaded function found matching %n", + +Prefix_Name); + end if; + when Iir_Kind_Function_Declaration + | Iir_Kind_Interface_Function_Declaration => + Sem_Parenthesis_Function (Prefix); + Set_Named_Entity (Prefix_Name, Res_Prefix); + if Res = Null_Iir then + Error_Parenthesis_Function (Prefix); + end if; + + when Iir_Kinds_Object_Declaration + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Selected_Element + | Iir_Kind_Attribute_Value + | Iir_Kind_Simple_Name_Attribute + | Iir_Kind_Function_Call => + Add_Result (Res, Sem_As_Indexed_Or_Slice_Name (Prefix, True)); + + when Iir_Kinds_Array_Attribute => + if Actual /= Null_Iir then + Finish_Sem_Array_Attribute (Prefix_Name, Prefix, Actual); + Set_Named_Entity (Name, Prefix); + else + Error_Msg_Sem (+Name, "bad attribute parameter"); + Set_Named_Entity (Name, Error_Mark); + end if; + return; + + when Iir_Kinds_Scalar_Type_Attribute + | Iir_Kind_Image_Attribute + | Iir_Kind_Value_Attribute => + if Get_Parameter (Prefix) /= Null_Iir then + -- Attribute already has a parameter, the expression + -- is either a slice or an index. + Add_Result + (Res, Sem_As_Indexed_Or_Slice_Name (Prefix, True)); + elsif Actual /= Null_Iir then + Finish_Sem_Scalar_Type_Attribute (Prefix_Name, Prefix, Actual); + Set_Named_Entity (Name, Prefix); + return; + else + Error_Msg_Sem (+Name, "bad attribute parameter"); + Set_Named_Entity (Name, Error_Mark); + return; + end if; + + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration => + Error_Msg_Sem + (+Name, "subprogram name is a type mark (missing apostrophe)"); + + when Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute => + if Actual /= Null_Iir then + Finish_Sem_Signal_Attribute (Prefix_Name, Prefix, Actual); + Set_Named_Entity (Name, Prefix); + else + Error_Msg_Sem (+Name, "bad attribute parameter"); + Set_Named_Entity (Name, Error_Mark); + end if; + return; + + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Interface_Procedure_Declaration => + Error_Msg_Sem (+Name, "cannot call %n in an expression", + +Prefix); + + when Iir_Kinds_Process_Statement + | Iir_Kind_Component_Declaration + | Iir_Kind_Type_Conversion + | Iir_Kind_Unit_Declaration + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Attribute_Declaration => + Error_Msg_Sem (+Name, "%n cannot be indexed or sliced", +Prefix); + Res := Null_Iir; + + when Iir_Kind_Psl_Declaration + | Iir_Kind_Psl_Endpoint_Declaration => + Res := Sem_Psl.Sem_Psl_Name (Name); + + when Iir_Kinds_Library_Unit => + Error_Msg_Sem (+Name, "function name is a design unit"); + + when Iir_Kind_Error => + -- Continue with the error. + Res := Prefix; + + when others => + Error_Kind ("sem_parenthesis_name", Prefix); + end case; + + if Res = Null_Iir then + Res := Error_Mark; + end if; + Set_Named_Entity (Name, Res); + end Sem_Parenthesis_Name; + + procedure Sem_Selected_By_All_Name (Name : Iir_Selected_By_All_Name) + is + Prefix : Iir; + Prefix_Name : Iir; + Res : Iir; + + procedure Sem_As_Selected_By_All_Name (Sub_Name : Iir) + is + Base_Type : Iir; + R, R1 : Iir; + begin + -- Only accept prefix of access type. + Base_Type := Get_Base_Type (Get_Type (Sub_Name)); + if Get_Kind (Base_Type) /= Iir_Kind_Access_Type_Definition then + return; + end if; + + if not Maybe_Function_Call (Sub_Name) then + return; + end if; + + R1 := Maybe_Insert_Function_Call (Get_Prefix (Name), Sub_Name); + + R := Create_Iir (Iir_Kind_Dereference); + Location_Copy (R, Name); + Set_Prefix (R, R1); + -- FIXME: access subtype. + Set_Type (R, Get_Designated_Type (Base_Type)); + Add_Result (Res, R); + end Sem_As_Selected_By_All_Name; + begin + Prefix := Get_Prefix (Name); + Sem_Name (Prefix); + Prefix_Name := Prefix; + Prefix := Get_Named_Entity (Prefix); + if Prefix = Null_Iir then + return; + end if; + Res := Null_Iir; + + case Get_Kind (Prefix) is + when Iir_Kind_Overload_List => + declare + Prefix_List : constant Iir_List := Get_Overload_List (Prefix); + It : List_Iterator; + begin + It := List_Iterate (Prefix_List); + while Is_Valid (It) loop + Sem_As_Selected_By_All_Name (Get_Element (It)); + Next (It); + end loop; + end; + when Iir_Kinds_Object_Declaration + | Iir_Kind_Selected_Element + | Iir_Kind_Dereference + | Iir_Kind_Indexed_Name + | Iir_Kind_Function_Call => + Sem_As_Selected_By_All_Name (Prefix); + when Iir_Kind_Function_Declaration => + Prefix := Sem_As_Function_Call (Name => Prefix_Name, + Spec => Prefix, + Assoc_Chain => Null_Iir); + Sem_As_Selected_By_All_Name (Prefix); + when Iir_Kind_Error => + Set_Named_Entity (Name, Error_Mark); + return; + when others => + Error_Kind ("sem_selected_by_all_name", Prefix); + end case; + if Res = Null_Iir then + Error_Msg_Sem (+Name, "prefix type is not an access type"); + Res := Error_Mark; + end if; + Set_Named_Entity (Name, Res); + end Sem_Selected_By_All_Name; + + function Sem_Base_Attribute (Attr : Iir_Attribute_Name) return Iir + is + Prefix_Name : Iir; + Prefix_Type : Iir; + Res : Iir; + Base_Type : Iir; + Type_Decl : Iir; + begin + Prefix_Name := Finish_Sem_Name (Get_Prefix (Attr)); + Prefix_Type := Name_To_Type_Definition (Prefix_Name); + if not Is_Error (Prefix_Type) then + Base_Type := Get_Base_Type (Prefix_Type); + -- Get the first subtype. FIXME: ref? + Type_Decl := Get_Type_Declarator (Base_Type); + if Get_Kind (Type_Decl) = Iir_Kind_Anonymous_Type_Declaration then + Base_Type := Get_Subtype_Definition (Type_Decl); + end if; + else + Base_Type := Prefix_Type; + end if; + Res := Create_Iir (Iir_Kind_Base_Attribute); + Location_Copy (Res, Attr); + Set_Prefix (Res, Prefix_Name); + Set_Type (Res, Base_Type); + return Res; + end Sem_Base_Attribute; + + function Sem_User_Attribute (Attr : Iir_Attribute_Name) return Iir + is + Prefix_Name : constant Iir := Get_Prefix (Attr); + Prefix : Iir; + Value : Iir; + Attr_Id : Name_Id; + begin + Prefix := Get_Named_Entity (Prefix_Name); + + -- LRM93 6.6 + -- If the attribute name denotes an alias, then the attribute name + -- denotes an attribute of the aliased name and not the alias itself, + -- except when the attribute designator denotes any of the predefined + -- attributes 'simple_name, 'path_name, or 'instance_name. + if Get_Kind (Prefix) = Iir_Kind_Object_Alias_Declaration then + -- GHDL: according to 4.3.3, the name cannot be an alias. + Prefix := Strip_Denoting_Name (Get_Name (Prefix)); + end if; + + -- LRM93 6.6 + -- If the attribute designator denotes a user-defined attribute, the + -- prefix cannot denote a subelement or a slice of an object. + case Get_Kind (Prefix) is + when Iir_Kind_Selected_By_All_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name => + Error_Msg_Sem (+Attr, "prefix of user defined attribute cannot be " + & "an object subelement"); + return Error_Mark; + when Iir_Kind_Dereference => + Error_Msg_Sem (+Attr, "prefix of user defined attribute cannot be " + & "an anonymous object"); + return Error_Mark; + when Iir_Kind_Attribute_Declaration => + Error_Msg_Sem (+Attr, "prefix of user defined attribute cannot be " + & "an attribute"); + return Error_Mark; + when Iir_Kind_Function_Call => + Error_Msg_Sem (+Attr, "invalid prefix or user defined attribute"); + return Error_Mark; + when Iir_Kinds_Object_Declaration + | Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Unit_Declaration + | Iir_Kind_Component_Declaration + | Iir_Kinds_Library_Unit => + -- FIXME: to complete + null; + when Iir_Kinds_Sequential_Statement + | Iir_Kinds_Concurrent_Statement => + -- May appear textually before the statement. + Set_Is_Forward_Ref (Prefix_Name, True); + when others => + Error_Kind ("sem_user_attribute", Prefix); + end case; + + Attr_Id := Get_Identifier (Attr); + Value := Sem_Specs.Find_Attribute_Value (Prefix, Attr_Id); + if Value = Null_Iir then + Error_Msg_Sem (+Attr, "%n was not annotated with attribute %i", + (+Prefix, +Attr_Id)); + if Attr_Id = Std_Names.Name_First or Attr_Id = Std_Names.Name_Last + then + -- Nice (?) message for Ada users. + Error_Msg_Sem + (+Attr, "(you may use 'high, 'low, 'left or 'right attribute)"); + end if; + return Error_Mark; + end if; + + Xref_Ref (Attr, Value); + + return Value; + end Sem_User_Attribute; + + -- The prefix of scalar type attributes is a type name (or 'base), and + -- therefore isn't overloadable. So at the end of the function, the + -- analyze is finished. + function Sem_Scalar_Type_Attribute (Attr : Iir_Attribute_Name) + return Iir + is + use Std_Names; + Prefix_Name : constant Iir := Get_Prefix (Attr); + Id : constant Name_Id := Get_Identifier (Attr); + Prefix_Type : Iir; + Res : Iir; + begin + -- LRM93 14.1 + -- Prefix: Any discrete or physical type of subtype T. + Prefix_Type := + Name_To_Type_Definition (Name_To_Analyzed_Name (Prefix_Name)); + Set_Type (Prefix_Name, Prefix_Type); + if Is_Error (Prefix_Type) then + --Error_Msg_Sem + --(+Attr, "prefix of %i attribute must be a type", +Id); + return Error_Mark; + end if; + + case Id is + when Name_Image + | Name_Value => + if Get_Kind (Prefix_Type) + not in Iir_Kinds_Scalar_Type_And_Subtype_Definition + then + Error_Msg_Sem + (+Attr, "prefix of %i attribute must be a scalar type", + (1 => +Id), Cont => True); + Error_Msg_Sem + (+Attr, "found %n defined at %l", + (+Prefix_Type, +Prefix_Type)); + return Error_Mark; + end if; + when others => + case Get_Kind (Prefix_Type) is + when Iir_Kinds_Discrete_Type_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Physical_Type_Definition => + null; + when others => + Error_Msg_Sem + (+Attr, "prefix of %i" + & " attribute must be discrete or physical type", + (1 => +Id), Cont => True); + Error_Msg_Sem + (+Attr, "found %n defined at %l", + (+Prefix_Type, +Prefix_Type)); + return Error_Mark; + end case; + end case; + + -- Create the resulting node. + case Get_Identifier (Attr) is + when Name_Pos => + Res := Create_Iir (Iir_Kind_Pos_Attribute); + when Name_Val => + Res := Create_Iir (Iir_Kind_Val_Attribute); + when Name_Succ => + Res := Create_Iir (Iir_Kind_Succ_Attribute); + when Name_Pred => + Res := Create_Iir (Iir_Kind_Pred_Attribute); + when Name_Leftof => + Res := Create_Iir (Iir_Kind_Leftof_Attribute); + when Name_Rightof => + Res := Create_Iir (Iir_Kind_Rightof_Attribute); + when Name_Image => + Res := Create_Iir (Iir_Kind_Image_Attribute); + when Name_Value => + Res := Create_Iir (Iir_Kind_Value_Attribute); + when others => + raise Internal_Error; + end case; + Location_Copy (Res, Attr); + Set_Prefix (Res, Prefix_Name); + Set_Base_Name (Res, Res); + + case Get_Identifier (Attr) is + when Name_Pos => + -- LRM93 14.1 + -- Result type: universal_integer. + Set_Type (Res, Convertible_Integer_Type_Definition); + when Name_Val => + -- LRM93 14.1 + -- Result type: the base type of T + Set_Type (Res, Get_Base_Type (Prefix_Type)); + when Name_Succ + | Name_Pred + | Name_Leftof + | Name_Rightof => + -- LRM93 14.1 + -- Result type: the base type of T. + Set_Type (Res, Get_Base_Type (Prefix_Type)); + when Name_Image => + -- LRM93 14.1 + -- Result type: type string + Set_Type (Res, String_Type_Definition); + when Name_Value => + -- LRM93 14.1 + -- Result type: the base type of T. + Set_Type (Res, Get_Base_Type (Prefix_Type)); + when others => + raise Internal_Error; + end case; + return Res; + end Sem_Scalar_Type_Attribute; + + -- Analyze attributes whose prefix is a type or a subtype and result is + -- a value (not a function). + function Sem_Predefined_Type_Attribute (Attr : Iir_Attribute_Name) + return Iir + is + use Std_Names; + Prefix_Name : constant Iir := Get_Prefix (Attr); + Id : constant Name_Id := Get_Identifier (Attr); + Res : Iir; + Prefix : Iir; + Prefix_Type : Iir; + begin + case Id is + when Name_Left => + Res := Create_Iir (Iir_Kind_Left_Type_Attribute); + when Name_Right => + Res := Create_Iir (Iir_Kind_Right_Type_Attribute); + when Name_High => + Res := Create_Iir (Iir_Kind_High_Type_Attribute); + when Name_Low => + Res := Create_Iir (Iir_Kind_Low_Type_Attribute); + when Name_Ascending => + Res := Create_Iir (Iir_Kind_Ascending_Type_Attribute); + when Name_Range + | Name_Reverse_Range => + Error_Msg_Sem + (+Attr, + "prefix of range attribute must be an array type or object"); + return Error_Mark; + when others => + Error_Msg_Sem (+Attr, "attribute %i not valid on this type", +Id); + return Error_Mark; + end case; + Location_Copy (Res, Attr); + Set_Base_Name (Res, Res); + + Prefix := Get_Named_Entity (Prefix_Name); + case Get_Kind (Prefix) is + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + Prefix := Finish_Sem_Name (Prefix_Name, Prefix); + Prefix_Type := Get_Type (Prefix); + Set_Expr_Staticness (Res, Get_Expr_Staticness (Prefix)); + when Iir_Kind_Base_Attribute => + -- Base_Attribute is already finished. + pragma Assert (Get_Kind (Prefix_Name) = Iir_Kind_Attribute_Name); + Free_Iir (Prefix_Name); + Prefix_Type := Get_Type (Prefix); + Set_Expr_Staticness (Res, Get_Type_Staticness (Prefix_Type)); + when others => + Prefix := Sem_Type_Mark (Prefix_Name); + Prefix_Type := Get_Type (Prefix); + Set_Expr_Staticness (Res, Get_Type_Staticness (Prefix_Type)); + end case; + Set_Prefix (Res, Prefix); + + case Get_Identifier (Attr) is + when Name_Ascending => + -- LRM93 14.1 + -- Result Type: type boolean. + Set_Type (Res, Boolean_Type_Definition); + when others => + -- LRM 14.1 + -- Result Type: Same type as T. + Set_Type (Res, Prefix_Type); + end case; + return Res; + end Sem_Predefined_Type_Attribute; + + -- Called for attributes Length, Left, Right, High, Low, Range, + -- Reverse_Range, Ascending. + -- FIXME: handle overload + function Sem_Array_Attribute_Name (Attr : Iir_Attribute_Name) return Iir + is + use Std_Names; + Prefix_Name : constant Iir := Get_Prefix (Attr); + Prefix_Type : Iir; + Prefix : Iir; + Res : Iir; + Res_Type : Iir; + begin + Prefix := Get_Named_Entity (Prefix_Name); + + -- LRM93 14.1 + -- Prefix: Any prefix A that is appropriate for an array object, or an + -- alias thereof, or that denotes a constrained array subtype. + -- + -- LRM08 16.2 Predefined attributes. + -- Prefix of A'Left[(N)], A'Right[(N)]... : + -- Any prefix A that is appropriate for an array object, or an alias + -- thereof, or that denotes a constrained an array subtype whose index + -- ranges are defined by a constraint. + -- + -- GHDL: the prefix cannot be a function call, as the result is not + -- an object and it doesn't denote a subtype. References are: + -- + -- LRM08 6.4 Objects: + -- An object is a named entity [...] + -- In addition the following are objects, but are not named + -- entities[...] + -- + -- LRM08 6 Declarations + -- the name is said to denote the associated entity. + case Get_Kind (Prefix) is + when Iir_Kind_Dereference + | Iir_Kinds_Object_Declaration + | Iir_Kind_Function_Call + | Iir_Kind_Function_Declaration + | Iir_Kind_Selected_Element + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Attribute_Value + | Iir_Kind_Image_Attribute => + -- FIXME: list of expr. + Prefix_Type := Get_Type (Prefix); + case Get_Kind (Prefix_Type) is + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + declare + Designated_Type : Iir; + begin + Designated_Type := + Get_Designated_Type (Get_Base_Type (Prefix_Type)); + Prefix := Insert_Implicit_Dereference (Prefix, Attr); + Prefix_Type := Designated_Type; + end; + when Iir_Kinds_Array_Type_Definition => + null; + when others => + Error_Msg_Sem (+Attr, "object prefix must be an array"); + return Error_Mark; + end case; + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Type_Declaration + | Iir_Kind_Base_Attribute + | Iir_Kind_Subtype_Attribute + | Iir_Kind_Element_Attribute => + Prefix_Type := Get_Type (Prefix); + if not Is_Fully_Constrained_Type (Prefix_Type) then + Error_Msg_Sem (+Attr, "prefix type is not constrained"); + -- We continue using the unconstrained array type. + -- At least, this type is valid; and even if the array was + -- constrained, the base type would be the same. + end if; + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + -- For names such as pfx'Range'Left. + -- Finish_Sem_Array_Attribute (Prefix_Name, Prefix, Null_Iir); + Prefix_Type := Get_Type (Prefix); + when Iir_Kind_Process_Statement => + Error_Msg_Sem + (+Attr, "%n is not an appropriate prefix for %i attribute", + (+Prefix, +Attr)); + return Error_Mark; + when others => + Error_Msg_Sem + (+Attr, "prefix must denote an array object or type"); + return Error_Mark; + end case; + + case Get_Kind (Prefix_Type) is + when Iir_Kinds_Scalar_Type_And_Subtype_Definition => + -- Note: prefix is a scalar type or subtype. + return Sem_Predefined_Type_Attribute (Attr); + when Iir_Kinds_Array_Type_Definition => + null; + when others => + Error_Msg_Sem (+Attr, "prefix of %i attribute must denote a " + & "constrained array subtype", +Attr); + return Error_Mark; + end case; + + -- Type of the attribute. This is correct unless there is a parameter, + -- and furthermore 'range and 'reverse_range has to be handled + -- specially because the result is a range and not a value. + Res_Type := Get_Index_Type (Get_Index_Subtype_List (Prefix_Type), 0); + + -- Create the node for the attribute. + case Get_Identifier (Attr) is + when Name_Left => + Res := Create_Iir (Iir_Kind_Left_Array_Attribute); + when Name_Right => + Res := Create_Iir (Iir_Kind_Right_Array_Attribute); + when Name_High => + Res := Create_Iir (Iir_Kind_High_Array_Attribute); + when Name_Low => + Res := Create_Iir (Iir_Kind_Low_Array_Attribute); + when Name_Range => + Res := Create_Iir (Iir_Kind_Range_Array_Attribute); + when Name_Reverse_Range => + Res := Create_Iir (Iir_Kind_Reverse_Range_Array_Attribute); + when Name_Length => + Res := Create_Iir (Iir_Kind_Length_Array_Attribute); + -- FIXME: Error if ambiguous + Res_Type := Convertible_Integer_Type_Definition; + when Name_Ascending => + Res := Create_Iir (Iir_Kind_Ascending_Array_Attribute); + -- FIXME: Error if ambiguous + Res_Type := Boolean_Type_Definition; + when others => + raise Internal_Error; + end case; + Location_Copy (Res, Attr); + Set_Prefix (Res, Prefix); + Set_Type (Res, Res_Type); + return Res; + end Sem_Array_Attribute_Name; + + -- For 'Subtype + function Sem_Subtype_Attribute (Attr : Iir_Attribute_Name) return Iir + is + Prefix_Name : constant Iir := Get_Prefix (Attr); + Prefix : Iir; + Prefix_Type : Iir; + Res : Iir; + begin + Prefix := Get_Named_Entity (Prefix_Name); + + -- LRM08 16.2 Predefined attributes + -- Prefix: Any prefix O that is appropriate for an object, or an alias + -- thereof + if Get_Kind (Prefix) not in Iir_Kinds_Object_Declaration then + Error_Msg_Sem (+Attr, "prefix must denote an object"); + return Error_Mark; + end if; + + Prefix_Type := Get_Type (Prefix); + + Res := Create_Iir (Iir_Kind_Subtype_Attribute); + Location_Copy (Res, Attr); + Set_Prefix (Res, Prefix); + Set_Type (Res, Prefix_Type); + + Set_Base_Name (Res, Get_Base_Name (Prefix_Name)); + Set_Name_Staticness (Res, Get_Name_Staticness (Prefix)); + Set_Type_Staticness (Res, Get_Type_Staticness (Prefix_Type)); + + return Res; + end Sem_Subtype_Attribute; + + function Sem_Signal_Signal_Attribute + (Attr : Iir_Attribute_Name; Kind : Iir_Kind) + return Iir + is + Res : Iir; + Prefix : Iir; + begin + Prefix := Get_Named_Entity (Get_Prefix (Attr)); + Res := Create_Iir (Kind); + Location_Copy (Res, Attr); + if Kind = Iir_Kind_Delayed_Attribute then + Set_Type (Res, Get_Type (Prefix)); + elsif Kind = Iir_Kind_Transaction_Attribute then + Set_Type (Res, Bit_Type_Definition); + else + Set_Type (Res, Boolean_Type_Definition); + end if; + Set_Base_Name (Res, Res); + + if Get_Kind (Prefix) = Iir_Kind_Interface_Signal_Declaration then + -- LRM93 2.1.1.2 / LRM08 4.2.2.3 + -- + -- It is an error if signal-valued attributes 'STABLE , 'QUIET, + -- 'TRANSACTION, and 'DELAYED of formal signal paramaters of any + -- mode are read within a subprogram. + case Get_Kind (Get_Parent (Prefix)) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Error_Msg_Sem + (+Attr, "%i is not allowed for a signal parameter", +Attr); + when others => + null; + end case; + end if; + Sem_Decls.Add_Declaration_For_Implicit_Signal (Res); + return Res; + end Sem_Signal_Signal_Attribute; + + function Sem_Signal_Attribute (Attr : Iir_Attribute_Name) return Iir + is + use Std_Names; + Prefix: Iir; + Res : Iir; + Base : Iir; + begin + Prefix := Get_Named_Entity (Get_Prefix (Attr)); + Base := Get_Object_Prefix (Prefix); + case Get_Kind (Base) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kinds_Signal_Attribute => + null; + when others => + Error_Msg_Sem + (+Attr, "prefix of %i attribute must denote a signal", +Attr); + return Error_Mark; + end case; + case Get_Identifier (Attr) is + when Name_Stable => + Res := Sem_Signal_Signal_Attribute + (Attr, Iir_Kind_Stable_Attribute); + when Name_Quiet => + Res := Sem_Signal_Signal_Attribute + (Attr, Iir_Kind_Quiet_Attribute); + when Name_Delayed => + Res := Sem_Signal_Signal_Attribute + (Attr, Iir_Kind_Delayed_Attribute); + when Name_Transaction => + Res := Sem_Signal_Signal_Attribute + (Attr, Iir_Kind_Transaction_Attribute); + when Name_Event => + Res := Create_Iir (Iir_Kind_Event_Attribute); + Set_Type (Res, Boolean_Type_Definition); + when Name_Active => + Res := Create_Iir (Iir_Kind_Active_Attribute); + Set_Type (Res, Boolean_Type_Definition); + when Name_Last_Value => + Res := Create_Iir (Iir_Kind_Last_Value_Attribute); + Set_Type (Res, Get_Type (Prefix)); + when Name_Last_Event => + Res := Create_Iir (Iir_Kind_Last_Event_Attribute); + Set_Type (Res, Time_Type_Definition); + when Name_Last_Active => + Res := Create_Iir (Iir_Kind_Last_Active_Attribute); + Set_Type (Res, Time_Type_Definition); + when Name_Driving_Value => + Res := Create_Iir (Iir_Kind_Driving_Value_Attribute); + Set_Type (Res, Get_Type (Prefix)); + -- FIXME: check restrictions. + when Name_Driving => + Res := Create_Iir (Iir_Kind_Driving_Attribute); + Set_Type (Res, Boolean_Type_Definition); + -- FIXME: check restrictions. + when others => + -- Not yet implemented attribute, or really an internal error. + raise Internal_Error; + end case; + Location_Copy (Res, Attr); + + -- LRM 4.3.2 + -- The value of an object is said to be read when one of the following + -- conditions is satisfied: + -- [...] + -- * When the object is a signal and the value of any of its predefined + -- attributes 'STABLE, 'QUIET, 'DELAYED, 'TRANSACTION, 'EVENT, + -- 'ACTIVE, 'LAST_EVENT, 'LAST_ACTIVE, or 'LAST_VALUE is read. + + -- LRM 14.1 + -- S'Driving Restrictions: + -- S'Driving_Value Restrictions: + -- This attribute is available only from within a process, a + -- concurrent statement with an equivalent process, or a subprogram. + -- If the prefix denotes a port, it is an error if the port does not + -- have a mode of INOUT, OUT or BUFFER. It is also an error if the + -- attribute name appears in a subprogram body that is not a declarative + -- item contained within a process statement and the prefix is not a + -- formal parameter of the given subprogram or of a parent of that + -- subprogram. Finally, it is an error if the prefix denotes a + -- subprogram formal parameter whose mode is not INOUT or OUT, or if + -- S'Driving is False at the time of the evaluation of S'Driving_Value. + case Get_Kind (Res) is + when Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Event_Attribute + | Iir_Kind_Active_Attribute + | Iir_Kind_Last_Event_Attribute + | Iir_Kind_Last_Active_Attribute + | Iir_Kind_Last_Value_Attribute => + Check_Read (Prefix); + when Iir_Kind_Driving_Attribute + | Iir_Kind_Driving_Value_Attribute => + -- FIXME: complete checks. + if Get_Current_Concurrent_Statement = Null_Iir then + Error_Msg_Sem + (+Attr, "'driving or 'driving_value is available only " + & "within a concurrent statement"); + else + case Get_Kind (Get_Current_Concurrent_Statement) is + when Iir_Kinds_Process_Statement + | Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment + | Iir_Kind_Concurrent_Procedure_Call_Statement => + null; + when others => + Error_Msg_Sem + (+Attr, "'driving or 'driving_value not available " + & "within this concurrent statement"); + end case; + end if; + + case Get_Kind (Base) is + when Iir_Kind_Signal_Declaration => + null; + when Iir_Kind_Interface_Signal_Declaration => + case Get_Mode (Base) is + when Iir_Buffer_Mode + | Iir_Inout_Mode + | Iir_Out_Mode => + null; + when others => + Error_Msg_Sem + (+Attr, "mode of 'driving or 'driving_value prefix " + & "must be out, inout or buffer"); + end case; + when others => + Error_Msg_Sem + (+Attr, "bad prefix for 'driving or 'driving_value"); + end case; + when others => + null; + end case; + + -- According to LRM 7.4, signal attributes are not static expressions + -- since the prefix (a signal) is not a static expression. + Set_Expr_Staticness (Res, None); + + -- LRM02 6.1 / LRM08 8.1 + -- A name is said to be a static name if and only if at least one of + -- the following conditions holds: + -- [...] + -- - The name is a attribute name whose prefix is a static signal name + -- and whose suffix is one of the predefined attributes 'DELAYED, + -- 'STABLE, 'QUIET or 'TRANSACTION. + -- According to LRM 6.1, attributes are not static names. + if Flags.Vhdl_Std = Vhdl_93c or Flag_Relaxed_Rules + or Flags.Vhdl_Std >= Vhdl_02 + then + case Get_Kind (Res) is + when Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute => + Set_Name_Staticness (Res, Get_Name_Staticness (Prefix)); + when others => + Set_Name_Staticness (Res, None); + end case; + else + Set_Name_Staticness (Res, None); + end if; + + Set_Prefix (Res, Prefix); + + -- Set has_active_flag when activity is read. + case Get_Kind (Res) is + when Iir_Kind_Quiet_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Active_Attribute + | Iir_Kind_Last_Active_Attribute => + Set_Has_Active_Flag (Base, True); + when others => + null; + end case; + + return Res; + end Sem_Signal_Attribute; + + -- 'Simple_name, 'instance_name and 'path_name. + function Sem_Name_Attribute (Attr : Iir_Attribute_Name) return Iir + is + use Std_Names; + Prefix_Name : constant Iir := Get_Prefix (Attr); + Prefix: Iir; + Res : Iir; + Attr_Type : Iir; + begin + Prefix := Get_Named_Entity (Prefix_Name); + Set_Prefix (Attr, Finish_Sem_Name (Prefix_Name, Prefix)); + + -- LRM 14.1 Predefined attributes + -- E'SIMPLE_NAME + -- Prefix: Any named entity as defined in 5.1 + -- E'INSTANCE_NAME + -- Prefix: Any named entity other than the local ports and generics + -- of a component declaration. + -- E'PATH_NAME + -- Prefix: Any named entity other than the local ports and generics + -- of a component declaration. + case Get_Kind (Prefix) is + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Component_Declaration + | Iir_Kinds_Concurrent_Statement + | Iir_Kinds_Sequential_Statement + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Group_Declaration + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_File_Declaration + | Iir_Kinds_Library_Unit + | Iir_Kind_Non_Object_Alias_Declaration => + null; + + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_Constant_Declaration => + if Get_Identifier (Attr) /= Name_Simple_Name + and then Get_Kind (Get_Parent (Prefix)) + = Iir_Kind_Component_Declaration + then + Error_Msg_Sem + (+Attr, + "local ports or generics of a component cannot be a prefix"); + end if; + + when Iir_Kind_Subtype_Attribute + | Iir_Kind_Base_Attribute => + declare + Atype : constant Iir := Get_Type (Prefix); + begin + if Is_Anonymous_Type_Definition (Atype) then + Error_Msg_Sem (+Attr, "%n is not a named entity", +Prefix); + return Create_Error_Expr (Attr, String_Type_Definition); + end if; + Prefix := Get_Type_Declarator (Atype); + end; + when others => + Error_Msg_Sem (+Attr, "%n is not a named entity", +Prefix); + return Create_Error_Expr (Attr, String_Type_Definition); + end case; + + case Get_Identifier (Attr) is + when Name_Simple_Name => + declare + Id : constant Name_Id := Name_Table.Get_Identifier + (Eval_Simple_Name (Get_Identifier (Prefix))); + begin + Res := Create_Iir (Iir_Kind_Simple_Name_Attribute); + Set_Simple_Name_Identifier (Res, Id); + Attr_Type := Create_Unidim_Array_By_Length + (String_Type_Definition, + Iir_Int64 (Name_Table.Get_Name_Length (Id)), + Attr); + Set_Simple_Name_Subtype (Res, Attr_Type); + Set_Expr_Staticness (Res, Locally); + end; + + when Name_Path_Name => + Res := Create_Iir (Iir_Kind_Path_Name_Attribute); + Set_Expr_Staticness (Res, Globally); + Attr_Type := String_Type_Definition; + + when Name_Instance_Name => + Res := Create_Iir (Iir_Kind_Instance_Name_Attribute); + Set_Expr_Staticness (Res, Globally); + Attr_Type := String_Type_Definition; + + when others => + raise Internal_Error; + end case; + + Location_Copy (Res, Attr); + Set_Prefix (Res, Prefix_Name); + Set_Type (Res, Attr_Type); + return Res; + end Sem_Name_Attribute; + + procedure Sem_Attribute_Name (Attr : Iir_Attribute_Name) + is + use Std_Names; + Prefix : Iir; + Res : Iir; + Sig : Iir_Signature; + begin + -- LRM93 6.6 Attribute names + -- The meaning of the prefix of an attribute name must be determinable + -- independently of the attribute designator and independently of the + -- fact that it is the prefix of an attribute. + Prefix := Get_Prefix (Attr); + + -- LRM93 6.6 + -- If the prefix of an attribute name denotes an alias, then the + -- attribute name denotes an attribute of the aliased name and not the + -- alias itself, except when the attribute designator denotes any of + -- the predefined attributes 'Simple_Name, 'Path_Name or 'Instance_Name. + -- If the prefix of an attribute name denotes an alias and the + -- attribute designator denotes any of the predefined attributes + -- 'Simple_Name, 'Path_Name or 'Instance_Name, then the attribute name + -- denotes the attribute of the alias and not of the aliased name. + if Flags.Vhdl_Std > Vhdl_87 + and then Get_Identifier (Attr) in Name_Id_Name_Attributes + then + Sem_Name (Prefix, True); + else + Sem_Name (Prefix, False); + end if; + Prefix := Get_Named_Entity (Prefix); + + if Prefix = Error_Mark then + Set_Named_Entity (Attr, Prefix); + return; + end if; + + -- LRM93 6.6 + -- A signature may follow the prefix if and only if the prefix denotes + -- a subprogram or enumeration literal, or an alias thereof. + -- In this case, the signature is required to match (see Section 2.3.2) + -- the parameter and result type profile of exactly one visible + -- subprogram or enumeration literal, as is appropriate to the prefix. + -- GHDL: this is done by Sem_Signature. + Sig := Get_Attribute_Signature (Attr); + if Sig /= Null_Iir then + Prefix := Sem_Signature (Prefix, Sig); + if Prefix = Null_Iir then + Set_Named_Entity (Attr, Error_Mark); + return; + end if; + Set_Named_Entity (Get_Prefix (Attr), Prefix); + end if; + + if Get_Kind (Prefix) = Iir_Kind_Overload_List then + -- FIXME: this should be allowed. + Error_Msg_Sem (+Attr, "prefix of attribute is overloaded"); + Set_Named_Entity (Attr, Error_Mark); + return; + end if; + + -- Set_Prefix (Attr, Finish_Sem_Name (Get_Prefix (Attr), Prefix)); + + case Get_Identifier (Attr) is + when Name_Base => + Res := Sem_Base_Attribute (Attr); + when Name_Image + | Name_Value => + if Flags.Vhdl_Std > Vhdl_87 then + Res := Sem_Scalar_Type_Attribute (Attr); + else + Res := Sem_User_Attribute (Attr); + end if; + + when Name_Pos + | Name_Val + | Name_Succ + | Name_Pred + | Name_Rightof + | Name_Leftof => + Res := Sem_Scalar_Type_Attribute (Attr); + + when Name_Length + | Name_Left + | Name_Right + | Name_High + | Name_Low + | Name_Range + | Name_Reverse_Range => + Res := Sem_Array_Attribute_Name (Attr); + + when Name_Ascending => + if Flags.Vhdl_Std > Vhdl_87 then + Res := Sem_Array_Attribute_Name (Attr); + else + Res := Sem_User_Attribute (Attr); + end if; + + when Name_Stable + | Name_Event + | Name_Last_Value + | Name_Delayed + | Name_Quiet + | Name_Transaction + | Name_Active + | Name_Last_Active + | Name_Last_Event => + Res := Sem_Signal_Attribute (Attr); + + when Name_Driving + | Name_Driving_Value => + if Flags.Vhdl_Std > Vhdl_87 then + Res := Sem_Signal_Attribute (Attr); + else + Res := Sem_User_Attribute (Attr); + end if; + + when Name_Simple_Name + | Name_Path_Name + | Name_Instance_Name => + if Flags.Vhdl_Std > Vhdl_87 then + Res := Sem_Name_Attribute (Attr); + else + Res := Sem_User_Attribute (Attr); + end if; + + when Name_Subtype => + if Flags.Vhdl_Std >= Vhdl_08 then + Res := Sem_Subtype_Attribute (Attr); + else + Res := Sem_User_Attribute (Attr); + end if; + + when others => + Res := Sem_User_Attribute (Attr); + end case; + + if Res = Null_Iir then + Error_Kind ("sem_attribute_name", Attr); + end if; + Set_Named_Entity (Attr, Res); + end Sem_Attribute_Name; + + -- LRM93 §6 + procedure Sem_Name (Name : Iir; Keep_Alias : Boolean := False) is + begin + -- Exit now if NAME was already analyzed. + if Get_Named_Entity (Name) /= Null_Iir then + return; + end if; + + case Get_Kind (Name) is + when Iir_Kind_Simple_Name + | Iir_Kind_Character_Literal + | Iir_Kind_Operator_Symbol => + -- String_Literal may be a operator_symbol. + Sem_Simple_Name (Name, Keep_Alias, Soft => False); + when Iir_Kind_Selected_Name => + Sem_Selected_Name (Name, Keep_Alias); + when Iir_Kind_Parenthesis_Name => + Sem_Parenthesis_Name (Name); + when Iir_Kind_Selected_By_All_Name => + Sem_Selected_By_All_Name (Name); + when Iir_Kind_Attribute_Name => + Sem_Attribute_Name (Name); + when Iir_Kinds_External_Name => + Sem_External_Name (Name); + when others => + Error_Kind ("sem_name", Name); + end case; + end Sem_Name; + + procedure Sem_Name_Soft (Name : Iir) + is + begin + -- Exit now if NAME was already analyzed. + if Get_Named_Entity (Name) /= Null_Iir then + return; + end if; + + case Get_Kind (Name) is + when Iir_Kind_Simple_Name + | Iir_Kind_Operator_Symbol => + -- String_Literal may be a operator_symbol. + Sem_Simple_Name (Name, False, Soft => True); + when Iir_Kind_Selected_Name => + Sem_Selected_Name (Name, Keep_Alias => False, Soft => True); + when Iir_Kind_Parenthesis_Name => + -- FIXME: SOFT!! + Sem_Parenthesis_Name (Name); + when others => + Error_Kind ("sem_name_soft", Name); + end case; + end Sem_Name_Soft; + + procedure Sem_Name_Clean_1 (Name : Iir) + is + Named_Entity : Iir; + Atype : Iir; + begin + if Name = Null_Iir then + return; + end if; + + -- Clear and free overload lists of Named_entity and type. + Named_Entity := Get_Named_Entity (Name); + Set_Named_Entity (Name, Null_Iir); + if Named_Entity /= Null_Iir + and then Is_Overload_List (Named_Entity) + then + Free_Iir (Named_Entity); + end if; + + Atype := Get_Type (Name); + Set_Type (Name, Null_Iir); + if Atype /= Null_Iir + and then Is_Overload_List (Atype) + then + Free_Iir (Atype); + end if; + end Sem_Name_Clean_1; + + procedure Sem_Name_Clean (Name : Iir) is + begin + case Get_Kind (Name) is + when Iir_Kind_Simple_Name + | Iir_Kind_Operator_Symbol => + Sem_Name_Clean_1 (Name); + when Iir_Kind_Parenthesis_Name + | Iir_Kind_Selected_Name => + Sem_Name_Clean_1 (Get_Prefix (Name)); + Sem_Name_Clean_1 (Name); + when others => + Error_Kind ("sem_name_clean", Name); + end case; + end Sem_Name_Clean; + + -- Remove procedure specification from LIST. + function Remove_Procedures_From_List (Expr : Iir) return Iir + is + El : Iir; + List : Iir_List; + It : List_Iterator; + New_List : Iir_List; + begin + if not Is_Overload_List (Expr) then + return Expr; + end if; + List := Get_Overload_List (Expr); + New_List := Create_Iir_List; + It := List_Iterate (List); + while Is_Valid (It) loop + El := Get_Element (It); + case Get_Kind (El) is + when Iir_Kind_Procedure_Declaration => + null; + when Iir_Kind_Function_Declaration => + if Maybe_Function_Call (El) then + Append_Element (New_List, El); + end if; + when others => + Append_Element (New_List, El); + end case; + Next (It); + end loop; + case Get_Nbr_Elements (New_List) is + when 0 => + Free_Iir (Expr); + Destroy_Iir_List (New_List); + return Null_Iir; + when 1 => + Free_Iir (Expr); + El := Get_First_Element (New_List); + Destroy_Iir_List (New_List); + return El; + when others => + Set_Overload_List (Expr, New_List); + Destroy_Iir_List (List); + return Expr; + end case; + end Remove_Procedures_From_List; + + -- Return the fully analyzed name of NAME. + function Name_To_Analyzed_Name (Name : Iir) return Iir is + begin + case Get_Kind (Name) is + when Iir_Kind_Attribute_Name + | Iir_Kind_Parenthesis_Name => + return Get_Named_Entity (Name); + when others => + return Name; + end case; + end Name_To_Analyzed_Name; + + -- Convert name EXPR to an expression (ie, create function call). + -- A_TYPE is the expected type of the expression. + -- Returns an Error node in case of error. + function Name_To_Expression (Name : Iir; A_Type : Iir) return Iir + is + Ret_Type : Iir; + Res_Type : Iir; + Expr : Iir; + Expr_List : Iir_List; + Expr_It : List_Iterator; + Res : Iir; + Res1 : Iir; + El : Iir; + begin + Expr := Get_Named_Entity (Name); + if Get_Kind (Expr) = Iir_Kind_Error then + return Expr; + end if; + if Check_Is_Expression (Expr, Name) = Null_Iir then + return Create_Error_Expr (Name, A_Type); + end if; + + -- Note: EXPR may contain procedure names... + Expr := Remove_Procedures_From_List (Expr); + Set_Named_Entity (Name, Expr); + if Expr = Null_Iir then + Error_Msg_Sem (+Name, "%n cannot be used as expression", +Name); + return Create_Error_Expr (Name, A_Type); + end if; + + if not Is_Overload_List (Expr) then + Res := Finish_Sem_Name (Name); + pragma Assert (Res /= Null_Iir); + if A_Type /= Null_Iir then + Res_Type := Get_Type (Res); + if Res_Type = Null_Iir then + return Create_Error_Expr (Res, A_Type); + end if; + if Are_Basetypes_Compatible (Get_Base_Type (Res_Type), A_Type) + = Not_Compatible + then + Error_Not_Match (Res, A_Type); + return Create_Error_Expr (Res, A_Type); + end if; + -- Fall through. + end if; + else + -- EXPR is an overloaded name. + Expr_List := Get_Overload_List (Expr); + + if A_Type /= Null_Iir then + -- Find the name returning A_TYPE. + Res := Null_Iir; + Expr_It := List_Iterate (Expr_List); + while Is_Valid (Expr_It) loop + El := Get_Element (Expr_It); + if Are_Basetypes_Compatible (Get_Base_Type (Get_Type (El)), + A_Type) + /= Not_Compatible + then + Add_Result (Res, El); + end if; + Next (Expr_It); + end loop; + if Res = Null_Iir then + -- Specific error message for a non-visible enumeration + -- literal. + if (Get_Kind (Get_Base_Type (A_Type)) + = Iir_Kind_Enumeration_Type_Definition) + and then Kind_In (Name, Iir_Kind_Simple_Name, + Iir_Kind_Character_Literal) + then + Res := Find_Name_In_Flist (Get_Enumeration_Literal_List + (Get_Base_Type (A_Type)), + Get_Identifier (Name)); + if Res /= Null_Iir then + Error_Msg_Sem + (+Name, "enumeration literal %i is not visible " + & "(add a use clause)", +Name); + -- Keep the literal as result. + end if; + end if; + end if; + + if Res = Null_Iir then + Error_Not_Match (Name, A_Type); + return Create_Error_Expr (Name, A_Type); + elsif Is_Overload_List (Res) then + Res1 := Extract_Call_Without_Implicit_Conversion (Res); + if Res1 /= Null_Iir then + Free_Iir (Res); + Res := Res1; + else + Error_Overload (Name); + Disp_Overload_List (Get_Overload_List (Res), Name); + Free_Iir (Res); + return Create_Error_Expr (Name, A_Type); + end if; + end if; + + -- Free results + Sem_Name_Free_Result (Expr, Res); + + Ret_Type := Get_Type (Name); + if Ret_Type /= Null_Iir then + pragma Assert (Is_Overload_List (Ret_Type)); + Free_Overload_List (Ret_Type); + end if; + -- Fall through. + else + -- Create a list of type. + Ret_Type := Create_List_Of_Types (Expr_List); + if Ret_Type = Null_Iir or else not Is_Overload_List (Ret_Type) then + Res1 := Extract_Call_Without_Implicit_Conversion (Expr); + if Res1 /= Null_Iir then + -- Found it. + Res := Res1; + -- Fall through + else + -- There is either no types or one type for + -- several meanings. + Error_Overload (Name); + Disp_Overload_List (Expr_List, Name); + --Free_Iir (Ret_Type); + return Create_Error_Expr (Name, A_Type); + end if; + else + Set_Type (Name, Ret_Type); + return Name; + end if; + end if; + + Set_Named_Entity (Name, Res); + Res := Finish_Sem_Name (Name); + end if; + + -- NAME has only one meaning, which is RES. + case Get_Kind (Res) is + when Iir_Kind_Simple_Name + | Iir_Kind_Character_Literal + | Iir_Kind_Selected_Name => + Expr := Get_Named_Entity (Res); + if Get_Kind (Expr) = Iir_Kind_Function_Declaration then + return Function_Declaration_To_Call (Res); + else + Set_Type (Res, Get_Type (Expr)); + Set_Expr_Staticness (Res, Get_Expr_Staticness (Expr)); + --Set_Name_Staticness (Name, Get_Name_Staticness (Expr)); + --Set_Base_Name (Name, Get_Base_Name (Expr)); + return Res; + end if; + when Iir_Kind_Function_Call + | Iir_Kind_Selected_Element + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Type_Conversion + | Iir_Kind_Attribute_Name => + return Eval_Expr_If_Static (Res); + when Iir_Kind_Dereference => + -- Never static. + return Res; + when Iir_Kinds_Array_Attribute => + -- FIXME: exclude range and reverse_range. + return Eval_Expr_If_Static (Res); + when Iir_Kinds_Signal_Attribute + | Iir_Kinds_Signal_Value_Attribute => + -- Never static + return Res; + when Iir_Kinds_Type_Attribute + | Iir_Kinds_Scalar_Type_Attribute + | Iir_Kind_Image_Attribute + | Iir_Kind_Value_Attribute + | Iir_Kind_Simple_Name_Attribute + | Iir_Kind_Path_Name_Attribute + | Iir_Kind_Instance_Name_Attribute => + return Eval_Expr_If_Static (Res); + when Iir_Kind_Parenthesis_Name + | Iir_Kind_Selected_By_All_Name => + raise Internal_Error; + when others => + Error_Kind ("name_to_expression", Res); + end case; + end Name_To_Expression; + + function Name_To_Range (Name : Iir) return Iir + is + Expr : Iir; + begin + Expr := Get_Named_Entity (Name); + if Get_Kind (Expr) = Iir_Kind_Error then + return Error_Mark; + end if; + + case Get_Kind (Expr) is + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Type_Declaration => + Expr := Sem_Type_Mark (Name); + Set_Expr_Staticness + (Expr, Get_Type_Staticness (Get_Type (Expr))); + return Expr; + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + if Get_Parameter (Expr) = Null_Iir then + Finish_Sem_Array_Attribute (Name, Expr, Null_Iir); + end if; + if Get_Kind (Name) = Iir_Kind_Attribute_Name then + Free_Iir (Name); + else + Free_Iir (Get_Prefix (Name)); + Free_Parenthesis_Name (Name, Expr); + end if; + return Expr; + when others => + Error_Msg_Sem (+Name, "%n doesn't denote a range", +Name); + return Error_Mark; + end case; + end Name_To_Range; + + function Name_To_Type_Definition (Name : Iir) return Iir + is + Atype : Iir; + begin + case Get_Kind (Name) is + when Iir_Kinds_Denoting_Name => + -- Common correct case. + Atype := Get_Named_Entity (Name); + case Get_Kind (Atype) is + when Iir_Kind_Type_Declaration => + return Get_Type_Definition (Atype); + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Interface_Type_Declaration => + return Get_Type (Atype); + when Iir_Kind_Error => + return Atype; + when others => + Error_Msg_Sem + (+Name, "a type mark must denote a type or a subtype", + Cont => True); + Error_Msg_Sem + (+Name, "(type mark denotes %n)", +Atype); + return Create_Error_Type (Atype); + end case; + when Iir_Kind_Subtype_Attribute + | Iir_Kind_Element_Attribute + | Iir_Kind_Base_Attribute => + return Get_Type (Name); + when Iir_Kinds_Expression_Attribute => + Error_Msg_Sem (+Name, "%n is not a valid type mark", +Name); + return Create_Error_Type (Name); + when others => + if not Is_Error (Name) then + Error_Msg_Sem + (+Name, "a type mark must be a simple or expanded name"); + end if; + return Create_Error_Type (Name); + end case; + end Name_To_Type_Definition; + + function Sem_Denoting_Name (Name: Iir) return Iir + is + Res: Iir; + begin + pragma Assert (Get_Kind (Name) in Iir_Kinds_Denoting_Name); + + Sem_Name (Name); + Res := Get_Named_Entity (Name); + + case Get_Kind (Res) is + when Iir_Kind_Error => + -- A message must have been displayed. + return Name; + when Iir_Kind_Overload_List => + Error_Overload (Res); + Set_Named_Entity (Name, Create_Error_Name (Name)); + return Name; + when Iir_Kinds_Concurrent_Statement + | Iir_Kinds_Sequential_Statement + | Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Unit_Declaration + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration + | Iir_Kind_Attribute_Declaration + | Iir_Kinds_Object_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Context_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Interface_Package_Declaration + | Iir_Kind_Library_Declaration + | Iir_Kinds_Subprogram_Declaration + | Iir_Kind_Component_Declaration => + Res := Finish_Sem_Name (Name, Res); + pragma Assert (Get_Kind (Res) in Iir_Kinds_Denoting_Name); + return Res; + when Iir_Kind_Selected_Element => + -- An error (to be diagnosticed by the caller). + return Name; + when others => + Error_Kind ("sem_denoting_name", Res); + end case; + end Sem_Denoting_Name; + + procedure Sem_External_Name (Name : Iir) + is + Atype : Iir; + begin + pragma Assert (Get_Type (Name) = Null_Iir); + + Atype := Get_Subtype_Indication (Name); + + Atype := Sem_Types.Sem_Subtype_Indication (Atype); + Set_Subtype_Indication (Name, Atype); + Atype := Get_Type_Of_Subtype_Indication (Atype); + if Atype = Null_Iir then + Atype := Create_Error_Type (Null_Iir); + end if; + + Set_Type (Name, Atype); + + -- LRM08 8.1 Names + -- A name is said to be a static name if and only if one of the + -- following condition holds: + -- - The name is an external name. + Set_Name_Staticness (Name, Globally); + + Set_Expr_Staticness (Name, None); + + -- Consider the node as analyzed. + Set_Named_Entity (Name, Name); + end Sem_External_Name; + + function Sem_Terminal_Name (Name : Iir) return Iir + is + Res : Iir; + Ent : Iir; + begin + Res := Sem_Denoting_Name (Name); + Ent := Get_Named_Entity (Res); + if Get_Kind (Ent) /= Iir_Kind_Terminal_Declaration then + Error_Class_Match (Name, "terminal"); + Set_Named_Entity (Res, Create_Error_Name (Name)); + end if; + return Res; + end Sem_Terminal_Name; + + procedure Error_Class_Match (Name : Iir; Class_Name : String) + is + Ent : constant Iir := Get_Named_Entity (Name); + begin + if Is_Error (Ent) then + Error_Msg_Sem (+Name, Class_Name & " name expected"); + else + Error_Msg_Sem (+Name, Class_Name & " name expected, found %n", + +Get_Named_Entity (Name)); + end if; + end Error_Class_Match; +end Vhdl.Sem_Names; diff --git a/src/vhdl/vhdl-sem_names.ads b/src/vhdl/vhdl-sem_names.ads new file mode 100644 index 000000000..d5ed1a462 --- /dev/null +++ b/src/vhdl/vhdl-sem_names.ads @@ -0,0 +1,159 @@ +-- Semantic analysis. +-- 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 Iirs; use Iirs; + +package Vhdl.Sem_Names is + -- In VHDL, most of name notations are ambiguous: + -- P.N is either + -- an expanded name or + -- a selected name for an element (with a possible implicit dereference) + -- P (A1, A2, ...) can be + -- an indexed name (with a possible implicit dereference) + -- a slice name (with a possible implicit dereference) + -- a subprogram call + -- a type conversion + + -- The name analysis resolves two ambiguities: notation and overload. + -- In a first pass, all possible meaning are collected as an overload + -- list in the Named_Entity field of the name. Prefixes in that list + -- are always declarations and not simple or expanded names. This is done + -- to avoid creating nodes for simple or expanded names, as they cannot be + -- shared in the prefixes because they can have several meanings. + -- + -- In a second pass, when the caller has resolved the overloading (using + -- the context), the name is rewritten: parenthesis and selected names are + -- replaced (by slice, index, call, element selection...). Prefixes are + -- simple or expanded names (and never declarations). Checks are also + -- performed on the result (pure, all sensitized). + -- + -- The result of the name analysis may not be a name: a function_call or + -- a type conversion are not names. + + -- Analyze NAME: perform the first pass only. In case of error, a message + -- is displayed and the named entity is error_mark. + procedure Sem_Name (Name : Iir; Keep_Alias : Boolean := False); + + -- Finish analysis of NAME, if necessary. The named entity must not + -- be an overload list (ie the overload resolution must have been done). + -- Do remaining checks, transform function names into calls... + function Finish_Sem_Name (Name : Iir) return Iir; + + -- Analyze NAME as a type mark. NAME must be either a simple name or an + -- expanded name, and the denoted entity must be either a type or a subtype + -- declaration. Return the name (possibly modified) and set named_entity + -- and type. In case of error, the type is error_mark. NAME may have + -- already been analyzed by Sem_Name. + -- Incomplete types are allowed only if INCOMPLETE is True. + function Sem_Type_Mark (Name : Iir; Incomplete : Boolean := False) + return Iir; + + -- Same as Sem_Name but without any side-effect: + -- * do not report error + -- * do not set xrefs + -- Currently, only simple names (and expanded names) are handled. + -- This is to be used during sem of associations. Because there is no side + -- effect, NAME is not modified (but is decorated with Named_Entity) + procedure Sem_Name_Soft (Name : Iir); + + -- Remove every named_entity of NAME. + -- If NAME is Null_Iir then this is no op. + -- To be used only for names (weakly) analyzed by sem_name_soft. + procedure Sem_Name_Clean (Name : Iir); + + -- If NAME is a selected name whose prefix is a protected variable, set + -- method_object of CALL. + procedure Name_To_Method_Object (Call : Iir; Name : Iir); + + -- Convert name NAME to an expression (ie, can create function call). + -- A_TYPE is the expected type of the expression. + -- FIXME: it is unclear whether the result must be an expression or not + -- (ie, it *must* have a type, but may be a range). + function Name_To_Expression (Name : Iir; A_Type : Iir) return Iir; + + -- Finish analyze of NAME and expect a range (either a type or subtype + -- declaration or a range attribute). Return Error_Mark in case of error. + function Name_To_Range (Name : Iir) return Iir; + + -- Convert name NAME to a type definition. Return an error if NAME does + -- not designate a type (and emit an error message). NAME must be a fully + -- analyzed name (cannot be an Iir_Kind_Attribute_Name). + function Name_To_Type_Definition (Name : Iir) return Iir; + + -- Return true if AN_IIR is an overload list. + function Is_Overload_List (An_Iir: Iir) return Boolean; + pragma Inline (Is_Overload_List); + + -- Create an overload list, that must be destroyed by Destroy_Overload_List. + function Get_Overload_List return Iir_Overload_List; + pragma Inline (Get_Overload_List); + + function Create_Overload_List (List : Iir_List) return Iir_Overload_List; + pragma Inline (Create_Overload_List); + + -- Free the list node (and the list itself). + procedure Free_Overload_List (N : in out Iir_Overload_List); + + -- Display an error message if the overload resolution for EXPR find more + -- than one interpretation. + procedure Error_Overload (Expr: Iir); + + -- Disp the overload list LIST. + procedure Disp_Overload_List (List : Iir_List; Loc : Iir); + + -- Convert a list to either Null_Iir, an element or an overload list. + function Simplify_Overload_List (List : Iir_List) return Iir; + + -- Add new interpretation DECL to RES. + -- Create an overload_list if necessary. + -- Before the first call, RES should be set to NULL_IIR. + procedure Add_Result (Res : in out Iir; Decl : Iir); + + -- Return TRUE if ATYPE is defined: not Null_Iir, not an overload list and + -- not a wildcard. + function Is_Defined_Type (Atype : Iir) return Boolean; + + -- Free a Parenthesis_Name. This is a special case as in general the + -- Association_Chain field must be freed too. + procedure Free_Parenthesis_Name (Name : Iir; Res : Iir); + + -- Return TRUE iff TYPE1 and TYPE2 are closely related. + function Are_Types_Closely_Related (Type1, Type2 : Iir) return Boolean; + + -- From the list LIST of function or enumeration literal, extract the + -- list of (return) types. + -- If there is only one type, return it. + -- If there is no types, return NULL. + -- Otherwise, return the list as an overload list. + function Create_List_Of_Types (List : Iir_List) return Iir; + + function Sem_Index_Specification (Name : Iir_Parenthesis_Name; Itype : Iir) + return Iir; + + -- Analyze denoting name NAME. NAME must be either a simple name or an + -- expanded name and so is the result. + function Sem_Denoting_Name (Name: Iir) return Iir; + + -- Like Sem_Denoting_Name but expect a terminal name. + function Sem_Terminal_Name (Name : Iir) return Iir; + + -- Analyze an external name. + procedure Sem_External_Name (Name : Iir); + + -- Emit an error for NAME that doesn't match its class CLASS_NAME. + procedure Error_Class_Match (Name : Iir; Class_Name : String); +end Vhdl.Sem_Names; diff --git a/src/vhdl/vhdl-sem_psl.adb b/src/vhdl/vhdl-sem_psl.adb new file mode 100644 index 000000000..41a2e74d9 --- /dev/null +++ b/src/vhdl/vhdl-sem_psl.adb @@ -0,0 +1,808 @@ +-- Semantic analysis pass for PSL. +-- Copyright (C) 2009 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 Types; use Types; +with PSL.Nodes; use PSL.Nodes; +with PSL.Subsets; +with PSL.Hash; + +with Vhdl.Sem_Expr; +with Vhdl.Sem_Stmts; use Vhdl.Sem_Stmts; +with Vhdl.Sem_Scopes; +with Vhdl.Sem_Names; +with Std_Names; +with Iirs_Utils; use Iirs_Utils; +with Evaluation; use Evaluation; +with Std_Package; +with Ieee.Std_Logic_1164; +with Errorout; use Errorout; +with Xrefs; use Xrefs; + +package body Vhdl.Sem_Psl is + procedure Sem_Psl_Directive_Clock (Stmt : Iir; Prop : in out Node); + + -- Return TRUE iff Atype is a PSL boolean type. + -- See PSL1.1 5.1.2 Boolean expressions + function Is_Psl_Bool_Type (Atype : Iir) return Boolean + is + Btype : Iir; + begin + if Atype = Null_Iir then + return False; + end if; + Btype := Get_Base_Type (Atype); + return Btype = Std_Package.Boolean_Type_Definition + or else Btype = Std_Package.Bit_Type_Definition + or else Btype = Ieee.Std_Logic_1164.Std_Ulogic_Type; + end Is_Psl_Bool_Type; + + -- Return TRUE if EXPR type is a PSL boolean type. + function Is_Psl_Bool_Expr (Expr : Iir) return Boolean is + begin + return Is_Psl_Bool_Type (Get_Type (Expr)); + end Is_Psl_Bool_Expr; + + -- Convert VHDL and/or/not nodes to PSL nodes. + function Convert_Bool (Expr : Iir) return Node + is + use Std_Names; + Impl : Iir; + begin + case Get_Kind (Expr) is + when Iir_Kinds_Dyadic_Operator => + declare + Left : Iir; + Right : Iir; + + function Build_Op (Kind : Nkind) return Node + is + N : Node; + begin + N := Create_Node (Kind); + Set_Location (N, Get_Location (Expr)); + Set_Left (N, Convert_Bool (Left)); + Set_Right (N, Convert_Bool (Right)); + Free_Iir (Expr); + return N; + end Build_Op; + begin + Impl := Get_Implementation (Expr); + Left := Get_Left (Expr); + Right := Get_Right (Expr); + if Impl /= Null_Iir + and then Is_Psl_Bool_Expr (Left) + and then Is_Psl_Bool_Expr (Right) + then + if Get_Identifier (Impl) = Name_And then + return Build_Op (N_And_Bool); + elsif Get_Identifier (Impl) = Name_Or then + return Build_Op (N_Or_Bool); + end if; + end if; + end; + when Iir_Kinds_Monadic_Operator => + declare + Operand : Iir; + + function Build_Op (Kind : Nkind) return Node + is + N : Node; + begin + N := Create_Node (Kind); + Set_Location (N, Get_Location (Expr)); + Set_Boolean (N, Convert_Bool (Operand)); + Free_Iir (Expr); + return N; + end Build_Op; + begin + Impl := Get_Implementation (Expr); + Operand := Get_Operand (Expr); + if Impl /= Null_Iir + and then Is_Psl_Bool_Expr (Operand) + then + if Get_Identifier (Impl) = Name_Not then + return Build_Op (N_Not_Bool); + end if; + end if; + end; + when Iir_Kinds_Name => + -- Get the named entity for names in order to hash it. + declare + Name : Iir; + begin + Name := Get_Named_Entity (Expr); + if Name /= Null_Iir then + return PSL.Hash.Get_PSL_Node (HDL_Node (Name)); + end if; + end; + when others => + null; + end case; + return PSL.Hash.Get_PSL_Node (HDL_Node (Expr)); + end Convert_Bool; + + -- Analyze an HDL expression. This may mostly a wrapper except in the + -- case when the expression is in fact a PSL expression. + function Sem_Hdl_Expr (N : Node) return Node + is + use Sem_Names; + + Expr : Iir; + Name : Iir; + Decl : Node; + Res : Node; + begin + Expr := Get_HDL_Node (N); + if Get_Kind (Expr) in Iir_Kinds_Name then + Sem_Name (Expr); + Expr := Finish_Sem_Name (Expr); + Set_HDL_Node (N, Expr); + + Name := Strip_Denoting_Name (Expr); + + case Get_Kind (Name) is + when Iir_Kind_Error => + return N; + when Iir_Kind_Overload_List => + -- FIXME: todo. + raise Internal_Error; + when Iir_Kind_Psl_Declaration => + Decl := Get_Psl_Declaration (Name); + case Get_Kind (Decl) is + when N_Sequence_Declaration => + Res := Create_Node (N_Sequence_Instance); + when N_Property_Declaration => + Res := Create_Node (N_Property_Instance); + when N_Boolean_Parameter + | N_Sequence_Parameter + | N_Const_Parameter + | N_Property_Parameter => + -- FIXME: create a n_name + Free_Node (N); + Free_Iir (Expr); + return Decl; + when others => + Error_Kind ("sem_hdl_expr(2)", Decl); + end case; + Set_Location (Res, Get_Location (N)); + Set_Declaration (Res, Decl); + if Get_Parameter_List (Decl) /= Null_Node then + Error_Msg_Sem (+Res, "no actual for instantiation"); + end if; + Free_Node (N); + Free_Iir (Expr); + return Res; + when Iir_Kind_Psl_Expression => + -- Remove the two bridge nodes: from PSL to HDL and from + -- HDL to PSL. + Free_Node (N); + Res := Get_Psl_Expression (Name); + Free_Iir (Expr); + if Name /= Expr then + Free_Iir (Name); + end if; + return Res; + when Iir_Kind_Function_Call + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element => + Expr := Name; + when others => + Expr := Name_To_Expression (Expr, Null_Iir); + end case; + else + Expr := Sem_Expr.Sem_Expression (Expr, Null_Iir); + end if; + + if Expr = Null_Iir then + return N; + end if; + Free_Node (N); + if not Is_Psl_Bool_Expr (Expr) then + Error_Msg_Sem (+Expr, "type of expression must be boolean"); + return PSL.Hash.Get_PSL_Node (HDL_Node (Expr)); + else + return Convert_Bool (Expr); + end if; + end Sem_Hdl_Expr; + + -- Sem a boolean node. + function Sem_Boolean (Bool : Node) return Node is + begin + case Get_Kind (Bool) is + when N_HDL_Expr => + return Sem_Hdl_Expr (Bool); + when N_And_Bool + | N_Or_Bool => + Set_Left (Bool, Sem_Boolean (Get_Left (Bool))); + Set_Right (Bool, Sem_Boolean (Get_Right (Bool))); + return Bool; + when others => + Error_Kind ("psl.sem_boolean", Bool); + end case; + end Sem_Boolean; + + procedure Sem_Boolean (N : Node) + is + Bool : Node; + begin + Bool := Get_Boolean (N); + Bool := Sem_Boolean (Bool); + Set_Boolean (N, Bool); + end Sem_Boolean; + + -- Used by Sem_Property to rewrite a property logical operator to a + -- boolean logical operator. + function Reduce_Logic_Node (Prop : Node; Bool_Kind : Nkind) return Node + is + Res : Node; + begin + Res := Create_Node (Bool_Kind); + Set_Location (Res, Get_Location (Prop)); + Set_Left (Res, Get_Left (Prop)); + Set_Right (Res, Get_Right (Prop)); + Free_Node (Prop); + return Res; + end Reduce_Logic_Node; + + function Sem_Sequence (Seq : Node) return Node + is + Res : Node; + L, R : Node; + begin + case Get_Kind (Seq) is + when N_Braced_SERE => + Res := Sem_Sequence (Get_SERE (Seq)); + Set_SERE (Seq, Res); + return Seq; + when N_Clocked_SERE => + Res := Sem_Sequence (Get_SERE (Seq)); + Set_SERE (Seq, Res); + Sem_Boolean (Seq); + return Seq; + when N_Concat_SERE + | N_Fusion_SERE + | N_Within_SERE + | N_Or_Seq + | N_And_Seq + | N_Match_And_Seq => + L := Sem_Sequence (Get_Left (Seq)); + Set_Left (Seq, L); + R := Sem_Sequence (Get_Right (Seq)); + Set_Right (Seq, R); + return Seq; + when N_Star_Repeat_Seq => + Res := Get_Sequence (Seq); + if Res /= Null_Node then + Res := Sem_Sequence (Get_Sequence (Seq)); + Set_Sequence (Seq, Res); + end if; + -- FIXME: range. + return Seq; + when N_Plus_Repeat_Seq => + Res := Get_Sequence (Seq); + if Res /= Null_Node then + Res := Sem_Sequence (Get_Sequence (Seq)); + Set_Sequence (Seq, Res); + end if; + return Seq; + when N_And_Bool + | N_Or_Bool + | N_Not_Bool => + return Sem_Boolean (Seq); + when N_HDL_Expr => + Res := Sem_Hdl_Expr (Seq); + case Get_Kind (Res) is + when N_Sequence_Instance + | N_Endpoint_Instance + | N_Boolean_Parameter + | N_Booleans => + null; + when N_Property_Instance => + Error_Msg_Sem + (+Res, "property instance not allowed in PSL sequence"); + when others => + Error_Kind ("psl.sem_sequence.hdl", Res); + end case; + return Res; + when others => + Error_Kind ("psl.sem_sequence", Seq); + end case; + end Sem_Sequence; + + function Sem_Property (Prop : Node; Top : Boolean := False) return Node; + + procedure Sem_Property (N : Node; Top : Boolean := False) + is + Prop : Node; + begin + Prop := Get_Property (N); + Prop := Sem_Property (Prop, Top); + Set_Property (N, Prop); + end Sem_Property; + + procedure Sem_Number (N : Node) + is + Num : Node; + begin + Num := Get_Number (N); + -- FIXME: todo + null; + Set_Number (N, Num); + end Sem_Number; + + function Sem_Property (Prop : Node; Top : Boolean := False) return Node + is + Res : Node; + L, R : Node; + begin + case Get_Kind (Prop) is + when N_Braced_SERE => + return Sem_Sequence (Prop); + when N_Always + | N_Never => + -- By extension, clock_event is allowed within outermost + -- always/never. + Sem_Property (Prop, Top); + return Prop; + when N_Eventually => + Sem_Property (Prop); + return Prop; + when N_Clock_Event => + Sem_Property (Prop); + Sem_Boolean (Prop); + if not Top then + Error_Msg_Sem (+Prop, "inner clock event not supported"); + end if; + return Prop; + when N_Abort => + Sem_Property (Prop); + Sem_Boolean (Prop); + return Prop; + when N_Until + | N_Before => + Res := Sem_Property (Get_Left (Prop)); + Set_Left (Prop, Res); + Res := Sem_Property (Get_Right (Prop)); + Set_Right (Prop, Res); + return Prop; + when N_Log_Imp_Prop + | N_And_Prop + | N_Or_Prop => + L := Sem_Property (Get_Left (Prop)); + Set_Left (Prop, L); + R := Sem_Property (Get_Right (Prop)); + Set_Right (Prop, R); + if Get_Psl_Type (L) = Type_Boolean + and then Get_Psl_Type (R) = Type_Boolean + then + case Get_Kind (Prop) is + when N_And_Prop => + return Reduce_Logic_Node (Prop, N_And_Bool); + when N_Or_Prop => + return Reduce_Logic_Node (Prop, N_Or_Bool); + when N_Log_Imp_Prop => + return Reduce_Logic_Node (Prop, N_Imp_Bool); + when others => + Error_Kind ("psl.sem_property(log)", Prop); + end case; + end if; + return Prop; + when N_Overlap_Imp_Seq + | N_Imp_Seq => + Res := Sem_Sequence (Get_Sequence (Prop)); + Set_Sequence (Prop, Res); + Sem_Property (Prop); + return Prop; + when N_Next => + Sem_Number (Prop); + Sem_Property (Prop); + return Prop; + when N_Next_A => + -- FIXME: range. + Sem_Property (Prop); + return Prop; + when N_Next_Event => + Sem_Number (Prop); + Sem_Boolean (Prop); + Sem_Property (Prop); + return Prop; + when N_HDL_Expr => + Res := Sem_Hdl_Expr (Prop); + if not Top and then Get_Kind (Res) = N_Property_Instance then + declare + Decl : constant Node := Get_Declaration (Res); + begin + if Decl /= Null_Node + and then Get_Global_Clock (Decl) /= Null_Node + then + Error_Msg_Sem + (+Prop, "property instance already has a clock"); + end if; + end; + end if; + return Res; + when others => + Error_Kind ("psl.sem_property", Prop); + end case; + end Sem_Property; + + -- Extract the clock from PROP. + procedure Extract_Clock (Prop : in out Node; Clk : out Node) + is + Child : Node; + begin + Clk := Null_Node; + case Get_Kind (Prop) is + when N_Clock_Event => + Clk := Get_Boolean (Prop); + Prop := Get_Property (Prop); + when N_Clocked_SERE => + Clk := Get_Boolean (Prop); + Prop := Get_SERE (Prop); + when N_Always + | N_Never => + Child := Get_Property (Prop); + if Get_Kind (Child) = N_Clock_Event then + Set_Property (Prop, Get_Property (Child)); + Clk := Get_Boolean (Child); + end if; + when N_Property_Instance => + Child := Get_Declaration (Prop); + Clk := Get_Global_Clock (Child); + when others => + null; + end case; + end Extract_Clock; + + -- Sem a property/sequence/endpoint declaration. + procedure Sem_Psl_Declaration (Stmt : Iir) + is + use Sem_Scopes; + Decl : constant Node := Get_Psl_Declaration (Stmt); + Prop : Node; + Clk : Node; + Formal : Node; + El : Iir; + begin + Sem_Scopes.Add_Name (Stmt); + Xref_Decl (Stmt); + + Open_Declarative_Region; + + -- Make formal parameters visible. + Formal := Get_Parameter_List (Decl); + while Formal /= Null_Node loop + El := Create_Iir (Iir_Kind_Psl_Declaration); + Set_Location (El, Get_Location (Formal)); + Set_Identifier (El, Get_Identifier (Formal)); + Set_Psl_Declaration (El, Formal); + + Sem_Scopes.Add_Name (El); + Xref_Decl (El); + Set_Visible_Flag (El, True); + + Formal := Get_Chain (Formal); + end loop; + + case Get_Kind (Decl) is + when N_Property_Declaration => + -- FIXME: sem formal list + Prop := Get_Property (Decl); + Prop := Sem_Property (Prop, True); + Extract_Clock (Prop, Clk); + Set_Property (Decl, Prop); + Set_Global_Clock (Decl, Clk); + -- Check simple subset restrictions. + PSL.Subsets.Check_Simple (Prop); + when N_Sequence_Declaration + | N_Endpoint_Declaration => + -- FIXME: sem formal list, do not allow property parameter. + Prop := Get_Sequence (Decl); + Prop := Sem_Sequence (Prop); + Set_Sequence (Decl, Prop); + PSL.Subsets.Check_Simple (Prop); + when others => + Error_Kind ("sem_psl_declaration", Decl); + end case; + Set_Visible_Flag (Stmt, True); + + Close_Declarative_Region; + end Sem_Psl_Declaration; + + procedure Sem_Psl_Endpoint_Declaration (Stmt : Iir) + is + Decl : constant Node := Get_Psl_Declaration (Stmt); + Prop : Node; + begin + Sem_Scopes.Add_Name (Stmt); + Xref_Decl (Stmt); + + pragma Assert (Get_Parameter_List (Decl) = Null_Node); + pragma Assert (Get_Kind (Decl) = N_Endpoint_Declaration); + + Prop := Get_Sequence (Decl); + Prop := Sem_Sequence (Prop); + Sem_Psl_Directive_Clock (Stmt, Prop); + Set_Sequence (Decl, Prop); + + PSL.Subsets.Check_Simple (Prop); + + -- Endpoints are considered as an HDL declaration and must have a + -- type. + Set_Type (Stmt, Std_Package.Boolean_Type_Definition); + Set_Expr_Staticness (Stmt, None); + + Set_Visible_Flag (Stmt, True); + end Sem_Psl_Endpoint_Declaration; + + function Rewrite_As_Boolean_Expression (Prop : Node) return Iir + is + function Rewrite_Dyadic_Operator + (Expr : Node; Kind : Iir_Kind) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Kind); + Set_Location (Res, Get_Location (Expr)); + Set_Left (Res, Rewrite_As_Boolean_Expression (Get_Left (Expr))); + Set_Right (Res, Rewrite_As_Boolean_Expression (Get_Right (Expr))); + return Res; + end Rewrite_Dyadic_Operator; + + function Rewrite_Monadic_Operator + (Expr : Node; Kind : Iir_Kind) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Kind); + Set_Location (Res, Get_Location (Expr)); + Set_Operand (Res, Rewrite_As_Boolean_Expression (Get_Boolean (Expr))); + return Res; + end Rewrite_Monadic_Operator; + begin + case Get_Kind (Prop) is + when N_HDL_Expr => + return Get_HDL_Node (Prop); + when N_And_Bool => + return Rewrite_Dyadic_Operator (Prop, Iir_Kind_And_Operator); + when N_Or_Bool => + return Rewrite_Dyadic_Operator (Prop, Iir_Kind_Or_Operator); + when N_Not_Bool => + return Rewrite_Monadic_Operator (Prop, Iir_Kind_Not_Operator); + when others => + Error_Kind ("rewrite_as_boolean_expression", Prop); + end case; + end Rewrite_As_Boolean_Expression; + + function Rewrite_As_Concurrent_Assertion (Stmt : Iir) return Iir + is + Res : Iir; + Cond : Iir; + begin + Res := Create_Iir (Iir_Kind_Concurrent_Assertion_Statement); + Set_Location (Res, Get_Location (Stmt)); + Cond := Rewrite_As_Boolean_Expression (Get_Psl_Property (Stmt)); + if Get_Type (Cond) = Null_Iir then + Cond := Sem_Expr.Sem_Condition (Cond); + elsif Get_Base_Type (Get_Type (Cond)) + /= Std_Package.Boolean_Type_Definition + then + Cond := Sem_Expr.Insert_Condition_Operator (Cond); + end if; + Cond := Eval_Expr_If_Static (Cond); + Set_Assertion_Condition (Res, Cond); + Set_Label (Res, Get_Label (Stmt)); + Set_Severity_Expression (Res, Get_Severity_Expression (Stmt)); + Set_Report_Expression (Res, Get_Report_Expression (Stmt)); + Set_Postponed_Flag (Res, Get_Postponed_Flag (Stmt)); + return Res; + end Rewrite_As_Concurrent_Assertion; + + -- Return True iff EXPR is a boolean expression. + function Is_Boolean_Assertion (Expr : Node) return Boolean is + begin + case Get_Kind (Expr) is + when N_HDL_Expr => + return True; + when N_And_Bool | N_Or_Bool | N_Not_Bool => + return True; + when others => + return False; + end case; + end Is_Boolean_Assertion; + + procedure Sem_Psl_Directive_Clock (Stmt : Iir; Prop : in out Node) + is + Clk : Node; + begin + Extract_Clock (Prop, Clk); + if Clk = Null_Node then + if Current_Psl_Default_Clock = Null_Iir then + Error_Msg_Sem (+Stmt, "no clock for PSL directive"); + Clk := Null_Node; + else + Clk := Get_Psl_Boolean (Current_Psl_Default_Clock); + end if; + end if; + Set_PSL_Clock (Stmt, Clk); + end Sem_Psl_Directive_Clock; + + function Sem_Psl_Assert_Statement (Stmt : Iir) return Iir + is + Prop : Node; + Res : Iir; + begin + pragma Assert (Get_Kind (Stmt) = Iir_Kind_Psl_Assert_Statement); + + -- Sem report and severity expressions. + Sem_Report_Statement (Stmt); + + Prop := Get_Psl_Property (Stmt); + Prop := Sem_Property (Prop, True); + Set_Psl_Property (Stmt, Prop); + + if Is_Boolean_Assertion (Prop) then + -- This is a simple assertion. Convert to a non-PSL statement, as + -- the handling is simpler (and the assertion doesn't need a clock). + Res := Rewrite_As_Concurrent_Assertion (Stmt); + Free_Iir (Stmt); + return Res; + end if; + + if Get_Postponed_Flag (Stmt) then + Error_Msg_Sem (+Stmt, "PSL assertions cannot be postponed"); + Set_Postponed_Flag (Stmt, False); + end if; + + -- Properties must be clocked. + Sem_Psl_Directive_Clock (Stmt, Prop); + Set_Psl_Property (Stmt, Prop); + + -- Check simple subset restrictions. + PSL.Subsets.Check_Simple (Prop); + + return Stmt; + end Sem_Psl_Assert_Statement; + + procedure Sem_Psl_Cover_Statement (Stmt : Iir) + is + Seq : Node; + begin + -- Sem report and severity expressions. + Sem_Report_Statement (Stmt); + + Seq := Get_Psl_Sequence (Stmt); + Seq := Sem_Sequence (Seq); + + -- Properties must be clocked. + Sem_Psl_Directive_Clock (Stmt, Seq); + Set_Psl_Sequence (Stmt, Seq); + + -- Check simple subset restrictions. + PSL.Subsets.Check_Simple (Seq); + end Sem_Psl_Cover_Statement; + + procedure Sem_Psl_Default_Clock (Stmt : Iir) + is + Expr : Node; + begin + if Current_Psl_Default_Clock /= Null_Iir + and then Get_Parent (Current_Psl_Default_Clock) = Get_Parent (Stmt) + then + Error_Msg_Sem + (+Stmt, "redeclaration of PSL default clock in the same region", + Cont => True); + Error_Msg_Sem + (+Current_Psl_Default_Clock, + " (previous default clock declaration)"); + end if; + Expr := Sem_Boolean (Get_Psl_Boolean (Stmt)); + Set_Psl_Boolean (Stmt, Expr); + Current_Psl_Default_Clock := Stmt; + end Sem_Psl_Default_Clock; + + function Sem_Psl_Instance_Name (Name : Iir) return Iir + is + Prefix : constant Iir := Get_Prefix (Name); + Ent : constant Iir := Get_Named_Entity (Prefix); + Decl : constant Node := Get_Psl_Declaration (Ent); + Formal : Node; + Assoc : Iir; + Res : Node; + Last_Assoc : Node; + Assoc2 : Node; + Actual : Iir; + Psl_Actual : Node; + Res2 : Iir; + begin + pragma Assert (Get_Kind (Ent) = Iir_Kind_Psl_Declaration + or Get_Kind (Ent) = Iir_Kind_Psl_Endpoint_Declaration); + case Get_Kind (Decl) is + when N_Property_Declaration => + Res := Create_Node (N_Property_Instance); + when N_Sequence_Declaration => + Res := Create_Node (N_Sequence_Instance); + when N_Endpoint_Declaration => + Res := Create_Node (N_Endpoint_Instance); + when others => + Error_Msg_Sem (+Name, "can only instantiate a psl declaration"); + return Null_Iir; + end case; + Set_Declaration (Res, Decl); + Set_Location (Res, Get_Location (Name)); + Formal := Get_Parameter_List (Decl); + Assoc := Get_Association_Chain (Name); + Last_Assoc := Null_Node; + + while Formal /= Null_Node loop + if Assoc = Null_Iir then + Error_Msg_Sem (+Name, "not enough association"); + exit; + end if; + if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Expression then + Error_Msg_Sem + (+Assoc, "open or individual association not allowed"); + elsif Get_Formal (Assoc) /= Null_Iir then + Error_Msg_Sem (+Assoc, "named association not allowed in psl"); + else + Actual := Get_Actual (Assoc); + -- FIXME: currently only boolean are parsed. + Actual := Sem_Expr.Sem_Expression (Actual, Null_Iir); + if Get_Kind (Actual) in Iir_Kinds_Name then + Actual := Get_Named_Entity (Actual); + end if; + Psl_Actual := PSL.Hash.Get_PSL_Node (HDL_Node (Actual)); + end if; + + Assoc2 := Create_Node (N_Actual); + Set_Location (Assoc2, Get_Location (Assoc)); + Set_Formal (Assoc2, Formal); + Set_Actual (Assoc2, Psl_Actual); + if Last_Assoc = Null_Node then + Set_Association_Chain (Res, Assoc2); + else + Set_Chain (Last_Assoc, Assoc2); + end if; + Last_Assoc := Assoc2; + + Formal := Get_Chain (Formal); + Assoc := Get_Chain (Assoc); + end loop; + if Assoc /= Null_Iir then + Error_Msg_Sem (+Name, "too many association"); + end if; + + Res2 := Create_Iir (Iir_Kind_Psl_Expression); + Set_Psl_Expression (Res2, Res); + Location_Copy (Res2, Name); + return Res2; + end Sem_Psl_Instance_Name; + + -- Called by sem_names to analyze a psl name. + function Sem_Psl_Name (Name : Iir) return Iir is + begin + case Get_Kind (Name) is + when Iir_Kind_Parenthesis_Name => + return Sem_Psl_Instance_Name (Name); + when others => + Error_Kind ("sem_psl_name", Name); + end case; + return Null_Iir; + end Sem_Psl_Name; + +end Vhdl.Sem_Psl; diff --git a/src/vhdl/vhdl-sem_psl.ads b/src/vhdl/vhdl-sem_psl.ads new file mode 100644 index 000000000..396927f4d --- /dev/null +++ b/src/vhdl/vhdl-sem_psl.ads @@ -0,0 +1,31 @@ +-- Semantic analysis pass for PSL. +-- Copyright (C) 2009 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 Iirs; use Iirs; + +package Vhdl.Sem_Psl is + procedure Sem_Psl_Declaration (Stmt : Iir); + procedure Sem_Psl_Endpoint_Declaration (Stmt : Iir); + + -- May return a non-psl concurrent assertion statement. + function Sem_Psl_Assert_Statement (Stmt : Iir) return Iir; + + procedure Sem_Psl_Cover_Statement (Stmt : Iir); + procedure Sem_Psl_Default_Clock (Stmt : Iir); + function Sem_Psl_Name (Name : Iir) return Iir; +end Vhdl.Sem_Psl; diff --git a/src/vhdl/vhdl-sem_scopes.adb b/src/vhdl/vhdl-sem_scopes.adb new file mode 100644 index 000000000..8e616bd4b --- /dev/null +++ b/src/vhdl/vhdl-sem_scopes.adb @@ -0,0 +1,1672 @@ +-- Semantic analysis. +-- 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 Logging; use Logging; +with Tables; +with Flags; use Flags; +with Name_Table; -- use Name_Table; +with Files_Map; use Files_Map; +with Errorout; use Errorout; +with Iirs_Utils; use Iirs_Utils; + +package body Vhdl.Sem_Scopes is + -- An interpretation cell is the element of the simply linked list + -- of interpretation for an identifier. + -- Interpretation cells are stored in table Interpretations. + type Interpretation_Cell is record + -- The declaration for this interpretation. + Decl: Iir; + + -- If True, the declaration is potentially visible (ie visible via a + -- use clause). + Is_Potential : Boolean; + + -- If True, previous declarations in PREV chain are hidden and shouldn't + -- be considered. + Prev_Hidden : Boolean; + + -- Previous interpretation for this identifier. + -- If No_Name_Interpretation, this (not PREV) interpretation is the last + -- one. If Prev_Hidden is True, PREV must be ignored. If Prev_Hidden is + -- false, the identifier is overloaded. + Prev: Name_Interpretation_Type; + + -- Previous added identifier in the declarative region. This forms a + -- linked list used to remove interpretations when a declarative + -- region is closed. + Prev_In_Region : Name_Id; + end record; + pragma Pack (Interpretation_Cell); + + package Interpretations is new Tables + (Table_Component_Type => Interpretation_Cell, + Table_Index_Type => Name_Interpretation_Type, + Table_Low_Bound => First_Valid_Interpretation, + Table_Initial => 1024); + + -- Cached value of Prev_In_Region of current region. + Last_In_Region : Name_Id := Null_Identifier; + + -- First interpretation in the current declarative region. + Current_Region_Start : Name_Interpretation_Type := + First_Valid_Interpretation; + + -- First valid interpretation. All interpretations smaller than this + -- value are part of a previous (and nested) analysis and must not be + -- considered. + First_Interpretation : Name_Interpretation_Type := + First_Valid_Interpretation; + + -- List of non-local hidden declarations. + type Hide_Index is new Nat32; + No_Hide_Index : constant Hide_Index := 0; + + package Hidden_Decls is new Tables + (Table_Component_Type => Name_Interpretation_Type, + Table_Index_Type => Hide_Index, + Table_Low_Bound => No_Hide_Index + 1, + Table_Initial => 32); + + -- First non-local hidden declarations. In VHDL, it is possible to hide + -- an overloaded declaration (by declaring a subprogram with the same + -- profile). If the overloaded declaration is local, the interpretation + -- can simply be modified. But if it is not local, the interpretation is + -- removed from the chain and saved in the Hidden_Decls table. + First_Hide_Index : Hide_Index := No_Hide_Index; + + -- To manage the list of interpretation and to add informations to this + -- list, a stack is used. + -- Elements of stack can be of kind: + -- Save_Cell: + -- the element contains the interpretation INTER for the indentifier ID + -- for the outer declarative region. + -- A save cell is always created each time a declaration is added to save + -- the previous interpretation. + -- Region_Start: + -- A new declarative region start at interpretation INTER. Here, INTER + -- is used as an index in the interpretations stack (table). + -- ID is used as an index into the unidim_array stack. + -- Barrier_start, Barrier_end: + -- All currents interpretations are saved between both INTER, and + -- are cleared. This is used to call semantic during another semantic. + + type Scope_Cell_Kind_Type is (Scope_Start, Scope_Region); + + type Scope_Cell is record + Kind: Scope_Cell_Kind_Type; + + -- Values for the previous scope. + Saved_Last_In_Region : Name_Id; + Saved_Region_Start : Name_Interpretation_Type; + Saved_First_Hide_Index : Hide_Index; + Saved_First_Interpretation : Name_Interpretation_Type; + end record; + + package Scopes is new Tables + (Table_Component_Type => Scope_Cell, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 64); + + function Valid_Interpretation (Inter : Name_Interpretation_Type) + return Boolean is + begin + return Inter >= First_Interpretation; + end Valid_Interpretation; + + -- Return True iff NI means there is a conflict for the identifier: no + -- valid interpretation due to potentially visible homoraph. + function Is_Conflict_Declaration (Ni : Name_Interpretation_Type) + return Boolean is + begin + pragma Assert (Valid_Interpretation (Ni)); + return Interpretations.Table (Ni).Decl = Null_Iir; + end Is_Conflict_Declaration; + + -- Get the current interpretation for ID. The result is raw: it may not + -- be valid. + function Get_Interpretation_Raw (Id : Name_Id) + return Name_Interpretation_Type is + begin + return Name_Interpretation_Type (Name_Table.Get_Name_Info (Id)); + end Get_Interpretation_Raw; + + procedure Set_Interpretation + (Id : Name_Id; Inter : Name_Interpretation_Type) is + begin + Name_Table.Set_Name_Info (Id, Int32 (Inter)); + end Set_Interpretation; + + function Get_Interpretation_From_Raw (Inter : Name_Interpretation_Type) + return Name_Interpretation_Type is + begin + if Valid_Interpretation (Inter) + and then not Is_Conflict_Declaration (Inter) + then + -- In the current scopes set and not a conflict. + return Inter; + else + return No_Name_Interpretation; + end if; + end Get_Interpretation_From_Raw; + + function Get_Interpretation (Id : Name_Id) + return Name_Interpretation_Type is + begin + return Get_Interpretation_From_Raw (Get_Interpretation_Raw (Id)); + end Get_Interpretation; + + procedure Check_Interpretations; + pragma Unreferenced (Check_Interpretations); + + procedure Check_Interpretations + is + Inter: Name_Interpretation_Type; + Last : constant Name_Interpretation_Type := Interpretations.Last; + Err : Boolean; + begin + Err := False; + for I in 0 .. Name_Table.Last_Name_Id loop + Inter := Get_Interpretation (I); + if Inter > Last then + Log_Line ("bad interpretation for " & Name_Table.Image (I)); + Err := True; + end if; + end loop; + if Err then + raise Internal_Error; + end if; + end Check_Interpretations; + + procedure Push_Interpretations is + begin + Scopes.Append ((Kind => Scope_Start, + Saved_Last_In_Region => Last_In_Region, + Saved_Region_Start => Current_Region_Start, + Saved_First_Hide_Index => First_Hide_Index, + Saved_First_Interpretation => First_Interpretation)); + Last_In_Region := Null_Identifier; + Current_Region_Start := Interpretations.Last + 1; + First_Hide_Index := Hidden_Decls.Last + 1; + First_Interpretation := Interpretations.Last + 1; + end Push_Interpretations; + + procedure Pop_Interpretations + is + Cell : Scope_Cell renames Scopes.Table (Scopes.Last); + begin + pragma Assert (Scopes.Table (Scopes.Last).Kind = Scope_Start); + + -- All the declarative regions must have been removed. + pragma Assert (Last_In_Region = Null_Identifier); + pragma Assert (Current_Region_Start = Interpretations.Last + 1); + pragma Assert (First_Hide_Index = Hidden_Decls.Last + 1); + pragma Assert (First_Interpretation = Interpretations.Last + 1); + + Last_In_Region := Cell.Saved_Last_In_Region; + Current_Region_Start := Cell.Saved_Region_Start; + First_Hide_Index := Cell.Saved_First_Hide_Index; + First_Interpretation := Cell.Saved_First_Interpretation; + + Scopes.Decrement_Last; + end Pop_Interpretations; + + -- Create a new declarative region. + -- Simply push a region_start cell and update current_scope_start. + procedure Open_Declarative_Region is + begin + Scopes.Append ((Kind => Scope_Region, + Saved_Last_In_Region => Last_In_Region, + Saved_Region_Start => Current_Region_Start, + Saved_First_Hide_Index => First_Hide_Index, + Saved_First_Interpretation => No_Name_Interpretation)); + Last_In_Region := Null_Identifier; + Current_Region_Start := Interpretations.Last + 1; + First_Hide_Index := Hidden_Decls.Last + 1; + end Open_Declarative_Region; + + -- Close a declarative region. + -- Update interpretation of identifiers. + procedure Close_Declarative_Region + is + Cell : Scope_Cell renames Scopes.Table (Scopes.Last); + Id : Name_Id; + begin + pragma Assert (Cell.Kind = Scope_Region); + + -- Restore hidden declarations. + for I in reverse First_Hide_Index .. Hidden_Decls.Last loop + declare + Inter : constant Name_Interpretation_Type := + Hidden_Decls.Table (I); + Prev_Inter, Next_Inter : Name_Interpretation_Type; + begin + Prev_Inter := Interpretations.Table (Inter).Prev; + Next_Inter := Interpretations.Table (Prev_Inter).Prev; + Interpretations.Table (Inter).Prev := Next_Inter; + Interpretations.Table (Prev_Inter).Prev := Inter; + end; + end loop; + Hidden_Decls.Set_Last (First_Hide_Index - 1); + + -- Remove interpretations of that region. + Id := Last_In_Region; + if Id /= Null_Identifier then + declare + Inter : Name_Interpretation_Type; + begin + loop + Inter := Get_Interpretation_Raw (Id); + pragma Assert (Inter >= Current_Region_Start); + Set_Interpretation (Id, Interpretations.Table (Inter).Prev); + Id := Interpretations.Table (Inter).Prev_In_Region; + exit when Id = Null_Identifier; + end loop; + pragma Assert (Inter = Current_Region_Start); + end; + Interpretations.Set_Last (Current_Region_Start - 1); + end if; + + Last_In_Region := Cell.Saved_Last_In_Region; + Current_Region_Start := Cell.Saved_Region_Start; + First_Hide_Index := Cell.Saved_First_Hide_Index; + + Scopes.Decrement_Last; + end Close_Declarative_Region; + + procedure Open_Scope_Extension renames Open_Declarative_Region; + procedure Close_Scope_Extension renames Close_Declarative_Region; + + function Get_Next_Interpretation (Ni : Name_Interpretation_Type) + return Name_Interpretation_Type + is + pragma Assert (Valid_Interpretation (Ni)); + Cell : Interpretation_Cell renames Interpretations.Table (Ni); + begin + if Cell.Prev_Hidden + or else not Valid_Interpretation (Cell.Prev) + then + return No_Name_Interpretation; + else + return Cell.Prev; + end if; + end Get_Next_Interpretation; + + function Get_Declaration (Ni : Name_Interpretation_Type) return Iir is + begin + pragma Assert (Valid_Interpretation (Ni)); + return Interpretations.Table (Ni).Decl; + end Get_Declaration; + + function Get_Under_Interpretation (Id : Name_Id) + return Name_Interpretation_Type + is + Inter : constant Name_Interpretation_Type := Get_Interpretation (Id); + begin + -- ID has no interpretation. + -- So, there is no 'under' interpretation (FIXME: prove it). + pragma Assert (Valid_Interpretation (Inter)); + + declare + Cell : Interpretation_Cell renames Interpretations.Table (Inter); + Prev : constant Name_Interpretation_Type := Cell.Prev; + begin + -- Get_Under_Interpretation can be used only to get a hidden + -- interpretation. + pragma Assert (Cell.Prev_Hidden); + + if Valid_Interpretation (Prev) + -- Not a conflict one (use clauses). + and then Get_Declaration (Prev) /= Null_Iir + then + return Prev; + else + return No_Name_Interpretation; + end if; + end; + end Get_Under_Interpretation; + + function Strip_Non_Object_Alias (Decl : Iir) return Iir + is + Res : Iir; + begin + Res := Decl; + if Get_Kind (Res) = Iir_Kind_Non_Object_Alias_Declaration then + Res := Get_Named_Entity (Get_Name (Res)); + end if; + return Res; + end Strip_Non_Object_Alias; + + function Get_Non_Alias_Declaration (Ni : Name_Interpretation_Type) + return Iir is + begin + return Strip_Non_Object_Alias (Get_Declaration (Ni)); + end Get_Non_Alias_Declaration; + + -- Return TRUE if INTER was made directly visible via a use clause. + function Is_Potentially_Visible (Inter : Name_Interpretation_Type) + return Boolean is + begin + return Interpretations.Table (Inter).Is_Potential; + end Is_Potentially_Visible; + + -- Return TRUE iif DECL can be overloaded. + function Is_Overloadable (Decl : Iir) return Boolean is + begin + -- LRM93 10.3: + -- The overloaded declarations considered in this chapter are those for + -- subprograms and enumeration literals. + case Get_Kind (Decl) is + when Iir_Kind_Enumeration_Literal + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Interface_Function_Declaration + | Iir_Kind_Interface_Procedure_Declaration => + return True; + when Iir_Kind_Non_Object_Alias_Declaration => + case Get_Kind (Get_Named_Entity (Get_Name (Decl))) is + when Iir_Kind_Enumeration_Literal + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Interface_Function_Declaration + | Iir_Kind_Interface_Procedure_Declaration => + return True; + when Iir_Kind_Non_Object_Alias_Declaration => + raise Internal_Error; + when others => + return False; + end case; + when others => + return False; + end case; + end Is_Overloadable; + + -- Return TRUE if INTER was made direclty visible in the current + -- declarative region. + function Is_In_Current_Declarative_Region (Inter : Name_Interpretation_Type) + return Boolean is + begin + return Inter >= Current_Region_Start; + end Is_In_Current_Declarative_Region; + + -- Emit a warning when DECL hides PREV_DECL. + procedure Warning_Hide (Decl : Iir; Prev_Decl : Iir) + is + begin + if Get_Kind (Decl) in Iir_Kinds_Interface_Declaration + and then Get_Kind (Get_Parent (Decl)) = Iir_Kind_Component_Declaration + then + -- Do not warn when an interface in a component hides a declaration. + -- This is a common case (eg: in testbenches), and there is no real + -- hiding. + return; + end if; + + if Get_Kind (Decl) = Iir_Kind_Element_Declaration then + -- Do not warn for record elements. They are used by selection. + return; + end if; + + if Decl = Prev_Decl then + -- Can happen in configuration. No real hidding. + return; + end if; + + Warning_Msg_Sem (Warnid_Hide, +Decl, + "declaration of %i hides %n", (+Decl, +Prev_Decl)); + end Warning_Hide; + + -- Add interpretation DECL to the identifier of DECL. + -- POTENTIALLY is true if the identifier comes from a use clause. + procedure Add_Name (Decl : Iir; Ident : Name_Id; Potentially : Boolean) + is + -- Current interpretation of ID. This is the one before DECL is + -- added (if so). + Raw_Inter : constant Name_Interpretation_Type := + Get_Interpretation_Raw (Ident); + Current_Inter : constant Name_Interpretation_Type := + Get_Interpretation_From_Raw (Raw_Inter); + Current_Decl : Iir; + + -- Add DECL in the chain of interpretation for the identifier. + procedure Add_New_Interpretation (Hid_Prev : Boolean; D : Iir := Decl) is + begin + Interpretations.Append ((Decl => D, + Prev => Raw_Inter, + Is_Potential => Potentially, + Prev_Hidden => Hid_Prev, + Prev_In_Region => Last_In_Region)); + Set_Interpretation (Ident, Interpretations.Last); + Last_In_Region := Ident; + end Add_New_Interpretation; + begin + if Ident = Null_Identifier then + -- Missing identifier can happen only in case of parse error. + pragma Assert (Flags.Flag_Force_Analysis); + return; + end if; + + if not Valid_Interpretation (Raw_Inter) then + -- Very simple: no hidding, no overloading. + Add_New_Interpretation (True); + return; + end if; + + if Is_Conflict_Declaration (Raw_Inter) then + if Potentially then + -- Yet another conflicting interpretation. + return; + else + -- Very simple: no hidding, no overloading. + -- (current interpretation is Conflict_Interpretation if there is + -- only potentially visible declarations that are not made + -- directly visible). + -- Note: in case of conflict interpretation, it may be unnecessary + -- to keep the current interpretation (but it is simpler as is). + Add_New_Interpretation (True); + return; + end if; + end if; + + if Potentially then + -- Do not re-add a potential decl. This handles cases like: + -- 'use p.all; use p.all;'. + -- FIXME: add a flag (or reuse Visible_Flag) to avoid walking all + -- the interpretations. + declare + Inter : Name_Interpretation_Type := Current_Inter; + begin + while Valid_Interpretation (Inter) loop + if Get_Declaration (Inter) = Decl then + return; + end if; + Inter := Get_Next_Interpretation (Inter); + end loop; + end; + end if; + + -- LRM 10.3 Visibility + -- Each of two declarations is said to be a homograph of the other if + -- both declarations have the same identifier, operator symbol, or + -- character literal, and overloading is allowed for at most one + -- of the two. + -- + -- GHDL: the condition 'overloading is allowed for at most one of the + -- two' is false iff overloading is allowed for both; this is a nand. + + -- Note: at this stage, current_inter is valid. + Current_Decl := Get_Declaration (Current_Inter); + + if Is_Overloadable (Current_Decl) and then Is_Overloadable (Decl) then + -- Current_Inter and Decl overloads (well, they have the same + -- designator). + + -- LRM 10.3 Visibility + -- If overloading is allowed for both declarations, then each of the + -- two is a homograph of the other if they have the same identifier, + -- operator symbol or character literal, as well as the same + -- parameter and result profile. + + declare + Homograph : Name_Interpretation_Type; + Prev_Homograph : Name_Interpretation_Type; + + -- Hide HOMOGRAPH (ie unlink it from the chain of interpretation). + procedure Hide_Homograph + is + S : Name_Interpretation_Type; + begin + if Prev_Homograph = No_Name_Interpretation then + Prev_Homograph := Interpretations.Last; + end if; + + -- PREV_HOMOGRAPH must be the interpretation just before + -- HOMOGRAPH. + pragma Assert + (Interpretations.Table (Prev_Homograph).Prev = Homograph); + + -- Hide previous interpretation. + Hidden_Decls.Append (Homograph); + + S := Interpretations.Table (Homograph).Prev; + Interpretations.Table (Homograph).Prev := Prev_Homograph; + Interpretations.Table (Prev_Homograph).Prev := S; + end Hide_Homograph; + + function Get_Hash_Non_Alias (D : Iir) return Iir_Int32 is + begin + return Get_Subprogram_Hash (Strip_Non_Object_Alias (D)); + end Get_Hash_Non_Alias; + + -- Return True iff D is an implicit declaration (either a + -- subprogram or an implicit alias). + function Is_Implicit_Declaration (D : Iir) return Boolean is + begin + case Get_Kind (D) is + when Iir_Kind_Non_Object_Alias_Declaration => + return Get_Implicit_Alias_Flag (D); + when Iir_Kind_Enumeration_Literal => + return False; + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + return Is_Implicit_Subprogram (D); + when others => + Error_Kind ("is_implicit_declaration", D); + end case; + end Is_Implicit_Declaration; + + -- Return TRUE iff D is an implicit alias of an implicit + -- subprogram. + function Is_Implicit_Alias (D : Iir) return Boolean is + begin + -- FIXME: Is it possible to have an implicit alias of an + -- explicit subprogram ? Yes for enumeration literal and + -- physical units. + return Get_Kind (D) = Iir_Kind_Non_Object_Alias_Declaration + and then Get_Implicit_Alias_Flag (D) + and then Is_Implicit_Subprogram (Get_Named_Entity + (Get_Name (D))); + end Is_Implicit_Alias; + + -- Replace the homograph of DECL by DECL. + procedure Replace_Homograph is + begin + Interpretations.Table (Homograph).Decl := Decl; + end Replace_Homograph; + + Decl_Hash : Iir_Int32; + Hash : Iir_Int32; + begin + Decl_Hash := Get_Hash_Non_Alias (Decl); + -- The hash must have been computed. + pragma Assert (Decl_Hash /= 0); + + -- LRM02 10.3 Visibility + -- Each of two declarations is said to be a /homograph/ of the + -- other if both declarations have the same identifier, operator + -- symbol, or character literal, and if overloading is allowed for + -- at most one of the two. + -- + -- LRM08 12.3 Visibility + -- Each of two declarations is said to be a /homograph/ of the + -- other if and only if both declarations have the same + -- designator, and they denote different named entities, and + -- either overloading is allows for at most one of the two, or + -- overloading is allowed for both declarations and they have the + -- same parameter and result type profile. + + -- GHDL: here we are in the case when both declarations are + -- overloadable. Also, always follow the LRM08 rules as they fix + -- issues. + -- GHDL: Special case for a second declaration with the same + -- designator and that denotes the same named entity than a + -- previous one (that would be an alias): according to the LRM, + -- they are both visible and there are no ambiguity as they + -- denotes the same named entity. In GHDL, the new one hides the + -- previous one. The behaviour should be the same. + + -- Find an homograph of this declaration (and also keep the + -- interpretation just before it in the chain). + Homograph := Current_Inter; + Prev_Homograph := No_Name_Interpretation; + while Homograph /= No_Name_Interpretation loop + Current_Decl := Get_Declaration (Homograph); + Hash := Get_Hash_Non_Alias (Current_Decl); + exit when Decl_Hash = Hash + and then Is_Same_Profile (Decl, Current_Decl); + Prev_Homograph := Homograph; + Homograph := Get_Next_Interpretation (Homograph); + end loop; + + if Homograph = No_Name_Interpretation then + -- Simple case: no homograph. + Add_New_Interpretation (False); + return; + end if; + + -- There is an homograph (or the named entity is the same). + if Potentially then + -- Added DECL would be made potentially visible. + + -- LRM93 10.4 1) / LRM08 12.4 a) Use Clauses + -- 1. A potentially visible declaration is not made + -- directly visible if the place considered is within the + -- immediate scope of a homograph of the declaration. + if not Is_Potentially_Visible (Homograph) then + return; + end if; + + -- LRM08 12.4 Use Clauses + -- b) If two potentially visible declarations are homograph + -- and one is explicitly declared and the other is + -- implicitly declared, then the implicit declaration is + -- not made directly visible. + if (Flags.Flag_Explicit or else Flags.Vhdl_Std >= Vhdl_08) + and then Is_Potentially_Visible (Homograph) + then + declare + Implicit_Current_Decl : constant Boolean := + Is_Implicit_Declaration (Current_Decl); + Implicit_Decl : constant Boolean := + Is_Implicit_Declaration (Decl); + begin + if Implicit_Current_Decl and then not Implicit_Decl then + if Is_In_Current_Declarative_Region (Homograph) then + Replace_Homograph; + else + -- Insert DECL and hide homograph. + Add_New_Interpretation (False); + Hide_Homograph; + end if; + return; + elsif not Implicit_Current_Decl and then Implicit_Decl + then + -- Discard decl. + return; + elsif Strip_Non_Object_Alias (Decl) + = Strip_Non_Object_Alias (Current_Decl) + then + -- This rule is not written clearly in the LRM, but + -- if two designators denote the same named entity, + -- no need to make both visible. + return; + end if; + end; + end if; + + -- GHDL: if the homograph is in the same declarative + -- region than DECL, it must be an implicit declaration + -- to be hidden. + -- FIXME: this rule is not in the LRM93, but it is necessary + -- so that explicit declaration hides the implicit one. + if Flags.Vhdl_Std < Vhdl_08 + and then not Flags.Flag_Explicit + and then Get_Parent (Decl) = Get_Parent (Current_Decl) + then + declare + Implicit_Current_Decl : constant Boolean := + Is_Implicit_Subprogram (Current_Decl); + Implicit_Decl : constant Boolean := + Is_Implicit_Subprogram (Decl); + begin + if Implicit_Current_Decl and not Implicit_Decl then + -- Note: no need to save previous interpretation, as + -- it is in the same declarative region. + -- Replace the previous homograph with DECL. + Replace_Homograph; + return; + elsif not Implicit_Current_Decl and Implicit_Decl then + -- As we have replaced the homograph, it is possible + -- than the implicit declaration is re-added (by + -- a new use clause). Discard it. + return; + end if; + end; + end if; + + -- The homograph was made visible in an outer declarative + -- region. Therefore, it must not be hidden. + Add_New_Interpretation (False); + + return; + else + -- Added DECL would be made directly visible. + + if not Is_Potentially_Visible (Homograph) then + -- The homograph was also declared in that declarative + -- region or in an inner one. + if Is_In_Current_Declarative_Region (Homograph) then + -- ... and was declared in the same region + + -- To sum up: at this point both DECL and CURRENT_DECL + -- are overloadable, have the same profile (but may be + -- aliases) and are declared in the same declarative + -- region. + + -- LRM08 12.3 Visibility + -- LRM93 10.3 Visibility + -- Two declarations that occur immediately within + -- the same declarative regions [...] shall not be + -- homograph, unless exactely one of them is the + -- implicit declaration of a predefined operation, + + -- LRM08 12.3 Visibility + -- or is an implicit alias of such implicit declaration. + -- + -- GHDL: FIXME: 'implicit alias' + + -- LRM08 12.3 Visibility + -- LRM93 10.3 Visibility + -- Each of two declarations is said to be a + -- homograph of the other if and only if both + -- declarations have the same designator, [...] + -- + -- LRM08 12.3 Visibility + -- [...] and they denote different named entities, + -- and [...] + declare + Is_Decl_Implicit : Boolean; + Is_Current_Decl_Implicit : Boolean; + begin + if Flags.Vhdl_Std >= Vhdl_08 then + Is_Current_Decl_Implicit := + Is_Implicit_Subprogram (Current_Decl) + or else Is_Implicit_Alias (Current_Decl); + Is_Decl_Implicit := Is_Implicit_Subprogram (Decl) + or else Is_Implicit_Alias (Decl); + + -- If they denote the same entity, they aren't + -- homograph. + if Strip_Non_Object_Alias (Decl) + = Strip_Non_Object_Alias (Current_Decl) + then + if Is_Current_Decl_Implicit + and then not Is_Decl_Implicit + then + -- They aren't homograph but DECL is stronger + -- (at it is not an implicit declaration) + -- than CURRENT_DECL + Replace_Homograph; + end if; + + return; + end if; + + if Is_Decl_Implicit + and then not Is_Current_Decl_Implicit + then + -- Re-declaration of an implicit subprogram via + -- an implicit alias is simply discarded. + return; + end if; + else + -- Can an implicit subprogram declaration appears + -- after an explicit one in vhdl 93? I don't + -- think so. + Is_Decl_Implicit := Is_Implicit_Subprogram (Decl); + Is_Current_Decl_Implicit := + Is_Implicit_Subprogram (Current_Decl); + end if; + + if not (Is_Decl_Implicit xor Is_Current_Decl_Implicit) + then + Error_Msg_Sem + (+Decl, "redeclaration of %n defined at %l", + (+Current_Decl, +Current_Decl)); + return; + end if; + + if not Is_Decl_Implicit and Is_Current_Decl_Implicit + then + -- DECL 'overrides' the predefined current + -- declaration. + + -- LRM93 10.3 Visibility + -- In such cases, a predefined operation is always + -- hidden by the other homograph. Where hidden in + -- this manner, an implicit declaration is hidden + -- within the entire scope of the other declaration + -- (regardless of which declaration occurs first); + -- the implicit declaration is visible neither by + -- selection nor directly. + Set_Visible_Flag (Current_Decl, False); + if Get_Kind (Decl) + in Iir_Kinds_Subprogram_Declaration + then + Set_Hide_Implicit_Flag (Decl, True); + end if; + end if; + end; + else + -- GHDL: hide directly visible declaration declared in + -- an outer region. + null; + end if; + else + -- LRM 10.4 Use Clauses + -- 1. A potentially visible declaration is not made + -- directly visible if the place considered is within the + -- immediate scope of a homograph of the declaration. + + -- GHDL: hide the potentially visible declaration. + null; + end if; + Add_New_Interpretation (False); + + Hide_Homograph; + return; + end if; + end; + end if; + + -- The current interpretation and the new one aren't overloadable, ie + -- they are homograph (well almost). + + if Is_Potentially_Visible (Current_Inter) then + if Potentially then + -- LRM93 10.4 2) / LRM08 12.4 c) Use clauses + -- Potentially visible declarations that have the same + -- designator are not made directly visible unless each of + -- them is either an enumeration literal specification or + -- the declaration of a subprogram. + if Decl = Get_Declaration (Current_Inter) then + -- The rule applies only for distinct declaration. + -- This handles 'use p.all; use P.all;'. + -- FIXME: this should have been handled at the start of + -- this subprogram. + raise Internal_Error; + return; + end if; + + -- LRM08 12.3 Visibility + -- Each of two declarations is said to be a homograph of the + -- other if and only if both declarations have the same + -- designator; and they denote different named entities, [...] + if Flags.Vhdl_Std >= Vhdl_08 then + if Strip_Non_Object_Alias (Decl) + = Strip_Non_Object_Alias (Current_Decl) + then + return; + end if; + end if; + + -- Conflict. + Add_New_Interpretation (True, Null_Iir); + return; + else + -- LRM93 10.4 item #1 + -- A potentially visible declaration is not made directly + -- visible if the place considered is within the immediate + -- scope of a homograph of the declaration. + -- GHDL: Could directly replace the previous interpretation + -- (added in same scope), but don't do that for entity + -- declarations, since it is used to find default binding. + Add_New_Interpretation (True); + return; + end if; + else + -- There is already a declaration in the current scope. + if Potentially then + -- LRM93 §10.4 item #1 + -- Discard the new and potentially visible declaration. + -- However, add the type. + -- FIXME: Add_In_Visible_List (Ident, Decl); + return; + else + if Is_In_Current_Declarative_Region (Current_Inter) then + -- They are perhaps visible in the same declarative region. + + -- LRM93 11.2 + -- If two or more logical names having the same + -- identifier appear in library clauses in the same + -- context, the second and subsequent occurences of the + -- logical name have no effect. The same is true of + -- logical names appearing both in the context clause + -- of a primary unit and in the context clause of a + -- corresponding secondary unit. + -- GHDL: we apply this rule with VHDL-87, because of implicits + -- library clauses STD and WORK. + if Get_Kind (Decl) = Iir_Kind_Library_Declaration + and then + Get_Kind (Current_Decl) = Iir_Kind_Library_Declaration + then + return; + end if; + + -- None of the two declarations are potentially visible, ie + -- both are visible. + -- LRM §10.3: + -- Two declarations that occur immediately within the same + -- declarative region must not be homographs, + -- FIXME: unless one of them is the implicit declaration of a + -- predefined operation. + Error_Msg_Sem + (+Decl, "identifier %i already used for a declaration", + (1 => +Ident), Cont => True); + Error_Msg_Sem + (+Current_Decl, "previous declaration: %n", +Current_Decl); + return; + else + -- Homograph, not in the same scope. + -- LRM §10.3: + -- A declaration is said to be hidden within (part of) an inner + -- declarative region if the inner region contains an homograph + -- of this declaration; the outer declaration is the hidden + -- within the immediate scope of the inner homograph. + if Is_Warning_Enabled (Warnid_Hide) + and then not Is_Potentially_Visible (Current_Inter) + then + Warning_Hide (Decl, Current_Decl); + end if; + + Add_New_Interpretation (True); + return; + end if; + end if; + end if; + end Add_Name; + + procedure Add_Name (Decl: Iir) is + begin + Add_Name (Decl, Get_Identifier (Decl), False); + end Add_Name; + + procedure Replace_Name (Id: Name_Id; Old : Iir; Decl: Iir) + is + Inter : Name_Interpretation_Type; + begin + Inter := Get_Interpretation (Id); + loop + exit when Get_Declaration (Inter) = Old; + Inter := Get_Next_Interpretation (Inter); + pragma Assert (Valid_Interpretation (Inter)); + end loop; + Interpretations.Table (Inter).Decl := Decl; + pragma Assert (Get_Next_Interpretation (Inter) = No_Name_Interpretation); + end Replace_Name; + + procedure Name_Visible (Decl : Iir) is + begin + -- A name can be made visible only once. + pragma Assert (not Get_Visible_Flag (Decl)); + Set_Visible_Flag (Decl, True); + end Name_Visible; + + procedure Iterator_Decl (Decl : Iir; Arg : Arg_Type) + is + begin + case Get_Kind (Decl) is + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Enumeration_Literal -- By use clause + | Iir_Kind_Constant_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kinds_Interface_Object_Declaration + | Iir_Kind_Interface_Package_Declaration + | Iir_Kinds_Interface_Subprogram_Declaration + | Iir_Kind_Component_Declaration + | Iir_Kind_Attribute_Declaration + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration + | Iir_Kind_Nature_Declaration + | Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Terminal_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Context_Declaration + | Iir_Kinds_Concurrent_Statement + | Iir_Kinds_Sequential_Statement => + Handle_Decl (Decl, Arg); + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + if not Is_Second_Subprogram_Specification (Decl) then + Handle_Decl (Decl, Arg); + end if; + when Iir_Kind_Type_Declaration => + declare + Def : constant Iir := Get_Type_Definition (Decl); + List : Iir_Flist; + El : Iir; + begin + -- Handle incomplete type declaration. + if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then + return; + end if; + + Handle_Decl (Decl, Arg); + + if Get_Kind (Def) = Iir_Kind_Enumeration_Type_Definition then + List := Get_Enumeration_Literal_List (Def); + for I in Flist_First .. Flist_Last (List) loop + El := Get_Nth_Element (List, I); + Handle_Decl (El, Arg); + end loop; + end if; + end; + when Iir_Kind_Anonymous_Type_Declaration => + Handle_Decl (Decl, Arg); + + declare + Def : constant Iir := Get_Type_Definition (Decl); + El : Iir; + begin + if Get_Kind (Def) = Iir_Kind_Physical_Type_Definition then + El := Get_Unit_Chain (Def); + while El /= Null_Iir loop + Handle_Decl (El, Arg); + El := Get_Chain (El); + end loop; + end if; + end; + when Iir_Kind_Interface_Type_Declaration => + Handle_Decl (Decl, Arg); + declare + El : Iir; + begin + El := Get_Interface_Type_Subprograms (Decl); + while El /= Null_Iir loop + Handle_Decl (El, Arg); + El := Get_Chain (El); + end loop; + end; + when Iir_Kind_Use_Clause + | Iir_Kind_Context_Reference => + Handle_Decl (Decl, Arg); + when Iir_Kind_Library_Clause => + Handle_Decl (Decl, Arg); +-- El := Get_Library_Declaration (Decl); +-- if El /= Null_Iir then +-- -- May be empty. +-- Handle_Decl (El, Arg); +-- end if; + + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body => + null; + + when Iir_Kind_Package_Body => + null; + + when Iir_Kind_Attribute_Specification + | Iir_Kind_Configuration_Specification + | Iir_Kind_Disconnection_Specification => + null; + when Iir_Kinds_Signal_Attribute + | Iir_Kind_Signal_Attribute_Declaration => + null; + + when Iir_Kind_Protected_Type_Body => + -- FIXME: allowed only in debugger (if the current scope is + -- within a package body) ? + null; + + when others => + Error_Kind ("iterator_decl", Decl); + end case; + end Iterator_Decl; + + -- Handle context_clause of context reference CTXT. + procedure Add_One_Context_Reference (Ctxt : Iir) + is + Name : constant Iir := Get_Selected_Name (Ctxt); + Ent : constant Iir := Get_Named_Entity (Name); + Item : Iir; + begin + if Ent = Null_Iir or else Is_Error (Ent) then + -- Stop now in case of error. + return; + end if; + pragma Assert (Get_Kind (Ent) = Iir_Kind_Context_Declaration); + + Item := Get_Context_Items (Ent); + while Item /= Null_Iir loop + case Get_Kind (Item) is + when Iir_Kind_Use_Clause => + Add_Use_Clause (Item); + when Iir_Kind_Library_Clause => + Add_Name (Get_Library_Declaration (Item), + Get_Identifier (Item), False); + when Iir_Kind_Context_Reference => + Add_Context_Reference (Item); + when others => + Error_Kind ("add_context_reference", Item); + end case; + Item := Get_Chain (Item); + end loop; + end Add_One_Context_Reference; + + procedure Add_Context_Reference (Ref : Iir) + is + Ctxt : Iir; + begin + Ctxt := Ref; + loop + Add_One_Context_Reference (Ctxt); + Ctxt := Get_Context_Reference_Chain (Ctxt); + exit when Ctxt = Null_Iir; + end loop; + end Add_Context_Reference; + + -- Make POTENTIALLY (or not) visible DECL. + procedure Add_Name_Decl (Decl : Iir; Potentially : Boolean) is + begin + case Get_Kind (Decl) is + when Iir_Kind_Use_Clause => + if not Potentially then + Add_Use_Clause (Decl); + end if; + when Iir_Kind_Context_Reference => + pragma Assert (not Potentially); + Add_Context_Reference (Decl); + when Iir_Kind_Library_Clause => + Add_Name (Get_Library_Declaration (Decl), + Get_Identifier (Decl), Potentially); + when Iir_Kind_Anonymous_Type_Declaration => + null; + when others => + Add_Name (Decl, Get_Identifier (Decl), Potentially); + end case; + end Add_Name_Decl; + + procedure Add_Declaration is + new Iterator_Decl (Arg_Type => Boolean, Handle_Decl => Add_Name_Decl); + + procedure Iterator_Decl_List (Decl_List : Iir_List; Arg : Arg_Type) + is + Decl : Iir; + It : List_Iterator; + begin + if Decl_List = Null_Iir_List then + return; + end if; + It := List_Iterate (Decl_List); + while Is_Valid (It) loop + Decl := Get_Element (It); + Handle_Decl (Decl, Arg); + Next (It); + end loop; + end Iterator_Decl_List; + + procedure Iterator_Decl_Chain (Chain_First : Iir; Arg : Arg_Type) + is + Decl: Iir; + begin + Decl := Chain_First; + while Decl /= Null_Iir loop + Handle_Decl (Decl, Arg); + Decl := Get_Chain (Decl); + end loop; + end Iterator_Decl_Chain; + + procedure Add_Declarations_1 is new Iterator_Decl_Chain + (Arg_Type => Boolean, Handle_Decl => Add_Declaration); + + procedure Add_Declarations (Chain : Iir; Potentially : Boolean := False) + renames Add_Declarations_1; + + procedure Add_Declarations_List is new Iterator_Decl_List + (Arg_Type => Boolean, Handle_Decl => Add_Declaration); + + procedure Add_Declarations_From_Interface_Chain (Chain : Iir) + is + El : Iir; + Id : Name_Id; + begin + El := Chain; + while El /= Null_Iir loop + Id := Get_Identifier (El); + + -- The chain may be from an implicitely declared subprograms, with + -- anonymous identifiers. In that case, all interfaces are + -- anonymous and there is no need to iterate. + exit when Id = Null_Identifier; + + Add_Name (El, Id, False); + El := Get_Chain (El); + end loop; + end Add_Declarations_From_Interface_Chain; + + procedure Add_Declarations_Of_Concurrent_Statement (Parent : Iir) + is + El: Iir; + Label: Name_Id; + begin + El := Get_Concurrent_Statement_Chain (Parent); + while El /= Null_Iir loop + Label := Get_Label (El); + if Label /= Null_Identifier then + Add_Name (El, Get_Identifier (El), False); + end if; + El := Get_Chain (El); + end loop; + end Add_Declarations_Of_Concurrent_Statement; + + procedure Add_Context_Clauses (Unit : Iir_Design_Unit) is + begin + Add_Declarations (Get_Context_Items (Unit), False); + end Add_Context_Clauses; + + -- Add declarations from an entity into the current declarative region. + -- This is needed when an architecture is analysed. + procedure Add_Entity_Declarations (Entity : Iir_Entity_Declaration) + is + begin + Add_Declarations_From_Interface_Chain (Get_Generic_Chain (Entity)); + Add_Declarations_From_Interface_Chain (Get_Port_Chain (Entity)); + Add_Declarations (Get_Declaration_Chain (Entity), False); + Add_Declarations_Of_Concurrent_Statement (Entity); + end Add_Entity_Declarations; + + -- Add declarations from a package into the current declarative region. + -- (for a use clause or when a package body is analyzed) + procedure Add_Package_Declarations + (Decl: Iir_Package_Declaration; Potentially : Boolean) + is + Header : constant Iir := Get_Package_Header (Decl); + begin + -- LRM08 12.1 Declarative region + -- d) A package declaration together with the corresponding body + -- + -- GHDL: the formal generic declarations are considered to be in the + -- same declarative region as the package declarations (and therefore + -- in the same scope), even if they don't occur immediately within a + -- package declaration. + if Header /= Null_Iir then + Add_Declarations (Get_Generic_Chain (Header), Potentially); + end if; + + Add_Declarations (Get_Declaration_Chain (Decl), Potentially); + end Add_Package_Declarations; + + procedure Add_Package_Instantiation_Declarations + (Decl: Iir; Potentially : Boolean) is + begin + -- LRM08 4.9 Package instantiation declarations + -- The package instantiation declaration is equivalent to declaration of + -- a generic-mapped package, consisting of a package declaration [...] + Add_Declarations (Get_Generic_Chain (Decl), Potentially); + Add_Declarations (Get_Declaration_Chain (Decl), Potentially); + end Add_Package_Instantiation_Declarations; + + -- Add declarations from a package into the current declarative region. + -- This is needed when a package body is analysed. + procedure Add_Package_Declarations (Decl: Iir_Package_Declaration) is + begin + Add_Package_Declarations (Decl, False); + end Add_Package_Declarations; + + procedure Add_Component_Declarations (Component: Iir_Component_Declaration) + is + begin + Add_Declarations_From_Interface_Chain (Get_Generic_Chain (Component)); + Add_Declarations_From_Interface_Chain (Get_Port_Chain (Component)); + end Add_Component_Declarations; + + procedure Add_Protected_Type_Declarations + (Decl : Iir_Protected_Type_Declaration) is + begin + Add_Declarations (Get_Declaration_Chain (Decl), False); + end Add_Protected_Type_Declarations; + + procedure Extend_Scope_Of_Block_Declarations (Decl : Iir) is + begin + case Get_Kind (Decl) is + when Iir_Kind_Architecture_Body => + Add_Context_Clauses (Get_Design_Unit (Decl)); + when Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement_Body => + -- FIXME: formal, iterator ? + null; + when others => + Error_Kind ("extend_scope_of_block_declarations", Decl); + end case; + Add_Declarations (Get_Declaration_Chain (Decl), False); + Add_Declarations_Of_Concurrent_Statement (Decl); + end Extend_Scope_Of_Block_Declarations; + + procedure Use_Library_All (Library : Iir_Library_Declaration) + is + Design_File : Iir_Design_File; + Design_Unit : Iir_Design_Unit; + Library_Unit : Iir; + begin + Design_File := Get_Design_File_Chain (Library); + while Design_File /= Null_Iir loop + Design_Unit := Get_First_Design_Unit (Design_File); + while Design_Unit /= Null_Iir loop + Library_Unit := Get_Library_Unit (Design_Unit); + if Get_Kind (Library_Unit) /= Iir_Kind_Package_Body then + Add_Name (Design_Unit, Get_Identifier (Design_Unit), True); + end if; + Design_Unit := Get_Chain (Design_Unit); + end loop; + Design_File := Get_Chain (Design_File); + end loop; + end Use_Library_All; + + procedure Potentially_Add_Name (Name : Iir) is + begin + Add_Name (Name, Get_Identifier (Name), True); + end Potentially_Add_Name; + + -- LRM08 12.4 Use clauses + -- Moreover, the following declarations, if any, that occurs immediately + -- within the package denoted by the prefix of the selected name, are also + -- identifier: + procedure Use_Selected_Type_Name (Name : Iir) + is + Type_Def : constant Iir := Get_Type (Name); + Base_Type : constant Iir := Get_Base_Type (Type_Def); + begin + case Get_Kind (Base_Type) is + when Iir_Kind_Enumeration_Type_Definition => + -- LRM08 12.4 Use clauses + -- - If the type mark denotes an enumeration type of a subtype of + -- an enumeration type, the enumeration literals of the base + -- type + declare + List : constant Iir_Flist := + Get_Enumeration_Literal_List (Base_Type); + El : Iir; + begin + for I in Flist_First .. Flist_Last (List) loop + El := Get_Nth_Element (List, I); + Potentially_Add_Name (El); + end loop; + end; + when Iir_Kind_Physical_Type_Definition => + -- LRM08 12.4 Use clauses + -- - If the type mark denotes a subtype of a physical type, the + -- units of the base type + declare + El : Iir; + begin + El := Get_Unit_Chain (Base_Type); + while El /= Null_Iir loop + Potentially_Add_Name (El); + El := Get_Chain (El); + end loop; + end; + when others => + null; + end case; + + -- LRM08 12.4 Use clauses + -- - The implicit declarations of predefined operations for the type + -- that are not hidden by homographs explicitely declared immediately + -- within the package denoted by the prefix of the selected name + -- - The declarations of homographs, explicitely declared immediately + -- within the package denotes by the prefix of the selected name, + -- that hide implicit declarations of predefined operations for the + -- type + declare + Type_Decl : constant Iir := Get_Type_Declarator (Base_Type); + El : Iir; + Has_Override : Boolean; + begin + Has_Override := False; + El := Get_Chain (Type_Decl); + while El /= Null_Iir loop + if Is_Implicit_Subprogram (El) + and then Is_Operation_For_Type (El, Base_Type) + then + if Get_Visible_Flag (El) then + -- Implicit declaration EL was overriden by a user + -- declaration. Don't make it visible. + Potentially_Add_Name (El); + else + Has_Override := True; + end if; + El := Get_Chain (El); + else + exit; + end if; + end loop; + + -- Explicitely declared homograph. + if Has_Override then + while El /= Null_Iir loop + if Get_Kind (El) in Iir_Kinds_Subprogram_Declaration + and then Get_Hide_Implicit_Flag (El) + and then Is_Operation_For_Type (El, Base_Type) + then + Potentially_Add_Name (El); + end if; + El := Get_Chain (El); + end loop; + end if; + end; + end Use_Selected_Type_Name; + + -- LRM02 10.4 Use clauses + -- Each selected name in a use clause identifiers one or more declarations + -- that will potentially become directly visible. If the suffix of the + -- selected name is a simple name, a character literal, or operator + -- symbol, then the selected name identifiers only the declarations(s) of + -- that simple name, character literal, or operator symbol contained + -- within the package or library denoted by the prefix of the selected + -- name. + procedure Use_Selected_Name (Name : Iir) is + begin + case Get_Kind (Name) is + when Iir_Kind_Overload_List => + Add_Declarations_List (Get_Overload_List (Name), True); + when Iir_Kind_Error => + null; + when others => + Potentially_Add_Name (Name); + + -- LRM08 12.4 Use clauses + -- If the suffix of the selected name is a type mark, then the + -- declaration of the type or subtype denoted by the type mark + -- is identified. Moreover [...] + if (Vhdl_Std >= Vhdl_08 or else Flag_Relaxed_Rules) + and then Get_Kind (Name) in Iir_Kinds_Type_Declaration + then + Use_Selected_Type_Name (Name); + end if; + end case; + end Use_Selected_Name; + + -- LRM93 10.4 Use clauses + -- If the suffix is the reserved word ALL, then all the selected name + -- identifies all declaration that are contained within the package or + -- library denotes by te prefix of the selected name. + procedure Use_All_Names (Name: Iir) is + begin + case Get_Kind (Name) is + when Iir_Kind_Library_Declaration => + Use_Library_All (Name); + when Iir_Kind_Package_Declaration => + Add_Package_Declarations (Name, True); + when Iir_Kind_Package_Instantiation_Declaration => + Add_Package_Instantiation_Declarations (Name, True); + when Iir_Kind_Interface_Package_Declaration => + -- LRM08 6.5.5 Interface package declarations + -- Within an entity declaration, an architecture body, a + -- component declaration, or an uninstantiated subprogram or + -- package declaration that declares a given interface package, + -- the name of the given interface package denotes an undefined + -- instance of the uninstantiated package. + Add_Package_Instantiation_Declarations (Name, True); + when Iir_Kind_Error => + null; + when others => + raise Internal_Error; + end case; + end Use_All_Names; + + procedure Add_Use_Clause (Clause : Iir_Use_Clause) + is + Name : Iir; + Cl : Iir_Use_Clause; + begin + Cl := Clause; + loop + Name := Get_Selected_Name (Cl); + if Name = Null_Iir then + pragma Assert (Flags.Flag_Force_Analysis); + null; + else + if Get_Kind (Name) = Iir_Kind_Selected_By_All_Name then + Name := Get_Prefix (Name); + if not Is_Error (Name) then + Use_All_Names (Get_Named_Entity (Name)); + end if; + else + if not Is_Error (Name) then + Use_Selected_Name (Get_Named_Entity (Name)); + end if; + end if; + end if; + Cl := Get_Use_Clause_Chain (Cl); + exit when Cl = Null_Iir; + end loop; + end Add_Use_Clause; + + -- Debugging subprograms. + procedure Disp_All_Names; + pragma Unreferenced (Disp_All_Names); + + procedure Disp_Scopes; + pragma Unreferenced (Disp_Scopes); + + procedure Disp_Detailed_Interpretations (Ident : Name_Id); + pragma Unreferenced (Disp_Detailed_Interpretations); + + procedure Dump_Current_Scope; + pragma Unreferenced (Dump_Current_Scope); + + procedure Disp_Detailed_Interpretations (Ident : Name_Id) + is + Inter: Name_Interpretation_Type; + Decl : Iir; + begin + Log (Name_Table.Image (Ident)); + Log_Line (":"); + + Inter := Get_Interpretation (Ident); + while Valid_Interpretation (Inter) loop + Log (Name_Interpretation_Type'Image (Inter)); + if Is_Potentially_Visible (Inter) then + Log (" (use)"); + end if; + Log (":"); + Decl := Get_Declaration (Inter); + Log (Iir'Image (Decl)); + Log (":"); + Log (Iir_Kind'Image (Get_Kind (Decl))); + Log_Line (", loc: " & Image (Get_Location (Decl))); + if Get_Kind (Decl) in Iir_Kinds_Subprogram_Declaration then + Log_Line (" " & Disp_Subprg (Decl)); + end if; + Inter := Get_Next_Interpretation (Inter); + end loop; + end Disp_Detailed_Interpretations; + + procedure Disp_All_Interpretations + (Interpretation : Name_Interpretation_Type) + is + Inter: Name_Interpretation_Type; + begin + Inter := Interpretation; + while Valid_Interpretation (Inter) loop + Log (Name_Interpretation_Type'Image (Inter)); + Log ("."); + Log (Iir_Kind'Image (Get_Kind (Get_Declaration (Inter)))); + Inter := Get_Next_Interpretation (Inter); + end loop; + Log_Line; + end Disp_All_Interpretations; + + procedure Disp_All_Names + is + Inter: Name_Interpretation_Type; + begin + for I in 0 .. Name_Table.Last_Name_Id loop + Inter := Get_Interpretation (I); + if Valid_Interpretation (Inter) then + Log (Name_Table.Image (I)); + Log (Name_Id'Image (I)); + Log (":"); + Disp_All_Interpretations (Inter); + end if; + end loop; + Log_Line ("interprations.last = " + & Name_Interpretation_Type'Image (Interpretations.Last)); + Log_Line ("current_region_start =" + & Name_Interpretation_Type'Image (Current_Region_Start)); + end Disp_All_Names; + + procedure Dump_Interpretation (Inter : Name_Interpretation_Type) + is + Decl : Iir; + begin + Log (Name_Interpretation_Type'Image (Inter)); + if Is_Potentially_Visible (Inter) then + Log (" (use)"); + end if; + Log (": "); + Decl := Get_Declaration (Inter); + if Decl = Null_Iir then + Log_Line ("null: conflict"); + else + Log (Iir_Kind'Image (Get_Kind (Decl))); + Log_Line (", loc: " & Image (Get_Location (Decl))); + if Get_Kind (Decl) in Iir_Kinds_Subprogram_Declaration then + Log_Line (" " & Disp_Subprg (Decl)); + end if; + end if; + end Dump_Interpretation; + + procedure Dump_A_Scope (First, Last : Name_Interpretation_Type) is + begin + if First > Last then + Log_Line ("scope is empty"); + return; + end if; + + for Inter in reverse First .. Last loop + declare + Cell : Interpretation_Cell renames Interpretations.Table (Inter); + begin + Dump_Interpretation (Inter); + if Cell.Prev_Hidden then + Log (" [prev:"); + Log (Name_Interpretation_Type'Image (Cell.Prev)); + if Cell.Prev_Hidden then + Log (" hidden"); + end if; + Log_Line ("]"); + else + if Cell.Prev < First then + Log_Line (" [last in scope]"); + end if; + end if; + end; + end loop; + end Dump_A_Scope; + + procedure Dump_Current_Scope is + begin + Dump_A_Scope (Current_Region_Start, Interpretations.Last); + end Dump_Current_Scope; + + procedure Disp_Scopes is + begin + for I in reverse Scopes.First .. Scopes.Last loop + declare + S : Scope_Cell renames Scopes.Table (I); + begin + case S.Kind is + when Scope_Start => + Log ("scope_start at"); + when Scope_Region => + Log ("scope_region at"); + end case; + Log_Line (Name_Interpretation_Type'Image (S.Saved_Region_Start)); + end; + end loop; + end Disp_Scopes; +end Vhdl.Sem_Scopes; diff --git a/src/vhdl/vhdl-sem_scopes.ads b/src/vhdl/vhdl-sem_scopes.ads new file mode 100644 index 000000000..93aad18cd --- /dev/null +++ b/src/vhdl/vhdl-sem_scopes.ads @@ -0,0 +1,220 @@ +-- Semantic analysis. +-- 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 Iirs; use Iirs; +with Types; use Types; + +package Vhdl.Sem_Scopes is + + -- The purpose of SEM_NAME package is to handle association between + -- identifiers and declarations. + -- Roughly speacking, it implements ch10 of LRM: scope and visibility. + -- + -- Basic elements are: declarations and declarative region. + -- Declaration should be understood in the large meaning: any textual + -- construction declaring an identifier, which can be a label. + -- A declarative region contains declarations and possibly other + -- declarative regions. + -- + -- Rules are scope, visibility and overloading. + -- + + -- Create and close a declarative region. + -- By closing a declarative region, all declarations made in this region + -- are discarded. + procedure Open_Declarative_Region; + procedure Close_Declarative_Region; + + -- Add meaning DECL for its identifier to the current declarative region. + procedure Add_Name (Decl: Iir); + pragma Inline (Add_Name); + + -- Add meaning DECL to the identifier IDENT. + -- POTENTIALLY is true if the identifier comes from a use clause. + procedure Add_Name (Decl: Iir; Ident : Name_Id; Potentially: Boolean); + + -- Set the visible_flag of DECL to true. + procedure Name_Visible (Decl : Iir); + + -- Replace the interpretation OLD of ID by DECL. + -- ID must have a uniq interpretation OLD (ie, it must not be overloaded). + -- The interpretation must have been done in the current scope. + -- + -- This procedure is used when the meaning of a name is changed due to its + -- analysis, eg: when a concurrent_procedure_call_statement becomes + -- a component_instantiation_statement. + procedure Replace_Name (Id: Name_Id; Old : Iir; Decl: Iir); + + -- Interpretation is a simply linked list of what an identifier means. + -- In LRM08 12.3 Visibility, the sentence is 'the declaration defines a + -- possible meaning of this occurrence'. + -- FIXME: replace Interpretation by Meaning. + type Name_Interpretation_Type is private; + + -- Return true if INTER is a valid interpretation, ie has a corresponding + -- declaration. There are only two invalids interpretations, which + -- are declared just below as constants. + function Valid_Interpretation (Inter : Name_Interpretation_Type) + return Boolean; + pragma Inline (Valid_Interpretation); + + -- Get the first interpretation of identifier ID. + function Get_Interpretation (Id: Name_Id) return Name_Interpretation_Type; + + -- Get the next interpretation from an interpretation. + function Get_Next_Interpretation (Ni: Name_Interpretation_Type) + return Name_Interpretation_Type; + + -- Get a declaration associated with an interpretation. + function Get_Declaration (Ni: Name_Interpretation_Type) return Iir; + pragma Inline (Get_Declaration); + + -- Same as Get_Declaration, but get the name of non-object alias. + -- (ie, can never returns an object alias). + function Get_Non_Alias_Declaration (Ni: Name_Interpretation_Type) + return Iir; + + -- Get the previous interpretation of identifier ID, ie the interpretation + -- for ID before the current interpretation of ID. + function Get_Under_Interpretation (Id : Name_Id) + return Name_Interpretation_Type; + + -- Return TRUE if INTER was made directly visible via a use clause. + function Is_Potentially_Visible (Inter: Name_Interpretation_Type) + return Boolean; + pragma Inline (Is_Potentially_Visible); + + -- Return TRUE if INTER was made direclty visible in the current + -- declarative region. Note this is different from being declared in the + -- current declarative region because of use clauses. + function Is_In_Current_Declarative_Region (Inter: Name_Interpretation_Type) + return Boolean; + pragma Inline (Is_In_Current_Declarative_Region); + + -- Return the raw interpretation of ID. To be used only in case of + -- invalid interpretation to clarify the issue: this may be due to + -- conflicting declarations. + function Get_Interpretation_Raw (Id : Name_Id) + return Name_Interpretation_Type; + + -- Return True iff NI is a conflicting declaration. + function Is_Conflict_Declaration (Ni : Name_Interpretation_Type) + return Boolean; + + -- Push and pop all interpretations. + -- This can be used to suspend name interpretation, in case of recursive + -- semantics. + -- After a push, all names have no_name_interpretation. + -- Pop restore the previous state. + procedure Pop_Interpretations; + procedure Push_Interpretations; + + -- Execute a use clause on NAME. + -- Make potentially directly visible declarations of NAMES. + --procedure Use_Selected_Name (Name : Iir); + procedure Use_All_Names (Name: Iir); + + -- Achieves visibility of the selected_name of use clause CLAUSE. + procedure Add_Use_Clause (Clause : Iir_Use_Clause); + + -- Add declarations for context clause in REF. + procedure Add_Context_Reference (Ref : Iir); + + -- Add declarations for a context clause into the current declarative + -- regions. + procedure Add_Context_Clauses (Unit : Iir_Design_Unit); + + -- Add declarations from an entity into the current declarative region. + -- This is needed when an architecture is analysed. + procedure Add_Entity_Declarations (Entity : Iir_Entity_Declaration); + + -- Add declarations from a package into the current declarative region. + -- This is needed when a package body is analysed. + -- FIXME: this must be done as if the declarative region was extended. + procedure Add_Package_Declarations (Decl: Iir_Package_Declaration); + + -- Add interfaces declaration of a component into the current declarative + -- region. + procedure Add_Component_Declarations + (Component : Iir_Component_Declaration); + + -- Add declarations from a protected type declaration into the current + -- declaration region (which is expected to be the region of the protected + -- type body). + procedure Add_Protected_Type_Declarations + (Decl : Iir_Protected_Type_Declaration); + + -- Add declarations of interface chain CHAIN into the current + -- declarative region. + procedure Add_Declarations_From_Interface_Chain (Chain : Iir); + + -- Add all declarations for concurrent statements declared in PARENT. + procedure Add_Declarations_Of_Concurrent_Statement (Parent : Iir); + + -- Add declarations of a declaration chain CHAIN. + procedure Add_Declarations (Chain : Iir; Potentially : Boolean := False); + + -- Scope extension area contains declarations from another declarative + -- region. These area are abstract and only used to be able to add + -- and remove declarations. + procedure Open_Scope_Extension; + procedure Close_Scope_Extension; + + -- Add any declarations that include the end of the declarative part of + -- the given block BLOCK. This follow rules of LRM93 10.2 + -- FIXME: BLOCK must be an architecture at first, then blocks declared + -- inside this architecture, then a block declared inside this block... + -- This procedure must be called after an Open_Scope_Extension and + -- declarations added can be removed with Close_Scope_Extension. + procedure Extend_Scope_Of_Block_Declarations (Decl : Iir); + + -- Call HANDLE_DECL for each declaration found in DECL. + -- This will generally call HANDLE_DECL with DECL. + -- For types, HANDLE_DECL is first called with the type declaration, then + -- with implicit functions, with element literals for enumeration type, + -- and units for physical type. + generic + type Arg_Type is private; + with procedure Handle_Decl (Decl : Iir; Arg : Arg_Type); + procedure Iterator_Decl (Decl : Iir; Arg : Arg_Type); + + -- Call HANDLE_DECL for each declaration found in DECL_LIST. + -- Generally, HANDLE_DECL must be an ITERATOR_DECL; this is not + -- automatically done, since the user might be interested in using the + -- ITERATOR_DECL. + generic + type Arg_Type is private; + with procedure Handle_Decl (Decl : Iir; Arg : Arg_Type); + procedure Iterator_Decl_List (Decl_List : Iir_List; Arg : Arg_Type); + + generic + type Arg_Type is private; + with procedure Handle_Decl (Decl : Iir; Arg : Arg_Type); + procedure Iterator_Decl_Chain (Chain_First : Iir; Arg : Arg_Type); + +private + type Name_Interpretation_Type is new Int32 range 0 .. (2 ** 30) - 1; + + -- This pseudo interpretation marks the end of the interpretation chain, + -- and means there is no (more) interpretations for the name. + -- Unless you need to discriminate between an absence of declaration and + -- a conflict between potential declarations, you should use the + -- VALID_INTERPRETATION function. + No_Name_Interpretation : constant Name_Interpretation_Type := 0; + + First_Valid_Interpretation : constant Name_Interpretation_Type := 1; +end Vhdl.Sem_Scopes; diff --git a/src/vhdl/vhdl-sem_specs.adb b/src/vhdl/vhdl-sem_specs.adb new file mode 100644 index 000000000..bd21e7e47 --- /dev/null +++ b/src/vhdl/vhdl-sem_specs.adb @@ -0,0 +1,1928 @@ +-- Semantic analysis. +-- 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 Iirs_Utils; use Iirs_Utils; +with Vhdl.Sem_Expr; use Vhdl.Sem_Expr; +with Vhdl.Sem_Names; use Vhdl.Sem_Names; +with Evaluation; use Evaluation; +with Std_Package; use Std_Package; +with Errorout; use Errorout; +with Vhdl.Sem; use Vhdl.Sem; +with Vhdl.Sem_Lib; use Vhdl.Sem_Lib; +with Vhdl.Sem_Scopes; use Vhdl.Sem_Scopes; +with Vhdl.Sem_Assocs; use Vhdl.Sem_Assocs; +with Libraries; +with Iir_Chains; use Iir_Chains; +with Flags; use Flags; +with Std_Names; +with Vhdl.Sem_Decls; +with Xrefs; use Xrefs; +with Back_End; + +package body Vhdl.Sem_Specs is + function Get_Entity_Class_Kind (Decl : Iir) return Vhdl.Tokens.Token_Type + is + use Vhdl.Tokens; + begin + case Get_Kind (Decl) is + when Iir_Kind_Entity_Declaration => + return Tok_Entity; + when Iir_Kind_Architecture_Body => + return Tok_Architecture; + when Iir_Kind_Configuration_Declaration => + return Tok_Configuration; + when Iir_Kind_Package_Declaration => + return Tok_Package; + when Iir_Kind_Procedure_Declaration => + return Tok_Procedure; + when Iir_Kind_Function_Declaration => + return Tok_Function; + when Iir_Kind_Type_Declaration => + return Tok_Type; + when Iir_Kind_Subtype_Declaration => + return Tok_Subtype; + when Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Constant_Declaration => + return Tok_Constant; + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration => + return Tok_Signal; + when Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration => + return Tok_Variable; + when Iir_Kind_Component_Declaration => + return Tok_Component; + when Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_If_Generate_Statement + | Iir_Kind_For_Generate_Statement + | Iir_Kind_Concurrent_Procedure_Call_Statement + | Iir_Kinds_Sequential_Statement => + return Tok_Label; + when Iir_Kind_Enumeration_Literal => + return Tok_Literal; + when Iir_Kind_Unit_Declaration => + return Tok_Units; + when Iir_Kind_Group_Declaration => + return Tok_Group; + when Iir_Kind_File_Declaration + | Iir_Kind_Interface_File_Declaration => + return Tok_File; + when Iir_Kind_Attribute_Declaration => + -- Even if an attribute can't have a attribute... + -- Because an attribute declaration can appear in a declaration + -- region. + return Tok_Attribute; + when others => + Error_Kind ("get_entity_class_kind", Decl); + end case; + return Tok_Invalid; + end Get_Entity_Class_Kind; + + -- Return the node containing the attribute_value_chain field for DECL. + -- This is the parent of the attribute specification, so in general this + -- is also the parent of the declaration, but there are exceptions... + function Get_Attribute_Value_Chain_Parent (Decl : Iir) return Iir + is + Parent : Iir; + begin + case Get_Kind (Decl) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Configuration_Declaration => + -- LRM93 5.1 + -- An attribute specification for an attribute of a design unit + -- [...] must appear immediately within the declarative part of + -- that design unit. + return Decl; + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration => + -- LRM93 5.1 + -- Similarly, an attribute specification for an attribute of an + -- interface object of a design unit, subprogram, block statement + -- or package must appear immediately within the declarative part + -- of that design unit, subprogram, block statement, or package. + Parent := Get_Parent (Decl); + case Get_Kind (Parent) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Block_Statement + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration => + return Parent; + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + return Get_Subprogram_Body (Parent); + when others => + raise Internal_Error; + end case; + when Iir_Kinds_Sequential_Statement => + -- Sequential statements can be nested. + Parent := Get_Parent (Decl); + loop + if Get_Kind (Parent) not in Iir_Kinds_Sequential_Statement then + return Parent; + end if; + Parent := Get_Parent (Parent); + end loop; + when others => + -- This is also true for enumeration literals and physical units. + return Get_Parent (Decl); + end case; + end Get_Attribute_Value_Chain_Parent; + + function Find_Attribute_Value (Ent : Iir; Id : Name_Id) return Iir + is + Attr_Value_Parent : constant Iir := + Get_Attribute_Value_Chain_Parent (Ent); + Value : Iir; + Spec : Iir; + Attr_Decl : Iir; + begin + Value := Get_Attribute_Value_Chain (Attr_Value_Parent); + while Value /= Null_Iir loop + if Get_Designated_Entity (Value) = Ent then + Spec := Get_Attribute_Specification (Value); + Attr_Decl := Get_Attribute_Designator (Spec); + if Get_Identifier (Attr_Decl) = Id then + return Value; + end if; + end if; + Value := Get_Value_Chain (Value); + end loop; + return Null_Iir; + end Find_Attribute_Value; + + -- Decorate DECL with attribute ATTR. + -- If CHECK_CLASS is true, class of DECL must be class of ATTR, otherwise + -- returns silently. + -- If CHECK_DEFINED is true, DECL must not have been decorated, otherwise + -- returns silently. + procedure Attribute_A_Decl (Decl : Iir; + Attr : Iir_Attribute_Specification; + Check_Class : Boolean; + Check_Defined : Boolean) + is + use Vhdl.Tokens; + Attr_Expr : constant Iir := Get_Expression (Attr); + + El : Iir_Attribute_Value; + + -- Attribute declaration corresponding to ATTR. + -- Due to possible error, it is not required to be an attribute decl, + -- it may be a simple name. + Attr_Decl : Iir; + + Attr_Chain_Parent : Iir; + begin + -- LRM93 5.1 + -- It is an error if the class of those names is not the same as that + -- denoted by the entity class. + if Get_Entity_Class_Kind (Decl) /= Get_Entity_Class (Attr) then + if Check_Class then + Error_Msg_Sem (+Attr, "%n is not of class %t", + (+Decl, +Get_Entity_Class (Attr))); + if Get_Kind (Decl) = Iir_Kind_Subtype_Declaration + and then Get_Entity_Class (Attr) = Tok_Type + and then Get_Type (Decl) /= Null_Iir + and then Get_Base_Type (Get_Type (Decl)) /= Null_Iir + and then Get_Kind + (Get_Type_Declarator (Get_Base_Type (Get_Type (Decl)))) + = Iir_Kind_Anonymous_Type_Declaration + then + -- The type declaration declares an anonymous type + -- and a named subtype. + Error_Msg_Sem + (+Decl, + "%i declares both an anonymous type and a named subtype", + +Decl); + end if; + end if; + return; + end if; + + -- LRM93 5.1 + -- An attribute specification for an attribute of a design unit + -- (ie an entity declaration, an architecture, a configuration, or a + -- package) must appear immediately within the declarative part of + -- that design unit. + case Get_Entity_Class (Attr) is + when Tok_Entity + | Tok_Architecture + | Tok_Configuration + | Tok_Package => + if Get_Design_Unit (Decl) /= Get_Current_Design_Unit then + Error_Msg_Sem (+Attr, "%n must appear immediatly within %n", + (+Attr, +Decl)); + return; + end if; + when others => + null; + end case; + + Attr_Decl := Get_Named_Entity (Get_Attribute_Designator (Attr)); + + -- LRM93 5.1 + -- It is an error if a given attribute is associated more than once with + -- a given named entity. + -- LRM 5.1 + -- Similarly, it is an error if two different attributes with the + -- same simple name (whether predefined or user-defined) are both + -- associated with a given named entity. + Attr_Chain_Parent := Get_Attribute_Value_Chain_Parent (Decl); + El := Get_Attribute_Value_Chain (Attr_Chain_Parent); + while El /= Null_Iir loop + if Get_Designated_Entity (El) = Decl then + declare + El_Attr : constant Iir_Attribute_Declaration := + Get_Named_Entity (Get_Attribute_Designator + (Get_Attribute_Specification (El))); + begin + if El_Attr = Attr_Decl then + if Get_Attribute_Specification (El) = Attr then + -- Was already specified with the same attribute value. + -- This is possible only in one case: + -- + -- signal S1 : real; + -- alias S1_too : real is S1; + -- attribute ATTR : T1; + -- attribute ATTR of ALL : signal is '1'; + return; + end if; + if Check_Defined then + Error_Msg_Sem + (+Attr, "%n has already %n", (+Decl, +Attr), + Cont => True); + Error_Msg_Sem + (+Attr, "previous attribute specification at %l", +El); + end if; + return; + elsif Get_Identifier (El_Attr) = Get_Identifier (Attr_Decl) then + Error_Msg_Sem (+Attr, "%n is already decorated with an %n", + (+Decl, +El_Attr), Cont => True); + Error_Msg_Sem + (+El, "(previous attribute specification was here)"); + return; + end if; + end; + end if; + El := Get_Value_Chain (El); + end loop; + + El := Create_Iir (Iir_Kind_Attribute_Value); + Location_Copy (El, Attr); + Set_Name_Staticness (El, None); + Set_Attribute_Specification (El, Attr); + -- FIXME: create an expr_error node? + if Is_Error (Attr_Expr) then + Set_Expr_Staticness (El, Locally); + else + Set_Expr_Staticness (El, Get_Expr_Staticness (Attr_Expr)); + end if; + Set_Designated_Entity (El, Decl); + Set_Type (El, Get_Type (Attr_Expr)); + Set_Base_Name (El, El); + + -- Put the attribute value in the attribute_value_chain. + Set_Value_Chain (El, Get_Attribute_Value_Chain (Attr_Chain_Parent)); + Set_Attribute_Value_Chain (Attr_Chain_Parent, El); + + -- Put the attribute value in the chain of the attribute specification. + -- This is prepended, so in reverse order. Will be reversed later. + Set_Spec_Chain (El, Get_Attribute_Value_Spec_Chain (Attr)); + Set_Attribute_Value_Spec_Chain (Attr, El); + + -- Special handling for 'Foreign. + if (Flags.Vhdl_Std >= Vhdl_93c + and then Attr_Decl = Foreign_Attribute) + or else + (Flags.Vhdl_Std <= Vhdl_93c + and then Get_Identifier (Attr_Decl) = Std_Names.Name_Foreign) + then + -- LRM93 12.4 + -- The 'FOREIGN attribute may be associated only with + -- architectures or with subprograms. + case Get_Entity_Class (Attr) is + when Tok_Architecture => + null; + + when Tok_Function + | Tok_Procedure => + -- LRM93 12.4 + -- In the latter case, the attribute specification must + -- appear in the declarative part in which the subprogram + -- is declared. + -- GHDL: huh, this is the case for any attributes. + null; + + when others => + Error_Msg_Sem + (+Attr, + "'FOREIGN allowed only for architectures and subprograms"); + return; + end case; + + Set_Foreign_Flag (Decl, True); + + -- Use 'standard' convention call for foreign procedures, so as a + -- consequence they cannot be suspended. + if Get_Kind (Decl) = Iir_Kind_Procedure_Declaration then + Set_Suspend_Flag (Decl, False); + end if; + + declare + use Back_End; + begin + if Sem_Foreign /= null then + Sem_Foreign.all (Decl); + end if; + end; + end if; + end Attribute_A_Decl; + + -- Return TRUE if a named entity was attributed. + function Sem_Named_Entities (Scope : Iir; + Name : Iir; + Attr : Iir_Attribute_Specification; + Check_Defined : Boolean) + return Boolean + is + -- Name is set (ie neither ALL nor OTHERS). + Is_Designator : constant Boolean := Name /= Null_Iir; + + Res : Boolean; + + -- If declaration DECL matches then named entity ENT, apply attribute + -- specification and returns TRUE. Otherwise, return FALSE. + -- Note: ENT and DECL are different for aliases. + function Sem_Named_Entity1 (Ent : Iir; Decl : Iir) return Boolean + is + use Vhdl.Tokens; + Ent_Id : constant Name_Id := Get_Identifier (Ent); + begin + if (not Is_Designator or else Ent_Id = Get_Identifier (Name)) + and then Ent_Id /= Null_Identifier + then + if Is_Designator then + -- The designator is neither ALL nor OTHERS. + Set_Named_Entity (Name, Ent); + Xref_Ref (Name, Ent); + + if Get_Entity_Class (Attr) = Tok_Label then + -- Concurrent or sequential statements appear later in the + -- AST, but their label are considered to appear before + -- other items in the declarative part. + Set_Is_Forward_Ref (Name, True); + end if; + end if; + if Get_Visible_Flag (Ent) = False then + Error_Msg_Sem (+Attr, "%n is not yet visible", +Ent); + else + Attribute_A_Decl (Decl, Attr, Is_Designator, Check_Defined); + return True; + end if; + end if; + return False; + end Sem_Named_Entity1; + + procedure Sem_Named_Entity (Ent : Iir) is + begin + case Get_Kind (Ent) is + when Iir_Kinds_Library_Unit + | Iir_Kinds_Concurrent_Statement + | Iir_Kinds_Sequential_Statement + | Iir_Kinds_Non_Alias_Object_Declaration + | Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Component_Declaration + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Unit_Declaration + | Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration => + Res := Res or Sem_Named_Entity1 (Ent, Ent); + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if not Is_Second_Subprogram_Specification (Ent) then + Res := Res or Sem_Named_Entity1 (Ent, Ent); + end if; + when Iir_Kind_Object_Alias_Declaration => + -- LRM93 5.1 + -- An entity designator that denotes an alias of an object is + -- required to denote the entire object, and not a subelement + -- or slice thereof. + declare + Decl : constant Iir := Get_Name (Ent); + Base : constant Iir := Get_Object_Prefix (Decl, False); + Applied : Boolean; + begin + Applied := Sem_Named_Entity1 (Ent, Base); + -- FIXME: check the alias denotes a local entity... + if Applied + and then Base /= Strip_Denoting_Name (Decl) + then + Error_Msg_Sem + (+Attr, "%n does not denote the entire object", +Ent); + end if; + Res := Res or Applied; + end; + when Iir_Kind_Non_Object_Alias_Declaration => + Res := Res + or Sem_Named_Entity1 (Ent, Get_Named_Entity (Get_Name (Ent))); + when Iir_Kind_Attribute_Declaration + | Iir_Kind_Attribute_Specification + | Iir_Kind_Configuration_Specification + | Iir_Kind_Use_Clause => + null; + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body => + null; + when Iir_Kind_Anonymous_Type_Declaration => + null; + when others => + Error_Kind ("sem_named_entity", Ent); + end case; + end Sem_Named_Entity; + + procedure Sem_Named_Entity_Chain (Chain_First : Iir) + is + El : Iir; + Def : Iir; + begin + El := Chain_First; + while El /= Null_Iir loop + exit when El = Attr; + Sem_Named_Entity (El); + case Get_Kind (El) is + when Iir_Kind_Type_Declaration => + Def := Get_Type_Definition (El); + if Get_Kind (Def) = Iir_Kind_Enumeration_Type_Definition then + declare + List : constant Iir_Flist := + Get_Enumeration_Literal_List (Def); + El1 : Iir; + begin + for I in Flist_First .. Flist_Last (List) loop + El1 := Get_Nth_Element (List, I); + Sem_Named_Entity (El1); + end loop; + end; + end if; + when Iir_Kind_Anonymous_Type_Declaration => + Def := Get_Type_Definition (El); + if Get_Kind (Def) = Iir_Kind_Physical_Type_Definition then + declare + El1 : Iir; + begin + El1 := Get_Unit_Chain (Def); + while El1 /= Null_Iir loop + Sem_Named_Entity (El1); + El1 := Get_Chain (El1); + end loop; + end; + end if; + when Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement => + Sem_Named_Entity_Chain (Get_Sequential_Statement_Chain (El)); + when Iir_Kind_If_Statement => + declare + Clause : Iir; + begin + Clause := El; + while Clause /= Null_Iir loop + Sem_Named_Entity_Chain + (Get_Sequential_Statement_Chain (Clause)); + Clause := Get_Else_Clause (Clause); + end loop; + end; + when Iir_Kind_Case_Statement => + declare + El1 : Iir; + begin + El1 := Get_Case_Statement_Alternative_Chain (El); + while El1 /= Null_Iir loop + Sem_Named_Entity_Chain (Get_Associated_Chain (El1)); + El1 := Get_Chain (El1); + end loop; + end; + + when Iir_Kind_If_Generate_Statement + | Iir_Kind_For_Generate_Statement => + -- INT-1991/issue 27 + -- Generate statements represent declarative region and + -- have implicit declarative parts. + -- Was: There is no declarative part in generate statement + -- for VHDL 87. + if False and then Flags.Vhdl_Std = Vhdl_87 then + Sem_Named_Entity_Chain + (Get_Concurrent_Statement_Chain (El)); + end if; + + when others => + null; + end case; + El := Get_Chain (El); + end loop; + end Sem_Named_Entity_Chain; + begin + -- The attribute specification was not yet applied. + Res := False; + + -- LRM 5.1 Attribute specification + -- o If a list of entity designators is supplied, then the + -- attribute specification applies to the named entities denoted + -- by those designators. + -- + -- o If the reserved word OTHERS is supplied, then the attribute + -- specification applies to named entities of the specified class + -- that are declared in the immediately enclosing declarative + -- part [...] + -- + -- o If the reserved word ALL is supplied, then the attribute + -- specification applies to all named entities of the specified + -- class that are declared in the immediatly enclosing + -- declarative part. + + -- NOTE: therefore, ALL/OTHERS do not apply to named entities declared + -- beyond the immediate declarative part, such as design unit or + -- interfaces. + if Is_Designator then + if Is_Error (Name) then + pragma Assert (Flags.Flag_Force_Analysis); + return True; + end if; + + -- LRM 5.1 Attribute specification + -- An attribute specification for an attribute of a design unit + -- (i.e. an entity declaration, an architecture, a configuration + -- or a package) must appear immediatly within the declarative part + -- of that design unit. + case Get_Kind (Scope) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Package_Declaration => + Sem_Named_Entity (Scope); + when others => + null; + end case; + + -- LRM 5.1 Attribute specification + -- Similarly, an attribute specification for an attribute of an + -- interface object of a design unit, subprogram or block statement + -- must appear immediatly within the declarative part of that design + -- unit, subprogram, or block statement. + case Get_Kind (Scope) is + when Iir_Kind_Entity_Declaration => + Sem_Named_Entity_Chain (Get_Generic_Chain (Scope)); + Sem_Named_Entity_Chain (Get_Port_Chain (Scope)); + when Iir_Kind_Block_Statement => + declare + Header : constant Iir := Get_Block_Header (Scope); + begin + if Header /= Null_Iir then + Sem_Named_Entity_Chain (Get_Generic_Chain (Header)); + Sem_Named_Entity_Chain (Get_Port_Chain (Header)); + end if; + end; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + declare + Spec : Iir; + begin + Spec := Get_Subprogram_Specification (Scope); + Sem_Named_Entity_Chain + (Get_Interface_Declaration_Chain (Spec)); + end; + when others => + null; + end case; + end if; + + case Get_Kind (Scope) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Generate_Statement_Body => + Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); + Sem_Named_Entity_Chain (Get_Concurrent_Statement_Chain (Scope)); + when Iir_Kind_Block_Statement => + declare + Guard : constant Iir := Get_Guard_Decl (Scope); + begin + if Guard /= Null_Iir then + Sem_Named_Entity (Guard); + end if; + end; + Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); + Sem_Named_Entity_Chain (Get_Concurrent_Statement_Chain (Scope)); + when Iir_Kind_Configuration_Declaration => + null; + when Iir_Kind_Package_Declaration => + Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); + when Iir_Kinds_Process_Statement => + Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); + Sem_Named_Entity_Chain (Get_Sequential_Statement_Chain (Scope)); + when Iir_Kind_Package_Body => + Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); + Sem_Named_Entity_Chain (Get_Sequential_Statement_Chain (Scope)); + when others => + Error_Kind ("sem_named_entities", Scope); + end case; + return Res; + end Sem_Named_Entities; + + procedure Sem_Signature_Entity_Designator + (Sig : Iir_Signature; Attr : Iir_Attribute_Specification) + is + Prefix : Iir; + Inter : Name_Interpretation_Type; + List : Iir_List; + Name : Iir; + begin + List := Create_Iir_List; + + -- Sem_Name cannot be used here (at least not directly) because only + -- the declarations of the current scope are considered. + Prefix := Get_Signature_Prefix (Sig); + Inter := Get_Interpretation (Get_Identifier (Prefix)); + while Valid_Interpretation (Inter) loop + exit when not Is_In_Current_Declarative_Region (Inter); + if not Is_Potentially_Visible (Inter) then + Name := Get_Declaration (Inter); + -- LRM 5.1 Attribute Specification + -- The entity tag of an entity designator containing a signature + -- must denote the name of one or more subprograms or enumeration + -- literals. + case Get_Kind (Name) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Enumeration_Literal => + Append_Element (List, Name); + when others => + Error_Msg_Sem + (+Sig, "entity tag must denote a subprogram or a literal"); + end case; + end if; + Inter := Get_Next_Interpretation (Inter); + end loop; + + Name := Sem_Decls.Sem_Signature (Create_Overload_List (List), Sig); + if Name = Null_Iir then + return; + end if; + + Set_Named_Entity (Prefix, Name); + Prefix := Finish_Sem_Name (Prefix); + Set_Signature_Prefix (Sig, Prefix); + + Attribute_A_Decl (Name, Attr, True, True); + end Sem_Signature_Entity_Designator; + + procedure Sem_Attribute_Specification + (Spec : Iir_Attribute_Specification; Scope : Iir) + is + -- Emit an error message when NAME is not found. + procedure Error_Attribute_Specification (Name : Iir) + is + Inter : Name_Interpretation_Type; + Decl : Iir; + begin + if Flag_Relaxed_Rules or Vhdl_Std = Vhdl_93c then + -- Some (clueless ?) vendors put attribute specifications in + -- architectures for ports (declared in entities). This is not + -- valid according to the LRM (eg: LRM02 5.1 Attribute + -- specification). Be tolerant. + Inter := Get_Interpretation (Get_Identifier (Name)); + if Valid_Interpretation (Inter) then + Decl := Get_Declaration (Inter); + if Get_Kind (Decl) = Iir_Kind_Interface_Signal_Declaration + and then (Get_Kind (Get_Parent (Decl)) + = Iir_Kind_Entity_Declaration) + and then Get_Kind (Scope) = Iir_Kind_Architecture_Body + then + Warning_Msg_Sem + (Warnid_Specs, +Name, + "attribute for port %i must be specified in the entity", + (1 => +Name)); + return; + end if; + end if; + end if; + + Error_Msg_Sem + (+Name, "no %i for attribute specification", (1 => +Name)); + end Error_Attribute_Specification; + + use Vhdl.Tokens; + + Name : Iir; + Attr : Iir_Attribute_Declaration; + Attr_Type : Iir; + List : Iir_Flist; + Expr : Iir; + Res : Boolean; + begin + -- LRM93 5.1 + -- The attribute designator must denote an attribute. + Name := Sem_Denoting_Name (Get_Attribute_Designator (Spec)); + Set_Attribute_Designator (Spec, Name); + + Attr := Get_Named_Entity (Name); + if Get_Kind (Attr) /= Iir_Kind_Attribute_Declaration then + Error_Class_Match (Name, "attribute"); + return; + end if; + + -- LRM 5.1 + -- The type of the expression in the attribute specification must be + -- the same as (or implicitly convertible to) the type mark in the + -- corresponding attribute declaration. + Attr_Type := Get_Type (Attr); + Expr := Sem_Expression (Get_Expression (Spec), Attr_Type); + if Expr /= Null_Iir then + Check_Read (Expr); + Expr := Eval_Expr_If_Static (Expr); + Set_Expression (Spec, Expr); + + -- LRM 5.1 + -- If the entity name list denotes an entity declaration, + -- architecture body or configuration declaration, then the + -- expression is required to be locally static. + -- GHDL: test based on the entity_class. + case Get_Entity_Class (Spec) is + when Tok_Entity + | Tok_Architecture + | Tok_Configuration => + if Get_Expr_Staticness (Expr) /= Locally then + Error_Msg_Sem + (+Spec, + "attribute expression for %t must be locally static", + +Get_Entity_Class (Spec)); + end if; + when others => + null; + end case; + else + Set_Expression + (Spec, Create_Error_Expr (Get_Expression (Spec), Attr_Type)); + end if; + + -- LRM93 3.2.1.1 Index constraints and discrete ranges + -- - For an attribute whose value is specified by an attribute + -- specification, the index ranges are defined by the expression + -- given in the specification, if the subtype of the attribute is + -- unconstrained [...] + -- GHDL: For attribute value. + + -- LRM 5.1 + -- The entity name list identifies those named entities, both + -- implicitly and explicitly defined, that inherit the attribute, as + -- defined below: + List := Get_Entity_Name_List (Spec); + if List = Iir_Flist_All then + -- o If the reserved word ALL is supplied, then the attribute + -- specification applies to all named entities of the specified + -- class that are declared in the immediatly enclosing + -- declarative part. + Res := Sem_Named_Entities (Scope, Null_Iir, Spec, True); + if Res = False and then Is_Warning_Enabled (Warnid_Specs) then + Warning_Msg_Sem + (Warnid_Specs, +Spec, + "attribute specification apply to no named entity"); + end if; + elsif List = Iir_Flist_Others then + -- o If the reserved word OTHERS is supplied, then the attribute + -- specification applies to named entities of the specified class + -- that are declared in the immediately enclosing declarative + -- part, provided that each such entity is not explicitly named + -- in the entity name list of a previous attribute specification + -- for the given attribute. + Res := Sem_Named_Entities (Scope, Null_Iir, Spec, False); + if Res = False and then Is_Warning_Enabled (Warnid_Specs) then + Warning_Msg_Sem + (Warnid_Specs, +Spec, + "attribute specification apply to no named entity"); + end if; + elsif List = Null_Iir_Flist then + pragma Assert (Flags.Flag_Force_Analysis); + null; + else + -- o If a list of entity designators is supplied, then the + -- attribute specification applies to the named entities denoted + -- by those designators. + declare + El : Iir; + begin + for I in Flist_First .. Flist_Last (List) loop + El := Get_Nth_Element (List, I); + if Get_Kind (El) = Iir_Kind_Signature then + Sem_Signature_Entity_Designator (El, Spec); + else + -- LRM 5.1 + -- It is an error if the class of those names is not the + -- same as that denoted by entity class. + if not Sem_Named_Entities (Scope, El, Spec, True) then + Error_Attribute_Specification (El); + end if; + end if; + end loop; + end; + end if; + + -- Reverse the chain of attribute value in specification, so that they + -- are in textual order. This is important if the expression is not + -- static. + declare + El : Iir; + New_El : Iir; + Tmp : Iir; + begin + El := Get_Attribute_Value_Spec_Chain (Spec); + New_El := Null_Iir; + while Is_Valid (El) loop + Tmp := Get_Spec_Chain (El); + Set_Spec_Chain (El, New_El); + New_El := El; + El := Tmp; + end loop; + Set_Attribute_Value_Spec_Chain (Spec, New_El); + end; + end Sem_Attribute_Specification; + + procedure Check_Post_Attribute_Specification + (Attr_Spec_Chain : Iir; Decl : Iir) + is + use Vhdl.Tokens; + + Has_Error : Boolean; + Spec : Iir; + Decl_Class : Token_Type; + Decl_Class2 : Token_Type; + Ent_Class : Token_Type; + begin + -- Some declaration items can never be attributed. + Decl_Class2 := Tok_Eof; + case Get_Kind (Decl) is + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kind_Use_Clause + | Iir_Kind_Attribute_Declaration + | Iir_Kinds_Signal_Attribute + | Iir_Kind_Disconnection_Specification => + return; + when Iir_Kind_Anonymous_Type_Declaration => + -- A physical type definition declares units. + if Get_Kind (Get_Type_Definition (Decl)) + = Iir_Kind_Physical_Type_Definition + then + Decl_Class := Tok_Units; + else + return; + end if; + when Iir_Kind_Attribute_Specification => + Decl_Class := Get_Entity_Class (Decl); + when Iir_Kind_Type_Declaration => + Decl_Class := Tok_Type; + -- An enumeration type declares literals. + if Get_Kind (Get_Type_Definition (Decl)) + = Iir_Kind_Enumeration_Type_Definition + then + Decl_Class2 := Tok_Literal; + end if; + when Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kind_Object_Alias_Declaration => + Decl_Class := Get_Entity_Class_Kind (Get_Name (Decl)); + -- NOTE: for non-object alias that declares an enumeration type + -- or a physical type, no need to set decl_class2, since + -- all implicit aliases are checked. + when others => + Decl_Class := Get_Entity_Class_Kind (Decl); + end case; + + Spec := Attr_Spec_Chain; + -- Skip itself (newly added, therefore first of the chain). + if Spec = Decl then + Spec := Get_Attribute_Specification_Chain (Spec); + end if; + while Spec /= Null_Iir loop + pragma Assert (Get_Entity_Name_List (Spec) in Iir_Flists_All_Others); + Ent_Class := Get_Entity_Class (Spec); + if Ent_Class = Decl_Class or Ent_Class = Decl_Class2 then + Has_Error := False; + + if Get_Kind (Decl) = Iir_Kind_Attribute_Specification then + -- LRM 5.1 Attribute specifications + -- An attribute specification with the entity name list OTHERS + -- or ALL for a given entity class that appears in a + -- declarative part must be the last such specification for the + -- given attribute for the given entity class in that + -- declarative part. + if Get_Identifier (Get_Attribute_Designator (Decl)) + = Get_Identifier (Get_Attribute_Designator (Spec)) + then + Error_Msg_Sem + (+Decl, "no attribute specification may follow an " + & "all/others spec", Cont => True); + Has_Error := True; + end if; + else + -- LRM 5.1 Attribute specifications + -- It is an error if a named entity in the specificied entity + -- class is declared in a given declarative part following such + -- an attribute specification. + Error_Msg_Sem + (+Decl, "no named entity may follow an all/others attribute " + & "specification", Cont => True); + Has_Error := True; + end if; + if Has_Error then + Error_Msg_Sem + (+Spec, "(previous all/others specification for the given " + &"entity class)"); + end if; + end if; + Spec := Get_Attribute_Specification_Chain (Spec); + end loop; + end Check_Post_Attribute_Specification; + + -- Compare ATYPE and TYPE_MARK. + -- ATYPE is a type definition, which can be anonymous. + -- TYPE_MARK is a subtype definition, established from a type mark. + -- Therefore, it is the name of a type or a subtype. + -- Return TRUE iff the type mark of ATYPE is TYPE_MARK. + function Is_Same_Type_Mark (Atype : Iir; Type_Mark : Iir) + return Boolean is + begin + if Get_Kind (Atype) in Iir_Kinds_Subtype_Definition + and then Is_Anonymous_Type_Definition (Atype) + then + -- FIXME: to be removed; used to catch uninitialized type_mark. + if Get_Subtype_Type_Mark (Atype) = Null_Iir then + raise Internal_Error; + end if; + return Get_Type (Get_Subtype_Type_Mark (Atype)) = Type_Mark; + else + return Atype = Type_Mark; + end if; + end Is_Same_Type_Mark; + + procedure Sem_Disconnection_Specification + (Dis : Iir_Disconnection_Specification) + is + Type_Mark : Iir; + Atype : Iir; + Time_Expr : Iir; + List : Iir_Flist; + El : Iir; + Sig : Iir; + Prefix : Iir; + begin + -- Sem type mark. + Type_Mark := Get_Type_Mark (Dis); + Type_Mark := Sem_Type_Mark (Type_Mark); + Set_Type_Mark (Dis, Type_Mark); + Atype := Get_Type (Type_Mark); + + -- LRM93 5.3 + -- The time expression in a disconnection specification must be static + -- and must evaluate to a non-negative value. + Time_Expr := Sem_Expression + (Get_Expression (Dis), Time_Subtype_Definition); + if Time_Expr /= Null_Iir then + Check_Read (Time_Expr); + Set_Expression (Dis, Time_Expr); + if Get_Expr_Staticness (Time_Expr) < Globally then + Error_Msg_Sem (+Time_Expr, "time expression must be static"); + end if; + end if; + + List := Get_Signal_List (Dis); + if List in Iir_Flists_All_Others then + -- FIXME: checks todo + null; + else + for I in Flist_First .. Flist_Last (List) loop + El := Get_Nth_Element (List, I); + + if Is_Error (El) then + Sig := Null_Iir; + else + Sem_Name (El); + El := Finish_Sem_Name (El); + Set_Nth_Element (List, I, El); + + Sig := Get_Named_Entity (El); + Sig := Name_To_Object (Sig); + end if; + + if Sig /= Null_Iir then + Set_Type (El, Get_Type (Sig)); + Prefix := Get_Object_Prefix (Sig); + -- LRM93 5.3 + -- Each signal name in a signal list in a guarded signal + -- specification must be a locally static name that + -- denotes a guarded signal. + case Get_Kind (Prefix) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + null; + when others => + Error_Msg_Sem (+El, "object must be a signal"); + return; + end case; + if Get_Name_Staticness (Sig) /= Locally then + Error_Msg_Sem (+El, "signal name must be locally static"); + end if; + if not Get_Guarded_Signal_Flag (Prefix) then + Error_Msg_Sem (+El, "signal must be a guarded signal"); + end if; + Set_Has_Disconnect_Flag (Prefix, True); + + -- LRM93 5.3 + -- If the guarded signal is a declared signal or a slice of + -- thereof, the type mark must be the same as the type mark + -- indicated in the guarded signal specification. + -- If the guarded signal is an array element of an explicitly + -- declared signal, the type mark must be the same as the + -- element subtype indication in the (explicit or implicit) + -- array type declaration that declares the base type of the + -- explicitly declared signal. + -- If the guarded signal is a record element of an explicitly + -- declared signal, then the type mark must be the same as + -- the type mark in the element subtype definition of the + -- record type declaration that declares the type of the + -- explicitly declared signal. + -- FIXME: to be checked: the expression type (as set by + -- sem_expression) may be a base type instead of a type mark. + if not Is_Same_Type_Mark (Get_Type (Sig), Atype) then + Error_Msg_Sem (+El, "type mark and signal type mismatch"); + end if; + + -- LRM93 5.3 + -- Each signal must be declared in the declarative part + -- enclosing the disconnection specification. + -- FIXME: todo. + elsif not Is_Error (El) + and then Get_Designated_Entity (El) /= Error_Mark + then + Error_Msg_Sem (+El, "name must designate a signal"); + end if; + end loop; + end if; + end Sem_Disconnection_Specification; + + -- Analyze entity aspect ASPECT and return the entity declaration. + -- Return NULL_IIR if not found. + function Sem_Entity_Aspect (Aspect : Iir) return Iir is + begin + case Get_Kind (Aspect) is + when Iir_Kind_Entity_Aspect_Entity => + declare + Entity_Name : Iir; + Entity : Iir; + Arch_Name : Iir; + Arch_Unit : Iir; + begin + -- The entity. + Entity_Name := Sem_Denoting_Name (Get_Entity_Name (Aspect)); + Set_Entity_Name (Aspect, Entity_Name); + Entity := Get_Named_Entity (Entity_Name); + if Entity = Error_Mark then + return Null_Iir; + end if; + if Get_Kind (Entity) /= Iir_Kind_Entity_Declaration then + Error_Class_Match (Entity_Name, "entity"); + return Null_Iir; + end if; + -- Note: dependency is added by Sem_Denoting_Name. + + -- Check architecture. + Arch_Name := Get_Architecture (Aspect); + if Arch_Name /= Null_Iir then + Arch_Unit := Libraries.Find_Secondary_Unit + (Get_Design_Unit (Entity), Get_Identifier (Arch_Name)); + if Arch_Unit /= Null_Iir then + -- The architecture is known. + if Get_Date_State (Arch_Unit) >= Date_Parse then + -- And loaded! + Arch_Unit := Get_Library_Unit (Arch_Unit); + end if; + Set_Named_Entity (Arch_Name, Arch_Unit); + Xref_Ref (Arch_Name, Arch_Unit); + end if; + + -- FIXME: may emit a warning if the architecture does not + -- exist. + -- Note: the design needs the architecture. + Add_Dependence (Aspect); + end if; + return Entity; + end; + + when Iir_Kind_Entity_Aspect_Configuration => + declare + Conf_Name : Iir; + Conf : Iir; + begin + Conf_Name := + Sem_Denoting_Name (Get_Configuration_Name (Aspect)); + Set_Configuration_Name (Aspect, Conf_Name); + Conf := Get_Named_Entity (Conf_Name); + if Is_Error (Conf) then + return Null_Iir; + elsif Get_Kind (Conf) /= Iir_Kind_Configuration_Declaration then + Error_Class_Match (Conf, "configuration"); + return Null_Iir; + end if; + + return Get_Entity (Conf); + end; + + when Iir_Kind_Entity_Aspect_Open => + return Null_Iir; + + when others => + Error_Kind ("sem_entity_aspect", Aspect); + end case; + end Sem_Entity_Aspect; + + procedure Sem_Binding_Indication (Bind : Iir_Binding_Indication; + Parent : Iir; + Primary_Entity_Aspect : Iir) + is + Entity_Aspect : Iir; + Entity : Iir_Entity_Declaration; + begin + if Bind = Null_Iir then + raise Internal_Error; + end if; + + Entity_Aspect := Get_Entity_Aspect (Bind); + if Entity_Aspect /= Null_Iir then + Entity := Sem_Entity_Aspect (Entity_Aspect); + + -- LRM93 5.2.1 Binding Indication + -- An incremental binding indication must not have an entity aspect. + if Primary_Entity_Aspect /= Null_Iir then + Error_Msg_Sem + (+Bind, "entity aspect not allowed for incremental binding"); + end if; + + -- Return now in case of error. + if Entity = Null_Iir then + return; + end if; + else + -- LRM93 5.2.1 + -- When a binding indication is used in an explicit configuration + -- specification, it is an error if the entity aspect is absent. + case Get_Kind (Parent) is + when Iir_Kind_Component_Configuration => + if Primary_Entity_Aspect = Null_Iir then + Entity := Null_Iir; + else + case Get_Kind (Primary_Entity_Aspect) is + when Iir_Kind_Entity_Aspect_Entity => + Entity := Get_Entity (Primary_Entity_Aspect); + when others => + Error_Kind + ("sem_binding_indication", Primary_Entity_Aspect); + end case; + end if; + when Iir_Kind_Configuration_Specification => + Error_Msg_Sem + (+Bind, + "entity aspect required in a configuration specification"); + return; + when others => + raise Internal_Error; + end case; + end if; + if Entity = Null_Iir + or else Get_Kind (Entity) = Iir_Kind_Entity_Aspect_Open + then + -- LRM 5.2.1.1 Entity aspect + -- The third form of entity aspect is used to specify that the + -- indiciation of the design entity is to be defined. In this case, + -- the immediatly enclosing binding indication is said to not + -- imply any design entity. Furthermore, the immediatly enclosing + -- binding indication must not include a generic map aspect or a + -- port map aspect. + if Get_Generic_Map_Aspect_Chain (Bind) /= Null_Iir + or else Get_Port_Map_Aspect_Chain (Bind) /= Null_Iir + then + Error_Msg_Sem + (+Bind, "map aspect not allowed for open entity aspect"); + return; + end if; + else + Sem_Generic_Port_Association_Chain (Entity, Bind); + + -- LRM 5.2.1 Binding Indication + -- If the generic map aspect or port map aspect of a binding + -- indication is not present, then the default rules as described + -- in 5.2.2 apply. + -- GHDL: done in canon + end if; + end Sem_Binding_Indication; + + -- Set configuration_specification or component_configuration SPEC to + -- component instantiation COMP. + procedure Apply_Configuration_Specification + (Comp : Iir_Component_Instantiation_Statement; + Spec : Iir; + Primary_Entity_Aspect : in out Iir) + is + Prev_Spec : Iir; + Prev_Conf : Iir; + + procedure Prev_Spec_Error is + begin + Error_Msg_Sem + (+Spec, "%n is alreay bound by a configuration specification", + (1 => +Comp), Cont => True); + Error_Msg_Sem (+Prev_Spec, "(previous is %n)", +Prev_Spec); + end Prev_Spec_Error; + + Prev_Binding : Iir_Binding_Indication; + Prev_Entity_Aspect : Iir; + begin + Prev_Spec := Get_Configuration_Specification (Comp); + if Prev_Spec /= Null_Iir then + case Get_Kind (Spec) is + when Iir_Kind_Configuration_Specification => + Prev_Spec_Error; + return; + when Iir_Kind_Component_Configuration => + if Flags.Vhdl_Std = Vhdl_87 then + Prev_Spec_Error; + Error_Msg_Sem + (+Spec, "(incremental binding is not allowed in vhdl87)"); + return; + end if; + -- Incremental binding. + Prev_Binding := Get_Binding_Indication (Prev_Spec); + if Prev_Binding /= Null_Iir then + Prev_Entity_Aspect := Get_Entity_Aspect (Prev_Binding); + if Primary_Entity_Aspect = Null_Iir then + Primary_Entity_Aspect := Prev_Entity_Aspect; + else + -- FIXME: checks to do ? + null; + end if; + end if; + when others => + Error_Kind ("apply_configuration_specification", Spec); + end case; + end if; + Prev_Conf := Get_Component_Configuration (Comp); + if Prev_Conf /= Null_Iir then + case Get_Kind (Spec) is + when Iir_Kind_Configuration_Specification => + -- How can this happen ? + raise Internal_Error; + when Iir_Kind_Component_Configuration => + Error_Msg_Sem + (+Spec, "%n is already bound by a component configuration", + (1 => +Comp), Cont => True); + Error_Msg_Sem (+Prev_Conf, "(previous is %n)", +Prev_Conf); + return; + when others => + Error_Kind ("apply_configuration_specification(2)", Spec); + end case; + end if; + if Get_Kind (Spec) = Iir_Kind_Configuration_Specification then + Set_Configuration_Specification (Comp, Spec); + end if; + Set_Component_Configuration (Comp, Spec); + end Apply_Configuration_Specification; + + -- Analyze component_configuration or configuration_specification SPEC. + -- STMTS is the concurrent statement list related to SPEC. + procedure Sem_Component_Specification + (Parent_Stmts : Iir; Spec : Iir; Primary_Entity_Aspect : out Iir) + is + function Apply_Component_Specification + (Chain : Iir; Check_Applied : Boolean) return Boolean + is + Comp : constant Iir := Get_Named_Entity (Get_Component_Name (Spec)); + El : Iir; + Res : Boolean; + begin + if Chain = Null_Iir then + return False; + end if; + + El := Get_Concurrent_Statement_Chain (Chain); + Res := False; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Component_Instantiation_Statement => + if Is_Component_Instantiation (El) + and then + Get_Named_Entity (Get_Instantiated_Unit (El)) = Comp + and then + (not Check_Applied + or else Get_Component_Configuration (El) = Null_Iir) + then + Apply_Configuration_Specification + (El, Spec, Primary_Entity_Aspect); + Res := True; + end if; + when Iir_Kind_For_Generate_Statement + | Iir_Kind_If_Generate_Statement => + if False and then Flags.Vhdl_Std = Vhdl_87 then + Res := Res + or Apply_Component_Specification (El, Check_Applied); + end if; + when others => + null; + end case; + El := Get_Chain (El); + end loop; + return Res; + end Apply_Component_Specification; + + List : Iir_Flist; + El : Iir; + Inter : Sem_Scopes.Name_Interpretation_Type; + Comp : Iir; + Comp_Name : Iir; + Inst : Iir; + Inst_Unit : Iir; + begin + Primary_Entity_Aspect := Null_Iir; + Comp_Name := Get_Component_Name (Spec); + if Is_Error (Comp_Name) then + pragma Assert (Flags.Flag_Force_Analysis); + return; + end if; + Comp_Name := Sem_Denoting_Name (Comp_Name); + Set_Component_Name (Spec, Comp_Name); + Comp := Get_Named_Entity (Comp_Name); + if Get_Kind (Comp) /= Iir_Kind_Component_Declaration then + Error_Class_Match (Comp_Name, "component"); + return; + end if; + + List := Get_Instantiation_List (Spec); + if List = Iir_Flist_All then + -- LRM93 5.2 + -- * If the reserved word ALL is supplied, then the configuration + -- specification applies to all instances of the specified + -- component declaration whose labels are (implicitly) declared + -- in the immediately enclosing declarative region part. + -- This rule applies only to those component instantiation + -- statements whose corresponding instantiated units name + -- component. + if not Apply_Component_Specification (Parent_Stmts, False) + and then Is_Warning_Enabled (Warnid_Specs) + then + Warning_Msg_Sem (Warnid_Specs, +Spec, + "component specification applies to no instance"); + end if; + elsif List = Iir_Flist_Others then + -- LRM93 5.2 + -- * If the reserved word OTHERS is supplied, then the + -- configuration specification applies to instances of the + -- specified component declaration whoce labels are (implicitly) + -- declared in the immediatly enclosing declarative part, + -- provided that each such component instance is not explicitly + -- names in the instantiation list of a previous configuration + -- specification. + -- This rule applies only to those component instantiation + -- statements whose corresponding instantiated units name + -- components. + if not Apply_Component_Specification (Parent_Stmts, True) + and then Is_Warning_Enabled (Warnid_Specs) + then + Warning_Msg_Sem (Warnid_Specs, +Spec, + "component specification applies to no instance"); + end if; + else + -- LRM93 5.2 + -- * If a list of instantiation labels is supplied, then the + -- configuration specification applies to the corresponding + -- component instances. + -- Such labels must be (implicitly) declared within the + -- immediatly enclosing declarative part. + -- It is an error if these component instances are not instances + -- of the component declaration named in the component + -- specification. + -- It is also an error if any of the labels denote a component + -- instantiation statement whose corresponding instantiated unit + -- does not name a component. + -- FIXME: error message are *really* cryptic. + for I in Flist_First .. Flist_Last (List) loop + El := Get_Nth_Element (List, I); + Inter := Sem_Scopes.Get_Interpretation (Get_Identifier (El)); + if not Valid_Interpretation (Inter) then + Error_Msg_Sem + (+El, "no component instantation with label %i", +El); + elsif not Is_In_Current_Declarative_Region (Inter) then + -- FIXME. + Error_Msg_Sem (+El, "label not in block declarative part"); + else + Inst := Get_Declaration (Inter); + if Get_Kind (Inst) /= Iir_Kind_Component_Instantiation_Statement + then + Error_Msg_Sem + (+El, "label does not denote an instantiation"); + else + Inst_Unit := Get_Instantiated_Unit (Inst); + if Is_Entity_Instantiation (Inst) + or else (Get_Kind (Get_Named_Entity (Inst_Unit)) + /= Iir_Kind_Component_Declaration) + then + Error_Msg_Sem + (+El, "specification does not apply to " + & "direct instantiation"); + elsif Get_Named_Entity (Inst_Unit) /= Comp then + Error_Msg_Sem (+El, "component names mismatch"); + else + Apply_Configuration_Specification + (Inst, Spec, Primary_Entity_Aspect); + Xref_Ref (El, Inst); + Set_Named_Entity (El, Inst); + Set_Is_Forward_Ref (El, True); + end if; + end if; + end if; + end loop; + end if; + end Sem_Component_Specification; + + procedure Sem_Configuration_Specification + (Parent_Stmts : Iir; Conf : Iir_Configuration_Specification) + is + Primary_Entity_Aspect : Iir; + Component : Iir; + begin + Sem_Component_Specification (Parent_Stmts, Conf, Primary_Entity_Aspect); + Component := Get_Component_Name (Conf); + if Is_Error (Component) then + pragma Assert (Flags.Flag_Force_Analysis); + return; + end if; + Component := Get_Named_Entity (Component); + + -- Return now in case of error. + if Get_Kind (Component) /= Iir_Kind_Component_Declaration then + return; + end if; + -- Extend scope of component interface declaration. + Sem_Scopes.Open_Scope_Extension; + Sem_Scopes.Add_Component_Declarations (Component); + Sem_Binding_Indication + (Get_Binding_Indication (Conf), Conf, Primary_Entity_Aspect); + -- FIXME: check default port and generic association. + Sem_Scopes.Close_Scope_Extension; + end Sem_Configuration_Specification; + + function Sem_Create_Default_Binding_Indication + (Comp : Iir_Component_Declaration; + Entity_Unit : Iir_Design_Unit; + Parent : Iir; + Force : Boolean; + Create_Map_Aspect : Boolean) + return Iir_Binding_Indication + is + Entity : Iir_Entity_Declaration; + Entity_Name : Iir; + Aspect : Iir; + Res : Iir; + Design_Unit : Iir_Design_Unit; + begin + -- LRM 5.2.2 + -- The default binding indication consists of a default entity aspect, + -- together with a default generic map aspect and a default port map + -- aspect, as appropriate. + + if Entity_Unit = Null_Iir then + if not Force then + return Null_Iir; + end if; + + -- LRM 5.2.2 + -- If no visible entity declaration has the same simple name as that + -- of the instantiated component, then the default entity aspect is + -- OPEN. + Aspect := Create_Iir (Iir_Kind_Entity_Aspect_Open); + Location_Copy (Aspect, Comp); + Res := Create_Iir (Iir_Kind_Binding_Indication); + Set_Entity_Aspect (Res, Aspect); + return Res; + else + -- LRM 5.2.2 + -- Otherwise, the default entity aspect is of the form: + -- ENTITY entity_name ( architecture_identifier) + -- where the entity name is the simple name of the instantiated + -- component and the architecture identifier is the same as the + -- simple name of the most recently analyzed architecture body + -- associated with the entity declaration. + -- + -- If this rule is applied either to a binding indication contained + -- within a configuration specification or to a component + -- configuration that does not contain an explicit inner block + -- configuration, then the architecture identifier is determined + -- during elaboration of the design hierarchy containing the binding + -- indication. + -- + -- Likewise, if a component instantiation statement contains an + -- instantiated unit containing the reserved word ENTITY, but does + -- not contain an explicitly specified architecture identifier, this + -- rule is applied during the elaboration of the design hierarchy + -- containing a component instantiation statement. + -- + -- In all other cases, this rule is applied during analysis of the + -- binding indication. + -- + -- It is an error if there is no architecture body associated with + -- the entity declaration denoted by an entity name that is the + -- simple name of the instantiated component. + null; + end if; + + Design_Unit := Load_Primary_Unit + (Get_Library (Get_Design_File (Entity_Unit)), + Get_Identifier (Get_Library_Unit (Entity_Unit)), + Parent); + if Design_Unit = Null_Iir then + -- Found an entity which is not in the library. + raise Internal_Error; + end if; + + Entity := Get_Library_Unit (Design_Unit); + + Res := Create_Iir (Iir_Kind_Binding_Indication); + Aspect := Create_Iir (Iir_Kind_Entity_Aspect_Entity); + Location_Copy (Aspect, Parent); + + -- Create a name for the entity. As this is a default binding + -- indication, the design unit does *NOT* depend on the entity, so the + -- reference is a forward reference. + Entity_Name := Build_Simple_Name (Entity, Parent); + Set_Is_Forward_Ref (Entity_Name, True); + + Set_Entity_Name (Aspect, Entity_Name); + Set_Entity_Aspect (Res, Aspect); + + if Create_Map_Aspect then + -- LRM 5.2.2 + -- The default binding indication includes a default generic map + -- aspect if the design entity implied by the entity aspect contains + -- formal generics. + Set_Generic_Map_Aspect_Chain + (Res, + Create_Default_Map_Aspect (Comp, Entity, Map_Generic, Parent)); + + -- LRM 5.2.2 + -- The default binding indication includes a default port map aspect + -- if the design entity implied by the entity aspect contains formal + -- ports. + Set_Port_Map_Aspect_Chain + (Res, Create_Default_Map_Aspect (Comp, Entity, Map_Port, Parent)); + end if; + + return Res; + end Sem_Create_Default_Binding_Indication; + + -- LRM 5.2.2 + -- The default binding indication includes a default generic map aspect + -- if the design entity implied by the entity aspect contains formal + -- generics. + -- + -- The default generic map aspect associates each local generic in + -- the corresponding component instantiation (if any) with a formal + -- of the same simple name. + -- It is an error if such a formal does not exist, or if its mode and + -- type are not appropriate for such an association. + -- Any remaining unassociated formals are associated with the actual + -- designator OPEN. + + -- LRM 5.2.2 + -- The default binding indication includes a default port map aspect + -- if the design entity implied by the entity aspect contains formal + -- ports. + -- + -- The default port map aspect associates each local port in the + -- corresponding component instantiation (if any) with a formal of + -- the same simple name. + -- It is an error if such a formal does not exist, or if its mode + -- and type are not appropriate for such an association. + -- Any remaining unassociated formals are associated with the actual + -- designator OPEN. + function Create_Default_Map_Aspect + (Comp : Iir; Entity : Iir; Kind : Map_Kind_Type; Parent : Iir) + return Iir + is + Error : Boolean; + + procedure Error_Header is + begin + if Error then + return; + end if; + Error_Msg_Sem + (+Parent, "for default port binding of %n:", + (1 => +Parent), Cont => True); + Error := True; + end Error_Header; + + Res, Last : Iir; + Comp_El, Ent_El : Iir; + Assoc : Iir; + Name : Iir; + Found : Natural; + Comp_Chain : Iir; + Ent_Chain : Iir; + begin + case Kind is + when Map_Generic => + Ent_Chain := Get_Generic_Chain (Entity); + Comp_Chain := Get_Generic_Chain (Comp); + when Map_Port => + Ent_Chain := Get_Port_Chain (Entity); + Comp_Chain := Get_Port_Chain (Comp); + end case; + + -- No error found yet. + Error := False; + + Sub_Chain_Init (Res, Last); + Found := 0; + Ent_El := Ent_Chain; + while Ent_El /= Null_Iir loop + -- Find the component generic/port with the same name. + Comp_El := Find_Name_In_Chain (Comp_Chain, Get_Identifier (Ent_El)); + if Comp_El = Null_Iir then + Assoc := Create_Iir (Iir_Kind_Association_Element_Open); + Location_Copy (Assoc, Parent); + else + if Are_Nodes_Compatible (Comp_El, Ent_El) = Not_Compatible then + Error_Header; + Error_Msg_Sem + (+Parent, "type of %n declared at %l", + (+Comp_El, +Comp_El), Cont => True); + Error_Msg_Sem + (+Parent, "not compatible with type of %n declared at %l", + (+Ent_El, +Ent_El)); + elsif Kind = Map_Port + and then not Check_Port_Association_Mode_Restrictions + (Ent_El, Comp_El, Null_Iir) + then + Error_Header; + Error_Msg_Sem (+Parent, "cannot associate " + & Get_Mode_Name (Get_Mode (Ent_El)) + & " %n declared at %l", + (+Ent_El, +Ent_El), Cont => True); + Error_Msg_Sem (+Parent, "with actual port of mode " + & Get_Mode_Name (Get_Mode (Comp_El)) + & " declared at %l", +Comp_El); + end if; + Assoc := Create_Iir (Iir_Kind_Association_Element_By_Expression); + Location_Copy (Assoc, Parent); + Name := Build_Simple_Name (Comp_El, Parent); + Set_Type (Name, Get_Type (Comp_El)); + Set_Actual (Assoc, Name); + if Kind = Map_Port and then not Error then + Check_Port_Association_Bounds_Restrictions + (Ent_El, Comp_El, Assoc); + end if; + Found := Found + 1; + end if; + Set_Whole_Association_Flag (Assoc, True); + + -- Create the formal name. This is a forward reference as the + -- current design unit does not depend on the entity. + Name := Build_Simple_Name (Ent_El, Parent); + Set_Is_Forward_Ref (Name, True); + Set_Type (Name, Get_Type (Ent_El)); + Set_Formal (Assoc, Name); + + if Kind = Map_Port + and then not Error + and then Comp_El /= Null_Iir + then + Set_Collapse_Signal_Flag + (Assoc, Can_Collapse_Signals (Assoc, Ent_El)); + end if; + Sub_Chain_Append (Res, Last, Assoc); + Ent_El := Get_Chain (Ent_El); + end loop; + if Iir_Chains.Get_Chain_Length (Comp_Chain) /= Found then + -- At least one component generic/port cannot be associated with + -- the entity one. + + -- Disp unassociated interfaces. + Comp_El := Comp_Chain; + while Comp_El /= Null_Iir loop + Ent_El := Find_Name_In_Chain (Ent_Chain, Get_Identifier (Comp_El)); + if Ent_El = Null_Iir then + Error_Header; + Error_Msg_Sem (+Parent, "%n has no association in %n", + (+Comp_El, +Entity)); + end if; + Comp_El := Get_Chain (Comp_El); + end loop; + end if; + if Error then + return Null_Iir; + else + return Res; + end if; + end Create_Default_Map_Aspect; + + -- LRM93 §5.2.2 + function Get_Visible_Entity_Declaration (Comp: Iir_Component_Declaration) + return Iir_Design_Unit + is + -- Return the design_unit if DECL is an entity declaration or the + -- design unit of an entity declaration. Otherwise return Null_Iir. + -- This double check is needed as the interpretation may be both. + function Is_Entity_Declaration (Decl : Iir) return Iir is + begin + if Get_Kind (Decl) = Iir_Kind_Entity_Declaration then + return Get_Design_Unit (Decl); + elsif Get_Kind (Decl) = Iir_Kind_Design_Unit + and then + Get_Kind (Get_Library_Unit (Decl)) = Iir_Kind_Entity_Declaration + then + return Decl; + else + return Null_Iir; + end if; + end Is_Entity_Declaration; + + Name : constant Name_Id := Get_Identifier (Comp); + Inter : Name_Interpretation_Type; + Decl : Iir; + Res : Iir; + Target_Lib : Iir; + begin + Inter := Get_Interpretation (Name); + + if Valid_Interpretation (Inter) then + -- LRM93 5.2.2 Default binding indication + -- A visible entity declaration is either: + -- + -- a) An entity declaration that has the same simple name as that of + -- the instantiated component and that is directly visible + -- (see 10.3), + Decl := Get_Declaration (Inter); + Res := Is_Entity_Declaration (Decl); + if Res /= Null_Iir then + return Res; + end if; + + -- b) An entity declaration that has the same simple name that of + -- the instantiated component and that would be directly + -- visible in the absence of a directly visible (see 10.3) + -- component declaration with the same simple name as that + -- of the entity declaration, or + if Get_Kind (Decl) = Iir_Kind_Component_Declaration then + Inter := Get_Under_Interpretation (Name); + if Valid_Interpretation (Inter) then + Decl := Get_Declaration (Inter); + Res := Is_Entity_Declaration (Decl); + if Res /= Null_Iir then + return Res; + end if; + end if; + end if; + end if; + + -- VHDL02: + -- c) An entity declaration denoted by "L.C", where L is the target + -- library and C is the simple name of the instantiated component. + -- The target library is the library logical name of the library + -- containing the design unit in which the component C is + -- declared. + if Flags.Flag_Syn_Binding + or Flags.Vhdl_Std >= Vhdl_02 + or Flags.Vhdl_Std = Vhdl_93c + then + -- Find target library. + Target_Lib := Comp; + while Get_Kind (Target_Lib) /= Iir_Kind_Library_Declaration loop + Target_Lib := Get_Parent (Target_Lib); + end loop; + + Decl := Libraries.Find_Primary_Unit (Target_Lib, Name); + if Decl /= Null_Iir then + Res := Is_Entity_Declaration (Decl); + if Res /= Null_Iir then + return Res; + end if; + end if; + end if; + + -- --syn-binding + -- Search for any entity. + if Flags.Flag_Syn_Binding then + Decl := Libraries.Find_Entity_For_Component (Name); + if Decl /= Null_Iir then + return Decl; + end if; + end if; + + return Null_Iir; + end Get_Visible_Entity_Declaration; + + -- Explain why there is no default binding for COMP. + procedure Explain_No_Visible_Entity (Comp: Iir_Component_Declaration) + is + Inter : Name_Interpretation_Type; + Name : Name_Id; + Decl : Iir; + begin + Name := Get_Identifier (Comp); + Inter := Get_Interpretation (Name); + + if Valid_Interpretation (Inter) then + -- LRM93 5.2.2 Default binding indication + -- A visible entity declaration is either: + -- + -- a) An entity declaration that has the same simple name as that of + -- the instantiated component and that is directly visible + -- (see 10.3), + Decl := Get_Declaration (Inter); + Warning_Msg_Elab + (Warnid_Default_Binding, Decl, "visible declaration for %i", +Name); + + -- b) An entity declaration that has the same simple name that of + -- the instantiated component and that would be directly + -- visible in the absence of a directly visible (see 10.3) + -- component declaration with the same simple name as that + -- of the entity declaration, or + if Get_Kind (Decl) = Iir_Kind_Component_Declaration then + Inter := Get_Under_Interpretation (Name); + if Valid_Interpretation (Inter) then + Decl := Get_Declaration (Inter); + Warning_Msg_Elab (Warnid_Default_Binding, Comp, + "interpretation behind the component is %n", + +Decl); + end if; + end if; + end if; + + -- VHDL02: + -- c) An entity declaration denoted by "L.C", where L is the target + -- library and C is the simple name of the instantiated component. + -- The target library is the library logical name of the library + -- containing the design unit in which the component C is + -- declared. + if Flags.Vhdl_Std >= Vhdl_02 + or else Flags.Vhdl_Std = Vhdl_93c + then + Decl := Comp; + while Get_Kind (Decl) /= Iir_Kind_Library_Declaration loop + Decl := Get_Parent (Decl); + end loop; + + Warning_Msg_Elab (Warnid_Default_Binding, Comp, + "no entity %i in %n", (+Name, +Decl)); + end if; + end Explain_No_Visible_Entity; + + procedure Sem_Specification_Chain (Decls_Parent : Iir; Parent_Stmts: Iir) + is + Decl: Iir; + begin + Decl := Get_Declaration_Chain (Decls_Parent); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Configuration_Specification => + Sem_Configuration_Specification (Parent_Stmts, Decl); + when others => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + end Sem_Specification_Chain; +end Vhdl.Sem_Specs; diff --git a/src/vhdl/vhdl-sem_specs.ads b/src/vhdl/vhdl-sem_specs.ads new file mode 100644 index 000000000..5c4fef962 --- /dev/null +++ b/src/vhdl/vhdl-sem_specs.ads @@ -0,0 +1,99 @@ +-- Semantic analysis. +-- 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 Types; use Types; +with Iirs; use Iirs; +with Vhdl.Tokens; + +package Vhdl.Sem_Specs is + -- Return the attribute_value for named entity ENT and attribute identifier + -- ID. Return Null_Iir if ENT was not decorated with attribute ID. + function Find_Attribute_Value (Ent : Iir; Id : Name_Id) return Iir; + + -- Return the node containing the attribute_value_chain field for DECL. + -- This is the parent of the attribute specification, so in general this + -- is also the parent of the declaration, but there are exceptions... + function Get_Attribute_Value_Chain_Parent (Decl : Iir) return Iir; + + function Get_Entity_Class_Kind (Decl : Iir) return Vhdl.Tokens.Token_Type; + + procedure Sem_Attribute_Specification + (Spec : Iir_Attribute_Specification; Scope : Iir); + + -- Check declarations following an ALL/OTHERS attribute specification. + -- ATTR_SPEC_CHAIN is the linked list of all attribute specifications whith + -- the entity name list ALL or OTHERS until the current declaration DECL. + -- So no specification in the chain must match the declaration. + procedure Check_Post_Attribute_Specification + (Attr_Spec_Chain : Iir; Decl : Iir); + + procedure Sem_Disconnection_Specification + (Dis : Iir_Disconnection_Specification); + + procedure Sem_Configuration_Specification + (Parent_Stmts : Iir; Conf : Iir_Configuration_Specification); + + -- Analyze binding indication BIND of configuration specification or + -- component configuration PARENT. + -- PRIMARY_ENTITY_ASPECT is not Null_Iir for an incremental binding. + procedure Sem_Binding_Indication (Bind : Iir_Binding_Indication; + Parent : Iir; + Primary_Entity_Aspect : Iir); + + -- Analyze entity aspect ASPECT and return the entity declaration. + -- Return NULL_IIR if not found. + function Sem_Entity_Aspect (Aspect : Iir) return Iir; + + -- Analyze component_configuration or configuration_specification SPEC. + -- STMTS is the concurrent statement list related to SPEC. + procedure Sem_Component_Specification + (Parent_Stmts : Iir; Spec : Iir; Primary_Entity_Aspect : out Iir); + + -- Create a default binding indication for component COMP which will be + -- bound with entity ENTITY_UNIT. + -- If ENTITY_UNIT is NULL_IIR, the component is not bound. + -- If FORCE is True, a binding indication will be created even if the + -- component is not bound (this is an open binding indication). + -- If CREATE_MAP_ASPECT is true, port and generic map aspect are created. + -- PARENT is used to report error. + function Sem_Create_Default_Binding_Indication + (Comp : Iir_Component_Declaration; + Entity_Unit : Iir_Design_Unit; + Parent : Iir; + Force : Boolean; + Create_Map_Aspect : Boolean) + return Iir_Binding_Indication; + + -- Create a default generic or port map aspect that associates all elements + -- of ENTITY (if any) to elements of COMP with the same name or to + -- an open association. + -- If KIND is GENERIC_MAP, apply this on generics, if KIND is PORT_MAP, + -- apply this on ports. + -- PARENT is used to report errors. + type Map_Kind_Type is (Map_Generic, Map_Port); + function Create_Default_Map_Aspect + (Comp : Iir; Entity : Iir; Kind : Map_Kind_Type; Parent : Iir) + return Iir; + + -- Explain why there is no default binding for COMP. + procedure Explain_No_Visible_Entity (Comp: Iir_Component_Declaration); + + function Get_Visible_Entity_Declaration (Comp: Iir_Component_Declaration) + return Iir_Design_Unit; + + procedure Sem_Specification_Chain (Decls_Parent : Iir; Parent_Stmts: Iir); +end Vhdl.Sem_Specs; diff --git a/src/vhdl/vhdl-sem_stmts.adb b/src/vhdl/vhdl-sem_stmts.adb new file mode 100644 index 000000000..9a616896a --- /dev/null +++ b/src/vhdl/vhdl-sem_stmts.adb @@ -0,0 +1,2183 @@ +-- Semantic analysis. +-- 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 Errorout; use Errorout; +with Types; use Types; +with Flags; use Flags; +with Vhdl.Sem_Specs; use Vhdl.Sem_Specs; +with Std_Package; use Std_Package; +with Vhdl.Sem; use Vhdl.Sem; +with Vhdl.Sem_Decls; use Vhdl.Sem_Decls; +with Vhdl.Sem_Expr; use Vhdl.Sem_Expr; +with Vhdl.Sem_Names; use Vhdl.Sem_Names; +with Vhdl.Sem_Scopes; use Vhdl.Sem_Scopes; +with Vhdl.Sem_Types; +with Vhdl.Sem_Psl; +with Std_Names; +with Evaluation; use Evaluation; +with Iirs_Utils; use Iirs_Utils; +with Xrefs; use Xrefs; + +package body Vhdl.Sem_Stmts is + -- Process is the scope, this is also the process for which drivers can + -- be created. + -- Note: FIRST_STMT is the first statement, which can be get by: + -- get_sequential_statement_chain (usual) + -- get_associated_chain (for case statement). + procedure Sem_Sequential_Statements_Internal (First_Stmt : Iir); + + -- Access to the current subprogram or process. + Current_Subprogram: Iir := Null_Iir; + + function Get_Current_Subprogram return Iir is + begin + return Current_Subprogram; + end Get_Current_Subprogram; + + -- Access to the current concurrent statement. + -- Null_iir if no one. + Current_Concurrent_Statement : Iir := Null_Iir; + + function Get_Current_Concurrent_Statement return Iir is + begin + return Current_Concurrent_Statement; + end Get_Current_Concurrent_Statement; + + -- LRM 8 Sequential statements. + -- All statements may be labeled. + -- Such labels are implicitly declared at the beginning of the declarative + -- part of the innermost enclosing process statement of subprogram body. + procedure Sem_Sequential_Labels (First_Stmt : Iir) + is + Stmt: Iir; + Label: Name_Id; + begin + Stmt := First_Stmt; + while Stmt /= Null_Iir loop + Label := Get_Label (Stmt); + if Label /= Null_Identifier then + Sem_Scopes.Add_Name (Stmt); + Name_Visible (Stmt); + Xref_Decl (Stmt); + end if; + + -- Some statements have sub-lists of statements. + case Get_Kind (Stmt) is + when Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement => + Sem_Sequential_Labels (Get_Sequential_Statement_Chain (Stmt)); + when Iir_Kind_If_Statement => + declare + Clause : Iir; + begin + Clause := Stmt; + while Clause /= Null_Iir loop + Sem_Sequential_Labels + (Get_Sequential_Statement_Chain (Clause)); + Clause := Get_Else_Clause (Clause); + end loop; + end; + when Iir_Kind_Case_Statement => + declare + El : Iir; + begin + El := Get_Case_Statement_Alternative_Chain (Stmt); + while El /= Null_Iir loop + Sem_Sequential_Labels (Get_Associated_Chain (El)); + El := Get_Chain (El); + end loop; + end; + when others => + null; + end case; + Stmt := Get_Chain (Stmt); + end loop; + end Sem_Sequential_Labels; + + procedure Fill_Array_From_Aggregate_Associated + (Chain : Iir; Nbr : in out Natural; Arr : in out Iir_Array) + is + El : Iir; + Ass : Iir; + begin + El := Chain; + while El /= Null_Iir loop + Ass := Get_Associated_Expr (El); + if Get_Kind (Ass) = Iir_Kind_Aggregate then + Fill_Array_From_Aggregate_Associated + (Get_Association_Choices_Chain (Ass), Nbr, Arr); + else + Arr (Nbr) := Ass; + Nbr := Nbr + 1; + end if; + El := Get_Chain (El); + end loop; + end Fill_Array_From_Aggregate_Associated; + + -- Return TRUE iff there is no common elements designed by N1 and N2. + -- N1 and N2 are static names. + -- FIXME: The current implementation is completly wrong; should check from + -- prefix to suffix. + function Is_Disjoint (N1, N2: Iir) return Boolean + is + List1, List2 : Iir_Flist; + El1, El2 : Iir; + begin + if N1 = N2 then + return False; + end if; + if Get_Kind (N1) = Iir_Kind_Indexed_Name + and then Get_Kind (N2) = Iir_Kind_Indexed_Name + then + if Is_Disjoint (Get_Prefix (N1), Get_Prefix (N2)) then + return True; + end if; + -- Check indexes. + List1 := Get_Index_List (N1); + List2 := Get_Index_List (N2); + for I in Flist_First .. Flist_Last (List1) loop + El1 := Get_Nth_Element (List1, I); + El2 := Get_Nth_Element (List2, I); + El1 := Eval_Expr (El1); + Set_Nth_Element (List1, I, El1); + El2 := Eval_Expr (El2); + Set_Nth_Element (List2, I, El2); + -- EL are of discrete type. + if Get_Value (El1) /= Get_Value (El2) then + return True; + end if; + end loop; + return False; + elsif Get_Kind (N1) in Iir_Kinds_Denoting_Name + and then Get_Kind (N2) in Iir_Kinds_Denoting_Name + then + return Get_Named_Entity (N1) /= Get_Named_Entity (N2); + else + return True; + end if; + end Is_Disjoint; + + procedure Check_Uniq_Aggregate_Associated + (Aggr : Iir_Aggregate; Nbr : Natural) + is + Chain : constant Iir := Get_Association_Choices_Chain (Aggr); + subtype El_Array_Type is Iir_Array (0 .. Nbr - 1); + Name_Arr, Obj_Arr : El_Array_Type; + Index : Natural; + El : Iir; + begin + -- Fill the array. + Index := 0; + Fill_Array_From_Aggregate_Associated (Chain, Index, Name_Arr); + -- Should be the same. + pragma Assert (Index = Nbr); + + -- Replace name with object. Return now in case of error (not an + -- object or not a static name). + for I in Name_Arr'Range loop + El := Name_To_Object (Name_Arr (I)); + if El = Null_Iir + or else Get_Name_Staticness (El) /= Locally + then + -- Error... + return; + end if; + Obj_Arr (I) := El; + end loop; + + -- Check each element is uniq. + for I in Name_Arr'Range loop + for J in 0 .. I - 1 loop + if not Is_Disjoint (Obj_Arr (I), Obj_Arr (J)) then + Error_Msg_Sem + (+Name_Arr (I), "target is assigned more than once", + Cont => True); + Error_Msg_Sem + (+Name_Arr (J), " (previous assignment is here)"); + return; + end if; + end loop; + end loop; + end Check_Uniq_Aggregate_Associated; + + -- Do checks for the target of an assignment. + procedure Check_Simple_Signal_Target + (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness); + -- STMT is used to localize the error (if any). + procedure Check_Simple_Variable_Target + (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness); + + -- Semantic associed with signal mode. + -- See LRM93 4.3.3 (or LRM08 6.5.2) + type Boolean_Array_Of_Iir_Mode is array (Iir_Mode) of Boolean; + Iir_Mode_Readable : constant Boolean_Array_Of_Iir_Mode := + (Iir_Unknown_Mode => False, + Iir_In_Mode => True, + Iir_Out_Mode => False, + Iir_Inout_Mode => True, + Iir_Buffer_Mode => True, + Iir_Linkage_Mode => False); + Iir_Mode_Writable : constant Boolean_Array_Of_Iir_Mode := + (Iir_Unknown_Mode => False, + Iir_In_Mode => False, + Iir_Out_Mode => True, + Iir_Inout_Mode => True, + Iir_Buffer_Mode => True, + Iir_Linkage_Mode => False); + + -- Return True iff signal interface INTER is readable. + function Is_Interface_Signal_Readable (Inter : Iir) return Boolean + is + pragma Assert (Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration); + Mode : constant Iir_Mode := Get_Mode (Inter); + begin + if Mode = Iir_Out_Mode and then Flags.Vhdl_Std >= Vhdl_08 then + -- LRM08 6.5.2 Interface object declarations + -- OUT. The value of the inerface object is allowed [...] and + -- provided it is not a signal parameter, read. + return not Is_Parameter (Inter); + else + return Iir_Mode_Readable (Mode); + end if; + end Is_Interface_Signal_Readable; + + procedure Check_Aggregate_Target + (Stmt : Iir; Target : Iir; Nbr : in out Natural) + is + Choice : Iir; + Ass : Iir; + begin + Choice := Get_Association_Choices_Chain (Target); + while Choice /= Null_Iir loop + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Range => + -- LRM93 8.4 + -- It is an error if an element association in such an + -- aggregate contains an OTHERS choice or a choice that is + -- a discrete range. + Error_Msg_Sem + (+Choice, "discrete range choice not allowed for target"); + when Iir_Kind_Choice_By_Others => + -- LRM93 8.4 + -- It is an error if an element association in such an + -- aggregate contains an OTHERS choice or a choice that is + -- a discrete range. + Error_Msg_Sem + (+Choice, "others choice not allowed for target"); + when Iir_Kind_Choice_By_Expression + | Iir_Kind_Choice_By_Name + | Iir_Kind_Choice_By_None => + -- LRM93 9.4 + -- Such a target may not only contain locally static signal + -- names [...] + Ass := Get_Associated_Expr (Choice); + if Get_Kind (Ass) = Iir_Kind_Aggregate then + Check_Aggregate_Target (Stmt, Ass, Nbr); + else + if Get_Kind (Stmt) in + Iir_Kinds_Variable_Assignment_Statement + then + Check_Simple_Variable_Target (Stmt, Ass, Locally); + else + Check_Simple_Signal_Target (Stmt, Ass, Locally); + end if; + Nbr := Nbr + 1; + end if; + when others => + Error_Kind ("check_aggregate_target", Choice); + end case; + Choice := Get_Chain (Choice); + end loop; + end Check_Aggregate_Target; + + procedure Check_Simple_Signal_Target + (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness) + is + Target_Object : Iir; + Target_Prefix : Iir; + Guarded_Target : Tri_State_Type; + Targ_Obj_Kind : Iir_Kind; + begin + Target_Object := Name_To_Object (Target); + if Target_Object = Null_Iir then + Error_Msg_Sem (+Target, "target is not a signal name"); + return; + end if; + + Target_Prefix := Get_Object_Prefix (Target_Object); + Targ_Obj_Kind := Get_Kind (Target_Prefix); + case Targ_Obj_Kind is + when Iir_Kind_Interface_Signal_Declaration => + if not Iir_Mode_Writable (Get_Mode (Target_Prefix)) then + Error_Msg_Sem + (+Target, "%n can't be assigned", +Target_Prefix); + else + Sem_Add_Driver (Target_Object, Stmt); + end if; + when Iir_Kind_Signal_Declaration => + Sem_Add_Driver (Target_Object, Stmt); + when Iir_Kind_Guard_Signal_Declaration => + Error_Msg_Sem (+Stmt, "implicit GUARD signal cannot be assigned"); + return; + when others => + Error_Msg_Sem + (+Stmt, "target (%n) is not a signal", +Get_Base_Name (Target)); + return; + end case; + if Get_Name_Staticness (Target_Object) < Staticness then + Error_Msg_Sem (+Stmt, "signal name must be static"); + end if; + + -- LRM93 2.1.1.2 + -- A formal signal parameter is a guarded signal if and only if + -- it is associated with an actual signal that is a guarded + -- signal. + -- GHDL: a formal signal interface of a subprogram has no static + -- kind. This is determined at run-time, according to the actual + -- associated with the formal. + -- GHDL: parent of target cannot be a function. + if Targ_Obj_Kind = Iir_Kind_Interface_Signal_Declaration + and then Is_Parameter (Target_Prefix) + then + Guarded_Target := Unknown; + else + if Get_Guarded_Signal_Flag (Target_Prefix) then + Guarded_Target := True; + else + Guarded_Target := False; + end if; + end if; + + case Get_Guarded_Target_State (Stmt) is + when Unknown => + Set_Guarded_Target_State (Stmt, Guarded_Target); + when True + | False => + if Get_Guarded_Target_State (Stmt) /= Guarded_Target then + -- LRM93 9.5 + -- It is an error if the target of a concurrent signal + -- assignment is neither a guarded target nor an + -- unguarded target. + Error_Msg_Sem (+Target, "guarded and unguarded target"); + end if; + end case; + end Check_Simple_Signal_Target; + + procedure Check_Simple_Variable_Target + (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness) + is + Target_Object : Iir; + Target_Prefix : Iir; + begin + Target_Object := Name_To_Object (Target); + if Target_Object = Null_Iir then + Error_Msg_Sem (+Stmt, "target is not a variable name"); + return; + end if; + Target_Prefix := Get_Object_Prefix (Target_Object); + case Get_Kind (Target_Prefix) is + when Iir_Kind_Interface_Variable_Declaration => + if not Iir_Mode_Writable (Get_Mode (Target_Prefix)) then + Error_Msg_Sem (+Target, "%n cannot be written (bad mode)", + +Target_Prefix); + return; + end if; + when Iir_Kind_Variable_Declaration => + null; + when Iir_Kind_Implicit_Dereference + | Iir_Kind_Dereference => + -- LRM 3.3 + -- An object designated by an access type is always an object of + -- class variable. + null; + when others => + Error_Msg_Sem (+Stmt, "%n is not a variable to be assigned", + +Target_Prefix); + return; + end case; + if Get_Name_Staticness (Target_Object) < Staticness then + Error_Msg_Sem + (+Target, "element of a target aggregate must be a static name"); + end if; + end Check_Simple_Variable_Target; + + procedure Check_Target (Stmt : Iir; Target : Iir) + is + Nbr : Natural; + begin + if Get_Kind (Target) = Iir_Kind_Aggregate then + Nbr := 0; + Check_Aggregate_Target (Stmt, Target, Nbr); + Check_Uniq_Aggregate_Associated (Target, Nbr); + else + case Get_Kind (Stmt) is + when Iir_Kind_Variable_Assignment_Statement + | Iir_Kind_Conditional_Variable_Assignment_Statement => + Check_Simple_Variable_Target (Stmt, Target, None); + when others => + Check_Simple_Signal_Target (Stmt, Target, None); + end case; + end if; + end Check_Target; + + type Resolve_Stages is (Resolve_Stage_1, Resolve_Stage_2); + pragma Unreferenced (Resolve_Stage_2); + + procedure Sem_Signal_Assignment_Target_And_Option + (Stmt: Iir; Sig_Type : in out Iir) + is + -- The target of the assignment. + Target: Iir; + -- The value that will be assigned. + Expr: Iir; + begin + Target := Get_Target (Stmt); + Target := Sem_Expression_Wildcard (Target, Get_Base_Type (Sig_Type)); + + if Target /= Null_Iir then + Set_Target (Stmt, Target); + if Is_Expr_Fully_Analyzed (Target) then + Check_Target (Stmt, Target); + Sig_Type := Get_Type (Target); + Sem_Types.Set_Type_Has_Signal (Sig_Type); + end if; + end if; + + Expr := Get_Reject_Time_Expression (Stmt); + if Expr /= Null_Iir + and then Is_Expr_Not_Analyzed (Expr) + then + Expr := Sem_Expression (Expr, Time_Type_Definition); + if Expr /= Null_Iir then + Check_Read (Expr); + Set_Reject_Time_Expression (Stmt, Expr); + end if; + end if; + end Sem_Signal_Assignment_Target_And_Option; + + -- Analyze a waveform_list WAVEFORM_LIST that is assigned via statement + -- ASSIGN_STMT to a subelement or a slice of a signal SIGNAL_DECL. + procedure Sem_Waveform_Chain (Waveform_Chain : Iir_Waveform_Element; + Waveform_Type : in out Iir) + is + Expr: Iir; + We: Iir_Waveform_Element; + Time, Last_Time : Iir_Int64; + begin + if Get_Kind (Waveform_Chain) = Iir_Kind_Unaffected_Waveform then + -- Unaffected. + return; + end if; + + -- Start with -1 to allow after 0 ns. + Last_Time := -1; + We := Waveform_Chain; + while We /= Null_Iir loop + Expr := Get_We_Value (We); + if Get_Kind (Expr) = Iir_Kind_Null_Literal then + -- GHDL: allowed only if target is guarded; this is checked by + -- sem_check_waveform_list. + null; + else + Expr := Sem_Expression_Wildcard (Expr, Waveform_Type, True); + + if Expr /= Null_Iir then + if Is_Expr_Fully_Analyzed (Expr) then + Check_Read (Expr); + Expr := Eval_Expr_If_Static (Expr); + end if; + Set_We_Value (We, Expr); + + Merge_Wildcard_Type (Expr, Waveform_Type); + else + Expr := Get_We_Value (We); + Expr := Create_Error_Expr (Expr, Waveform_Type); + Set_We_Value (We, Expr); + end if; + end if; + + -- Analyze time expression. + if Get_Time (We) /= Null_Iir then + Expr := Get_Time (We); + if Is_Expr_Not_Analyzed (Expr) then + Expr := Sem_Expression (Expr, Time_Type_Definition); + if Expr /= Null_Iir then + Set_Time (We, Expr); + Check_Read (Expr); + + if Get_Expr_Staticness (Expr) = Locally + or else (Get_Kind (Expr) = Iir_Kind_Physical_Int_Literal + and then Flags.Flag_Time_64) + then + -- LRM 8.4 + -- It is an error if the time expression in a waveform + -- element evaluates to a negative value. + -- + -- LRM 8.4.1 + -- It is an error if the sequence of new transactions is + -- not in ascending order with repect to time. + -- GHDL: this must be checked at run-time, but this is + -- also checked now for static expressions. + if Get_Expr_Staticness (Expr) = Locally then + -- The expression is static, and therefore may be + -- evaluated. + Expr := Eval_Expr (Expr); + Set_Time (We, Expr); + Time := Get_Value (Expr); + else + -- The expression is a physical literal (common case). + -- Extract its value. + Time := Get_Physical_Value (Expr); + end if; + if Time < 0 then + Error_Msg_Sem + (+Expr, "waveform time expression must be >= 0"); + elsif Time <= Last_Time then + Error_Msg_Sem + (+Expr, + "time must be greather than previous transaction"); + else + Last_Time := Time; + end if; + end if; + end if; + end if; + else + if We /= Waveform_Chain then + -- Time expression must be in ascending order. + Error_Msg_Sem (+We, "time expression required here"); + end if; + + -- LRM93 12.6.4 + -- It is an error if the execution of any postponed process + -- causes a delta cycle to occur immediatly after the current + -- simulation cycle. + -- GHDL: try to warn for such an error; note the context may be + -- a procedure body. + if Current_Concurrent_Statement /= Null_Iir then + case Get_Kind (Current_Concurrent_Statement) is + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Concurrent_Selected_Signal_Assignment => + if Get_Postponed_Flag (Current_Concurrent_Statement) then + Warning_Msg_Sem + (Warnid_Delta_Cycle, +We, + "waveform may cause a delta cycle in a " & + "postponed process"); + end if; + when others => + -- Context is a subprogram. + null; + end case; + end if; + + Last_Time := 0; + end if; + + We := Get_Chain (We); + end loop; + end Sem_Waveform_Chain; + + -- Analyze a waveform chain WAVEFORM_CHAIN that is assigned via statement + -- ASSIGN_STMT to a subelement or a slice of a signal SIGNAL_DECL. + procedure Sem_Check_Waveform_Chain + (Assign_Stmt: Iir; Waveform_Chain: Iir_Waveform_Element) + is + We: Iir_Waveform_Element; + Expr : Iir; + Targ_Type : Iir; + begin + if Get_Kind (Waveform_Chain) = Iir_Kind_Unaffected_Waveform then + return; + end if; + + Targ_Type := Get_Type (Get_Target (Assign_Stmt)); + + We := Waveform_Chain; + while We /= Null_Iir loop + Expr := Get_We_Value (We); + if Get_Kind (Expr) = Iir_Kind_Null_Literal then + -- This is a null waveform element. + -- LRM93 8.4.1 + -- It is an error if the target of a signal assignment statement + -- containing a null waveform is not a guarded signal or an + -- aggregate of guarded signals. + if Get_Guarded_Target_State (Assign_Stmt) = False then + Error_Msg_Sem + (+Assign_Stmt, + "null transactions can be assigned only to guarded signals"); + end if; + else + if Is_Valid (Get_Type (Expr)) + and then not Eval_Is_In_Bound (Expr, Targ_Type) + and then Get_Kind (Expr) /= Iir_Kind_Overflow_Literal + then + Warning_Msg_Sem + (Warnid_Runtime_Error, +We, + "value constraints don't match target ones"); + Set_We_Value (We, Build_Overflow (Expr, Targ_Type)); + end if; + end if; + We := Get_Chain (We); + end loop; + end Sem_Check_Waveform_Chain; + + procedure Sem_Guard (Stmt: Iir) + is + Guard: Iir; + Guard_Interpretation : Name_Interpretation_Type; + begin + Guard := Get_Guard (Stmt); + if Guard = Null_Iir then + -- This assignment is not guarded. + + -- LRM93 9.5 + -- It is an error if a concurrent signal assignment is not a guarded + -- assignment, and the target of the concurrent signal assignment + -- is a guarded target. + if Get_Guarded_Target_State (Stmt) = True then + Error_Msg_Sem + (+Stmt, "not a guarded assignment for a guarded target"); + end if; + return; + end if; + if Guard /= Stmt then + -- if set, guard must be equal to stmt here. + raise Internal_Error; + end if; + Guard_Interpretation := Get_Interpretation (Std_Names.Name_Guard); + if not Valid_Interpretation (Guard_Interpretation) then + Error_Msg_Sem (+Stmt, "no guard signals for this guarded assignment"); + return; + end if; + + Guard := Get_Declaration (Guard_Interpretation); + -- LRM93 9.5: + -- The signal GUARD [...] an explicitly declared signal of type + -- BOOLEAN that is visible at the point of the concurrent signal + -- assignment statement + -- FIXME. + case Get_Kind (Guard) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration => + null; + when others => + Error_Msg_Sem (+Stmt, "visible GUARD object is not a signal", + Cont => True); + Error_Msg_Sem (+Stmt, "GUARD object is %n", +Guard); + return; + end case; + + if Get_Type (Guard) /= Boolean_Type_Definition then + Error_Msg_Sem (+Guard, "GUARD is not of boolean type"); + end if; + Set_Guard (Stmt, Guard); + end Sem_Guard; + + procedure Sem_Signal_Assignment (Stmt: Iir) + is + Cond_Wf : Iir_Conditional_Waveform; + Expr : Iir; + Wf_Chain : Iir_Waveform_Element; + Target_Type : Iir; + Done : Boolean; + begin + Target_Type := Wildcard_Any_Type; + + Done := False; + for S in Resolve_Stages loop + Sem_Signal_Assignment_Target_And_Option (Stmt, Target_Type); + if Is_Defined_Type (Target_Type) then + Done := True; + end if; + + case Get_Kind (Stmt) is + when Iir_Kind_Concurrent_Simple_Signal_Assignment + | Iir_Kind_Simple_Signal_Assignment_Statement => + Wf_Chain := Get_Waveform_Chain (Stmt); + Sem_Waveform_Chain (Wf_Chain, Target_Type); + if Done then + Sem_Check_Waveform_Chain (Stmt, Wf_Chain); + end if; + + when Iir_Kind_Concurrent_Conditional_Signal_Assignment + | Iir_Kind_Conditional_Signal_Assignment_Statement => + Cond_Wf := Get_Conditional_Waveform_Chain (Stmt); + while Cond_Wf /= Null_Iir loop + Wf_Chain := Get_Waveform_Chain (Cond_Wf); + Sem_Waveform_Chain (Wf_Chain, Target_Type); + if Done then + Sem_Check_Waveform_Chain (Stmt, Wf_Chain); + end if; + if S = Resolve_Stage_1 then + -- Must be analyzed only once. + Expr := Get_Condition (Cond_Wf); + if Expr /= Null_Iir then + Expr := Sem_Condition (Expr); + if Expr /= Null_Iir then + Set_Condition (Cond_Wf, Expr); + end if; + end if; + end if; + Cond_Wf := Get_Chain (Cond_Wf); + end loop; + + when Iir_Kind_Concurrent_Selected_Signal_Assignment => + declare + El : Iir; + begin + El := Get_Selected_Waveform_Chain (Stmt); + while El /= Null_Iir loop + Wf_Chain := Get_Associated_Chain (El); + if Is_Valid (Wf_Chain) then + -- The first choice of a list. + Sem_Waveform_Chain (Wf_Chain, Target_Type); + if Done then + Sem_Check_Waveform_Chain (Stmt, Wf_Chain); + end if; + end if; + El := Get_Chain (El); + end loop; + end; + + when others => + raise Internal_Error; + end case; + + exit when Done; + if not Is_Defined_Type (Target_Type) then + Error_Msg_Sem (+Stmt, "cannot resolve type of waveform"); + exit; + end if; + end loop; + + case Get_Kind (Stmt) is + when Iir_Kind_Concurrent_Simple_Signal_Assignment + | Iir_Kind_Concurrent_Conditional_Signal_Assignment => + Sem_Guard (Stmt); + when others => + null; + end case; + end Sem_Signal_Assignment; + + procedure Sem_Conditional_Expression (Cond_Expr : Iir; Atype : in out Iir) + is + El : Iir; + Expr : Iir; + Cond : Iir; + begin + El := Cond_Expr; + while El /= Null_Iir loop + Expr := Get_Expression (El); + Expr := Sem_Expression_Wildcard (Expr, Atype, True); + + if Expr /= Null_Iir then + Set_Expression (El, Expr); + + if Is_Expr_Fully_Analyzed (Expr) then + Check_Read (Expr); + Expr := Eval_Expr_If_Static (Expr); + end if; + + Merge_Wildcard_Type (Expr, Atype); + end if; + + Cond := Get_Condition (El); + exit when Cond = Null_Iir; + + if Is_Expr_Not_Analyzed (Cond) then + Cond := Sem_Condition (Cond); + Set_Condition (El, Cond); + end if; + + El := Get_Chain (El); + end loop; + end Sem_Conditional_Expression; + + procedure Sem_Variable_Assignment (Stmt: Iir) + is + Target : Iir; + Expr : Iir; + Target_Type : Iir; + Stmt_Type : Iir; + Done : Boolean; + begin + -- LRM93 8.5 Variable assignment statement + -- If the target of the variable assignment statement is in the form of + -- an aggregate, then the type of the aggregate must be determinable + -- from the context, excluding the aggregate itself but including the + -- fact that the type of the aggregate must be a composite type. The + -- base type of the expression on the right-hand side must be the + -- same as the base type of the aggregate. + -- + -- GHDL: this means that the type can only be deduced from the + -- expression (and not from the target). + + Target := Get_Target (Stmt); + Stmt_Type := Wildcard_Any_Type; + for S in Resolve_Stages loop + Done := False; + + Target := Sem_Expression_Wildcard (Target, Stmt_Type); + if Target = Null_Iir then + Target_Type := Stmt_Type; + else + Set_Target (Stmt, Target); + if Is_Expr_Fully_Analyzed (Target) then + Check_Target (Stmt, Target); + Done := True; + end if; + Target_Type := Get_Type (Target); + Stmt_Type := Target_Type; + end if; + + case Iir_Kinds_Variable_Assignment_Statement (Get_Kind (Stmt)) is + when Iir_Kind_Variable_Assignment_Statement => + Expr := Get_Expression (Stmt); + Expr := Sem_Expression_Wildcard (Expr, Stmt_Type, True); + if Expr /= Null_Iir then + if Is_Expr_Fully_Analyzed (Expr) then + Check_Read (Expr); + Expr := Eval_Expr_If_Static (Expr); + end if; + Set_Expression (Stmt, Expr); + Merge_Wildcard_Type (Expr, Stmt_Type); + if Done + and then not Eval_Is_In_Bound (Expr, Target_Type) + and then Get_Kind (Expr) /= Iir_Kind_Overflow_Literal + then + Warning_Msg_Sem + (Warnid_Runtime_Error, +Stmt, + "expression constraints don't match target ones"); + Set_Expression (Stmt, Build_Overflow (Expr, Target_Type)); + end if; + end if; + + when Iir_Kind_Conditional_Variable_Assignment_Statement => + Expr := Get_Conditional_Expression (Stmt); + Sem_Conditional_Expression (Expr, Stmt_Type); + end case; + + exit when Done; + if not Is_Defined_Type (Stmt_Type) then + Error_Msg_Sem (+Stmt, "cannot resolve type"); + if Get_Kind (Target) = Iir_Kind_Aggregate then + -- Try to give an advice. + Error_Msg_Sem (+Stmt, "use a qualified expression for the RHS"); + end if; + exit; + end if; + end loop; + end Sem_Variable_Assignment; + + procedure Sem_Return_Statement (Stmt: Iir_Return_Statement) is + Expr: Iir; + begin + if Current_Subprogram = Null_Iir then + Error_Msg_Sem (+Stmt, "return statement not in a subprogram body"); + return; + end if; + Expr := Get_Expression (Stmt); + case Get_Kind (Current_Subprogram) is + when Iir_Kind_Procedure_Declaration => + if Expr /= Null_Iir then + Error_Msg_Sem + (+Stmt, "return in a procedure can't have an expression"); + end if; + return; + when Iir_Kind_Function_Declaration => + if Expr = Null_Iir then + Error_Msg_Sem + (+Stmt, "return in a function must have an expression"); + return; + end if; + when Iir_Kinds_Process_Statement => + Error_Msg_Sem (+Stmt, "return statement not allowed in a process"); + return; + when others => + Error_Kind ("sem_return_statement", Stmt); + end case; + Set_Type (Stmt, Get_Return_Type (Current_Subprogram)); + Expr := Sem_Expression (Expr, Get_Return_Type (Current_Subprogram)); + if Expr /= Null_Iir then + Check_Read (Expr); + Set_Expression (Stmt, Eval_Expr_If_Static (Expr)); + end if; + end Sem_Return_Statement; + + -- Sem for concurrent and sequential assertion statements. + procedure Sem_Report_Statement (Stmt : Iir) + is + Expr : Iir; + begin + Expr := Get_Report_Expression (Stmt); + if Expr /= Null_Iir then + Expr := Sem_Expression (Expr, String_Type_Definition); + Check_Read (Expr); + Expr := Eval_Expr_If_Static (Expr); + Set_Report_Expression (Stmt, Expr); + end if; + + Expr := Get_Severity_Expression (Stmt); + if Expr /= Null_Iir then + Expr := Sem_Expression (Expr, Severity_Level_Type_Definition); + Check_Read (Expr); + Set_Severity_Expression (Stmt, Expr); + end if; + end Sem_Report_Statement; + + procedure Sem_Assertion_Statement (Stmt: Iir) + is + Expr : Iir; + begin + Expr := Get_Assertion_Condition (Stmt); + Expr := Sem_Condition (Expr); + Expr := Eval_Expr_If_Static (Expr); + Set_Assertion_Condition (Stmt, Expr); + + Sem_Report_Statement (Stmt); + end Sem_Assertion_Statement; + + -- Analyze a list of case choice LIST, and check for correct CHOICE type. + procedure Sem_Case_Choices + (Choice : Iir; Chain : in out Iir; Loc : Location_Type) + is + -- Check restrictions on the expression of a One-Dimensional Character + -- Array Type (ODCAT) given by LRM 8.8 + -- Return FALSE in case of violation. + function Check_Odcat_Expression (Expr : Iir) return Boolean + is + Expr_Type : constant Iir := Get_Type (Expr); + begin + -- LRM 8.8 Case Statement + -- If the expression is of a one-dimensional character array type, + -- then the expression must be one of the following: + case Get_Kind (Expr) is + when Iir_Kinds_Object_Declaration + | Iir_Kind_Selected_Element => + -- FIXME: complete the list. + -- * the name of an object whose subtype is locally static. + if Get_Type_Staticness (Expr_Type) /= Locally then + Error_Msg_Sem + (+Choice, "object subtype is not locally static"); + return False; + end if; + when Iir_Kind_Indexed_Name => + -- LRM93 + -- * an indexed name whose prefix is one of the members of + -- this list and whose indexing expressions are locally + -- static expression. + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Sem + (+Expr, "indexed name not allowed here in vhdl87"); + return False; + end if; + if not Check_Odcat_Expression (Get_Prefix (Expr)) then + return False; + end if; + -- GHDL: I don't understand why the indexing expressions + -- must be locally static. So I don't check this in 93c. + if Flags.Vhdl_Std /= Vhdl_93c + and then + (Get_Expr_Staticness + (Get_Nth_Element (Get_Index_List (Expr), 0)) /= Locally) + then + Error_Msg_Sem + (+Expr, "indexing expression must be locally static"); + return False; + end if; + when Iir_Kind_Slice_Name => + -- LRM93 + -- * a slice name whose prefix is one of the members of this + -- list and whose discrete range is a locally static + -- discrete range. + + -- LRM87/INT1991 IR96 + -- then the expression must be either a slice name whose + -- discrete range is locally static, or .. + if False and Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Sem + (+Expr, "slice not allowed as case expression in vhdl87"); + return False; + end if; + if not Check_Odcat_Expression (Get_Prefix (Expr)) then + return False; + end if; + if Get_Type_Staticness (Expr_Type) /= Locally then + Error_Msg_Sem + (+Expr, "slice discrete range must be locally static"); + return False; + end if; + when Iir_Kind_Function_Call => + -- LRM93 + -- * a function call whose return type mark denotes a + -- locally static subtype. + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Sem + (+Expr, "function call not allowed here in vhdl87"); + return False; + end if; + if Get_Type_Staticness (Expr_Type) /= Locally then + Error_Msg_Sem + (+Expr, "function call type is not locally static"); + end if; + when Iir_Kind_Qualified_Expression + | Iir_Kind_Type_Conversion => + -- * a qualified expression or type conversion whose type mark + -- denotes a locally static subtype. + if Get_Type_Staticness (Expr_Type) /= Locally then + Error_Msg_Sem + (+Expr, "type mark is not a locally static subtype"); + return False; + end if; + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return Check_Odcat_Expression (Get_Named_Entity (Expr)); + when others => + Error_Msg_Sem + (+Choice, "bad form of case expression (refer to LRM 8.8)"); + return False; + end case; + return True; + end Check_Odcat_Expression; + + Choice_Type : constant Iir := Get_Type (Choice); + Low, High : Iir; + El_Type : Iir; + begin + -- LRM 8.8 Case Statement + -- The expression must be of a discrete type, or of a one-dimensional + -- array type whose element base type is a character type. + case Get_Kind (Choice_Type) is + when Iir_Kinds_Discrete_Type_Definition => + Sem_Choices_Range + (Chain, Choice_Type, Low, High, Loc, False, True); + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Array_Type_Definition => + if not Is_One_Dimensional_Array_Type (Choice_Type) then + Error_Msg_Sem + (+Choice, + "expression must be of a one-dimensional array type"); + return; + end if; + El_Type := Get_Base_Type (Get_Element_Subtype (Choice_Type)); + if Get_Kind (El_Type) /= Iir_Kind_Enumeration_Type_Definition + or else not Get_Is_Character_Type (El_Type) + then + Error_Msg_Sem + (+Choice, + "element type of the expression must be a character type"); + return; + end if; + if Flags.Vhdl_Std >= Vhdl_08 then + -- No specific restrictions in vhdl 2008. + null; + else + if not Check_Odcat_Expression (Choice) then + return; + end if; + end if; + Sem_String_Choices_Range (Chain, Choice); + when others => + Error_Msg_Sem (+Choice, "type of expression must be discrete"); + end case; + end Sem_Case_Choices; + + procedure Sem_Case_Statement (Stmt: Iir_Case_Statement) + is + Expr: Iir; + Chain : Iir; + El: Iir; + begin + Expr := Get_Expression (Stmt); + Chain := Get_Case_Statement_Alternative_Chain (Stmt); + -- FIXME: overload. + Expr := Sem_Case_Expression (Expr); + if Expr /= Null_Iir then + Check_Read (Expr); + Set_Expression (Stmt, Expr); + + Sem_Case_Choices (Expr, Chain, Get_Location (Stmt)); + Set_Case_Statement_Alternative_Chain (Stmt, Chain); + end if; + + El := Chain; + while El /= Null_Iir loop + if not Get_Same_Alternative_Flag (El) then + Sem_Sequential_Statements_Internal (Get_Associated_Chain (El)); + end if; + El := Get_Chain (El); + end loop; + end Sem_Case_Statement; + + -- Sem the sensitivity list LIST. + procedure Sem_Sensitivity_List (List: Iir_List) + is + El: Iir; + It : List_Iterator; + Res: Iir; + Prefix : Iir; + begin + if List = Iir_List_All then + return; + end if; + + It := List_Iterate (List); + while Is_Valid (It) loop + -- El is an iir_identifier. + El := Get_Element (It); + + if Is_Error (El) then + pragma Assert (Flags.Flag_Force_Analysis); + Res := Error_Mark; + else + Sem_Name (El); + + Res := Get_Named_Entity (El); + end if; + + if Res = Error_Mark then + null; + elsif Is_Overload_List (Res) or else not Is_Object_Name (Res) then + Error_Msg_Sem (+El, "a sensitivity element must be a signal name"); + else + Res := Finish_Sem_Name (El); + Prefix := Get_Object_Prefix (Res); + case Get_Kind (Prefix) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kinds_Signal_Attribute => + null; + when Iir_Kind_Interface_Signal_Declaration => + if not Is_Interface_Signal_Readable (Prefix) then + Error_Msg_Sem + (+El, + "%n of mode out can't be in a sensivity list", +Res); + end if; + when others => + Error_Msg_Sem (+El, + "%n is neither a signal nor a port", +Res); + end case; + -- LRM 9.2 + -- Only static signal names (see section 6.1) for which reading + -- is permitted may appear in the sensitivity list of a process + -- statement. + + -- LRM 8.1 Wait statement + -- Each signal name in the sensitivity list must be a static + -- signal name, and each name must denote a signal for which + -- reading is permitted. + if Get_Name_Staticness (Res) < Globally then + Error_Msg_Sem + (+El, "sensitivity element %n must be a static name", +Res); + end if; + + Set_Element (It, Res); + end if; + + Next (It); + end loop; + end Sem_Sensitivity_List; + + -- Mark STMT and its parents as suspendable. + procedure Mark_Suspendable (Stmt : Iir) + is + Parent : Iir; + begin + Parent := Get_Parent (Stmt); + loop + case Get_Kind (Parent) is + when Iir_Kind_Function_Body + | Iir_Kind_Sensitized_Process_Statement => + exit; + when Iir_Kind_Process_Statement + | Iir_Kind_Procedure_Body => + Set_Suspend_Flag (Parent, True); + exit; + when Iir_Kind_If_Statement + | Iir_Kind_While_Loop_Statement + | Iir_Kind_For_Loop_Statement + | Iir_Kind_Case_Statement => + Set_Suspend_Flag (Parent, True); + Parent := Get_Parent (Parent); + when others => + Error_Kind ("mark_suspendable", Parent); + end case; + end loop; + end Mark_Suspendable; + + procedure Sem_Wait_Statement (Stmt: Iir_Wait_Statement) + is + Expr: Iir; + Sensitivity_List : Iir_List; + begin + -- Check validity. + case Get_Kind (Current_Subprogram) is + when Iir_Kind_Process_Statement => + null; + when Iir_Kind_Function_Declaration => + -- LRM93 8.2 + -- It is an error if a wait statement appears in a function + -- subprogram [...] + Error_Msg_Sem + (+Stmt, "wait statement not allowed in a function subprogram"); + return; + when Iir_Kind_Procedure_Declaration => + -- LRM93 8.2 + -- [It is an error ...] or in a procedure that has a parent that + -- is a function subprogram. + -- LRM93 8.2 + -- [...] or in a procedure that has a parent that is such a + -- process statement. + -- GHDL: this is checked at the end of analysis or during + -- elaboration. + Set_Wait_State (Current_Subprogram, True); + when Iir_Kind_Sensitized_Process_Statement => + -- LRM93 8.2 + -- Furthermore, it is an error if a wait statement appears in an + -- explicit process statement that includes a sensitivity list, + -- [...] + Error_Msg_Sem + (+Stmt, "wait statement not allowed in a sensitized process"); + return; + when others => + raise Internal_Error; + end case; + + Sensitivity_List := Get_Sensitivity_List (Stmt); + if Sensitivity_List /= Null_Iir_List then + Sem_Sensitivity_List (Sensitivity_List); + end if; + + Expr := Get_Condition_Clause (Stmt); + if Expr /= Null_Iir then + Expr := Sem_Condition (Expr); + Set_Condition_Clause (Stmt, Expr); + end if; + + Expr := Get_Timeout_Clause (Stmt); + if Expr /= Null_Iir then + Expr := Sem_Expression (Expr, Time_Type_Definition); + if Expr /= Null_Iir then + Check_Read (Expr); + Expr := Eval_Expr_If_Static (Expr); + Set_Timeout_Clause (Stmt, Expr); + if Get_Expr_Staticness (Expr) = Locally + and then Get_Value (Expr) < 0 + then + Error_Msg_Sem (+Stmt, "timeout value must be positive"); + end if; + end if; + end if; + + Mark_Suspendable (Stmt); + end Sem_Wait_Statement; + + procedure Sem_Exit_Next_Statement (Stmt : Iir) + is + Cond: Iir; + Loop_Label : Iir; + Loop_Stmt: Iir; + P : Iir; + begin + Cond := Get_Condition (Stmt); + if Cond /= Null_Iir then + Cond := Sem_Condition (Cond); + Set_Condition (Stmt, Cond); + end if; + + Loop_Label := Get_Loop_Label (Stmt); + if Loop_Label /= Null_Iir then + Loop_Label := Sem_Denoting_Name (Loop_Label); + Set_Loop_Label (Stmt, Loop_Label); + Loop_Stmt := Get_Named_Entity (Loop_Label); + case Get_Kind (Loop_Stmt) is + when Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement => + null; + when others => + Error_Class_Match (Loop_Label, "loop statement"); + Loop_Stmt := Null_Iir; + end case; + else + Loop_Stmt := Null_Iir; + end if; + + -- Check the current statement is inside the labeled loop. + P := Stmt; + loop + P := Get_Parent (P); + case Get_Kind (P) is + when Iir_Kind_While_Loop_Statement + | Iir_Kind_For_Loop_Statement => + if Loop_Stmt = Null_Iir or else P = Loop_Stmt then + exit; + end if; + when Iir_Kind_If_Statement + | Iir_Kind_Elsif + | Iir_Kind_Case_Statement => + null; + when others => + -- FIXME: should emit a message for label mismatch. + Error_Msg_Sem (+Stmt, "exit/next must be inside a loop"); + exit; + end case; + end loop; + end Sem_Exit_Next_Statement; + + -- Process is the scope, this is also the process for which drivers can + -- be created. + procedure Sem_Sequential_Statements_Internal (First_Stmt : Iir) + is + Stmt: Iir; + begin + Stmt := First_Stmt; + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kind_Null_Statement => + null; + when Iir_Kind_If_Statement => + declare + Clause: Iir := Stmt; + Cond: Iir; + begin + while Clause /= Null_Iir loop + Cond := Get_Condition (Clause); + if Cond /= Null_Iir then + Cond := Sem_Condition (Cond); + Set_Condition (Clause, Cond); + end if; + Sem_Sequential_Statements_Internal + (Get_Sequential_Statement_Chain (Clause)); + Clause := Get_Else_Clause (Clause); + end loop; + end; + when Iir_Kind_For_Loop_Statement => + declare + Iterator : constant Iir := + Get_Parameter_Specification (Stmt); + begin + -- LRM 10.1 Declarative region + -- 9. A loop statement. + Open_Declarative_Region; + + Set_Is_Within_Flag (Stmt, True); + Sem_Scopes.Add_Name (Iterator); + Sem_Iterator (Iterator, None); + Set_Visible_Flag (Iterator, True); + Sem_Sequential_Statements_Internal + (Get_Sequential_Statement_Chain (Stmt)); + Set_Is_Within_Flag (Stmt, False); + + Close_Declarative_Region; + end; + when Iir_Kind_While_Loop_Statement => + declare + Cond: Iir; + begin + Cond := Get_Condition (Stmt); + if Cond /= Null_Iir then + Cond := Sem_Condition (Cond); + Set_Condition (Stmt, Cond); + end if; + Sem_Sequential_Statements_Internal + (Get_Sequential_Statement_Chain (Stmt)); + end; + when Iir_Kind_Simple_Signal_Assignment_Statement + | Iir_Kind_Conditional_Signal_Assignment_Statement => + Sem_Signal_Assignment (Stmt); + if Current_Concurrent_Statement /= Null_Iir and then + Get_Kind (Current_Concurrent_Statement) + in Iir_Kinds_Process_Statement + and then Get_Passive_Flag (Current_Concurrent_Statement) + then + Error_Msg_Sem + (+Stmt, "signal statement forbidden in passive process"); + end if; + when Iir_Kind_Variable_Assignment_Statement + | Iir_Kind_Conditional_Variable_Assignment_Statement => + Sem_Variable_Assignment (Stmt); + when Iir_Kind_Return_Statement => + Sem_Return_Statement (Stmt); + when Iir_Kind_Assertion_Statement => + Sem_Assertion_Statement (Stmt); + when Iir_Kind_Report_Statement => + Sem_Report_Statement (Stmt); + when Iir_Kind_Case_Statement => + Sem_Case_Statement (Stmt); + when Iir_Kind_Wait_Statement => + Sem_Wait_Statement (Stmt); + when Iir_Kind_Procedure_Call_Statement => + declare + Call : constant Iir := Get_Procedure_Call (Stmt); + Imp : Iir; + begin + Sem_Procedure_Call (Call, Stmt); + + -- Set suspend flag, if calling a suspendable procedure + -- from a procedure or from a process. + Imp := Get_Implementation (Call); + if Imp /= Null_Iir + and then Get_Kind (Imp) = Iir_Kind_Procedure_Declaration + and then Get_Suspend_Flag (Imp) + and then (Get_Kind (Get_Current_Subprogram) + /= Iir_Kind_Function_Declaration) + and then (Get_Kind (Get_Current_Subprogram) + /= Iir_Kind_Sensitized_Process_Statement) + then + Set_Suspend_Flag (Stmt, True); + Mark_Suspendable (Stmt); + end if; + end; + when Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement => + Sem_Exit_Next_Statement (Stmt); + when others => + Error_Kind ("sem_sequential_statements_Internal", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + end Sem_Sequential_Statements_Internal; + + procedure Sem_Sequential_Statements (Decl : Iir; Body_Parent : Iir) + is + Outer_Subprogram: Iir; + begin + Outer_Subprogram := Current_Subprogram; + Current_Subprogram := Decl; + + -- Sem declarations + Sem_Sequential_Labels (Get_Sequential_Statement_Chain (Body_Parent)); + Sem_Declaration_Chain (Body_Parent); + Sem_Specification_Chain (Body_Parent, Null_Iir); + + -- Sem statements. + Sem_Sequential_Statements_Internal + (Get_Sequential_Statement_Chain (Body_Parent)); + + Check_Full_Declaration (Body_Parent, Body_Parent); + + Current_Subprogram := Outer_Subprogram; + end Sem_Sequential_Statements; + + -- Sem the instantiated unit of STMT and return the node constaining + -- ports and generics (either a entity_declaration or a component + -- declaration). + function Sem_Instantiated_Unit + (Stmt : Iir_Component_Instantiation_Statement) return Iir + is + Inst : constant Iir := Get_Instantiated_Unit (Stmt); + Comp_Name : Iir; + Comp : Iir; + begin + if Get_Kind (Inst) in Iir_Kinds_Entity_Aspect then + return Sem_Entity_Aspect (Inst); + else + Comp := Get_Named_Entity (Inst); + if Comp /= Null_Iir then + -- Already analyzed before, while trying to separate + -- concurrent procedure calls from instantiation stmts. + pragma Assert (Get_Kind (Comp) = Iir_Kind_Component_Declaration); + return Comp; + end if; + + -- Needs a denoting name + if Get_Kind (Inst) not in Iir_Kinds_Denoting_Name then + Error_Msg_Sem (+Inst, "name for a component expected"); + return Null_Iir; + end if; + + -- The component may be an entity or a configuration. + Comp_Name := Sem_Denoting_Name (Inst); + Set_Instantiated_Unit (Stmt, Comp_Name); + Comp := Get_Named_Entity (Comp_Name); + if Get_Kind (Comp) /= Iir_Kind_Component_Declaration then + Error_Class_Match (Comp_Name, "component"); + return Null_Iir; + end if; + + return Comp; + end if; + end Sem_Instantiated_Unit; + + procedure Sem_Component_Instantiation_Statement + (Stmt: Iir_Component_Instantiation_Statement; Is_Passive : Boolean) + is + Decl : Iir; + Entity_Unit : Iir_Design_Unit; + Bind : Iir_Binding_Indication; + begin + -- FIXME: move this check in parse ? + if Is_Passive then + Error_Msg_Sem (+Stmt, "component instantiation forbidden in entity"); + end if; + + -- Check for label. + -- This cannot be moved in parse since a procedure_call may be revert + -- into a component instantiation. + if Get_Label (Stmt) = Null_Identifier then + Error_Msg_Sem (+Stmt, "component instantiation requires a label"); + end if; + + -- Look for the component. + Decl := Sem_Instantiated_Unit (Stmt); + if Decl = Null_Iir then + return; + end if; + + -- The association + Sem_Generic_Port_Association_Chain (Decl, Stmt); + + -- FIXME: add sources for signals, in order to detect multiple sources + -- to unresolved signals. + -- What happen if the component is not bound ? + + -- Create a default binding indication if necessary. + if Get_Component_Configuration (Stmt) = Null_Iir + and then Is_Component_Instantiation (Stmt) + then + Entity_Unit := Get_Visible_Entity_Declaration (Decl); + if Entity_Unit = Null_Iir then + if Is_Warning_Enabled (Warnid_Default_Binding) + and then not Flags.Flag_Elaborate + then + Warning_Msg_Sem + (Warnid_Default_Binding, +Stmt, + "no default binding for instantiation of %n", +Decl); + Explain_No_Visible_Entity (Decl); + end if; + elsif Flags.Flag_Elaborate + and then (Flags.Flag_Elaborate_With_Outdated + or else Get_Date (Entity_Unit) in Date_Valid) + then + Bind := Sem_Create_Default_Binding_Indication + (Decl, Entity_Unit, Stmt, False, True); + Set_Default_Binding_Indication (Stmt, Bind); + end if; + end if; + end Sem_Component_Instantiation_Statement; + + -- Note: a statement such as + -- label1: name; + -- can be parsed as a procedure call statement or as a + -- component instantiation statement. + -- Check now and revert in case of error. + function Sem_Concurrent_Procedure_Call_Statement + (Stmt : Iir; Is_Passive : Boolean) return Iir + is + Call : Iir_Procedure_Call; + Decl : Iir; + Label : Name_Id; + N_Stmt : Iir_Component_Instantiation_Statement; + Imp : Iir; + begin + Call := Get_Procedure_Call (Stmt); + if Get_Parameter_Association_Chain (Call) = Null_Iir then + Imp := Get_Prefix (Call); + Sem_Name (Imp); + Set_Prefix (Call, Imp); + + Decl := Get_Named_Entity (Imp); + if Get_Kind (Decl) = Iir_Kind_Component_Declaration then + N_Stmt := Create_Iir (Iir_Kind_Component_Instantiation_Statement); + Label := Get_Label (Stmt); + Set_Label (N_Stmt, Label); + Set_Parent (N_Stmt, Get_Parent (Stmt)); + Set_Instantiated_Unit (N_Stmt, Finish_Sem_Name (Imp)); + Location_Copy (N_Stmt, Stmt); + + if Label /= Null_Identifier then + -- A component instantiation statement must have + -- a label, this condition is checked during the + -- sem of the statement. + Sem_Scopes.Replace_Name (Label, Stmt, N_Stmt); + end if; + + Free_Iir (Stmt); + Free_Iir (Call); + + Sem_Component_Instantiation_Statement (N_Stmt, Is_Passive); + return N_Stmt; + end if; + end if; + Sem_Procedure_Call (Call, Stmt); + + if Is_Passive then + Imp := Get_Implementation (Call); + if Imp /= Null_Iir + and then Get_Kind (Imp) = Iir_Kind_Procedure_Declaration + then + Decl := Get_Interface_Declaration_Chain (Imp); + while Decl /= Null_Iir loop + if Get_Mode (Decl) in Iir_Out_Modes then + Error_Msg_Sem (+Stmt, "%n is not passive", +Imp); + exit; + end if; + Decl := Get_Chain (Decl); + end loop; + end if; + end if; + + return Stmt; + end Sem_Concurrent_Procedure_Call_Statement; + + procedure Sem_Block_Statement (Stmt: Iir_Block_Statement) + is + Header : constant Iir_Block_Header := Get_Block_Header (Stmt); + Guard : constant Iir_Guard_Signal_Declaration := Get_Guard_Decl (Stmt); + Expr: Iir; + Generic_Chain : Iir; + Port_Chain : Iir; + begin + -- LRM 10.1 Declarative region. + -- 7. A block statement. + Open_Declarative_Region; + + Set_Is_Within_Flag (Stmt, True); + + if Header /= Null_Iir then + Generic_Chain := Get_Generic_Chain (Header); + Sem_Interface_Chain (Generic_Chain, Generic_Interface_List); + Port_Chain := Get_Port_Chain (Header); + Sem_Interface_Chain (Port_Chain, Port_Interface_List); + + -- LRM 9.1 + -- Such actuals are evaluated in the context of the enclosing + -- declarative region. + -- GHDL: close the declarative region... + Set_Is_Within_Flag (Stmt, False); + Close_Declarative_Region; + + Sem_Generic_Port_Association_Chain (Header, Header); + + -- ... and reopen-it. + Open_Declarative_Region; + Set_Is_Within_Flag (Stmt, True); + Add_Declarations_From_Interface_Chain (Generic_Chain); + Add_Declarations_From_Interface_Chain (Port_Chain); + end if; + + -- LRM93 9.1 + -- If a guard expression appears after the reserved word BLOCK, then a + -- signal with the simple name GUARD of predefined type BOOLEAN is + -- implicitly declared at the beginning of the declarative part of the + -- block, and the guard expression defined the value of that signal at + -- any given time. + if Guard /= Null_Iir then + -- LRM93 9.1 + -- The type of the guard expression must be type BOOLEAN. + -- GHDL: guard expression must be analyzed before creating the + -- implicit GUARD signal, since the expression may reference GUARD. + Set_Expr_Staticness (Guard, None); + Set_Name_Staticness (Guard, Locally); + Expr := Get_Guard_Expression (Guard); + Expr := Sem_Condition (Expr); + if Expr /= Null_Iir then + Set_Guard_Expression (Guard, Expr); + end if; + + -- FIXME: should extract sensivity now and set the has_active flag + -- on signals, since the guard expression is evaluated when one of + -- its signal is active. However, how can a bug be introduced by + -- evaluating only when signals have events ? + + -- the guard expression is an implicit definition of a signal named + -- GUARD. Create this definition. This is necessary for the type. + Set_Identifier (Guard, Std_Names.Name_Guard); + Set_Type (Guard, Boolean_Type_Definition); + Set_Block_Statement (Guard, Stmt); + Sem_Scopes.Add_Name (Guard); + Set_Visible_Flag (Guard, True); + end if; + + Sem_Block (Stmt); + Set_Is_Within_Flag (Stmt, False); + Close_Declarative_Region; + end Sem_Block_Statement; + + procedure Sem_Generate_Statement_Body (Bod : Iir) is + begin + Set_Is_Within_Flag (Bod, True); + Sem_Block (Bod); + Set_Is_Within_Flag (Bod, False); + end Sem_Generate_Statement_Body; + + procedure Sem_For_Generate_Statement (Stmt : Iir) + is + Param : constant Iir := Get_Parameter_Specification (Stmt); + begin + -- LRM93 10.1 Declarative region. + -- 12. A generate statement. + Open_Declarative_Region; + Set_Is_Within_Flag (Stmt, True); + + Sem_Scopes.Add_Name (Param); + + -- LRM93 7.4.2 (Globally Static Primaries) + -- 4. a generate parameter; + Sem_Iterator (Param, Globally); + Set_Visible_Flag (Param, True); + + -- LRM93 9.7 + -- The discrete range in a generation scheme of the first form must + -- be a static discrete range; + if Get_Type (Param) /= Null_Iir + and then Get_Type_Staticness (Get_Type (Param)) < Globally + then + Error_Msg_Sem (+Stmt, "range must be a static discrete range"); + end if; + + -- In the same declarative region. + Sem_Generate_Statement_Body (Get_Generate_Statement_Body (Stmt)); + + Set_Is_Within_Flag (Stmt, True); + Close_Declarative_Region; + end Sem_For_Generate_Statement; + + procedure Sem_If_Case_Generate_Statement_Body (Bod : Iir) + is + Alt_Label : Name_Id; + begin + Alt_Label := Get_Alternative_Label (Bod); + if Alt_Label /= Null_Identifier then + -- Declare label. This doesn't appear in the LRM (bug ?), but + -- used here to detect duplicated labels. + Sem_Scopes.Add_Name (Bod); + Xref_Decl (Bod); + end if; + + -- Contrary to the LRM, a new declarative region is declared. This + -- is required so that declarations in a generate statement body are + -- not in the scope of the following generate bodies. + Open_Declarative_Region; + Sem_Generate_Statement_Body (Bod); + Close_Declarative_Region; + end Sem_If_Case_Generate_Statement_Body; + + procedure Sem_If_Generate_Statement (Stmt : Iir) + is + Clause : Iir; + Condition : Iir; + begin + -- LRM93 10.1 Declarative region. + -- 12. A generate statement. + Open_Declarative_Region; + Set_Is_Within_Flag (Stmt, True); + + Clause := Stmt; + while Clause /= Null_Iir loop + Condition := Get_Condition (Clause); + + if Condition /= Null_Iir then + Condition := Sem_Condition (Condition); + -- LRM93 9.7 + -- the condition in a generation scheme of the second form must be + -- a static expression. + if Condition /= Null_Iir + and then Get_Expr_Staticness (Condition) < Globally + then + Error_Msg_Sem + (+Condition, "condition must be a static expression"); + else + Set_Condition (Clause, Condition); + end if; + else + -- No condition for the last 'else' part. + pragma Assert (Get_Generate_Else_Clause (Clause) = Null_Iir); + null; + end if; + + Sem_If_Case_Generate_Statement_Body + (Get_Generate_Statement_Body (Clause)); + + Clause := Get_Generate_Else_Clause (Clause); + end loop; + + Set_Is_Within_Flag (Stmt, False); + Close_Declarative_Region; + end Sem_If_Generate_Statement; + + procedure Sem_Case_Generate_Statement (Stmt : Iir) + is + Expr : Iir; + Chain : Iir; + El : Iir; + begin + -- LRM93 10.1 Declarative region. + -- 12. A generate statement. + Open_Declarative_Region; + Set_Is_Within_Flag (Stmt, True); + + Expr := Get_Expression (Stmt); + Chain := Get_Case_Statement_Alternative_Chain (Stmt); + -- FIXME: overload. + Expr := Sem_Case_Expression (Expr); + if Expr /= Null_Iir then + Check_Read (Expr); + Set_Expression (Stmt, Expr); + + if Get_Expr_Staticness (Expr) < Globally then + Error_Msg_Sem + (+Expr, "case expression must be a static expression"); + end if; + + Sem_Case_Choices (Expr, Chain, Get_Location (Stmt)); + Set_Case_Statement_Alternative_Chain (Stmt, Chain); + end if; + + El := Chain; + while El /= Null_Iir loop + if not Get_Same_Alternative_Flag (El) then + Sem_If_Case_Generate_Statement_Body (Get_Associated_Block (El)); + end if; + El := Get_Chain (El); + end loop; + + Set_Is_Within_Flag (Stmt, False); + Close_Declarative_Region; + end Sem_Case_Generate_Statement; + + procedure Sem_Process_Statement (Proc: Iir) is + begin + Set_Is_Within_Flag (Proc, True); + + -- LRM 10.1 + -- 8. A process statement + Open_Declarative_Region; + + -- Sem declarations + Sem_Sequential_Statements (Proc, Proc); + + Close_Declarative_Region; + + Set_Is_Within_Flag (Proc, False); + + if Get_Kind (Proc) = Iir_Kind_Sensitized_Process_Statement + and then Get_Callees_List (Proc) /= Null_Iir_List + then + -- Check there is no wait statement in subprograms called. + -- Also in the case of all-sensitized process, check that package + -- subprograms don't read signals. + Sem.Add_Analysis_Checks_List (Proc); + end if; + end Sem_Process_Statement; + + procedure Sem_Sensitized_Process_Statement + (Proc: Iir_Sensitized_Process_Statement) is + begin + Sem_Sensitivity_List (Get_Sensitivity_List (Proc)); + Sem_Process_Statement (Proc); + end Sem_Sensitized_Process_Statement; + + procedure Sem_Concurrent_Selected_Signal_Assignment (Stmt: Iir) + is + Expr: Iir; + Chain : Iir; + begin + -- LRM 9.5 Concurrent Signal Assgnment Statements. + -- The process statement equivalent to a concurrent signal assignment + -- statement [...] is constructed as follows: [...] + -- + -- LRM 9.5.2 Selected Signal Assignment + -- The characteristics of the selected expression, the waveforms and + -- the choices in the selected assignment statement must be such that + -- the case statement in the equivalent statement is a legal + -- statement + + -- Target and waveforms. + Sem_Signal_Assignment (Stmt); + + -- The choices. + Chain := Get_Selected_Waveform_Chain (Stmt); + Expr := Sem_Case_Expression (Get_Expression (Stmt)); + if Expr /= Null_Iir then + Check_Read (Expr); + Set_Expression (Stmt, Expr); + Sem_Case_Choices (Expr, Chain, Get_Location (Stmt)); + Set_Selected_Waveform_Chain (Stmt, Chain); + end if; + + Sem_Guard (Stmt); + end Sem_Concurrent_Selected_Signal_Assignment; + + procedure Simple_Simultaneous_Statement (Stmt : Iir) is + Left, Right : Iir; + Res_Type : Iir; + begin + Left := Get_Simultaneous_Left (Stmt); + Right := Get_Simultaneous_Right (Stmt); + + Left := Sem_Expression_Ov (Left, Null_Iir); + Right := Sem_Expression_Ov (Right, Null_Iir); + + -- Give up in case of error + if Left = Null_Iir or else Right = Null_Iir then + return; + end if; + + Res_Type := Search_Compatible_Type (Get_Type (Left), Get_Type (Right)); + if Res_Type = Null_Iir then + Error_Msg_Sem + (+Stmt, "types of left and right expressions are incompatible"); + return; + end if; + + -- FIXME: check for nature type... + end Simple_Simultaneous_Statement; + + procedure Sem_Concurrent_Statement_Chain (Parent : Iir) + is + Is_Passive : constant Boolean := + Get_Kind (Parent) = Iir_Kind_Entity_Declaration; + El: Iir; + New_El : Iir; + Next_El : Iir; + + procedure No_Generate_Statement is + begin + if Is_Passive then + Error_Msg_Sem (+El, "generate statement forbidden in entity"); + end if; + end No_Generate_Statement; + + Prev_El : Iir; + Prev_Concurrent_Statement : Iir; + begin + Prev_Concurrent_Statement := Current_Concurrent_Statement; + + El := Get_Concurrent_Statement_Chain (Parent); + Prev_El := Null_Iir; + while El /= Null_Iir loop + Current_Concurrent_Statement := El; + New_El := El; + Next_El := Get_Chain (El); + + case Get_Kind (El) is + when Iir_Kind_Concurrent_Simple_Signal_Assignment + | Iir_Kind_Concurrent_Conditional_Signal_Assignment => + if Is_Passive then + Error_Msg_Sem (+El, "signal assignment forbidden in entity"); + end if; + Sem_Signal_Assignment (El); + when Iir_Kind_Concurrent_Selected_Signal_Assignment => + if Is_Passive then + Error_Msg_Sem (+El, "signal assignment forbidden in entity"); + end if; + Sem_Concurrent_Selected_Signal_Assignment (El); + when Iir_Kind_Sensitized_Process_Statement => + Set_Passive_Flag (El, Is_Passive); + Sem_Sensitized_Process_Statement (El); + when Iir_Kind_Process_Statement => + Set_Passive_Flag (El, Is_Passive); + Sem_Process_Statement (El); + when Iir_Kind_Component_Instantiation_Statement => + Sem_Component_Instantiation_Statement (El, Is_Passive); + when Iir_Kind_Concurrent_Assertion_Statement => + -- FIXME: must check assertion expressions does not contain + -- non-passive subprograms ?? + Sem_Assertion_Statement (El); + when Iir_Kind_Block_Statement => + if Is_Passive then + Error_Msg_Sem (+El, "block forbidden in entity"); + end if; + Sem_Block_Statement (El); + when Iir_Kind_If_Generate_Statement => + No_Generate_Statement; + Sem_If_Generate_Statement (El); + when Iir_Kind_For_Generate_Statement => + No_Generate_Statement; + Sem_For_Generate_Statement (El); + when Iir_Kind_Case_Generate_Statement => + No_Generate_Statement; + Sem_Case_Generate_Statement (El); + when Iir_Kind_Concurrent_Procedure_Call_Statement => + New_El := Sem_Concurrent_Procedure_Call_Statement + (El, Is_Passive); + when Iir_Kind_Psl_Declaration => + Sem_Psl.Sem_Psl_Declaration (El); + when Iir_Kind_Psl_Endpoint_Declaration => + Sem_Psl.Sem_Psl_Endpoint_Declaration (El); + when Iir_Kind_Psl_Assert_Statement => + New_El := Sem_Psl.Sem_Psl_Assert_Statement (El); + when Iir_Kind_Psl_Cover_Statement => + Sem_Psl.Sem_Psl_Cover_Statement (El); + when Iir_Kind_Psl_Default_Clock => + Sem_Psl.Sem_Psl_Default_Clock (El); + when Iir_Kind_Simple_Simultaneous_Statement => + Simple_Simultaneous_Statement (El); + when others => + Error_Kind ("sem_concurrent_statement_chain", El); + end case; + + if New_El /= El then + -- Replace this node. + if Prev_El = Null_Iir then + Set_Concurrent_Statement_Chain (Parent, New_El); + else + Set_Chain (Prev_El, New_El); + end if; + Set_Chain (New_El, Next_El); + Set_Parent (New_El, Parent); + Prev_El := New_El; + else + Prev_El := El; + pragma Assert (Get_Parent (El) = Parent); + end if; + + El := Next_El; + end loop; + + Current_Concurrent_Statement := Prev_Concurrent_Statement; + end Sem_Concurrent_Statement_Chain; + + -- Put labels in declarative region. + procedure Sem_Labels_Chain (Parent : Iir) + is + Stmt: Iir; + Label: Name_Id; + begin + Stmt := Get_Concurrent_Statement_Chain (Parent); + while Stmt /= Null_Iir loop + + case Get_Kind (Stmt) is + when Iir_Kind_Psl_Declaration + | Iir_Kind_Psl_Endpoint_Declaration => + -- Special case for in-lined PSL declarations. + null; + when others => + Label := Get_Label (Stmt); + + if Label /= Null_Identifier then + Sem_Scopes.Add_Name (Stmt); + Name_Visible (Stmt); + Xref_Decl (Stmt); + end if; + end case; + + -- INT-1991/issue report 27 + -- Generate statements represent declarative region and have + -- implicit declarative part. + if False + and then Flags.Vhdl_Std = Vhdl_87 + and then + (Get_Kind (Stmt) = Iir_Kind_For_Generate_Statement + or else Get_Kind (Stmt) = Iir_Kind_If_Generate_Statement) + then + Sem_Labels_Chain (Stmt); + end if; + + Stmt := Get_Chain (Stmt); + end loop; + end Sem_Labels_Chain; + + procedure Sem_Block (Blk: Iir) + is + Implicit : Implicit_Signal_Declaration_Type; + Prev_Psl_Default_Clock : Iir; + begin + Prev_Psl_Default_Clock := Current_Psl_Default_Clock; + Push_Signals_Declarative_Part (Implicit, Blk); + + Sem_Labels_Chain (Blk); + Sem_Declaration_Chain (Blk); + + Sem_Concurrent_Statement_Chain (Blk); + + -- FIXME: do it only if there is conf. spec. in the declarative + -- part. + Sem_Specification_Chain (Blk, Blk); + Check_Full_Declaration (Blk, Blk); + + Pop_Signals_Declarative_Part (Implicit); + Current_Psl_Default_Clock := Prev_Psl_Default_Clock; + end Sem_Block; + + -- Add a driver for SIG. + -- STMT is used in case of error (it is the statement that creates the + -- driver). + -- Do nothing if: + -- The current statement list does not belong to a process, + -- SIG is a formal signal interface. + procedure Sem_Add_Driver (Sig : Iir; Stmt : Iir) + is + Sig_Object : Iir; + Sig_Object_Type : Iir; + begin + if Sig = Null_Iir then + return; + end if; + Sig_Object := Get_Object_Prefix (Sig); + Sig_Object_Type := Get_Type (Sig_Object); + + -- LRM 4.3.1.2 Signal Declaration + -- It is an error if, after the elaboration of a description, a + -- signal has multiple sources and it is not a resolved signal. + + -- Check for multiple driver for a unresolved signal declaration. + -- Do this only if the object is a non-composite signal declaration. + -- NOTE: THIS IS DISABLED, since the assignment may be within a + -- generate statement. + if False + and then Get_Kind (Sig_Object) = Iir_Kind_Signal_Declaration + and then Get_Kind (Sig_Object_Type) + not in Iir_Kinds_Composite_Type_Definition + and then not Get_Resolved_Flag (Sig_Object_Type) + then + if Get_Signal_Driver (Sig_Object) /= Null_Iir and then + Get_Signal_Driver (Sig_Object) /= Current_Concurrent_Statement + then + Error_Msg_Sem (+Stmt, "unresolved %n has already a driver at %l", + (+Sig_Object, +Get_Signal_Driver (Sig_Object))); + else + Set_Signal_Driver (Sig_Object, Current_Concurrent_Statement); + end if; + end if; + + -- LRM 8.4.1 + -- If a given procedure is declared by a declarative item that is not + -- contained within a process statement, and if a signal assignment + -- statement appears in that procedure, then the target of the + -- assignment statement must be a formal parameter of the given + -- procedure or of a parent of that procedure, or an aggregate of such + -- formal parameters. + -- Similarly, if a given procedure is declared by a declarative item + -- that is not contained within a process statement and if a signal is + -- associated with an INOUT or OUT mode signal parameter in a + -- subprogram call within that procedure, then the signal so associated + -- must be a formal parameter of the given procedure or of a parent of + -- that procedure. + if Current_Concurrent_Statement = Null_Iir + or else (Get_Kind (Current_Concurrent_Statement) + not in Iir_Kinds_Process_Statement) + then + -- Not within a process statement. + if Current_Subprogram = Null_Iir then + -- not within a subprogram: concurrent statement. + return; + end if; + + -- Within a subprogram. + if Get_Kind (Sig_Object) = Iir_Kind_Signal_Declaration + or else not Is_Parameter (Sig_Object) + then + Error_Msg_Sem (+Stmt, "%n is not a formal parameter", +Sig_Object); + end if; + end if; + end Sem_Add_Driver; +end Vhdl.Sem_Stmts; diff --git a/src/vhdl/vhdl-sem_stmts.ads b/src/vhdl/vhdl-sem_stmts.ads new file mode 100644 index 000000000..81c7806aa --- /dev/null +++ b/src/vhdl/vhdl-sem_stmts.ads @@ -0,0 +1,58 @@ +-- Semantic analysis. +-- 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 Iirs; use Iirs; + +package Vhdl.Sem_Stmts is + -- Analyze declarations and concurrent statements of BLK, which is + -- either an architecture_declaration, and entity_declaration, + -- a block_statement or a generate_statement_body. + procedure Sem_Block (Blk: Iir); + + -- Analyze the concurrent statements of PARENT. + procedure Sem_Concurrent_Statement_Chain (Parent : Iir); + + -- Analyze declaration chain and sequential statement chain + -- of BODY_PARENT. + -- DECL is the declaration for these chains (DECL is the declaration, which + -- is different from the bodies). + -- This is used by processes and subprograms analyze. + procedure Sem_Sequential_Statements (Decl : Iir; Body_Parent : Iir); + + -- Sem for concurrent and sequential assertion statements. + procedure Sem_Report_Statement (Stmt : Iir); + + -- Get the current subprogram or process. + function Get_Current_Subprogram return Iir; + pragma Inline (Get_Current_Subprogram); + + -- Get the current concurrent statement, or NULL_IIR if none. + function Get_Current_Concurrent_Statement return Iir; + pragma Inline (Get_Current_Concurrent_Statement); + + -- Current PSL default_clock declaration. + -- Automatically saved and restore while analyzing concurrent statements. + Current_Psl_Default_Clock : Iir; + + -- Add a driver for SIG. + -- STMT is used in case of error (it is the statement that creates the + -- driver). + -- Do nothing if: + -- The current statement list does not belong to a process, + -- SIG is a formal signal interface. + procedure Sem_Add_Driver (Sig : Iir; Stmt : Iir); +end Vhdl.Sem_Stmts; diff --git a/src/vhdl/vhdl-sem_types.adb b/src/vhdl/vhdl-sem_types.adb new file mode 100644 index 000000000..20651c000 --- /dev/null +++ b/src/vhdl/vhdl-sem_types.adb @@ -0,0 +1,2382 @@ +-- Semantic analysis. +-- 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 Libraries; +with Flags; use Flags; +with Types; use Types; +with Errorout; use Errorout; +with Evaluation; use Evaluation; +with Vhdl.Sem_Utils; +with Vhdl.Sem_Expr; use Vhdl.Sem_Expr; +with Vhdl.Sem_Scopes; use Vhdl.Sem_Scopes; +with Vhdl.Sem_Names; use Vhdl.Sem_Names; +with Vhdl.Sem_Decls; +with Vhdl.Sem_Inst; +with Name_Table; +with Std_Names; +with Iirs_Utils; use Iirs_Utils; +with Std_Package; use Std_Package; +with Ieee.Std_Logic_1164; +with Xrefs; use Xrefs; + +package body Vhdl.Sem_Types is + -- Mark the resolution function (this may be required by the back-end to + -- generate resolver). + procedure Mark_Resolution_Function (Subtyp : Iir) + is + Func : Iir_Function_Declaration; + begin + if not Get_Resolved_Flag (Subtyp) then + return; + end if; + + Func := Has_Resolution_Function (Subtyp); + -- Maybe the type is resolved through its elements. + if Func /= Null_Iir then + Set_Resolution_Function_Flag (Func, True); + + -- For internal reasons of translation, the element subtype has + -- to be translated for signals. + -- FIXME: maybe move the whole Has_Signal flag generation in + -- translation, as this is needed only for translation. + -- FIXME: how to deal with incorrect function ? Use an Error node ? + Set_Type_Has_Signal + (Get_Element_Subtype + (Get_Type (Get_Interface_Declaration_Chain (Func)))); + end if; + end Mark_Resolution_Function; + + procedure Set_Type_Has_Signal (Atype : Iir) + is + Orig : Iir; + begin + -- Sanity check: ATYPE can be a signal type (eg: not an access type) + if not Get_Signal_Type_Flag (Atype) then + -- Do not crash since this may be called on an erroneous design. + return; + end if; + + -- If the type is already marked, nothing to do. + if Get_Has_Signal_Flag (Atype) then + return; + end if; + + -- This type is used to declare a signal. + Set_Has_Signal_Flag (Atype, True); + + -- If this type was instantiated, also mark the origin. + Orig := Sem_Inst.Get_Origin (Atype); + if Orig /= Null_Iir then + Set_Type_Has_Signal (Orig); + end if; + + -- For subtype, mark resolution function and base type. + case Get_Kind (Atype) is + when Iir_Kinds_Scalar_Subtype_Definition + | Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Record_Subtype_Definition => + Set_Type_Has_Signal (Get_Base_Type (Atype)); + Mark_Resolution_Function (Atype); + declare + Tm : constant Iir := Get_Subtype_Type_Mark (Atype); + begin + if Tm /= Null_Iir then + Set_Type_Has_Signal (Get_Type (Get_Named_Entity (Tm))); + end if; + end; + when others => + null; + end case; + + -- For composite types, also mark type of elements. + case Get_Kind (Atype) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Physical_Type_Definition + | Iir_Kind_Floating_Type_Definition => + null; + when Iir_Kinds_Scalar_Subtype_Definition => + null; + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Array_Type_Definition => + Set_Type_Has_Signal (Get_Element_Subtype (Atype)); + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + declare + El_List : constant Iir_Flist := + Get_Elements_Declaration_List (Atype); + El : Iir; + begin + for I in Flist_First .. Flist_Last (El_List) loop + El := Get_Nth_Element (El_List, I); + Set_Type_Has_Signal (Get_Type (El)); + end loop; + end; + when Iir_Kind_Error => + null; + when Iir_Kind_Incomplete_Type_Definition => + -- No need to copy the flag. + null; + when Iir_Kind_Interface_Type_Definition => + null; + when others => + Error_Kind ("set_type_has_signal(2)", Atype); + end case; + end Set_Type_Has_Signal; + + -- Sem a range expression that appears in an integer, real or physical + -- type definition. + -- + -- Both left and right bounds must be of the same type class, ie + -- integer types, or if INT_ONLY is false, real types. + -- However, the two bounds need not have the same type. + function Sem_Type_Range_Expression (Expr : Iir; Int_Only : Boolean) + return Iir + is + Left, Right: Iir; + Bt_L_Kind, Bt_R_Kind : Iir_Kind; + begin + Left := Sem_Expression_Universal (Get_Left_Limit_Expr (Expr)); + Right := Sem_Expression_Universal (Get_Right_Limit_Expr (Expr)); + if Left = Null_Iir or Right = Null_Iir then + return Null_Iir; + end if; + + -- Emit error message for overflow and replace with a value to avoid + -- error storm. + if Get_Kind (Left) = Iir_Kind_Overflow_Literal then + Error_Msg_Sem (+Left, "overflow in left bound"); + Left := Build_Extreme_Value + (Get_Direction (Expr) = Iir_Downto, Left); + end if; + if Get_Kind (Right) = Iir_Kind_Overflow_Literal then + Error_Msg_Sem (+Right, "overflow in right bound"); + Right := Build_Extreme_Value + (Get_Direction (Expr) = Iir_To, Right); + end if; + Set_Left_Limit_Expr (Expr, Left); + Set_Right_Limit_Expr (Expr, Right); + Set_Left_Limit (Expr, Left); + Set_Right_Limit (Expr, Right); + + Set_Expr_Staticness (Expr, Min (Get_Expr_Staticness (Left), + Get_Expr_Staticness (Right))); + + Bt_L_Kind := Get_Kind (Get_Base_Type (Get_Type (Left))); + Bt_R_Kind := Get_Kind (Get_Base_Type (Get_Type (Right))); + + if Int_Only then + if Bt_L_Kind /= Iir_Kind_Integer_Type_Definition + and then Bt_R_Kind = Iir_Kind_Integer_Type_Definition + then + Error_Msg_Sem (+Left, "left bound must be an integer expression"); + return Null_Iir; + end if; + if Bt_R_Kind /= Iir_Kind_Integer_Type_Definition + and then Bt_L_Kind = Iir_Kind_Integer_Type_Definition + then + Error_Msg_Sem + (+Right, "right bound must be an integer expression"); + return Null_Iir; + end if; + if Bt_R_Kind /= Iir_Kind_Integer_Type_Definition + and then Bt_L_Kind /= Iir_Kind_Integer_Type_Definition + then + Error_Msg_Sem (+Expr, "each bound must be an integer expression"); + return Null_Iir; + end if; + else + if Bt_L_Kind /= Bt_R_Kind then + Error_Msg_Sem + (+Expr, "left and right bounds must be of the same type class"); + return Null_Iir; + end if; + case Bt_L_Kind is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition => + null; + when others => + -- Enumeration range are not allowed to define a new type. + Error_Msg_Sem + (+Expr, "bad range type, only integer or float is allowed"); + return Null_Iir; + end case; + end if; + + return Expr; + end Sem_Type_Range_Expression; + + function Create_Integer_Type (Loc : Iir; Constraint : Iir; Decl : Iir) + return Iir + is + Ntype: Iir_Integer_Subtype_Definition; + Ndef: Iir_Integer_Type_Definition; + begin + Ntype := Create_Iir (Iir_Kind_Integer_Subtype_Definition); + Location_Copy (Ntype, Loc); + Ndef := Create_Iir (Iir_Kind_Integer_Type_Definition); + Location_Copy (Ndef, Loc); + Set_Base_Type (Ndef, Ndef); + Set_Type_Declarator (Ndef, Decl); + Set_Type_Staticness (Ndef, Locally); + Set_Signal_Type_Flag (Ndef, True); + Set_Base_Type (Ntype, Ndef); + Set_Type_Declarator (Ntype, Decl); + Set_Range_Constraint (Ntype, Constraint); + Set_Type_Staticness (Ntype, Get_Expr_Staticness (Constraint)); + Set_Resolved_Flag (Ntype, False); + Set_Signal_Type_Flag (Ntype, True); + if Get_Type_Staticness (Ntype) /= Locally then + Error_Msg_Sem + (+Decl, "range constraint of type must be locally static"); + end if; + return Ntype; + end Create_Integer_Type; + + function Range_Expr_To_Type_Definition (Expr : Iir; Decl: Iir) + return Iir + is + Rng : Iir; + Res : Iir; + Base_Type : Iir; + begin + if Sem_Type_Range_Expression (Expr, False) = Null_Iir then + return Null_Iir; + end if; + Rng := Eval_Range_If_Static (Expr); + if Get_Expr_Staticness (Rng) /= Locally then + -- FIXME: create an artificial range to avoid error storm ? + null; + end if; + + case Get_Kind (Get_Base_Type (Get_Type (Get_Left_Limit (Rng)))) is + when Iir_Kind_Integer_Type_Definition => + Res := Create_Integer_Type (Expr, Rng, Decl); + when Iir_Kind_Floating_Type_Definition => + declare + Ntype: Iir_Floating_Subtype_Definition; + Ndef: Iir_Floating_Type_Definition; + begin + Ntype := Create_Iir (Iir_Kind_Floating_Subtype_Definition); + Location_Copy (Ntype, Expr); + Ndef := Create_Iir (Iir_Kind_Floating_Type_Definition); + Location_Copy (Ndef, Expr); + Set_Base_Type (Ndef, Ndef); + Set_Type_Declarator (Ndef, Decl); + Set_Type_Staticness (Ndef, Get_Expr_Staticness (Expr)); + Set_Signal_Type_Flag (Ndef, True); + Set_Base_Type (Ntype, Ndef); + Set_Type_Declarator (Ntype, Decl); + Set_Range_Constraint (Ntype, Rng); + Set_Resolved_Flag (Ntype, False); + Set_Type_Staticness (Ntype, Get_Expr_Staticness (Expr)); + Set_Signal_Type_Flag (Ntype, True); + Res := Ntype; + end; + when others => + -- sem_range_expression should catch such errors. + raise Internal_Error; + end case; + + -- A type and a subtype were declared. The type of the bounds are now + -- used for the implicit subtype declaration. But the type of the + -- bounds aren't of the type of the type declaration (this is 'obvious' + -- because they exist before the type declaration). Override their + -- type. This is doable without destroying information as they are + -- either literals (of type convertible_xx_type_definition) or an + -- evaluated literal. + -- + -- Overriding makes these implicit subtype homogenous with explicit + -- subtypes. + Base_Type := Get_Base_Type (Res); + Set_Type (Rng, Base_Type); + Set_Type (Get_Left_Limit (Rng), Base_Type); + Set_Type (Get_Right_Limit (Rng), Base_Type); + + return Res; + end Range_Expr_To_Type_Definition; + + function Create_Physical_Literal (Val : Iir_Int64; Unit : Iir) return Iir + is + Lit : Iir; + begin + Lit := Create_Iir (Iir_Kind_Physical_Int_Literal); + Set_Value (Lit, Val); + Set_Physical_Unit (Lit, Unit); + Set_Expr_Staticness (Lit, Locally); + Set_Type (Lit, Get_Type (Unit)); + Location_Copy (Lit, Unit); + return Lit; + end Create_Physical_Literal; + + -- Analyze a physical type definition. Create a subtype. + function Sem_Physical_Type_Definition (Def : Iir; Decl : Iir) + return Iir_Physical_Subtype_Definition + is + Unit: Iir_Unit_Declaration; + Sub_Type: Iir_Physical_Subtype_Definition; + Range_Expr : Iir; + Range_Expr1: Iir; + Val : Iir; + Lit : Iir_Physical_Int_Literal; + begin + Range_Expr := Get_Range_Constraint (Def); + + -- LRM93 4.1 + -- The simple name declared by a type declaration denotes the + -- declared type, unless the type declaration declares both a base + -- type and a subtype of the base type, in which case the simple name + -- denotes the subtype, and the base type is anonymous. + Set_Type_Declarator (Def, Decl); + Set_Base_Type (Def, Def); + Set_Resolved_Flag (Def, False); + Set_Type_Staticness (Def, Locally); + Set_Signal_Type_Flag (Def, True); + + -- LRM93 3.1.3 + -- Each bound of a range constraint that is used in a physical type + -- definition must be a locally static expression of some integer type + -- but the two bounds need not have the same integer type. + case Get_Kind (Range_Expr) is + when Iir_Kind_Range_Expression => + Range_Expr1 := Sem_Type_Range_Expression (Range_Expr, True); + when Iir_Kind_Attribute_Name => + Sem_Name (Range_Expr); + Range_Expr1 := Name_To_Range (Range_Expr); + when Iir_Kind_Error => + Range_Expr1 := Null_Iir; + when others => + Error_Kind ("sem_physical_type_definition", Range_Expr); + end case; + if Range_Expr1 = Null_Iir or else Is_Error (Range_Expr1) then + -- Avoid cascading errors. + Range_Expr1 := + Get_Range_Constraint (Universal_Integer_Subtype_Definition); + end if; + if Get_Expr_Staticness (Range_Expr1) /= Locally then + Error_Msg_Sem (+Range_Expr1, + "range constraint for a physical type must be static"); + Range_Expr1 := + Get_Range_Constraint (Universal_Integer_Subtype_Definition); + else + Range_Expr1 := Eval_Range_If_Static (Range_Expr1); + end if; + + -- Create the subtype. + Sub_Type := Create_Iir (Iir_Kind_Physical_Subtype_Definition); + Location_Copy (Sub_Type, Range_Expr); + Set_Base_Type (Sub_Type, Def); + Set_Signal_Type_Flag (Sub_Type, True); + + -- Analyze the primary unit. + Unit := Get_Unit_Chain (Def); + + -- Set its value to 1. + Set_Type (Unit, Def); + Set_Expr_Staticness (Unit, Locally); + Set_Name_Staticness (Unit, Locally); + Lit := Create_Physical_Literal (1, Unit); + Set_Physical_Literal (Unit, Lit); + + Sem_Scopes.Add_Name (Unit); + Set_Visible_Flag (Unit, True); + Xref_Decl (Unit); + + declare + -- Convert an integer literal to a physical literal. + -- This is used to convert bounds. + function Lit_To_Phys_Lit (Lim : Iir_Integer_Literal) + return Iir_Physical_Int_Literal + is + Res : Iir_Physical_Int_Literal; + begin + Res := Create_Iir (Iir_Kind_Physical_Int_Literal); + Location_Copy (Res, Lim); + Set_Type (Res, Def); + Set_Value (Res, Get_Value (Lim)); + Set_Physical_Unit (Res, Get_Primary_Unit (Def)); + Set_Expr_Staticness (Res, Locally); + Set_Literal_Origin (Res, Lim); + return Res; + end Lit_To_Phys_Lit; + + Phys_Range : Iir_Range_Expression; + Lit : Iir; + begin + -- Create the physical range. + Phys_Range := Create_Iir (Iir_Kind_Range_Expression); + Location_Copy (Phys_Range, Range_Expr1); + Set_Type (Phys_Range, Def); + Set_Direction (Phys_Range, Get_Direction (Range_Expr1)); + Lit := Lit_To_Phys_Lit (Get_Left_Limit (Range_Expr1)); + Set_Left_Limit (Phys_Range, Lit); + Set_Left_Limit_Expr (Phys_Range, Lit); + Lit := Lit_To_Phys_Lit (Get_Right_Limit (Range_Expr1)); + Set_Right_Limit (Phys_Range, Lit); + Set_Right_Limit_Expr (Phys_Range, Lit); + Set_Expr_Staticness + (Phys_Range, Get_Expr_Staticness (Range_Expr1)); + + Set_Range_Constraint (Sub_Type, Phys_Range); + Set_Range_Constraint (Def, Null_Iir); + -- This must be locally... + Set_Type_Staticness (Sub_Type, Get_Expr_Staticness (Range_Expr1)); + + -- FIXME: the original range is not used. Reuse it ? + Free_Iir (Range_Expr); + end; + Set_Resolved_Flag (Sub_Type, False); + + -- Analyze secondary units. + Unit := Get_Chain (Unit); + while Unit /= Null_Iir loop + Sem_Scopes.Add_Name (Unit); + Val := Sem_Expression (Get_Physical_Literal (Unit), Def); + if Val /= Null_Iir then + Val := Eval_Physical_Literal (Val); + Set_Physical_Literal (Unit, Val); + + -- LRM93 §3.1 + -- The position number of unit names need not lie within the range + -- specified by the range constraint. + -- GHDL: this was not true in VHDL87. + -- GHDL: This is not so simple if 1 is not included in the range. + if False and then Flags.Vhdl_Std = Vhdl_87 + and then Range_Expr1 /= Null_Iir + then + if not Eval_Int_In_Range (Get_Value (Unit), Range_Expr1) then + Error_Msg_Sem + (+Unit, "physical literal does not lie within the range"); + end if; + end if; + else + -- Avoid errors storm. + Val := Create_Physical_Literal (1, Get_Primary_Unit (Def)); + Set_Literal_Origin (Val, Get_Physical_Literal (Unit)); + Set_Physical_Literal (Unit, Val); + end if; + + Set_Type (Unit, Def); + Set_Expr_Staticness (Unit, Locally); + Set_Name_Staticness (Unit, Locally); + Sem_Scopes.Name_Visible (Unit); + Xref_Decl (Unit); + Unit := Get_Chain (Unit); + end loop; + + return Sub_Type; + end Sem_Physical_Type_Definition; + + -- Return true iff decl is std.textio.text + function Is_Text_Type_Declaration (Decl : Iir_Type_Declaration) + return Boolean + is + use Std_Names; + P : Iir; + begin + if Get_Identifier (Decl) /= Name_Text then + return False; + end if; + P := Get_Parent (Decl); + if Get_Kind (P) /= Iir_Kind_Package_Declaration + or else Get_Identifier (P) /= Name_Textio + then + return False; + end if; + -- design_unit, design_file, library_declaration. + P := Get_Library (Get_Design_File (Get_Design_Unit (P))); + if P /= Libraries.Std_Library then + return False; + end if; + return True; + end Is_Text_Type_Declaration; + + procedure Check_No_File_Type (El_Type : Iir; Loc : Iir) is + begin + case Get_Kind (El_Type) is + when Iir_Kind_File_Type_Definition => + Error_Msg_Sem + (+Loc, "file type element not allowed in a composite type"); + when Iir_Kind_Protected_Type_Declaration => + Error_Msg_Sem + (+Loc, "protected type element not allowed in a composite type"); + when others => + null; + end case; + end Check_No_File_Type; + + -- Analyze the array_element type of array type DEF. + -- Set resolved_flag of DEF. + procedure Sem_Array_Element (Def : Iir) + is + El_Type : Iir; + begin + El_Type := Get_Element_Subtype_Indication (Def); + El_Type := Sem_Subtype_Indication (El_Type); + if El_Type = Null_Iir then + Set_Type_Staticness (Def, None); + Set_Resolved_Flag (Def, False); + return; + end if; + Set_Element_Subtype_Indication (Def, El_Type); + + El_Type := Get_Type_Of_Subtype_Indication (El_Type); + Set_Element_Subtype (Def, El_Type); + Check_No_File_Type (El_Type, Def); + Set_Signal_Type_Flag (Def, Get_Signal_Type_Flag (El_Type)); + + -- LRM93 §3.2.1.1 + -- The same requirement exists [must define a constrained + -- array subtype] [...] for the element subtype indication + -- of an array type definition, if the type of the array + -- element is itself an array type. + if Vhdl_Std < Vhdl_08 + and then not Is_Fully_Constrained_Type (El_Type) + then + Error_Msg_Sem + (+Def, + "array element of unconstrained %n is not allowed before vhdl08", + +El_Type); + end if; + Set_Resolved_Flag (Def, Get_Resolved_Flag (El_Type)); + end Sem_Array_Element; + + procedure Sem_Protected_Type_Declaration (Type_Decl : Iir_Type_Declaration) + is + Decl : Iir_Protected_Type_Declaration; + El : Iir; + begin + Decl := Get_Type_Definition (Type_Decl); + Set_Base_Type (Decl, Decl); + Set_Resolved_Flag (Decl, False); + Set_Signal_Type_Flag (Decl, False); + Set_Type_Staticness (Decl, None); + + -- LRM 10.3 Visibility + -- [...] except in the declaration of a design_unit or a protected type + -- declaration, in which case it starts immediatly after the reserved + -- word is occuring after the identifier of the design unit or + -- protected type declaration. + Set_Visible_Flag (Type_Decl, True); + + -- LRM 10.1 + -- n) A protected type declaration, together with the corresponding + -- body. + Open_Declarative_Region; + + Sem_Decls.Sem_Declaration_Chain (Decl); + El := Get_Declaration_Chain (Decl); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Use_Clause + | Iir_Kind_Attribute_Specification => + null; + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + declare + Inter : Iir; + Inter_Type : Iir; + begin + -- LRM08 3.5.1 Protected type declarations + -- Such formal parameters must not be of an access type or + -- a file type; moreover, they must not have a subelement + -- that is an access type of a file type. + Inter := Get_Interface_Declaration_Chain (El); + while Inter /= Null_Iir loop + Inter_Type := Get_Type (Inter); + if Inter_Type /= Null_Iir + and then Get_Signal_Type_Flag (Inter_Type) = False + and then Get_Kind (Inter_Type) + /= Iir_Kind_Protected_Type_Declaration + then + Error_Msg_Sem + (+Inter, "formal parameter method must not be " + & "access or file type"); + end if; + Inter := Get_Chain (Inter); + end loop; + + -- LRM08 3.5.1 Protected type declarations + -- Additionally, in the case of a function subprogram, the + -- return type of the function must not be of an access type + -- or file type; moreover, it must not have a subelement + -- that is an access type of a file type. + if Get_Kind (El) = Iir_Kind_Function_Declaration then + Inter_Type := Get_Return_Type (El); + if Inter_Type /= Null_Iir + and then Get_Signal_Type_Flag (Inter_Type) = False + then + Error_Msg_Sem + (+El, "method cannot return an access or a file"); + end if; + end if; + end; + when Iir_Kind_Anonymous_Type_Declaration => + -- This is an error, but an anonynmous type declaration is + -- followed by a subtype declaration, which is also an error. + -- Avoid duplicate messages. + null; + when others => + Error_Msg_Sem + (+El, "%n is not allowed in protected type declaration", + +El); + end case; + El := Get_Chain (El); + end loop; + + Close_Declarative_Region; + end Sem_Protected_Type_Declaration; + + procedure Sem_Protected_Type_Body (Bod : Iir) + is + Inter : Name_Interpretation_Type; + Type_Decl : Iir; + Decl : Iir; + begin + -- LRM 3.5 Protected types. + -- Each protected type declaration appearing immediatly within a given + -- declaration region must have exactly one corresponding protected type + -- body appearing immediatly within the same declarative region and + -- textually subsequent to the protected type declaration. + -- + -- Similarly, each protected type body appearing immediatly within a + -- given declarative region must have exactly one corresponding + -- protected type declaration appearing immediatly within the same + -- declarative region and textually prior to the protected type body. + Inter := Get_Interpretation (Get_Identifier (Bod)); + if Valid_Interpretation (Inter) + and then Is_In_Current_Declarative_Region (Inter) + then + Type_Decl := Get_Declaration (Inter); + if Get_Kind (Type_Decl) = Iir_Kind_Type_Declaration then + Decl := Get_Type_Definition (Type_Decl); + else + Decl := Null_Iir; + end if; + else + Decl := Null_Iir; + end if; + + if Decl /= Null_Iir + and then Get_Kind (Decl) = Iir_Kind_Protected_Type_Declaration + then + Set_Protected_Type_Declaration (Bod, Decl); + if Get_Protected_Type_Body (Decl) /= Null_Iir then + Error_Msg_Sem + (+Bod, "protected type body already declared for %n", + (1 => +Decl), Cont => True); + Error_Msg_Sem + (+Get_Protected_Type_Body (Decl), "(previous body)"); + Decl := Null_Iir; + elsif not Get_Visible_Flag (Type_Decl) then + -- Can this happen ? + Error_Msg_Sem + (+Bod, "protected type declaration not yet visible", + Cont => True); + Error_Msg_Sem + (+Decl, "(location of protected type declaration)"); + Decl := Null_Iir; + else + Set_Protected_Type_Body (Decl, Bod); + end if; + else + Error_Msg_Sem + (+Bod, "no protected type declaration for this body"); + if Decl /= Null_Iir then + Error_Msg_Sem (+Decl, "(found %n declared here)", +Decl); + Decl := Null_Iir; + end if; + end if; + + -- LRM 10.1 + -- n) A protected type declaration, together with the corresponding + -- body. + Open_Declarative_Region; + + if Decl /= Null_Iir then + Xref_Body (Bod, Decl); + Add_Protected_Type_Declarations (Decl); + end if; + + Sem_Decls.Sem_Declaration_Chain (Bod); + + Sem_Decls.Check_Full_Declaration (Bod, Bod); + + -- LRM 3.5.2 Protected type bodies + -- Each subprogram declaration appearing in a given protected type + -- declaration shall have a corresponding subprogram body appearing in + -- the corresponding protected type body. + if Decl /= Null_Iir then + Sem_Decls.Check_Full_Declaration (Decl, Bod); + end if; + + Close_Declarative_Region; + end Sem_Protected_Type_Body; + + -- Return the constraint state from CONST (the initial state) and EL_TYPE, + -- as if ATYPE was a new element of a record. + -- + -- LRM08 5 Types + -- A composite subtype is said to be unconstrained if: + -- - [...] + -- - It is a record subtype with at least one element of a composite + -- subtype and each element that is of a composite subtype is + -- unconstrained. + -- + -- A composite subtype is said to be fully constrained if: + -- - [...] + -- - It is a record subtype and each element subtype either is not a + -- composite subtype or is a fully constrained composite subtype. + procedure Update_Record_Constraint (Constraint : in out Iir_Constraint; + Composite_Found : in out Boolean; + El_Type : Iir) is + begin + if Get_Kind (El_Type) not in Iir_Kinds_Composite_Type_Definition then + pragma Assert (Composite_Found or Constraint = Fully_Constrained); + return; + end if; + + if Composite_Found then + case Constraint is + when Fully_Constrained + | Unconstrained => + if Get_Constraint_State (El_Type) /= Constraint then + Constraint := Partially_Constrained; + end if; + when Partially_Constrained => + Constraint := Partially_Constrained; + end case; + else + Composite_Found := True; + Constraint := Get_Constraint_State (El_Type); + end if; + end Update_Record_Constraint; + + function Get_Array_Constraint (Def : Iir) return Iir_Constraint + is + El_Type : constant Iir := Get_Element_Subtype (Def); + Constrained_Index : constant Boolean := Get_Index_Constraint_Flag (Def); + begin + if Get_Kind (El_Type) in Iir_Kinds_Composite_Type_Definition then + case Get_Constraint_State (El_Type) is + when Fully_Constrained => + if Constrained_Index then + return Fully_Constrained; + else + return Partially_Constrained; + end if; + when Partially_Constrained => + return Partially_Constrained; + when Unconstrained => + if not Constrained_Index then + return Unconstrained; + else + return Partially_Constrained; + end if; + end case; + else + -- Element subtype is not a composite subtype. + if Constrained_Index then + return Fully_Constrained; + else + return Unconstrained; + end if; + end if; + end Get_Array_Constraint; + + function Sem_Enumeration_Type_Definition (Def: Iir; Decl: Iir) return Iir + is + Literal_List : constant Iir_Flist := Get_Enumeration_Literal_List (Def); + El: Iir; + Only_Characters : Boolean; + begin + Set_Base_Type (Def, Def); + Set_Type_Staticness (Def, Locally); + Set_Signal_Type_Flag (Def, True); + + -- Makes all literal visible. + Only_Characters := True; + for I in Flist_First .. Flist_Last (Literal_List) loop + El := Get_Nth_Element (Literal_List, I); + Set_Expr_Staticness (El, Locally); + Set_Name_Staticness (El, Locally); + Set_Type (El, Def); + Sem_Utils.Compute_Subprogram_Hash (El); + Sem_Scopes.Add_Name (El); + Name_Visible (El); + Xref_Decl (El); + + -- LRM93 3.1.1 Enumeration types + -- An enumeration type is said to be a character type if at least + -- one of its enumeration literals is a character literal. + if Name_Table.Is_Character (Get_Identifier (El)) then + Set_Is_Character_Type (Def, True); + else + Only_Characters := False; + end if; + end loop; + Set_Only_Characters_Flag (Def, Only_Characters); + Set_Resolved_Flag (Def, False); + + Create_Range_Constraint_For_Enumeration_Type (Def); + + -- Identifier IEEE.Std_Logic_1164.Std_Ulogic. + if Get_Identifier (Decl) = Std_Names.Name_Std_Ulogic + and then + Get_Parent (Decl) = Ieee.Std_Logic_1164.Std_Logic_1164_Pkg + then + Ieee.Std_Logic_1164.Std_Ulogic_Type := Def; + end if; + + return Def; + end Sem_Enumeration_Type_Definition; + + function Sem_Record_Type_Definition (Def: Iir) return Iir + is + -- Analyzed type of previous element + Last_Type : Iir; + + El_List : constant Iir_Flist := Get_Elements_Declaration_List (Def); + El : Iir; + El_Type : Iir; + Resolved_Flag : Boolean; + Type_Staticness : Iir_Staticness; + Constraint : Iir_Constraint; + Composite_Found : Boolean; + begin + -- LRM 10.1 + -- 5. A record type declaration, + Open_Declarative_Region; + + Resolved_Flag := True; + Last_Type := Null_Iir; + Type_Staticness := Locally; + Constraint := Fully_Constrained; + Composite_Found := False; + Set_Signal_Type_Flag (Def, True); + + for I in Flist_First .. Flist_Last (El_List) loop + El := Get_Nth_Element (El_List, I); + El_Type := Get_Subtype_Indication (El); + if El_Type /= Null_Iir then + -- Be careful for a declaration list (r,g,b: integer). + El_Type := Sem_Subtype_Indication (El_Type); + Set_Subtype_Indication (El, El_Type); + El_Type := Get_Type_Of_Subtype_Indication (El_Type); + Last_Type := El_Type; + else + El_Type := Last_Type; + end if; + if El_Type /= Null_Iir then + Set_Type (El, El_Type); + Check_No_File_Type (El_Type, El); + if not Get_Signal_Type_Flag (El_Type) then + Set_Signal_Type_Flag (Def, False); + end if; + + -- LRM93 3.2.1.1 + -- The same requirement [must define a constrained array + -- subtype] exits for the subtype indication of an + -- element declaration, if the type of the record + -- element is an array type. + if Vhdl_Std < Vhdl_08 + and then not Is_Fully_Constrained_Type (El_Type) + then + Error_Msg_Sem + (+El, + "element declaration of unconstrained %n is not allowed", + +El_Type); + end if; + Resolved_Flag := + Resolved_Flag and Get_Resolved_Flag (El_Type); + Type_Staticness := Min (Type_Staticness, + Get_Type_Staticness (El_Type)); + Update_Record_Constraint (Constraint, Composite_Found, El_Type); + else + Type_Staticness := None; + end if; + Sem_Scopes.Add_Name (El); + Name_Visible (El); + Xref_Decl (El); + end loop; + Close_Declarative_Region; + Set_Base_Type (Def, Def); + Set_Resolved_Flag (Def, Resolved_Flag); + Set_Type_Staticness (Def, Type_Staticness); + Set_Constraint_State (Def, Constraint); + return Def; + end Sem_Record_Type_Definition; + + function Sem_Unbounded_Array_Type_Definition (Def: Iir) return Iir + is + Index_List : constant Iir_Flist := + Get_Index_Subtype_Definition_List (Def); + Index_Type : Iir; + begin + Set_Base_Type (Def, Def); + + for I in Flist_First .. Flist_Last (Index_List) loop + Index_Type := Get_Nth_Element (Index_List, I); + + Index_Type := Sem_Type_Mark (Index_Type); + Set_Nth_Element (Index_List, I, Index_Type); + + Index_Type := Get_Type (Index_Type); + if Get_Kind (Index_Type) not in Iir_Kinds_Discrete_Type_Definition + then + Error_Msg_Sem + (+Index_Type, + "an index type of an array must be a discrete type"); + -- FIXME: disp type Index_Type ? + end if; + end loop; + + Set_Index_Subtype_List (Def, Index_List); + + Sem_Array_Element (Def); + Set_Constraint_State (Def, Get_Array_Constraint (Def)); + + -- According to LRM93 7.4.1, an unconstrained array type is not static. + Set_Type_Staticness (Def, None); + + return Def; + end Sem_Unbounded_Array_Type_Definition; + + -- Return the subtype declaration corresponding to the base type of ATYPE + -- (for integer and real types), or the type for enumerated types. To say + -- that differently, it returns the type or subtype which defines the + -- original range. + function Get_First_Subtype_Declaration (Atype : Iir) return Iir is + Base_Type : constant Iir := Get_Base_Type (Atype); + Base_Decl : constant Iir := Get_Type_Declarator (Base_Type); + begin + if Get_Kind (Base_Type) = Iir_Kind_Enumeration_Type_Definition then + pragma Assert (Get_Kind (Base_Decl) = Iir_Kind_Type_Declaration); + return Base_Decl; + else + return Get_Type_Declarator (Get_Subtype_Definition (Base_Decl)); + end if; + end Get_First_Subtype_Declaration; + + function Sem_Constrained_Array_Type_Definition (Def: Iir; Decl: Iir) + return Iir + is + Index_List : constant Iir_Flist := Get_Index_Constraint_List (Def); + Index_Type : Iir; + Index_Name : Iir; + Base_Index_List : Iir_Flist; + El_Type : Iir; + Staticness : Iir_Staticness; + + -- array_type_definition, which is the same as the subtype, + -- but without any constraint in the indexes. + Base_Type: Iir; + begin + -- LRM08 5.3.2.1 Array types + -- A constrained array definition similarly defines both an array + -- type and a subtype of this type. + -- - The array type is an implicitely declared anonymous type, + -- this type is defined by an (implicit) unbounded array + -- definition in which the element subtype indication either + -- denotes the base type of the subtype denoted by the element + -- subtype indication of the constrained array definition, if + -- that subtype is a composite type, or otherwise is the + -- element subtype indication of the constrained array + -- definition, and in which the type mark of each index subtype + -- definition denotes the subtype defined by the corresponding + -- discrete range. + -- - The array subtype is the subtype obtained by imposition of + -- the index constraint on the array type and if the element + -- subtype indication of the constrained array definition + -- denotes a fully or partially constrained composite subtype, + -- imposition of the constraint of that subtype as an array + -- element constraint on the array type. + + -- FIXME: all indexes must be either constrained or + -- unconstrained. + -- If all indexes are unconstrained, this is really a type + -- otherwise, this is a subtype. + + -- Create a definition for the base type of subtype DEF. + Base_Type := Create_Iir (Iir_Kind_Array_Type_Definition); + Location_Copy (Base_Type, Def); + Set_Base_Type (Base_Type, Base_Type); + Set_Type_Declarator (Base_Type, Decl); + Base_Index_List := Create_Iir_Flist (Get_Nbr_Elements (Index_List)); + Set_Index_Subtype_Definition_List (Base_Type, Base_Index_List); + Set_Index_Subtype_List (Base_Type, Base_Index_List); + + Staticness := Locally; + for I in Flist_First .. Flist_Last (Index_List) loop + Index_Type := Get_Nth_Element (Index_List, I); + + Index_Name := Sem_Discrete_Range_Integer (Index_Type); + if Index_Name /= Null_Iir then + Index_Name := Range_To_Subtype_Indication (Index_Name); + -- Index_Name is a subtype_indication, which can be a type_mark. + else + -- Avoid errors. + Index_Name := + Build_Simple_Name (Natural_Subtype_Declaration, Index_Type); + Set_Type (Index_Name, Natural_Subtype_Definition); + end if; + + Set_Nth_Element (Index_List, I, Index_Name); + + Index_Type := Get_Index_Type (Index_Name); + Staticness := Min (Staticness, Get_Type_Staticness (Index_Type)); + + -- Set the index subtype definition for the array base type. + if Get_Kind (Index_Name) in Iir_Kinds_Denoting_Name then + Index_Type := Get_Named_Entity (Index_Name); + else + pragma Assert + (Get_Kind (Index_Name) in Iir_Kinds_Subtype_Definition); + Index_Type := Get_Subtype_Type_Mark (Index_Name); + if Index_Type = Null_Iir then + -- From a range expression like '1 to 4' or from an attribute + -- name. + Index_Type := Get_First_Subtype_Declaration (Index_Name); + else + Index_Type := Get_Named_Entity (Index_Type); + end if; + end if; + + -- Create a new simple_name, as the type_mark is owned by the + -- index constraint of the array subtype. + Index_Name := Build_Simple_Name (Index_Type, Index_Name); + Set_Type (Index_Name, Get_Type (Index_Type)); + + Set_Nth_Element (Base_Index_List, I, Index_Name); + end loop; + Set_Index_Subtype_List (Def, Index_List); + + -- Element type. Transfer it to the base type. + Set_Element_Subtype_Indication + (Base_Type, Get_Array_Element_Constraint (Def)); + Sem_Array_Element (Base_Type); + El_Type := Get_Element_Subtype (Base_Type); + Set_Element_Subtype (Def, El_Type); + Set_Array_Element_Constraint (Def, Null_Iir); + + Set_Signal_Type_Flag (Def, Get_Signal_Type_Flag (Base_Type)); + + -- According to LRM93 §7.4.1, an unconstrained array type + -- is not static. + Set_Type_Staticness (Base_Type, None); + Set_Type_Staticness (Def, Min (Staticness, + Get_Type_Staticness (El_Type))); + + Set_Type_Declarator (Base_Type, Decl); + Set_Resolved_Flag (Base_Type, Get_Resolved_Flag (Def)); + Set_Index_Constraint_Flag (Def, True); + Set_Constraint_State (Def, Get_Array_Constraint (Def)); + Set_Constraint_State (Base_Type, Get_Array_Constraint (Base_Type)); + Set_Base_Type (Def, Base_Type); + Set_Subtype_Type_Mark (Def, Null_Iir); + return Def; + end Sem_Constrained_Array_Type_Definition; + + function Sem_Access_Type_Definition (Def: Iir) return Iir + is + D_Type : Iir; + begin + D_Type := Sem_Subtype_Indication + (Get_Designated_Subtype_Indication (Def), True); + Set_Designated_Subtype_Indication (Def, D_Type); + + D_Type := Get_Type_Of_Subtype_Indication (D_Type); + if D_Type /= Null_Iir then + case Get_Kind (D_Type) is + when Iir_Kind_Incomplete_Type_Definition => + -- Append on the chain of incomplete type ref + Set_Incomplete_Type_Ref_Chain + (Def, Get_Incomplete_Type_Ref_Chain (D_Type)); + Set_Incomplete_Type_Ref_Chain (D_Type, Def); + when Iir_Kind_File_Type_Definition => + -- LRM 3.3 + -- The designated type must not be a file type. + Error_Msg_Sem (+Def, "designated type must not be a file type"); + when Iir_Kind_Protected_Type_Declaration => + -- LRM02 3.3 + -- [..] or a protected type. + Error_Msg_Sem + (+Def, "designated type must not be a protected type"); + when others => + null; + end case; + Set_Designated_Type (Def, D_Type); + end if; + Set_Base_Type (Def, Def); + Set_Type_Staticness (Def, None); + Set_Resolved_Flag (Def, False); + Set_Signal_Type_Flag (Def, False); + return Def; + end Sem_Access_Type_Definition; + + function Sem_File_Type_Definition (Def: Iir; Decl: Iir) return Iir + is + Type_Mark : Iir; + begin + Type_Mark := Sem_Type_Mark (Get_File_Type_Mark (Def)); + Set_File_Type_Mark (Def, Type_Mark); + + Type_Mark := Get_Type (Type_Mark); + + if Get_Kind (Type_Mark) = Iir_Kind_Error then + null; + elsif Get_Signal_Type_Flag (Type_Mark) = False then + -- LRM 3.4 + -- The base type of this subtype must not be a file type + -- or an access type. + -- If the base type is a composite type, it must not + -- contain a subelement of an access type. + Error_Msg_Sem (+Def, "%n cannot be a file type", +Type_Mark); + else + -- LRM08 5.5 File type + -- If the base type is an array type, it shall be a one-dimensional + -- array type whose element subtype is fully constrained. If the + -- base type is a record type, it shall be fully constrained. + case Get_Kind (Type_Mark) is + when Iir_Kinds_Array_Type_Definition => + -- LRM 3.4 + -- If the base type is an array type, it must be a one + -- dimensional array type. + if not Is_One_Dimensional_Array_Type (Type_Mark) then + Error_Msg_Sem + (+Def, "multi-dimensional %n cannot be a file type", + +Type_Mark); + elsif not Is_Fully_Constrained_Type + (Get_Element_Subtype (Type_Mark)) + then + Error_Msg_Sem + (+Def, "element subtype of %n must be fully constrained", + +Type_Mark); + end if; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + if Get_Constraint_State (Type_Mark) /= Fully_Constrained then + Error_Msg_Sem + (+Def, "%n must be fully constrained", +Type_Mark); + end if; + when Iir_Kind_Interface_Type_Definition => + Error_Msg_Sem (+Def, "%n cannot be a file type", +Type_Mark); + when others => + null; + end case; + end if; + + Set_Base_Type (Def, Def); + Set_Resolved_Flag (Def, False); + Set_Text_File_Flag (Def, Is_Text_Type_Declaration (Decl)); + Set_Signal_Type_Flag (Def, False); + Set_Type_Staticness (Def, None); + return Def; + end Sem_File_Type_Definition; + + function Sem_Type_Definition (Def: Iir; Decl: Iir) return Iir is + begin + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition => + return Sem_Enumeration_Type_Definition (Def, Decl); + + when Iir_Kind_Physical_Type_Definition => + return Sem_Physical_Type_Definition (Def, Decl); + + when Iir_Kind_Range_Expression => + return Range_Expr_To_Type_Definition (Def, Decl); + + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Attribute_Name + | Iir_Kind_Parenthesis_Name => + if Get_Type (Def) /= Null_Iir then + return Sem_Physical_Type_Definition (Def, Decl); + end if; + -- Nb: the attribute is expected to be a 'range or + -- a 'reverse_range attribute. + declare + Res : Iir; + begin + Res := Sem_Discrete_Range_Expression (Def, Null_Iir, True); + if Res = Null_Iir then + return Null_Iir; + end if; + -- This cannot be a floating range. + return Create_Integer_Type (Def, Res, Decl); + end; + + when Iir_Kind_Array_Subtype_Definition => + return Sem_Constrained_Array_Type_Definition (Def, Decl); + + when Iir_Kind_Array_Type_Definition => + return Sem_Unbounded_Array_Type_Definition (Def); + + when Iir_Kind_Record_Type_Definition => + return Sem_Record_Type_Definition (Def); + + when Iir_Kind_Access_Type_Definition => + return Sem_Access_Type_Definition (Def); + + when Iir_Kind_File_Type_Definition => + return Sem_File_Type_Definition (Def, Decl); + + when Iir_Kind_Protected_Type_Declaration => + Sem_Protected_Type_Declaration (Decl); + return Def; + + when others => + Error_Kind ("sem_type_definition", Def); + return Def; + end case; + end Sem_Type_Definition; + + function Range_To_Subtype_Indication (A_Range: Iir) return Iir + is + Sub_Type: Iir; + Range_Type : Iir; + begin + case Get_Kind (A_Range) is + when Iir_Kind_Range_Expression + | Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + -- Create a sub type. + Range_Type := Get_Type (A_Range); + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return A_Range; + when Iir_Kinds_Discrete_Type_Definition => + -- A_RANGE is already a subtype definition. + return A_Range; + when others => + Error_Kind ("range_to_subtype_indication", A_Range); + return Null_Iir; + end case; + + case Get_Kind (Range_Type) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + Sub_Type := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Integer_Subtype_Definition => + Sub_Type := Create_Iir (Iir_Kind_Integer_Subtype_Definition); + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Floating_Subtype_Definition => + Sub_Type := Create_Iir (Iir_Kind_Floating_Subtype_Definition); + when others => + raise Internal_Error; + end case; + Location_Copy (Sub_Type, A_Range); + Set_Range_Constraint (Sub_Type, A_Range); + Set_Base_Type (Sub_Type, Get_Base_Type (Range_Type)); + Set_Type_Staticness (Sub_Type, Get_Expr_Staticness (A_Range)); + Set_Signal_Type_Flag (Sub_Type, True); + return Sub_Type; + end Range_To_Subtype_Indication; + + -- Return TRUE iff FUNC is a resolution function for ATYPE. + function Is_A_Resolution_Function (Func: Iir; Atype: Iir) return Boolean + is + Decl: Iir; + Decl_Type : Iir; + Ret_Type : Iir; + begin + -- LRM93 2.4 + -- A resolution function must be a [pure] function; + if Get_Kind (Func) /= Iir_Kind_Function_Declaration then + return False; + end if; + Decl := Get_Interface_Declaration_Chain (Func); + -- LRM93 2.4 + -- moreover, it must have a single input parameter of class constant + if Decl = Null_Iir or else Get_Chain (Decl) /= Null_Iir then + return False; + end if; + if Get_Kind (Decl) /= Iir_Kind_Interface_Constant_Declaration then + return False; + end if; + -- LRM93 2.4 + -- that is a one-dimensional, unconstrained array + Decl_Type := Get_Type (Decl); + if Get_Kind (Decl_Type) /= Iir_Kind_Array_Type_Definition then + return False; + end if; + if not Is_One_Dimensional_Array_Type (Decl_Type) then + return False; + end if; + -- LRM93 2.4 + -- whose element type is that of the resolved signal. + -- The type of the return value of the function must also be that of + -- the signal. + Ret_Type := Get_Return_Type (Func); + if Get_Base_Type (Get_Element_Subtype (Decl_Type)) + /= Get_Base_Type (Ret_Type) + then + return False; + end if; + if Atype /= Null_Iir + and then Get_Base_Type (Ret_Type) /= Get_Base_Type (Atype) + then + return False; + end if; + -- LRM93 2.4 + -- A resolution function must be a [pure] function; + if Flags.Vhdl_Std >= Vhdl_93 and then Get_Pure_Flag (Func) = False then + if Atype /= Null_Iir then + Error_Msg_Sem (+Atype, "resolution %n must be pure", +Func); + end if; + return False; + end if; + return True; + end Is_A_Resolution_Function; + + -- Note: this sets resolved_flag. + procedure Sem_Resolution_Function (Name : Iir; Atype : Iir) + is + Func : Iir; + Res: Iir; + El : Iir; + List : Iir_List; + It : List_Iterator; + Has_Error : Boolean; + Name1 : Iir; + begin + Sem_Name (Name); + + Func := Get_Named_Entity (Name); + if Func = Error_Mark then + return; + end if; + + Res := Null_Iir; + + if Is_Overload_List (Func) then + List := Get_Overload_List (Func); + Has_Error := False; + It := List_Iterate (List); + while Is_Valid (It) loop + El := Get_Element (It); + if Is_A_Resolution_Function (El, Atype) then + if Res /= Null_Iir then + if not Has_Error then + Has_Error := True; + Error_Msg_Sem + (+Atype, + "can't resolve overload for resolution function", + Cont => True); + Error_Msg_Sem (+Atype, "candidate functions are:"); + Error_Msg_Sem (+Func, " " & Disp_Subprg (Func)); + end if; + Error_Msg_Sem (+El, " " & Disp_Subprg (El)); + else + Res := El; + end if; + end if; + Next (It); + end loop; + Free_Overload_List (Func); + if Has_Error then + return; + end if; + Set_Named_Entity (Name, Res); + else + if Is_A_Resolution_Function (Func, Atype) then + Res := Func; + end if; + end if; + + if Res = Null_Iir then + Error_Msg_Sem + (+Atype, "no matching resolution function for %n", +Name); + else + Name1 := Finish_Sem_Name (Name); + Sem_Decls.Mark_Subprogram_Used (Res); + Set_Resolved_Flag (Atype, True); + Set_Resolution_Indication (Atype, Name1); + end if; + end Sem_Resolution_Function; + + -- Analyze the constraint DEF + RESOLUTION for type TYPE_MARK. The + -- result is always a subtype definition. + function Sem_Subtype_Constraint + (Def : Iir; Type_Mark : Iir; Resolution : Iir) return Iir; + + -- Create a copy of elements_declaration_list of SRC and set it to DST. + procedure Copy_Record_Elements_Declaration_List (Dst : Iir; Src : Iir) + is + El_List : constant Iir_Flist := Get_Elements_Declaration_List (Src); + New_El_List : Iir_Flist; + El : Iir; + begin + New_El_List := Create_Iir_Flist (Get_Nbr_Elements (El_List)); + Set_Elements_Declaration_List (Dst, New_El_List); + for I in Flist_First .. Flist_Last (El_List) loop + El := Get_Nth_Element (El_List, I); + Set_Nth_Element (New_El_List, I, El); + end loop; + end Copy_Record_Elements_Declaration_List; + + function Copy_Resolution_Indication (Subdef : Iir) return Iir + is + Ind : constant Iir := Get_Resolution_Indication (Subdef); + begin + if Is_Null (Ind) + or else Get_Kind (Ind) = Iir_Kind_Array_Element_Resolution + then + -- No need to copy array_element_resolution, it is part of the + -- element_subtype. + return Null_Iir; + else + return Build_Reference_Name (Ind); + end if; + end Copy_Resolution_Indication; + + function Copy_Subtype_Indication (Def : Iir) return Iir + is + Res : Iir; + begin + case Get_Kind (Def) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + Res := Create_Iir (Get_Kind (Def)); + Set_Range_Constraint (Res, Get_Range_Constraint (Def)); + Set_Is_Ref (Res, True); + Set_Resolution_Indication + (Res, Copy_Resolution_Indication (Def)); + + when Iir_Kind_Enumeration_Type_Definition => + Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); + Set_Range_Constraint (Res, Get_Range_Constraint (Def)); + Set_Is_Ref (Res, True); + + when Iir_Kind_Access_Subtype_Definition + | Iir_Kind_Access_Type_Definition => + Res := Create_Iir (Iir_Kind_Access_Subtype_Definition); + Set_Designated_Type (Res, Get_Designated_Type (Def)); + + when Iir_Kind_Array_Type_Definition => + Res := Create_Iir (Iir_Kind_Array_Subtype_Definition); + Set_Type_Staticness (Res, Get_Type_Staticness (Def)); + Set_Resolved_Flag (Res, Get_Resolved_Flag (Def)); + Set_Index_Constraint_List (Res, Null_Iir_Flist); + Set_Index_Subtype_List + (Res, Get_Index_Subtype_Definition_List (Def)); + Set_Element_Subtype (Res, Get_Element_Subtype (Def)); + Set_Index_Constraint_Flag (Res, False); + Set_Constraint_State (Res, Get_Constraint_State (Def)); + + when Iir_Kind_Array_Subtype_Definition => + Res := Create_Iir (Iir_Kind_Array_Subtype_Definition); + Set_Resolution_Indication (Res, Copy_Resolution_Indication (Def)); + Set_Resolved_Flag (Res, Get_Resolved_Flag (Def)); + Set_Index_Subtype_List (Res, Get_Index_Subtype_List (Def)); + Set_Element_Subtype (Res, Get_Element_Subtype (Def)); + Set_Index_Constraint_Flag + (Res, Get_Index_Constraint_Flag (Def)); + Set_Constraint_State (Res, Get_Constraint_State (Def)); + + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + Res := Create_Iir (Iir_Kind_Record_Subtype_Definition); + Set_Is_Ref (Res, True); + Set_Type_Staticness (Res, Get_Type_Staticness (Def)); + if Get_Kind (Def) = Iir_Kind_Record_Subtype_Definition then + Set_Resolution_Indication + (Res, Copy_Resolution_Indication (Def)); + end if; + Set_Resolved_Flag (Res, Get_Resolved_Flag (Def)); + Set_Constraint_State (Res, Get_Constraint_State (Def)); + Copy_Record_Elements_Declaration_List (Res, Def); + + when others => + -- FIXME: todo (protected type ?) + Error_Kind ("copy_subtype_indication", Def); + end case; + Location_Copy (Res, Def); + Set_Base_Type (Res, Get_Base_Type (Def)); + Set_Type_Staticness (Res, Get_Type_Staticness (Def)); + Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Def)); + return Res; + end Copy_Subtype_Indication; + + procedure Sem_Array_Constraint_Indexes (Def : Iir; Type_Mark : Iir) + is + El_Type : constant Iir := Get_Element_Subtype (Type_Mark); + Base_Type : constant Iir := Get_Base_Type (Type_Mark); + Type_Index, Subtype_Index: Iir; + Index_Staticness : Iir_Staticness; + Type_Nbr_Dim : Natural; + Subtype_Nbr_Dim : Natural; + Type_Index_List : Iir_Flist; + Subtype_Index_List : Iir_Flist; + Subtype_Index_List2 : Iir_Flist; + begin + -- Check each index constraint against array type. + Set_Base_Type (Def, Base_Type); + + Index_Staticness := Locally; + Type_Index_List := Get_Index_Subtype_Definition_List (Base_Type); + Subtype_Index_List := Get_Index_Constraint_List (Def); + + -- LRM08 5.3.2.2 + -- If an array constraint of the first form (including an index + -- constraint) applies to a type or subtype, then the type or + -- subtype shall be an unconstrained or partially constrained + -- array type with no index constraint applying to the index + -- subtypes, or an access type whose designated type is such + -- a type. + if Subtype_Index_List = Null_Iir_Flist then + -- Array is not constrained, but the type mark may already have + -- constrained on indexes. + if Get_Kind (Type_Mark) = Iir_Kind_Array_Subtype_Definition then + Set_Index_Constraint_Flag + (Def, Get_Index_Constraint_Flag (Type_Mark)); + Set_Index_Subtype_List + (Def, Get_Index_Subtype_List (Type_Mark)); + else + Set_Index_Constraint_Flag (Def, False); + Set_Index_Subtype_List (Def, Type_Index_List); + end if; + else + if Get_Kind (Type_Mark) = Iir_Kind_Array_Subtype_Definition + and then Get_Index_Constraint_Flag (Type_Mark) + then + Error_Msg_Sem (+Def, "constrained array cannot be re-constrained"); + end if; + Type_Nbr_Dim := Get_Nbr_Elements (Type_Index_List); + Subtype_Nbr_Dim := Get_Nbr_Elements (Subtype_Index_List); + + if Subtype_Nbr_Dim /= Type_Nbr_Dim then + -- Number of dimension mismatch. Create an index with the right + -- length. + Subtype_Index_List2 := Create_Iir_Flist (Type_Nbr_Dim); + for I in 1 .. Natural'Min (Subtype_Nbr_Dim, Type_Nbr_Dim) loop + Set_Nth_Element + (Subtype_Index_List2, I - 1, + Get_Nth_Element (Subtype_Index_List, I - 1)); + end loop; + + if Subtype_Nbr_Dim < Type_Nbr_Dim then + Error_Msg_Sem + (+Def, + "subtype has less indexes than %n defined at %l", + (+Type_Mark, +Type_Mark)); + + -- Clear extra indexes. + for I in Subtype_Nbr_Dim + 1 .. Type_Nbr_Dim loop + Set_Nth_Element (Subtype_Index_List2, I - 1, Null_Iir); + end loop; + else + Error_Msg_Sem + (+Get_Nth_Element (Subtype_Index_List, Type_Nbr_Dim), + "subtype has more indexes than %n defined at %l", + (+Type_Mark, +Type_Mark)); + + -- Forget extra indexes. + end if; + Destroy_Iir_Flist (Subtype_Index_List); + Subtype_Index_List := Subtype_Index_List2; + end if; + + for I in 1 .. Type_Nbr_Dim loop + Type_Index := Get_Nth_Element (Type_Index_List, I - 1); + + if I <= Subtype_Nbr_Dim then + Subtype_Index := Get_Nth_Element (Subtype_Index_List, I - 1); + Subtype_Index := Sem_Discrete_Range_Expression + (Subtype_Index, Get_Index_Type (Type_Index), True); + if Subtype_Index /= Null_Iir then + Subtype_Index := + Range_To_Subtype_Indication (Subtype_Index); + Index_Staticness := Min + (Index_Staticness, + Get_Type_Staticness (Get_Type_Of_Subtype_Indication + (Subtype_Index))); + end if; + else + Subtype_Index := Null_Iir; + end if; + if Subtype_Index = Null_Iir then + -- Create a fake subtype from type_index. + -- FIXME: It is too fake. + Subtype_Index := Type_Index; + Index_Staticness := None; + end if; + Set_Nth_Element (Subtype_Index_List, I - 1, Subtype_Index); + end loop; + + Set_Index_Subtype_List (Def, Subtype_Index_List); + Set_Index_Constraint_Flag (Def, True); + end if; + Set_Type_Staticness + (Def, Min (Get_Type_Staticness (El_Type), Index_Staticness)); + Set_Signal_Type_Flag (Def, Get_Signal_Type_Flag (Type_Mark)); + end Sem_Array_Constraint_Indexes; + + -- DEF is an incomplete subtype_indication or array_constraint, + -- TYPE_MARK is the base type of the subtype_indication. + function Sem_Array_Constraint + (Def : Iir; Type_Mark : Iir; Resolution : Iir) return Iir + is + El_Type : constant Iir := Get_Element_Subtype (Type_Mark); + Res : Iir; + El_Def : Iir; + Resolv_Func : Iir := Null_Iir; + Resolv_El : Iir := Null_Iir; + Resolv_Ind : Iir; + begin + if Resolution /= Null_Iir then + -- A resolution indication is present. + case Get_Kind (Resolution) is + when Iir_Kinds_Denoting_Name => + Resolv_Func := Resolution; + when Iir_Kind_Array_Element_Resolution => + Resolv_El := Get_Resolution_Indication (Resolution); + when Iir_Kind_Record_Resolution => + Error_Msg_Sem + (+Resolution, + "record resolution not allowed for array subtype"); + when others => + Error_Kind ("sem_array_constraint(resolution)", Resolution); + end case; + end if; + + if Def = Null_Iir then + -- There is no element_constraint. + pragma Assert (Resolution /= Null_Iir); + Res := Copy_Subtype_Indication (Type_Mark); + El_Def := Null_Iir; + else + case Get_Kind (Def) is + when Iir_Kind_Subtype_Definition => + -- This is the case of "subtype new_array is [func] old_array". + -- def must be a constrained array. + if Get_Range_Constraint (Def) /= Null_Iir then + Error_Msg_Sem + (+Def, "cannot use a range constraint for array types"); + return Copy_Subtype_Indication (Type_Mark); + end if; + + -- LRM08 6.3 Subtype declarations + -- + -- If the subtype indication does not include a constraint, the + -- subtype is the same as that denoted by the type mark. + if Resolution = Null_Iir then + -- FIXME: is it reachable ? + Free_Name (Def); + return Type_Mark; + end if; + + Res := Copy_Subtype_Indication (Type_Mark); + Location_Copy (Res, Def); + Free_Name (Def); + + -- No element constraint. + El_Def := Null_Iir; + + when Iir_Kind_Array_Subtype_Definition => + -- Case of a constraint for an array. + El_Def := Get_Array_Element_Constraint (Def); + Sem_Array_Constraint_Indexes (Def, Type_Mark); + Res := Def; + + when others => + -- LRM93 3.2.1.1 / LRM08 5.3.2.2 + -- Index Constraints and Discrete Ranges + -- + -- If an index constraint appears after a type mark [...] + -- The type mark must denote either an unconstrained array + -- type, or an access type whose designated type is such + -- an array type. + Error_Msg_Sem + (+Def, + "only unconstrained array type may be contrained by index", + Cont => True); + Error_Msg_Sem + (+Type_Mark, " (type mark is %n)", +Type_Mark); + return Type_Mark; + end case; + end if; + + -- Element subtype. + if Resolv_El /= Null_Iir or else El_Def /= Null_Iir then + El_Def := Sem_Subtype_Constraint (El_Def, El_Type, Resolv_El); + if Resolv_El /= Null_Iir then + -- Save EL_DEF so that it is owned. + Set_Element_Subtype_Indication (Resolution, El_Def); + Set_Resolution_Indication (Resolution, Null_Iir); + end if; + end if; + if El_Def = Null_Iir then + El_Def := Get_Element_Subtype (Type_Mark); + end if; + Set_Element_Subtype (Res, El_Def); + + Set_Constraint_State (Res, Get_Array_Constraint (Res)); + + if Resolv_Func /= Null_Iir then + Sem_Resolution_Function (Resolv_Func, Res); + elsif Resolv_El /= Null_Iir then + Set_Resolution_Indication (Res, Resolution); + -- FIXME: may a resolution indication for a record be incomplete ? + Set_Resolved_Flag (Res, Get_Resolved_Flag (El_Def)); + elsif Get_Kind (Type_Mark) = Iir_Kind_Array_Subtype_Definition then + Resolv_Ind := Get_Resolution_Indication (Type_Mark); + if Resolv_Ind /= Null_Iir then + case Get_Kind (Resolv_Ind) is + when Iir_Kinds_Denoting_Name => + Error_Kind ("sem_array_constraint(resolution)", Resolv_Ind); + when Iir_Kind_Array_Element_Resolution => + -- Already applied to the element. + Resolv_Ind := Null_Iir; + when others => + Error_Kind ("sem_array_constraint(resolution2)", Resolv_Ind); + end case; + Set_Resolution_Indication (Res, Resolv_Ind); + end if; + Set_Resolved_Flag (Res, Get_Resolved_Flag (Type_Mark)); + else + pragma Assert (Get_Kind (Type_Mark) = Iir_Kind_Array_Type_Definition); + Set_Resolved_Flag (Res, Get_Resolved_Flag (Type_Mark)); + end if; + + return Res; + end Sem_Array_Constraint; + + function Reparse_As_Record_Element_Constraint (Name : Iir) return Iir + is + Prefix : Iir; + Parent : Iir; + El : Iir; + begin + if Get_Kind (Name) /= Iir_Kind_Parenthesis_Name then + Error_Msg_Sem (+Name, "record element constraint expected"); + return Null_Iir; + else + Prefix := Get_Prefix (Name); + Parent := Name; + while Get_Kind (Prefix) = Iir_Kind_Parenthesis_Name loop + Parent := Prefix; + Prefix := Get_Prefix (Prefix); + end loop; + if Get_Kind (Prefix) /= Iir_Kind_Simple_Name then + Error_Msg_Sem + (+Prefix, "record element name must be a simple name"); + return Null_Iir; + else + El := Create_Iir (Iir_Kind_Record_Element_Constraint); + Location_Copy (El, Prefix); + Set_Identifier (El, Get_Identifier (Prefix)); + Set_Type (El, Name); + Set_Prefix (Parent, Null_Iir); + Free_Name (Prefix); + return El; + end if; + end if; + end Reparse_As_Record_Element_Constraint; + + function Reparse_As_Record_Constraint (Def : Iir) return Iir + is + Res : Iir; + Chain : Iir; + El_List : Iir_List; + El : Iir; + begin + pragma Assert (Get_Prefix (Def) = Null_Iir); + Res := Create_Iir (Iir_Kind_Record_Subtype_Definition); + Set_Is_Ref (Res, True); + Location_Copy (Res, Def); + El_List := Create_Iir_List; + Chain := Get_Association_Chain (Def); + while Chain /= Null_Iir loop + if Get_Kind (Chain) /= Iir_Kind_Association_Element_By_Expression + or else Get_Formal (Chain) /= Null_Iir + then + Error_Msg_Sem (+Chain, "badly formed record constraint"); + else + El := Reparse_As_Record_Element_Constraint (Get_Actual (Chain)); + if El /= Null_Iir then + Append_Element (El_List, El); + Set_Parent (El, Res); + Append_Owned_Element_Constraint (Res, El); + end if; + end if; + Chain := Get_Chain (Chain); + end loop; + Set_Elements_Declaration_List (Res, List_To_Flist (El_List)); + return Res; + end Reparse_As_Record_Constraint; + + function Reparse_As_Array_Constraint (Def : Iir; Def_Type : Iir) return Iir + is + Parent : Iir; + Name : Iir; + Prefix : Iir; + Res : Iir; + Chain : Iir; + El_List : Iir_List; + Def_El_Type : Iir; + begin + Name := Def; + Prefix := Get_Prefix (Name); + Parent := Null_Iir; + while Prefix /= Null_Iir + and then Get_Kind (Prefix) = Iir_Kind_Parenthesis_Name + loop + Parent := Name; + Name := Prefix; + Prefix := Get_Prefix (Name); + end loop; + -- Detach prefix. + if Parent /= Null_Iir then + Set_Prefix (Parent, Null_Iir); + end if; + Res := Create_Iir (Iir_Kind_Array_Subtype_Definition); + Location_Copy (Res, Name); + Chain := Get_Association_Chain (Name); + if Get_Kind (Chain) = Iir_Kind_Association_Element_Open then + if Get_Chain (Chain) /= Null_Iir then + Error_Msg_Sem (+Chain, "'open' must be alone"); + end if; + else + El_List := Create_Iir_List; + while Chain /= Null_Iir loop + if Get_Kind (Chain) /= Iir_Kind_Association_Element_By_Expression + or else Get_Formal (Chain) /= Null_Iir + then + Error_Msg_Sem (+Chain, "bad form of array constraint"); + else + Append_Element (El_List, Get_Actual (Chain)); + end if; + Chain := Get_Chain (Chain); + end loop; + Set_Index_Constraint_List (Res, List_To_Flist (El_List)); + end if; + + Def_El_Type := Get_Element_Subtype (Def_Type); + if Parent /= Null_Iir then + case Get_Kind (Def_El_Type) is + when Iir_Kinds_Array_Type_Definition => + Set_Element_Subtype_Indication + (Res, Reparse_As_Array_Constraint (Def, Def_El_Type)); + when others => + Error_Kind ("reparse_as_array_constraint", Def_El_Type); + end case; + end if; + return Res; + end Reparse_As_Array_Constraint; + + function Sem_Record_Constraint + (Def : Iir; Type_Mark : Iir; Resolution : Iir) return Iir + is + Res : Iir; + El_List, Tm_El_List : Iir_Flist; + El : Iir; + Tm_El : Iir; + Tm_El_Type : Iir; + El_Type : Iir; + Res_List : Iir_Flist; + + Index_List : Iir_Flist; + Index_El : Iir; + begin + Res := Create_Iir (Iir_Kind_Record_Subtype_Definition); + Set_Is_Ref (Res, True); + Location_Copy (Res, Def); + Set_Base_Type (Res, Get_Base_Type (Type_Mark)); + if Get_Kind (Type_Mark) = Iir_Kind_Record_Subtype_Definition then + Set_Resolution_Indication + (Res, Get_Resolution_Indication (Type_Mark)); + end if; + + case Get_Kind (Def) is + when Iir_Kind_Subtype_Definition => + -- Just an alias, without new constraints. + Free_Name (Def); + Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark)); + Set_Constraint_State (Res, Get_Constraint_State (Type_Mark)); + El_List := Null_Iir_Flist; + + when Iir_Kind_Array_Subtype_Definition => + -- Record constraints are parsed as array constraints. + pragma Assert (Get_Kind (Def) = Iir_Kind_Array_Subtype_Definition); + Index_List := Get_Index_Constraint_List (Def); + El_List := Create_Iir_Flist (Get_Nbr_Elements (Index_List)); + Set_Elements_Declaration_List (Res, El_List); + for I in Flist_First .. Flist_Last (Index_List) loop + Index_El := Get_Nth_Element (Index_List, I); + El := Reparse_As_Record_Element_Constraint (Index_El); + if El = Null_Iir then + return Create_Error_Type (Type_Mark); + end if; + Set_Nth_Element (El_List, I, El); + end loop; + + when Iir_Kind_Record_Subtype_Definition => + El_List := Get_Elements_Declaration_List (Def); + Set_Elements_Declaration_List (Res, El_List); + + when others => + Error_Kind ("sem_record_constraint", Def); + end case; + + -- Handle resolution. + Res_List := Null_Iir_Flist; + if Resolution /= Null_Iir then + case Get_Kind (Resolution) is + when Iir_Kinds_Denoting_Name => + null; + when Iir_Kind_Record_Subtype_Definition => + Res_List := Get_Elements_Declaration_List (Resolution); + when Iir_Kind_Array_Subtype_Definition => + Error_Msg_Sem + (+Resolution, + "resolution indication must be an array element resolution"); + when others => + Error_Kind ("sem_record_constraint(resolution)", Resolution); + end case; + end if; + + Tm_El_List := Get_Elements_Declaration_List (Type_Mark); + if El_List /= Null_Iir_Flist or Res_List /= Null_Iir_Flist then + -- Constraints (either range or resolution) have been added. + declare + Nbr_Els : constant Natural := Get_Nbr_Elements (Tm_El_List); + Els : Iir_Array (0 .. Nbr_Els - 1) := (others => Null_Iir); + Res_Els : Iir_Array (0 .. Nbr_Els - 1) := (others => Null_Iir); + Pos : Natural; + Constraint : Iir_Constraint; + Composite_Found : Boolean; + Staticness : Iir_Staticness; + begin + -- Fill ELS with record constraints. + if El_List /= Null_Iir_Flist then + for I in Flist_First .. Flist_Last (El_List) loop + El := Get_Nth_Element (El_List, I); + Tm_El := Find_Name_In_Flist + (Tm_El_List, Get_Identifier (El)); + if Tm_El = Null_Iir then + -- Constraint element references an element name that + -- doesn't exist. + Error_Msg_Sem (+El, "%n has no %n", (+Type_Mark, +El)); + else + Pos := Natural (Get_Element_Position (Tm_El)); + if Els (Pos) /= Null_Iir then + Error_Msg_Sem + (+El, "%n was already constrained", + (1 => +El), Cont => True); + Error_Msg_Sem + (+Els (Pos), " (location of previous constrained)"); + else + Els (Pos) := El; + Set_Parent (El, Res); + end if; + El_Type := Get_Type (El); + Tm_El_Type := Get_Type (Tm_El); + if Get_Kind (El_Type) = Iir_Kind_Parenthesis_Name then + -- Recurse. + case Get_Kind (Tm_El_Type) is + when Iir_Kinds_Array_Type_Definition => + El_Type := Reparse_As_Array_Constraint + (El_Type, Tm_El_Type); + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + El_Type := Reparse_As_Record_Constraint + (El_Type); + when Iir_Kind_Error => + null; + when others => + Error_Msg_Sem + (+El_Type, + "only composite types may be constrained"); + end case; + end if; + Set_Type (El, El_Type); + end if; + end loop; + -- Record element constraints are now in Els. + Destroy_Iir_Flist (El_List); + end if; + + -- Fill Res_Els (handle resolution constraints). + if Res_List /= Null_Iir_Flist then + for I in Flist_First .. Flist_Last (Res_List) loop + El := Get_Nth_Element (Res_List, I); + Tm_El := + Find_Name_In_Flist (Tm_El_List, Get_Identifier (El)); + if Tm_El = Null_Iir then + Error_Msg_Sem (+El, "%n has no %n", (+Type_Mark, +El)); + else + Pos := Natural (Get_Element_Position (Tm_El)); + if Res_Els (Pos) /= Null_Iir then + Error_Msg_Sem (+El, "%n was already resolved", + (1 => +El), Cont => True); + Error_Msg_Sem + (+Els (Pos), " (location of previous constrained)"); + else + Res_Els (Pos) := Tm_El; + end if; + end if; + --Free_Iir (El); + end loop; + Destroy_Iir_Flist (Res_List); + end if; + + -- Build elements list. + El_List := Create_Iir_Flist (Nbr_Els); + Set_Elements_Declaration_List (Res, El_List); + Constraint := Fully_Constrained; + Composite_Found := False; + Staticness := Locally; + for I in Els'Range loop + Tm_El := Get_Nth_Element (Tm_El_List, I); + if Els (I) = Null_Iir and Res_Els (I) = Null_Iir then + -- No new record element constraints. Copy the element from + -- the type mark. + El := Tm_El; + El_Type := Get_Type (El); + else + if Els (I) = Null_Iir then + -- Only a resolution constraint. + El := Create_Iir (Iir_Kind_Record_Element_Constraint); + Location_Copy (El, Tm_El); + Set_Parent (El, Res); + El_Type := Null_Iir; + Append_Owned_Element_Constraint (Res, El); + else + El := Els (I); + El_Type := Get_Type (El); + pragma Assert + (Get_Kind (El) = Iir_Kind_Record_Element_Constraint); + end if; + El_Type := Sem_Subtype_Constraint (El_Type, + Get_Type (Tm_El), + Res_Els (I)); + Set_Type (El, El_Type); + Set_Element_Position (El, Get_Element_Position (Tm_El)); + end if; + Set_Nth_Element (El_List, I, El); + Update_Record_Constraint (Constraint, Composite_Found, El_Type); + Staticness := Min (Staticness, Get_Type_Staticness (El_Type)); + end loop; + Set_Constraint_State (Res, Constraint); + Set_Type_Staticness (Res, Staticness); + end; + else + Copy_Record_Elements_Declaration_List (Res, Type_Mark); + Set_Constraint_State (Res, Get_Constraint_State (Type_Mark)); + Set_Type_Staticness (Res, Get_Type_Staticness (Type_Mark)); + end if; + + Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark)); + + if Resolution /= Null_Iir + and then Get_Kind (Resolution) in Iir_Kinds_Denoting_Name + then + Sem_Resolution_Function (Resolution, Res); + end if; + + return Res; + end Sem_Record_Constraint; + + -- Return a scalar subtype definition (even in case of error). + function Sem_Range_Constraint + (Def : Iir; Type_Mark : Iir; Resolution : Iir) + return Iir + is + Res : Iir; + A_Range : Iir; + Tolerance : Iir; + begin + if Def = Null_Iir then + Res := Copy_Subtype_Indication (Type_Mark); + elsif Get_Kind (Def) /= Iir_Kind_Subtype_Definition then + -- FIXME: find the correct sentence from LRM + -- GHDL: subtype_definition may also be used just to add + -- a resolution function. + Error_Msg_Sem + (+Def, "only scalar types may be constrained by range", + Cont => True); + Error_Msg_Sem + (+Type_Mark, " (type mark is %n)", +Type_Mark); + Res := Copy_Subtype_Indication (Type_Mark); + else + Tolerance := Get_Tolerance (Def); + + if Get_Range_Constraint (Def) = Null_Iir + and then Resolution = Null_Iir + and then Tolerance = Null_Iir + then + -- This defines an alias, and must have been handled just + -- before the case statment. + raise Internal_Error; + end if; + + -- There are limits. Create a new subtype. + if Get_Kind (Type_Mark) = Iir_Kind_Enumeration_Type_Definition then + Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); + else + Res := Create_Iir (Get_Kind (Type_Mark)); + end if; + Location_Copy (Res, Def); + Set_Base_Type (Res, Get_Base_Type (Type_Mark)); + Set_Resolution_Indication (Res, Get_Resolution_Indication (Def)); + A_Range := Get_Range_Constraint (Def); + if A_Range = Null_Iir then + A_Range := Get_Range_Constraint (Type_Mark); + Set_Is_Ref (Res, True); + else + A_Range := Sem_Range_Expression (A_Range, Type_Mark, True); + if A_Range = Null_Iir then + -- Avoid error propagation. + A_Range := Get_Range_Constraint (Type_Mark); + Set_Is_Ref (Res, True); + end if; + end if; + Set_Range_Constraint (Res, A_Range); + Set_Type_Staticness (Res, Get_Expr_Staticness (A_Range)); + Free_Name (Def); + Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark)); + if Tolerance /= Null_Iir then + -- LRM93 4.2 Subtype declarations + -- It is an error in this case the subtype is not a nature + -- type + -- + -- FIXME: should be moved into sem_subtype_indication + if Get_Kind (Res) /= Iir_Kind_Floating_Subtype_Definition then + Error_Msg_Sem + (+Tolerance, "tolerance allowed only for floating subtype"); + else + -- LRM93 4.2 Subtype declarations + -- If the subtype indication includes a tolerance aspect, then + -- the string expression must be a static expression + Tolerance := Sem_Expression (Tolerance, String_Type_Definition); + if Tolerance /= Null_Iir + and then Get_Expr_Staticness (Tolerance) /= Locally + then + Error_Msg_Sem + (+Tolerance, "tolerance must be a static string"); + end if; + Set_Tolerance (Res, Tolerance); + end if; + end if; + end if; + + if Resolution /= Null_Iir then + -- LRM08 6.3 Subtype declarations. + if Get_Kind (Resolution) not in Iir_Kinds_Denoting_Name then + Error_Msg_Sem + (+Resolution, "resolution indication must be a function name"); + else + Sem_Resolution_Function (Resolution, Res); + Location_Copy (Res, Resolution); + end if; + end if; + return Res; + end Sem_Range_Constraint; + + function Sem_Subtype_Constraint + (Def : Iir; Type_Mark : Iir; Resolution : Iir) + return Iir is + begin + case Get_Kind (Type_Mark) is + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Array_Type_Definition => + return Sem_Array_Constraint (Def, Type_Mark, Resolution); + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition=> + return Sem_Range_Constraint (Def, Type_Mark, Resolution); + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + return Sem_Record_Constraint (Def, Type_Mark, Resolution); + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + -- LRM93 4.2 + -- A subtype indication denoting an access type [or a file type] + -- may not contain a resolution function. + if Resolution /= Null_Iir then + Error_Msg_Sem + (+Def, "resolution function not allowed for an access type"); + end if; + + case Get_Kind (Def) is + when Iir_Kind_Subtype_Definition => + Free_Name (Def); + return Copy_Subtype_Indication (Type_Mark); + when Iir_Kind_Array_Subtype_Definition => + -- LRM93 3.3 + -- The only form of constraint that is allowed after a name + -- of an access type in a subtype indication is an index + -- constraint. + declare + Base_Type : constant Iir := + Get_Designated_Type (Type_Mark); + Sub_Type : Iir; + Res : Iir; + begin + Sub_Type := Sem_Array_Constraint + (Def, Base_Type, Null_Iir); + Res := Create_Iir (Iir_Kind_Access_Subtype_Definition); + Location_Copy (Res, Def); + Set_Base_Type (Res, Type_Mark); + Set_Designated_Subtype_Indication (Res, Sub_Type); + Set_Signal_Type_Flag (Res, False); + + -- The type_mark is a type_mark of the access subtype, + -- not of the array subtype. + Set_Subtype_Type_Mark + (Res, Get_Subtype_Type_Mark (Sub_Type)); + Set_Subtype_Type_Mark (Sub_Type, Null_Iir); + return Res; + end; + when others => + raise Internal_Error; + end case; + + when Iir_Kind_File_Type_Definition => + -- LRM08 6.3 Subtype declarations + -- A subtype indication denoting a subtype of [...] a file + -- type [...] shall not contain a constraint. + if Get_Kind (Def) /= Iir_Kind_Subtype_Definition + or else Get_Range_Constraint (Def) /= Null_Iir + then + Error_Msg_Sem (+Def, "file types can't be constrained"); + return Type_Mark; + end if; + + -- LRM93 4.2 + -- A subtype indication denoting [an access type or] a file type + -- may not contain a resolution function. + if Resolution /= Null_Iir then + Error_Msg_Sem + (+Def, "resolution function not allowed for file types"); + return Type_Mark; + end if; + Free_Name (Def); + return Type_Mark; + + when Iir_Kind_Protected_Type_Declaration => + -- LRM08 6.3 Subtype declarations + -- A subtype indication denoting a subtype of [...] a protected + -- type [...] shall not contain a constraint. + if Get_Kind (Def) /= Iir_Kind_Subtype_Definition + or else Get_Range_Constraint (Def) /= Null_Iir + then + Error_Msg_Sem (+Def, "protected types can't be constrained"); + return Type_Mark; + end if; + + -- LRM08 6.3 Subtype declarations + -- A subtype indication denoting [...] a protected type shall + -- not contain a resolution function. + if Resolution /= Null_Iir then + Error_Msg_Sem + (+Def, "resolution function not allowed for file types"); + return Type_Mark; + end if; + Free_Name (Def); + return Type_Mark; + + when Iir_Kind_Error => + return Type_Mark; + + when others => + Error_Kind ("sem_subtype_constraint", Type_Mark); + return Type_Mark; + end case; + end Sem_Subtype_Constraint; + + function Sem_Subtype_Indication (Def: Iir; Incomplete : Boolean := False) + return Iir + is + Type_Mark_Name : Iir; + Type_Mark: Iir; + Res : Iir; + begin + -- LRM08 6.3 Subtype declarations + -- + -- If the subtype indication does not include a constraint, the subtype + -- is the same as that denoted by the type mark. + case Get_Kind (Def) is + when Iir_Kinds_Denoting_Name + | Iir_Kind_Attribute_Name => + Type_Mark := Sem_Type_Mark (Def, Incomplete); + return Type_Mark; + when Iir_Kind_Error => + return Def; + when others => + null; + end case; + + -- Analyze the type mark. + Type_Mark_Name := Get_Subtype_Type_Mark (Def); + Type_Mark_Name := Sem_Type_Mark (Type_Mark_Name); + Set_Subtype_Type_Mark (Def, Type_Mark_Name); + if Is_Error (Type_Mark_Name) then + return Type_Mark_Name; + end if; + + Type_Mark := Get_Type (Type_Mark_Name); + -- FIXME: incomplete type ? + if Is_Error (Type_Mark) then + -- FIXME: handle inversion such as "subtype BASETYPE RESOLV", which + -- should emit "resolution function must precede type name". + + -- Discard the subtype definition and only keep the type mark. + return Type_Mark_Name; + end if; + + Res := Sem_Subtype_Constraint + (Def, Type_Mark, Get_Resolution_Indication (Def)); + if not Is_Error (Res) then + Set_Subtype_Type_Mark (Res, Type_Mark_Name); + end if; + return Res; + end Sem_Subtype_Indication; + + function Sem_Subnature_Indication (Def: Iir) return Iir + is + Nature_Mark: Iir; + Res : Iir; + begin + -- LRM 4.8 Nature declatation + -- + -- If the subnature indication does not include a constraint, the + -- subnature is the same as that denoted by the type mark. + case Get_Kind (Def) is + when Iir_Kind_Scalar_Nature_Definition => + -- Used for reference declared by a nature + return Def; + when Iir_Kinds_Denoting_Name => + Nature_Mark := Sem_Denoting_Name (Def); + Res := Get_Named_Entity (Nature_Mark); + if Get_Kind (Res) /= Iir_Kind_Scalar_Nature_Definition then + Error_Class_Match (Nature_Mark, "nature"); + raise Program_Error; -- TODO + else + return Nature_Mark; + end if; + when others => + raise Program_Error; -- TODO + end case; + end Sem_Subnature_Indication; + +end Vhdl.Sem_Types; diff --git a/src/vhdl/vhdl-sem_types.ads b/src/vhdl/vhdl-sem_types.ads new file mode 100644 index 000000000..33648b870 --- /dev/null +++ b/src/vhdl/vhdl-sem_types.ads @@ -0,0 +1,68 @@ +-- Semantic analysis. +-- 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 Iirs; use Iirs; + +package Vhdl.Sem_Types is + -- Analyze of types (LRM93 3 / LRM08 5) + + -- Analyze subtype indication DEF. + -- If INCOMPLETE is TRUE, then DEF may designate an incomplete type + -- definition. Return either a name (denoting a type), an anonymous + -- subtype definition or a name whose type is an error node. + function Sem_Subtype_Indication (Def: Iir; Incomplete : Boolean := False) + return Iir; + + procedure Sem_Protected_Type_Body (Bod : Iir); + + function Sem_Type_Definition (Def: Iir; Decl: Iir) return Iir; + + -- If A_RANGE is a range (range expression or range attribute), convert it + -- to a subtype definition. Otherwise return A_RANGE. + -- The result is a subtype indication: either a type name or a subtype + -- definition. + function Range_To_Subtype_Indication (A_Range: Iir) return Iir; + + -- ATYPE is used to declare a signal. + -- Set (recursively) the Has_Signal_Flag on ATYPE and all types used by + -- ATYPE (basetype, elements...) + -- If ATYPE can have signal (eg: access or file type), then this procedure + -- returns silently. + procedure Set_Type_Has_Signal (Atype : Iir); + + -- Return TRUE iff FUNC is a resolution function. + -- If ATYPE is not NULL_IIR, type must match. + function Is_A_Resolution_Function (Func: Iir; Atype: Iir) return Boolean; + + -- Return a subtype definition copy of DEF. + -- This is used when an alias of DEF is required (eg: subtype a is b). + function Copy_Subtype_Indication (Def : Iir) return Iir; + + -- Return a copy of the resolution_indication in SUBDEF, or null_iir if + -- none. + function Copy_Resolution_Indication (Subdef : Iir) return Iir; + + -- Adjust the constraint state CONSTRAINT given new element EL_TYPE. + -- Initially CONSTRAINT must be Fully_Constrained and COMPOSITE_FOUND + -- must be false. + procedure Update_Record_Constraint (Constraint : in out Iir_Constraint; + Composite_Found : in out Boolean; + El_Type : Iir); + + -- Although a nature is not a type, it is patterned like a type. + function Sem_Subnature_Indication (Def: Iir) return Iir; +end Vhdl.Sem_Types; diff --git a/src/vhdl/vhdl-sem_utils.adb b/src/vhdl/vhdl-sem_utils.adb new file mode 100644 index 000000000..06dfa5a50 --- /dev/null +++ b/src/vhdl/vhdl-sem_utils.adb @@ -0,0 +1,1039 @@ +-- Semantic utilities. +-- Copyright (C) 2018 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 Ada.Unchecked_Conversion; +with Types; use Types; +with Flags; use Flags; +with Errorout; use Errorout; +with Iirs_Utils; use Iirs_Utils; +with Iir_Chains; use Iir_Chains; +with Ieee.Std_Logic_1164; +with Std_Names; +with Std_Package; use Std_Package; + +package body Vhdl.Sem_Utils is + procedure Compute_Subprogram_Hash (Subprg : Iir) + is + type Hash_Type is mod 2**32; + function To_Hash is new Ada.Unchecked_Conversion + (Source => Iir, Target => Hash_Type); + function To_Int32 is new Ada.Unchecked_Conversion + (Source => Hash_Type, Target => Iir_Int32); + + Kind : Iir_Kind; + Hash : Hash_Type; + Sig : Hash_Type; + Inter : Iir; + Itype : Iir; + begin + Kind := Get_Kind (Subprg); + if Kind = Iir_Kind_Function_Declaration + or else Kind = Iir_Kind_Enumeration_Literal + then + Itype := Get_Base_Type (Get_Return_Type (Subprg)); + Hash := To_Hash (Itype); + Sig := 8; + else + Sig := 1; + Hash := 0; + end if; + + if Kind /= Iir_Kind_Enumeration_Literal then + Inter := Get_Interface_Declaration_Chain (Subprg); + while Inter /= Null_Iir loop + Itype := Get_Base_Type (Get_Type (Inter)); + Sig := Sig + 1; + Hash := Hash * 7 + To_Hash (Itype); + Hash := Hash + Hash / 2**28; + Inter := Get_Chain (Inter); + end loop; + end if; + Set_Subprogram_Hash (Subprg, To_Int32 (Hash + Sig)); + end Compute_Subprogram_Hash; + + -- LRM93 7.2.2 + -- A discrete array is a one-dimensional array whose elements are of a + -- discrete type. + function Is_Discrete_Array (Def : Iir) return Boolean + is + begin + case Get_Kind (Def) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + null; + when others => + raise Internal_Error; + -- return False; + end case; + if not Is_One_Dimensional_Array_Type (Def) then + return False; + end if; + if Get_Kind (Get_Element_Subtype (Def)) + not in Iir_Kinds_Discrete_Type_Definition + then + return False; + end if; + return True; + end Is_Discrete_Array; + + function Create_Anonymous_Interface (Atype : Iir) + return Iir_Interface_Constant_Declaration + is + Inter : Iir_Interface_Constant_Declaration; + begin + Inter := Create_Iir (Iir_Kind_Interface_Constant_Declaration); + Location_Copy (Inter, Atype); + Set_Identifier (Inter, Null_Identifier); + Set_Mode (Inter, Iir_In_Mode); + Set_Type (Inter, Atype); + return Inter; + end Create_Anonymous_Interface; + + -- Create an implicit/predefined function for DECL. + function Create_Implicit_Function (Name : Name_Id; + Decl : Iir; + Def : Iir_Predefined_Functions; + Interface_Chain : Iir; + Return_Type : Iir) + return Iir + is + Operation : Iir_Function_Declaration; + begin + Operation := Create_Iir (Iir_Kind_Function_Declaration); + Location_Copy (Operation, Decl); + Set_Parent (Operation, Get_Parent (Decl)); + Set_Interface_Declaration_Chain (Operation, Interface_Chain); + Set_Return_Type (Operation, Return_Type); + Set_Implicit_Definition (Operation, Def); + Set_Identifier (Operation, Name); + Set_Visible_Flag (Operation, True); + Compute_Subprogram_Hash (Operation); + return Operation; + end Create_Implicit_Function; + + procedure Create_Implicit_File_Primitives + (Decl : Iir_Type_Declaration; Type_Definition : Iir_File_Type_Definition) + is + use Iir_Chains.Interface_Declaration_Chain_Handling; + Type_Mark : constant Iir := Get_File_Type_Mark (Type_Definition); + Type_Mark_Type : constant Iir := Get_Type (Type_Mark); + Proc: Iir_Procedure_Declaration; + Func: Iir_Function_Declaration; + Inter: Iir; + Loc : Location_Type; + File_Interface_Kind : Iir_Kind; + Last_Interface : Iir; + Last : Iir; + begin + Last := Decl; + Loc := Get_Location (Decl); + + if Flags.Vhdl_Std >= Vhdl_93c then + for I in 1 .. 2 loop + -- Create the implicit file_open (form 1) declaration. + -- Create the implicit file_open (form 2) declaration. + Proc := Create_Iir (Iir_Kind_Procedure_Declaration); + Set_Location (Proc, Loc); + Set_Parent (Proc, Get_Parent (Decl)); + Set_Identifier (Proc, Std_Names.Name_File_Open); + Set_Visible_Flag (Proc, True); + Set_Wait_State (Proc, False); + Build_Init (Last_Interface); + case I is + when 1 => + Set_Implicit_Definition (Proc, Iir_Predefined_File_Open); + when 2 => + Set_Implicit_Definition (Proc, + Iir_Predefined_File_Open_Status); + -- status : out file_open_status. + Inter := + Create_Iir (Iir_Kind_Interface_Variable_Declaration); + Set_Location (Inter, Loc); + Set_Identifier (Inter, Std_Names.Name_Status); + Set_Type (Inter, + Std_Package.File_Open_Status_Type_Definition); + Set_Mode (Inter, Iir_Out_Mode); + Set_Visible_Flag (Inter, True); + Append (Last_Interface, Proc, Inter); + end case; + -- File F : FT + Inter := Create_Iir (Iir_Kind_Interface_File_Declaration); + Set_Location (Inter, Loc); + Set_Identifier (Inter, Std_Names.Name_F); + Set_Type (Inter, Type_Definition); + Set_Mode (Inter, Iir_Inout_Mode); + Set_Visible_Flag (Inter, True); + Append (Last_Interface, Proc, Inter); + -- External_Name : in STRING + Inter := Create_Iir (Iir_Kind_Interface_Constant_Declaration); + Set_Location (Inter, Loc); + Set_Identifier (Inter, Std_Names.Name_External_Name); + Set_Type (Inter, Std_Package.String_Type_Definition); + Set_Mode (Inter, Iir_In_Mode); + Set_Visible_Flag (Inter, True); + Append (Last_Interface, Proc, Inter); + -- Open_Kind : in File_Open_Kind := Read_Mode. + Inter := Create_Iir (Iir_Kind_Interface_Constant_Declaration); + Set_Location (Inter, Loc); + Set_Identifier (Inter, Std_Names.Name_Open_Kind); + Set_Type (Inter, Std_Package.File_Open_Kind_Type_Definition); + Set_Mode (Inter, Iir_In_Mode); + Set_Default_Value + (Inter, + Build_Simple_Name (Std_Package.File_Open_Kind_Read_Mode, Loc)); + Set_Visible_Flag (Inter, True); + Append (Last_Interface, Proc, Inter); + Compute_Subprogram_Hash (Proc); + -- Add it to the list. + Insert_Incr (Last, Proc); + end loop; + + -- Create the implicit file_close declaration. + Proc := Create_Iir (Iir_Kind_Procedure_Declaration); + Set_Identifier (Proc, Std_Names.Name_File_Close); + Set_Location (Proc, Loc); + Set_Parent (Proc, Get_Parent (Decl)); + Set_Implicit_Definition (Proc, Iir_Predefined_File_Close); + Set_Visible_Flag (Proc, True); + Set_Wait_State (Proc, False); + Build_Init (Last_Interface); + Inter := Create_Iir (Iir_Kind_Interface_File_Declaration); + Set_Identifier (Inter, Std_Names.Name_F); + Set_Location (Inter, Loc); + Set_Type (Inter, Type_Definition); + Set_Mode (Inter, Iir_Inout_Mode); + Set_Visible_Flag (Inter, True); + Append (Last_Interface, Proc, Inter); + Compute_Subprogram_Hash (Proc); + -- Add it to the list. + Insert_Incr (Last, Proc); + end if; + + if Flags.Vhdl_Std = Vhdl_87 then + File_Interface_Kind := Iir_Kind_Interface_Variable_Declaration; + else + File_Interface_Kind := Iir_Kind_Interface_File_Declaration; + end if; + + -- Create the implicit procedure read declaration. + Proc := Create_Iir (Iir_Kind_Procedure_Declaration); + Set_Identifier (Proc, Std_Names.Name_Read); + Set_Location (Proc, Loc); + Set_Parent (Proc, Get_Parent (Decl)); + Set_Visible_Flag (Proc, True); + Set_Wait_State (Proc, False); + Build_Init (Last_Interface); + Inter := Create_Iir (File_Interface_Kind); + Set_Identifier (Inter, Std_Names.Name_F); + Set_Location (Inter, Loc); + Set_Type (Inter, Type_Definition); + Set_Mode (Inter, Iir_In_Mode); + Set_Visible_Flag (Inter, True); + Append (Last_Interface, Proc, Inter); + Inter := Create_Iir (Iir_Kind_Interface_Variable_Declaration); + Set_Identifier (Inter, Std_Names.Name_Value); + Set_Location (Inter, Loc); + Set_Subtype_Indication (Inter, Build_Simple_Name (Decl, Loc)); + Set_Type (Inter, Type_Mark_Type); + Set_Mode (Inter, Iir_Out_Mode); + Set_Visible_Flag (Inter, True); + Append (Last_Interface, Proc, Inter); + if Get_Kind (Type_Mark_Type) in Iir_Kinds_Array_Type_Definition + and then Get_Constraint_State (Type_Mark_Type) /= Fully_Constrained + then + Inter := Create_Iir (Iir_Kind_Interface_Variable_Declaration); + Set_Identifier (Inter, Std_Names.Name_Length); + Set_Location (Inter, Loc); + Set_Type (Inter, Std_Package.Natural_Subtype_Definition); + Set_Mode (Inter, Iir_Out_Mode); + Set_Visible_Flag (Inter, True); + Append (Last_Interface, Proc, Inter); + Set_Implicit_Definition (Proc, Iir_Predefined_Read_Length); + else + Set_Implicit_Definition (Proc, Iir_Predefined_Read); + end if; + Compute_Subprogram_Hash (Proc); + -- Add it to the list. + Insert_Incr (Last, Proc); + + -- Create the implicit procedure write declaration. + Proc := Create_Iir (Iir_Kind_Procedure_Declaration); + Set_Identifier (Proc, Std_Names.Name_Write); + Set_Location (Proc, Loc); + Set_Parent (Proc, Get_Parent (Decl)); + Set_Visible_Flag (Proc, True); + Set_Wait_State (Proc, False); + Build_Init (Last_Interface); + Inter := Create_Iir (File_Interface_Kind); + Set_Identifier (Inter, Std_Names.Name_F); + Set_Location (Inter, Loc); + Set_Type (Inter, Type_Definition); + Set_Mode (Inter, Iir_Out_Mode); + Set_Name_Staticness (Inter, Locally); + Set_Expr_Staticness (Inter, None); + Set_Visible_Flag (Inter, True); + Append (Last_Interface, Proc, Inter); + Inter := Create_Iir (Iir_Kind_Interface_Constant_Declaration); + Set_Identifier (Inter, Std_Names.Name_Value); + Set_Location (Inter, Loc); + Set_Subtype_Indication (Inter, Build_Simple_Name (Decl, Loc)); + Set_Type (Inter, Type_Mark_Type); + Set_Mode (Inter, Iir_In_Mode); + Set_Visible_Flag (Inter, True); + Append (Last_Interface, Proc, Inter); + Set_Implicit_Definition (Proc, Iir_Predefined_Write); + Compute_Subprogram_Hash (Proc); + -- Add it to the list. + Insert_Incr (Last, Proc); + + -- Create the implicit procedure flush declaration + if Flags.Vhdl_Std >= Vhdl_08 then + Proc := Create_Iir (Iir_Kind_Procedure_Declaration); + Set_Identifier (Proc, Std_Names.Name_Flush); + Set_Location (Proc, Loc); + Set_Parent (Proc, Get_Parent (Decl)); + Set_Visible_Flag (Proc, True); + Set_Wait_State (Proc, False); + Build_Init (Last_Interface); + Inter := Create_Iir (File_Interface_Kind); + Set_Identifier (Inter, Std_Names.Name_F); + Set_Location (Inter, Loc); + Set_Type (Inter, Type_Definition); + Set_Name_Staticness (Inter, Locally); + Set_Expr_Staticness (Inter, None); + Set_Visible_Flag (Inter, True); + Append (Last_Interface, Proc, Inter); + Set_Implicit_Definition (Proc, Iir_Predefined_Flush); + Compute_Subprogram_Hash (Proc); + -- Add it to the list. + Insert_Incr (Last, Proc); + end if; + -- Create the implicit function endfile declaration. + Func := Create_Iir (Iir_Kind_Function_Declaration); + Set_Identifier (Func, Std_Names.Name_Endfile); + Set_Location (Func, Loc); + Set_Parent (Func, Get_Parent (Decl)); + Set_Visible_Flag (Func, True); + Build_Init (Last_Interface); + Inter := Create_Iir (File_Interface_Kind); + Set_Identifier (Inter, Std_Names.Name_F); + Set_Location (Inter, Loc); + Set_Type (Inter, Type_Definition); + Set_Mode (Inter, Iir_In_Mode); + Set_Visible_Flag (Inter, True); + Append (Last_Interface, Func, Inter); + Set_Return_Type (Func, Std_Package.Boolean_Type_Definition); + Set_Implicit_Definition (Func, Iir_Predefined_Endfile); + Compute_Subprogram_Hash (Func); + -- Add it to the list. + Insert_Incr (Last, Func); + end Create_Implicit_File_Primitives; + + procedure Create_Implicit_Operations + (Decl : Iir; Is_Std_Standard : Boolean := False) + is + use Std_Names; + Binary_Chain : Iir; + Unary_Chain : Iir; + Type_Definition : Iir; + Last : Iir; + + procedure Add_Operation (Name : Name_Id; + Def : Iir_Predefined_Functions; + Interface_Chain : Iir; + Return_Type : Iir) + is + Operation : Iir_Function_Declaration; + begin + Operation := Create_Implicit_Function + (Name, Decl, Def, Interface_Chain, Return_Type); + Insert_Incr (Last, Operation); + end Add_Operation; + + procedure Add_Relational (Name : Name_Id; Def : Iir_Predefined_Functions) + is + begin + Add_Operation + (Name, Def, Binary_Chain, Std_Package.Boolean_Type_Definition); + end Add_Relational; + + procedure Add_Binary (Name : Name_Id; Def : Iir_Predefined_Functions) is + begin + Add_Operation (Name, Def, Binary_Chain, Type_Definition); + end Add_Binary; + + procedure Add_Unary (Name : Name_Id; Def : Iir_Predefined_Functions) is + begin + Add_Operation (Name, Def, Unary_Chain, Type_Definition); + end Add_Unary; + + procedure Add_To_String (Def : Iir_Predefined_Functions) is + begin + Add_Operation (Name_To_String, Def, + Unary_Chain, String_Type_Definition); + end Add_To_String; + + procedure Add_Min_Max (Name : Name_Id; Def : Iir_Predefined_Functions) + is + Left, Right : Iir; + begin + Left := Create_Anonymous_Interface (Type_Definition); + Set_Identifier (Left, Name_L); + Right := Create_Anonymous_Interface (Type_Definition); + Set_Identifier (Right, Name_R); + Set_Chain (Left, Right); + Add_Operation (Name, Def, Left, Type_Definition); + end Add_Min_Max; + + procedure Add_Vector_Min_Max + (Name : Name_Id; Def : Iir_Predefined_Functions) + is + Left : Iir; + begin + Left := Create_Anonymous_Interface (Type_Definition); + Set_Identifier (Left, Name_L); + Add_Operation + (Name, Def, Left, Get_Element_Subtype (Type_Definition)); + end Add_Vector_Min_Max; + + procedure Add_Shift_Operators + is + Inter_Chain : Iir_Interface_Constant_Declaration; + Inter_Int : Iir; + begin + Inter_Chain := Create_Anonymous_Interface (Type_Definition); + + Inter_Int := Create_Iir (Iir_Kind_Interface_Constant_Declaration); + Location_Copy (Inter_Int, Decl); + Set_Identifier (Inter_Int, Null_Identifier); + Set_Mode (Inter_Int, Iir_In_Mode); + Set_Type (Inter_Int, Std_Package.Integer_Subtype_Definition); + + Set_Chain (Inter_Chain, Inter_Int); + + Add_Operation + (Name_Sll, Iir_Predefined_Array_Sll, Inter_Chain, Type_Definition); + Add_Operation + (Name_Srl, Iir_Predefined_Array_Srl, Inter_Chain, Type_Definition); + Add_Operation + (Name_Sla, Iir_Predefined_Array_Sla, Inter_Chain, Type_Definition); + Add_Operation + (Name_Sra, Iir_Predefined_Array_Sra, Inter_Chain, Type_Definition); + Add_Operation + (Name_Rol, Iir_Predefined_Array_Rol, Inter_Chain, Type_Definition); + Add_Operation + (Name_Ror, Iir_Predefined_Array_Ror, Inter_Chain, Type_Definition); + end Add_Shift_Operators; + begin + Last := Decl; + + Type_Definition := Get_Base_Type (Get_Type_Definition (Decl)); + if Get_Kind (Type_Definition) /= Iir_Kind_File_Type_Definition then + Unary_Chain := Create_Anonymous_Interface (Type_Definition); + Binary_Chain := Create_Anonymous_Interface (Type_Definition); + Set_Chain (Binary_Chain, Unary_Chain); + end if; + + case Get_Kind (Type_Definition) is + when Iir_Kind_Enumeration_Type_Definition => + Add_Relational (Name_Op_Equality, Iir_Predefined_Enum_Equality); + Add_Relational + (Name_Op_Inequality, Iir_Predefined_Enum_Inequality); + Add_Relational (Name_Op_Greater, Iir_Predefined_Enum_Greater); + Add_Relational + (Name_Op_Greater_Equal, Iir_Predefined_Enum_Greater_Equal); + Add_Relational (Name_Op_Less, Iir_Predefined_Enum_Less); + Add_Relational + (Name_Op_Less_Equal, Iir_Predefined_Enum_Less_Equal); + + if Flags.Vhdl_Std >= Vhdl_08 then + -- LRM08 5.2.6 Predefined operations on scalar types + -- Given a type declaration that declares a scalar type T, the + -- following operations are implicitely declared immediately + -- following the type declaration (except for the TO_STRING + -- operations in package STANDARD [...]) + Add_Min_Max (Name_Minimum, Iir_Predefined_Enum_Minimum); + Add_Min_Max (Name_Maximum, Iir_Predefined_Enum_Maximum); + if not Is_Std_Standard then + Add_To_String (Iir_Predefined_Enum_To_String); + end if; + + -- LRM08 9.2.3 Relational operators + -- The matching relational operators are predefined for the + -- [predefined type BIT and for the] type STD_ULOGIC defined + -- in package STD_LOGIC_1164. + if Type_Definition = Ieee.Std_Logic_1164.Std_Ulogic_Type then + Add_Binary (Name_Op_Match_Equality, + Iir_Predefined_Std_Ulogic_Match_Equality); + Add_Binary (Name_Op_Match_Inequality, + Iir_Predefined_Std_Ulogic_Match_Inequality); + Add_Binary (Name_Op_Match_Less, + Iir_Predefined_Std_Ulogic_Match_Less); + Add_Binary (Name_Op_Match_Less_Equal, + Iir_Predefined_Std_Ulogic_Match_Less_Equal); + Add_Binary (Name_Op_Match_Greater, + Iir_Predefined_Std_Ulogic_Match_Greater); + Add_Binary (Name_Op_Match_Greater_Equal, + Iir_Predefined_Std_Ulogic_Match_Greater_Equal); + end if; + end if; + + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + declare + Element_Type : Iir; + + Element_Array_Inter_Chain : Iir; + Array_Element_Inter_Chain : Iir; + Element_Element_Inter_Chain : Iir; + begin + Add_Relational + (Name_Op_Equality, Iir_Predefined_Array_Equality); + Add_Relational + (Name_Op_Inequality, Iir_Predefined_Array_Inequality); + if Is_Discrete_Array (Type_Definition) then + Add_Relational + (Name_Op_Greater, Iir_Predefined_Array_Greater); + Add_Relational + (Name_Op_Greater_Equal, + Iir_Predefined_Array_Greater_Equal); + Add_Relational + (Name_Op_Less, Iir_Predefined_Array_Less); + Add_Relational + (Name_Op_Less_Equal, Iir_Predefined_Array_Less_Equal); + + -- LRM08 5.3.2.4 Predefined operations on array types + -- Given a type declaration that declares a discrete array + -- type T, the following operatons are implicitly declared + -- immediately following the type declaration: + -- function MINIMUM (L, R : T) return T; + -- function MAXIMUM (L, R : T) return T; + if Vhdl_Std >= Vhdl_08 then + Add_Min_Max (Name_Maximum, Iir_Predefined_Array_Maximum); + Add_Min_Max (Name_Minimum, Iir_Predefined_Array_Minimum); + end if; + end if; + + Element_Type := Get_Element_Subtype (Type_Definition); + + if Is_One_Dimensional_Array_Type (Type_Definition) then + -- LRM93 7.2.4 Adding operators + -- The concatenation operator & is predefined for any + -- one-dimensional array type. + Add_Operation (Name_Op_Concatenation, + Iir_Predefined_Array_Array_Concat, + Binary_Chain, + Type_Definition); + + Element_Array_Inter_Chain := + Create_Anonymous_Interface (Element_Type); + Set_Chain (Element_Array_Inter_Chain, Unary_Chain); + Add_Operation (Name_Op_Concatenation, + Iir_Predefined_Element_Array_Concat, + Element_Array_Inter_Chain, + Type_Definition); + + Array_Element_Inter_Chain := + Create_Anonymous_Interface (Type_Definition); + Set_Chain (Array_Element_Inter_Chain, + Create_Anonymous_Interface (Element_Type)); + Add_Operation (Name_Op_Concatenation, + Iir_Predefined_Array_Element_Concat, + Array_Element_Inter_Chain, + Type_Definition); + + Element_Element_Inter_Chain := + Create_Anonymous_Interface (Element_Type); + Set_Chain (Element_Element_Inter_Chain, + Create_Anonymous_Interface (Element_Type)); + Add_Operation (Name_Op_Concatenation, + Iir_Predefined_Element_Element_Concat, + Element_Element_Inter_Chain, + Type_Definition); + + -- LRM08 5.3.2.4 Predefined operations on array types + -- In addition, given a type declaration that declares a + -- one-dimensional array type T whose elements are of a + -- sclar type E, the following operations are implicitly + -- declared immediately following the type declaration: + -- function MINIMUM (L : T) return E; + -- function MAXIMUM (L : T) return E; + if Vhdl_Std >= Vhdl_08 + and then (Get_Kind (Element_Type) in + Iir_Kinds_Scalar_Type_And_Subtype_Definition) + then + Add_Vector_Min_Max + (Name_Maximum, Iir_Predefined_Vector_Maximum); + Add_Vector_Min_Max + (Name_Minimum, Iir_Predefined_Vector_Minimum); + end if; + + if Element_Type = Std_Package.Boolean_Type_Definition + or else Element_Type = Std_Package.Bit_Type_Definition + then + -- LRM93 7.2.1 Logical operators + -- LRM08 9.2.2 Logical operators + -- The binary logical operators AND, OR, NAND, NOR, XOR, + -- and XNOR, and the unary logical operator NOT are + -- defined for predefined types BIT and BOOLEAN. They + -- are also defined for any one-dimensional array type + -- whose element type is BIT or BOOLEAN. + + Add_Unary (Name_Not, Iir_Predefined_TF_Array_Not); + + Add_Binary (Name_And, Iir_Predefined_TF_Array_And); + Add_Binary (Name_Or, Iir_Predefined_TF_Array_Or); + Add_Binary (Name_Nand, Iir_Predefined_TF_Array_Nand); + Add_Binary (Name_Nor, Iir_Predefined_TF_Array_Nor); + Add_Binary (Name_Xor, Iir_Predefined_TF_Array_Xor); + if Flags.Vhdl_Std > Vhdl_87 then + Add_Binary (Name_Xnor, Iir_Predefined_TF_Array_Xnor); + + -- LRM93 7.2.3 Shift operators + -- The shift operators SLL, SRL, SLA, SRA, ROL and + -- ROR are defined for any one-dimensional array type + -- whose element type is either of the predefined + -- types BIT or BOOLEAN. + Add_Shift_Operators; + end if; + + -- LRM08 9.2.2 Logical operators + -- For the binary operators AND, OR, NAND, NOR, XOR and + -- XNOR, the operands shall both be [of the same base + -- type,] or one operand shall be of a scalar type and + -- the other operand shall be a one-dimensional array + -- whose element type is the scalar type. The result + -- type is the same as the base type of the operands if + -- [both operands are scalars of the same base type or] + -- both operands are arrays, or the same as the base type + -- of the array operand if one operand is a scalar and + -- the other operand is an array. + if Flags.Vhdl_Std >= Vhdl_08 then + Add_Operation + (Name_And, Iir_Predefined_TF_Element_Array_And, + Element_Array_Inter_Chain, Type_Definition); + Add_Operation + (Name_And, Iir_Predefined_TF_Array_Element_And, + Array_Element_Inter_Chain, Type_Definition); + Add_Operation + (Name_Or, Iir_Predefined_TF_Element_Array_Or, + Element_Array_Inter_Chain, Type_Definition); + Add_Operation + (Name_Or, Iir_Predefined_TF_Array_Element_Or, + Array_Element_Inter_Chain, Type_Definition); + Add_Operation + (Name_Nand, Iir_Predefined_TF_Element_Array_Nand, + Element_Array_Inter_Chain, Type_Definition); + Add_Operation + (Name_Nand, Iir_Predefined_TF_Array_Element_Nand, + Array_Element_Inter_Chain, Type_Definition); + Add_Operation + (Name_Nor, Iir_Predefined_TF_Element_Array_Nor, + Element_Array_Inter_Chain, Type_Definition); + Add_Operation + (Name_Nor, Iir_Predefined_TF_Array_Element_Nor, + Array_Element_Inter_Chain, Type_Definition); + Add_Operation + (Name_Xor, Iir_Predefined_TF_Element_Array_Xor, + Element_Array_Inter_Chain, Type_Definition); + Add_Operation + (Name_Xor, Iir_Predefined_TF_Array_Element_Xor, + Array_Element_Inter_Chain, Type_Definition); + Add_Operation + (Name_Xnor, Iir_Predefined_TF_Element_Array_Xnor, + Element_Array_Inter_Chain, Type_Definition); + Add_Operation + (Name_Xnor, Iir_Predefined_TF_Array_Element_Xnor, + Array_Element_Inter_Chain, Type_Definition); + end if; + + if Flags.Vhdl_Std >= Vhdl_08 then + -- LRM08 9.2.2 Logical operations + -- The unary logical operators AND, OR, NAND, NOR, + -- XOR, and XNOR are referred to as logical reduction + -- operators. The logical reduction operators are + -- predefined for any one-dimensional array type whose + -- element type is BIT or BOOLEAN. The result type + -- for the logical reduction operators is the same as + -- the element type of the operand. + Add_Operation + (Name_And, Iir_Predefined_TF_Reduction_And, + Unary_Chain, Element_Type); + Add_Operation + (Name_Or, Iir_Predefined_TF_Reduction_Or, + Unary_Chain, Element_Type); + Add_Operation + (Name_Nand, Iir_Predefined_TF_Reduction_Nand, + Unary_Chain, Element_Type); + Add_Operation + (Name_Nor, Iir_Predefined_TF_Reduction_Nor, + Unary_Chain, Element_Type); + Add_Operation + (Name_Xor, Iir_Predefined_TF_Reduction_Xor, + Unary_Chain, Element_Type); + Add_Operation + (Name_Xnor, Iir_Predefined_TF_Reduction_Xnor, + Unary_Chain, Element_Type); + end if; + end if; + + -- LRM08 9.2.3 Relational operators + -- The matching equality and matching inequality operatotrs + -- are also defined for any one-dimensional array type + -- whose element type is BIT or STD_ULOGIC. + if Flags.Vhdl_Std >= Vhdl_08 then + if Element_Type = Std_Package.Bit_Type_Definition then + Add_Operation + (Name_Op_Match_Equality, + Iir_Predefined_Bit_Array_Match_Equality, + Binary_Chain, Element_Type); + Add_Operation + (Name_Op_Match_Inequality, + Iir_Predefined_Bit_Array_Match_Inequality, + Binary_Chain, Element_Type); + elsif Element_Type = Ieee.Std_Logic_1164.Std_Ulogic_Type + then + Add_Operation + (Name_Op_Match_Equality, + Iir_Predefined_Std_Ulogic_Array_Match_Equality, + Binary_Chain, Element_Type); + Add_Operation + (Name_Op_Match_Inequality, + Iir_Predefined_Std_Ulogic_Array_Match_Inequality, + Binary_Chain, Element_Type); + end if; + end if; + + -- LRM08 5.3.2.4 Predefined operations on array type + -- + -- Given a type declaration that declares a one-dimensional + -- array type T whose element type is a character type that + -- contains only character literals, the following operation + -- is implicitely declared immediately following the type + -- declaration + if Vhdl_Std >= Vhdl_08 + and then String_Type_Definition /= Null_Iir + and then (Get_Kind (Element_Type) + = Iir_Kind_Enumeration_Type_Definition) + and then Get_Only_Characters_Flag (Element_Type) + then + Add_Operation (Name_To_String, + Iir_Predefined_Array_Char_To_String, + Unary_Chain, + String_Type_Definition); + end if; + end if; + end; + + when Iir_Kind_Access_Type_Definition => + Add_Relational (Name_Op_Equality, Iir_Predefined_Access_Equality); + Add_Relational + (Name_Op_Inequality, Iir_Predefined_Access_Inequality); + declare + Deallocate_Proc: Iir_Procedure_Declaration; + Var_Interface: Iir_Interface_Variable_Declaration; + begin + Deallocate_Proc := + Create_Iir (Iir_Kind_Procedure_Declaration); + Location_Copy (Deallocate_Proc, Decl); + Set_Identifier (Deallocate_Proc, Std_Names.Name_Deallocate); + Set_Implicit_Definition + (Deallocate_Proc, Iir_Predefined_Deallocate); + Set_Parent (Deallocate_Proc, Get_Parent (Decl)); + + Var_Interface := + Create_Iir (Iir_Kind_Interface_Variable_Declaration); + Location_Copy (Var_Interface, Decl); + Set_Identifier (Var_Interface, Std_Names.Name_P); + Set_Parent (Var_Interface, Deallocate_Proc); + Set_Type (Var_Interface, Type_Definition); + Set_Mode (Var_Interface, Iir_Inout_Mode); + --Set_Purity_State (Deallocate_Proc, Impure); + Set_Wait_State (Deallocate_Proc, False); + Set_Visible_Flag (Deallocate_Proc, True); + + Set_Interface_Declaration_Chain + (Deallocate_Proc, Var_Interface); + Compute_Subprogram_Hash (Deallocate_Proc); + Insert_Incr (Last, Deallocate_Proc); + end; + + when Iir_Kind_Record_Type_Definition => + Add_Relational (Name_Op_Equality, Iir_Predefined_Record_Equality); + Add_Relational + (Name_Op_Inequality, Iir_Predefined_Record_Inequality); + + when Iir_Kind_Integer_Type_Definition => + Add_Relational (Name_Op_Equality, Iir_Predefined_Integer_Equality); + Add_Relational + (Name_Op_Inequality, Iir_Predefined_Integer_Inequality); + Add_Relational (Name_Op_Greater, Iir_Predefined_Integer_Greater); + Add_Relational + (Name_Op_Greater_Equal, Iir_Predefined_Integer_Greater_Equal); + Add_Relational (Name_Op_Less, Iir_Predefined_Integer_Less); + Add_Relational + (Name_Op_Less_Equal, Iir_Predefined_Integer_Less_Equal); + + Add_Binary (Name_Op_Plus, Iir_Predefined_Integer_Plus); + Add_Binary (Name_Op_Minus, Iir_Predefined_Integer_Minus); + + Add_Unary (Name_Op_Minus, Iir_Predefined_Integer_Negation); + Add_Unary (Name_Op_Plus, Iir_Predefined_Integer_Identity); + + Add_Binary (Name_Op_Mul, Iir_Predefined_Integer_Mul); + Add_Binary (Name_Op_Div, Iir_Predefined_Integer_Div); + Add_Binary (Name_Mod, Iir_Predefined_Integer_Mod); + Add_Binary (Name_Rem, Iir_Predefined_Integer_Rem); + + Add_Unary (Name_Abs, Iir_Predefined_Integer_Absolute); + + declare + Inter_Chain : Iir; + begin + Inter_Chain := Create_Anonymous_Interface (Type_Definition); + Set_Chain + (Inter_Chain, + Create_Anonymous_Interface (Integer_Type_Definition)); + Add_Operation (Name_Op_Exp, Iir_Predefined_Integer_Exp, + Inter_Chain, Type_Definition); + end; + + if Vhdl_Std >= Vhdl_08 then + -- LRM08 5.2.6 Predefined operations on scalar types + -- Given a type declaration that declares a scalar type T, the + -- following operations are implicitely declared immediately + -- following the type declaration (except for the TO_STRING + -- operations in package STANDARD [...]) + Add_Min_Max (Name_Minimum, Iir_Predefined_Integer_Minimum); + Add_Min_Max (Name_Maximum, Iir_Predefined_Integer_Maximum); + if not Is_Std_Standard then + Add_To_String (Iir_Predefined_Integer_To_String); + end if; + end if; + + when Iir_Kind_Floating_Type_Definition => + Add_Relational + (Name_Op_Equality, Iir_Predefined_Floating_Equality); + Add_Relational + (Name_Op_Inequality, Iir_Predefined_Floating_Inequality); + Add_Relational + (Name_Op_Greater, Iir_Predefined_Floating_Greater); + Add_Relational + (Name_Op_Greater_Equal, Iir_Predefined_Floating_Greater_Equal); + Add_Relational + (Name_Op_Less, Iir_Predefined_Floating_Less); + Add_Relational + (Name_Op_Less_Equal, Iir_Predefined_Floating_Less_Equal); + + Add_Binary (Name_Op_Plus, Iir_Predefined_Floating_Plus); + Add_Binary (Name_Op_Minus, Iir_Predefined_Floating_Minus); + + Add_Unary (Name_Op_Minus, Iir_Predefined_Floating_Negation); + Add_Unary (Name_Op_Plus, Iir_Predefined_Floating_Identity); + + Add_Binary (Name_Op_Mul, Iir_Predefined_Floating_Mul); + Add_Binary (Name_Op_Div, Iir_Predefined_Floating_Div); + + Add_Unary (Name_Abs, Iir_Predefined_Floating_Absolute); + + declare + Inter_Chain : Iir; + begin + Inter_Chain := Create_Anonymous_Interface (Type_Definition); + Set_Chain + (Inter_Chain, + Create_Anonymous_Interface (Integer_Type_Definition)); + Add_Operation (Name_Op_Exp, Iir_Predefined_Floating_Exp, + Inter_Chain, Type_Definition); + end; + + if Vhdl_Std >= Vhdl_08 then + -- LRM08 5.2.6 Predefined operations on scalar types + -- Given a type declaration that declares a scalar type T, the + -- following operations are implicitely declared immediately + -- following the type declaration (except for the TO_STRING + -- operations in package STANDARD [...]) + Add_Min_Max (Name_Minimum, Iir_Predefined_Floating_Minimum); + Add_Min_Max (Name_Maximum, Iir_Predefined_Floating_Maximum); + if not Is_Std_Standard then + Add_To_String (Iir_Predefined_Floating_To_String); + end if; + end if; + + when Iir_Kind_Physical_Type_Definition => + Add_Relational + (Name_Op_Equality, Iir_Predefined_Physical_Equality); + Add_Relational + (Name_Op_Inequality, Iir_Predefined_Physical_Inequality); + Add_Relational + (Name_Op_Greater, Iir_Predefined_Physical_Greater); + Add_Relational + (Name_Op_Greater_Equal, Iir_Predefined_Physical_Greater_Equal); + Add_Relational + (Name_Op_Less, Iir_Predefined_Physical_Less); + Add_Relational + (Name_Op_Less_Equal, Iir_Predefined_Physical_Less_Equal); + + Add_Binary (Name_Op_Plus, Iir_Predefined_Physical_Plus); + Add_Binary (Name_Op_Minus, Iir_Predefined_Physical_Minus); + + Add_Unary (Name_Op_Minus, Iir_Predefined_Physical_Negation); + Add_Unary (Name_Op_Plus, Iir_Predefined_Physical_Identity); + + declare + Inter_Chain : Iir; + begin + Inter_Chain := Create_Anonymous_Interface (Type_Definition); + Set_Chain + (Inter_Chain, + Create_Anonymous_Interface (Integer_Type_Definition)); + Add_Operation (Name_Op_Mul, Iir_Predefined_Physical_Integer_Mul, + Inter_Chain, Type_Definition); + Add_Operation (Name_Op_Div, Iir_Predefined_Physical_Integer_Div, + Inter_Chain, Type_Definition); + end; + + declare + Inter_Chain : Iir; + begin + Inter_Chain := + Create_Anonymous_Interface (Integer_Type_Definition); + Set_Chain (Inter_Chain, Unary_Chain); + Add_Operation (Name_Op_Mul, Iir_Predefined_Integer_Physical_Mul, + Inter_Chain, Type_Definition); + end; + + declare + Inter_Chain : Iir; + begin + Inter_Chain := Create_Anonymous_Interface (Type_Definition); + Set_Chain (Inter_Chain, + Create_Anonymous_Interface (Real_Type_Definition)); + Add_Operation (Name_Op_Mul, Iir_Predefined_Physical_Real_Mul, + Inter_Chain, Type_Definition); + Add_Operation (Name_Op_Div, Iir_Predefined_Physical_Real_Div, + Inter_Chain, Type_Definition); + end; + + declare + Inter_Chain : Iir; + begin + Inter_Chain := + Create_Anonymous_Interface (Real_Type_Definition); + Set_Chain (Inter_Chain, Unary_Chain); + Add_Operation (Name_Op_Mul, Iir_Predefined_Real_Physical_Mul, + Inter_Chain, Type_Definition); + end; + Add_Operation (Name_Op_Div, Iir_Predefined_Physical_Physical_Div, + Binary_Chain, + Std_Package.Convertible_Integer_Type_Definition); + + Add_Unary (Name_Abs, Iir_Predefined_Physical_Absolute); + + if Vhdl_Std >= Vhdl_08 then + -- LRM08 5.2.6 Predefined operations on scalar types + -- Given a type declaration that declares a scalar type T, the + -- following operations are implicitely declared immediately + -- following the type declaration (except for the TO_STRING + -- operations in package STANDARD [...]) + Add_Min_Max (Name_Minimum, Iir_Predefined_Physical_Minimum); + Add_Min_Max (Name_Maximum, Iir_Predefined_Physical_Maximum); + if not Is_Std_Standard then + Add_To_String (Iir_Predefined_Physical_To_String); + end if; + end if; + + when Iir_Kind_File_Type_Definition => + Create_Implicit_File_Primitives (Decl, Type_Definition); + + when Iir_Kind_Protected_Type_Declaration => + null; + + when others => + Error_Kind ("create_predefined_operations", Type_Definition); + end case; + + if not Is_Std_Standard then + return; + end if; + if Decl = Std_Package.Boolean_Type_Declaration then + Add_Binary (Name_And, Iir_Predefined_Boolean_And); + Add_Binary (Name_Or, Iir_Predefined_Boolean_Or); + Add_Binary (Name_Nand, Iir_Predefined_Boolean_Nand); + Add_Binary (Name_Nor, Iir_Predefined_Boolean_Nor); + Add_Binary (Name_Xor, Iir_Predefined_Boolean_Xor); + if Flags.Vhdl_Std > Vhdl_87 then + Add_Binary (Name_Xnor, Iir_Predefined_Boolean_Xnor); + end if; + Add_Unary (Name_Not, Iir_Predefined_Boolean_Not); + elsif Decl = Std_Package.Bit_Type_Declaration then + Add_Binary (Name_And, Iir_Predefined_Bit_And); + Add_Binary (Name_Or, Iir_Predefined_Bit_Or); + Add_Binary (Name_Nand, Iir_Predefined_Bit_Nand); + Add_Binary (Name_Nor, Iir_Predefined_Bit_Nor); + Add_Binary (Name_Xor, Iir_Predefined_Bit_Xor); + if Flags.Vhdl_Std > Vhdl_87 then + Add_Binary (Name_Xnor, Iir_Predefined_Bit_Xnor); + end if; + Add_Unary (Name_Not, Iir_Predefined_Bit_Not); + if Flags.Vhdl_Std >= Vhdl_08 then + Add_Binary (Name_Op_Match_Equality, + Iir_Predefined_Bit_Match_Equality); + Add_Binary (Name_Op_Match_Inequality, + Iir_Predefined_Bit_Match_Inequality); + Add_Binary (Name_Op_Match_Less, + Iir_Predefined_Bit_Match_Less); + Add_Binary (Name_Op_Match_Less_Equal, + Iir_Predefined_Bit_Match_Less_Equal); + Add_Binary (Name_Op_Match_Greater, + Iir_Predefined_Bit_Match_Greater); + Add_Binary (Name_Op_Match_Greater_Equal, + Iir_Predefined_Bit_Match_Greater_Equal); + + -- LRM08 9.2.9 Condition operator + -- The unary operator ?? is predefined for type BIT defined in + -- package STANDARD. + Add_Operation (Name_Op_Condition, Iir_Predefined_Bit_Condition, + Unary_Chain, Std_Package.Boolean_Type_Definition); + + end if; + elsif Decl = Std_Package.Universal_Real_Type_Declaration then + declare + Inter_Chain : Iir; + begin + Inter_Chain := Create_Anonymous_Interface (Type_Definition); + Set_Chain + (Inter_Chain, + Create_Anonymous_Interface (Universal_Integer_Type_Definition)); + Add_Operation (Name_Op_Mul, Iir_Predefined_Universal_R_I_Mul, + Inter_Chain, Type_Definition); + Add_Operation (Name_Op_Div, Iir_Predefined_Universal_R_I_Div, + Inter_Chain, Type_Definition); + end; + + declare + Inter_Chain : Iir; + begin + Inter_Chain := + Create_Anonymous_Interface (Universal_Integer_Type_Definition); + Set_Chain (Inter_Chain, Unary_Chain); + Add_Operation (Name_Op_Mul, Iir_Predefined_Universal_I_R_Mul, + Inter_Chain, Type_Definition); + end; + end if; + end Create_Implicit_Operations; +end Vhdl.Sem_Utils; diff --git a/src/vhdl/vhdl-sem_utils.ads b/src/vhdl/vhdl-sem_utils.ads new file mode 100644 index 000000000..b7fc8082e --- /dev/null +++ b/src/vhdl/vhdl-sem_utils.ads @@ -0,0 +1,30 @@ +-- Semantic utilities. +-- Copyright (C) 2018 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 Iirs; use Iirs; + +package Vhdl.Sem_Utils is + -- Compute and set the hash profile of a subprogram or enumeration clause. + procedure Compute_Subprogram_Hash (Subprg : Iir); + + function Create_Anonymous_Interface + (Atype : Iir) return Iir_Interface_Constant_Declaration; + + -- Create predefined operations for DECL. + procedure Create_Implicit_Operations + (Decl : Iir; Is_Std_Standard : Boolean := False); +end Vhdl.Sem_Utils; -- cgit v1.2.3