-- Semantic analysis. -- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation, either version 2 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . with Flags; use Flags; with Std_Names; with Str_Table; with Libraries; with Errorout; use Errorout; with Vhdl.Utils; use Vhdl.Utils; with Vhdl.Sem_Expr; use Vhdl.Sem_Expr; with Vhdl.Sem_Names; use Vhdl.Sem_Names; with Vhdl.Evaluation; use Vhdl.Evaluation; with Vhdl.Std_Package; use Vhdl.Std_Package; with Vhdl.Errors; use Vhdl.Errors; 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 Vhdl.Nodes_Utils; use Vhdl.Nodes_Utils; with Vhdl.Sem_Decls; with Vhdl.Xrefs; use Vhdl.Xrefs; with Vhdl.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; -- Called for 'Foreign attribute ATTR on procedure DECL. -- Handle intrinsic subprograms. procedure Attribute_Foreign_Procedure (Decl : Iir; Attr : Iir) is Expr : constant Iir := Get_Expression (Attr); Intrinsic_Str : constant String := "GHDL intrinsic"; Str_Id : String8_Id; begin -- Intrinsic must use a simple string literal. if Get_Kind (Expr) /= Iir_Kind_String_Literal8 then return; end if; -- Compare with the string. if Get_String_Length (Expr) /= Intrinsic_Str'Length then return; end if; Str_Id := Get_String8_Id (Expr); if Str_Table.String_String8 (Str_Id, Intrinsic_Str'Length) /= Intrinsic_Str then return; end if; pragma Assert (Get_Implicit_Definition (Decl) = Iir_Predefined_None); declare use Std_Names; Predefined : Iir_Predefined_Functions; begin case Get_Identifier (Decl) is when Name_Untruncated_Text_Read => Predefined := Iir_Predefined_Foreign_Untruncated_Text_Read; when Name_Textio_Read_Real => Predefined := Iir_Predefined_Foreign_Textio_Read_Real; when Name_Textio_Write_Real => Predefined := Iir_Predefined_Foreign_Textio_Write_Real; when others => Predefined := Iir_Predefined_None; end case; Set_Implicit_Definition (Decl, Predefined); end; end Attribute_Foreign_Procedure; -- 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); Attr_Class : constant Token_Type := Get_Entity_Class (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 Attr_Class /= Tok_Invalid and then Get_Entity_Class_Kind (Decl) /= Attr_Class then if Check_Class then Error_Msg_Sem (+Attr, "%n is not of class %t", (+Decl, +Attr_Class)); 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 Report_Start_Group; Error_Msg_Sem (+Attr, "%n has already %n", (+Decl, +Attr)); Error_Msg_Sem (+Attr, "previous attribute specification at %l", +El); Report_End_Group; end if; return; elsif Get_Identifier (El_Attr) = Get_Identifier (Attr_Decl) then Report_Start_Group; Error_Msg_Sem (+Attr, "%n is already decorated with an %n", (+Decl, +El_Attr)); Error_Msg_Sem (+El, "(previous attribute specification was here)"); Report_End_Group; 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_93 and then Attr_Decl = Foreign_Attribute) or else (Flags.Vhdl_Std <= Vhdl_93 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); Attribute_Foreign_Procedure (Decl, Attr); end if; declare use Vhdl.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 Iir_Kind_Protected_Type_Declaration | Iir_Kind_Protected_Type_Body => Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope)); when Iir_Kind_Vunit_Declaration => Sem_Named_Entity_Chain (Get_Vunit_Item_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) is Scope : constant Iir := Get_Parent (Spec); -- 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 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 => Set_Static_Attribute_Flag (Spec, True); if Get_Expr_Staticness (Expr) /= Locally then Error_Msg_Sem_Relaxed (Spec, Warnid_Attribute, "attribute expression for %t must be locally static", (1 => +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 Report_Start_Group; Error_Msg_Sem (+Decl, "no attribute specification may follow an " & "all/others spec"); 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. Report_Start_Group; Error_Msg_Sem (+Decl, "no named entity may follow an all/others attribute " & "specification"); Has_Error := True; end if; if Has_Error then Error_Msg_Sem (+Spec, "(previous all/others specification for the given " &"entity class)"); Report_End_Group; 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; procedure Sem_Step_Limit_Specification (Limit : Iir) is Type_Mark : Iir; Atype : Iir; Time_Expr : Iir; List : Iir_Flist; El : Iir; Quan : Iir; Prefix : Iir; begin -- Sem type mark. Type_Mark := Get_Type_Mark (Limit); Type_Mark := Sem_Type_Mark (Type_Mark); Set_Type_Mark (Limit, Type_Mark); Atype := Get_Type (Type_Mark); -- FIXME: there are no requirements on the expression. Time_Expr := Sem_Expression (Get_Expression (Limit), Real_Type_Definition); if Time_Expr /= Null_Iir then Check_Read (Time_Expr); Set_Expression (Limit, 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_Quantity_List (Limit); if List in Iir_Flists_All_Others then -- FIXME: checks todo raise Internal_Error; else for I in Flist_First .. Flist_Last (List) loop El := Get_Nth_Element (List, I); if Is_Error (El) then Quan := Null_Iir; else Sem_Name (El); El := Finish_Sem_Name (El); Set_Nth_Element (List, I, El); Quan := Get_Named_Entity (El); Quan := Name_To_Object (Quan); end if; if Quan /= Null_Iir then Set_Type (El, Get_Type (Quan)); Prefix := Get_Object_Prefix (Quan); -- AMS-LRM17 7.5 -- Each quantity name in a quantity in a step limit -- specification shall be a locally static name that denotes -- a quantity. case Get_Kind (Prefix) is when Iir_Kinds_Quantity_Declaration | Iir_Kind_Interface_Quantity_Declaration => null; when others => Error_Msg_Sem (+El, "object must be a quantity"); return; end case; if Get_Name_Staticness (Quan) /= Locally then Error_Msg_Sem (+El, "signal name must be locally static"); end if; -- AMS-LRM17 7.5 -- If the quantity is a declared quantity or a slice of -- thereof, the type mark shall be the same as the type mark -- indicated in the quantity declaration for that quantity. -- If the quantity is an array element of an explicitly -- declared quantity, 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 quantity. -- If the quantity is a record element of an explicitly -- declared quantity, 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 quantity. if not Is_Same_Type_Mark (Get_Type (Quan), Atype) then Error_Msg_Sem (+El, "type mark and quantity type mismatch"); end if; -- AMS-LRM17 7.5 -- Each quantity must be declared in the declarative part -- enclosing the step limit 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 quantity"); end if; end loop; end if; end Sem_Step_Limit_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 := Get_Entity_Name (Aspect); if Is_Error (Entity_Name) then return Null_Iir; end if; 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_Check_Missing_Generic_Association (Inter_Chain : Iir; Assoc1 : Iir; Assoc2 : Iir; Loc : Iir) is Inter : Iir; Inter_Iter : Iir; Assoc : Iir; Err : Boolean; pragma Unreferenced (Err); begin -- Set open flag. Inter := Inter_Chain; while Inter /= Null_Iir loop Set_Open_Flag (Inter, True); Inter := Get_Chain (Inter); end loop; -- Clear the open flag on associated interface. for I in 1 .. 2 loop case I is when 1 => Assoc := Assoc1; when 2 => Assoc := Assoc2; end case; Inter_Iter := Inter_Chain; while Assoc /= Null_Iir loop if Get_Kind (Assoc) /= Iir_Kind_Association_Element_Open then Inter := Get_Association_Interface (Assoc, Inter_Iter); Set_Open_Flag (Inter, False); end if; Next_Association_Interface (Assoc, Inter_Iter); end loop; end loop; -- Check open interface. Inter := Inter_Chain; while Inter /= Null_Iir loop if Get_Open_Flag (Inter) then Set_Open_Flag (Inter, False); Err := Sem_Check_Missing_Association (Inter, Missing_Generic, True, Loc); end if; Inter := Get_Chain (Inter); end loop; end Sem_Check_Missing_Generic_Association; procedure Sem_Binding_Indication (Bind : Iir_Binding_Indication; Parent : Iir; Primary_Binding : Iir) is pragma Assert (Bind /= Null_Iir); Entity_Aspect : constant Iir := Get_Entity_Aspect (Bind); Entity : Iir_Entity_Declaration; Primary_Aspect : Iir; begin 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_Binding /= 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_Binding = Null_Iir then Entity := Null_Iir; else Primary_Aspect := Get_Entity_Aspect (Primary_Binding); case Get_Kind (Primary_Aspect) is when Iir_Kind_Entity_Aspect_Entity => Entity := Get_Entity (Primary_Aspect); when others => Error_Kind ("sem_binding_indication", Primary_Aspect); end case; end if; when Iir_Kind_Configuration_Specification => -- LRM08 7.3.2 Binding indication -- When a binding indication is used in an explicit -- configuration specification, it is an error if the entity -- aspect is absent. 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); -- If the binding is final (cannot be incrementally bound), check -- that all generics are associated when required (like no default -- value). -- Do not check if there is no generic map aspect. if Get_Kind (Parent) = Iir_Kind_Component_Configuration and then Get_Generic_Map_Aspect_Chain (Bind) /= Null_Iir then declare Primary_Assoc : Iir; begin if Primary_Binding /= Null_Iir then Primary_Assoc := Get_Generic_Map_Aspect_Chain (Primary_Binding); else Primary_Assoc := Null_Iir; end if; Sem_Check_Missing_Generic_Association (Get_Generic_Chain (Entity), Get_Generic_Map_Aspect_Chain (Bind), Primary_Assoc, Bind); end; end if; -- 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_Binding : in out Iir) is Prev_Spec : Iir; Prev_Conf : Iir; procedure Prev_Spec_Error is begin Report_Start_Group; Error_Msg_Sem (+Spec, "%n is alreay bound by a configuration specification", +Comp); Error_Msg_Sem (+Prev_Spec, "(previous is %n)", +Prev_Spec); Report_End_Group; end Prev_Spec_Error; Prev_Binding : Iir_Binding_Indication; 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 if Primary_Binding = Null_Iir then Primary_Binding := Prev_Binding; 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 => Report_Start_Group; Error_Msg_Sem (+Spec, "%n is already bound by a component configuration", +Comp); Error_Msg_Sem (+Prev_Conf, "(previous is %n)", +Prev_Conf); Report_End_Group; 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_Binding : 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_Binding); 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_Binding := 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_Binding); 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_Binding : Iir; Component : Iir; Bind : Iir; begin Sem_Component_Specification (Parent_Stmts, Conf, Primary_Binding); 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; Bind := Get_Binding_Indication (Conf); if Bind = Null_Iir then -- LRM08 7.3.2 Binding indication -- When a binding indication is used in an explicit configuration -- specification, it is an error if the entity aspect is absent. Error_Msg_Sem (+Conf, "binding indication required"); else -- Extend scope of component interface declaration. Sem_Scopes.Open_Scope_Extension; Sem_Scopes.Add_Component_Declarations (Component); Sem_Binding_Indication (Bind, Conf, Primary_Binding); -- FIXME: check default port and generic association. Sem_Scopes.Close_Scope_Extension; end if; 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); Location_Copy (Res, Parent); 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, Entity); 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:", +Parent); 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; 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 Report_Start_Group; Error_Header; Error_Msg_Sem (+Parent, "type of %n declared at %l", (+Comp_El, +Comp_El)); Error_Msg_Sem (+Parent, "not compatible with type of %n declared at %l", (+Ent_El, +Ent_El)); Report_End_Group; elsif Kind = Map_Port and then not Check_Port_Association_Mode_Restrictions (Ent_El, Comp_El, Null_Iir) then Report_Start_Group; Error_Header; Error_Msg_Sem (+Parent, "cannot associate " & Get_Mode_Name (Get_Mode (Ent_El)) & " %n declared at %l", (+Ent_El, +Ent_El)); Error_Msg_Sem (+Parent, "with actual port of mode " & Get_Mode_Name (Get_Mode (Comp_El)) & " declared at %l", +Comp_El); Report_End_Group; end if; Assoc := Create_Iir (Iir_Kind_Association_Element_By_Expression); Location_Copy (Assoc, Parent); Name := Build_Simple_Name (Comp_El, Comp_El); 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, Ent_El); Set_Is_Forward_Ref (Name, True); Set_Formal (Assoc, Name); if Get_Kind (Ent_El) in Iir_Kinds_Interface_Object_Declaration then Set_Type (Name, Get_Type (Ent_El)); end if; 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; Chain_Append (Res, Last, Assoc); Ent_El := Get_Chain (Ent_El); end loop; if Nodes_Utils.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.Flag_Relaxed_Rules or Flags.Vhdl_Std >= Vhdl_02 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.Flag_Relaxed_Rules 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;