-- Configuration generation. -- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation, either version 2 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . with Name_Table; use Name_Table; with Str_Table; with Flags; with Errorout; use Errorout; with Libraries; with Vhdl.Errors; use Vhdl.Errors; with Vhdl.Std_Package; with Vhdl.Utils; use Vhdl.Utils; with Vhdl.Nodes_Walk; with Vhdl.Sem_Scopes; with Vhdl.Sem_Lib; use Vhdl.Sem_Lib; with Vhdl.Canon; with Vhdl.Evaluation; with Vhdl.Scanner; package body Vhdl.Configuration is procedure Add_Design_Concurrent_Stmts (Parent : Iir); procedure Add_Verification_Unit_Items (Unit : Iir); procedure Add_Design_Block_Configuration (Blk : Iir_Block_Configuration); procedure Add_Design_Aspect (Aspect : Iir; Add_Default : Boolean); Current_Configuration : Iir_Configuration_Declaration := Null_Iir; -- UNIT is a design unit of a configuration declaration. -- Fill the DESIGN_UNITS table with all design units required to build -- UNIT. procedure Add_Design_Unit (Unit : Iir_Design_Unit; From : Location_Type) is Loc : constant Location_Type := Get_Location (Unit); List : Iir_List; It : List_Iterator; El : Iir; Lib_Unit : Iir; begin -- If already in the table, then nothing to do. if Get_Configuration_Mark_Flag (Unit) then -- There might be some direct recursions: -- * the default configuration might be implicitly referenced by -- a direct entity instantiation -- * a configuration may be referenced by itself for a recursive -- instantiation pragma Assert (Get_Configuration_Done_Flag (Unit) or else (Get_Kind (Get_Library_Unit (Unit)) = Iir_Kind_Configuration_Declaration)); return; end if; Set_Configuration_Mark_Flag (Unit, True); -- May be enabled to debug dependency construction. if False then Report_Msg (Msgid_Note, Elaboration, +From, "%n added", (1 => +Unit)); end if; Lib_Unit := Get_Library_Unit (Unit); if Flag_Load_All_Design_Units then -- Load and analyze UNIT. Load_Design_Unit (Unit, From); -- TODO: exit now in case of error ? end if; -- Add packages from depend list. -- If Flag_Build_File_Dependences is set, add design units of the -- dependence list are added, because of LRM 11.4 Analysis Order. -- Note: a design unit may be referenced but unused. -- (eg: component specification which does not apply). List := Get_Dependence_List (Unit); It := List_Iterate_Safe (List); while Is_Valid (It) loop El := Get_Element (It); El := Libraries.Find_Design_Unit (El); if El /= Null_Iir and then Get_Kind (El) = Iir_Kind_Design_Unit then Lib_Unit := Get_Library_Unit (El); if Flag_Build_File_Dependence then Add_Design_Unit (El, Loc); else case Get_Kind (Lib_Unit) is when Iir_Kinds_Package_Declaration | Iir_Kind_Context_Declaration => Add_Design_Unit (El, Loc); when others => null; end case; end if; end if; Next (It); end loop; -- Lib_Unit may have changed. Lib_Unit := Get_Library_Unit (Unit); case Iir_Kinds_Library_Unit (Get_Kind (Lib_Unit)) is when Iir_Kind_Package_Declaration => -- Analyze the package declaration, so that Set_Package below -- will set the full package (and not a stub). Load_Design_Unit (Unit, From); Lib_Unit := Get_Library_Unit (Unit); when Iir_Kind_Package_Instantiation_Declaration => -- The uninstantiated package is part of the dependency. null; when Iir_Kind_Configuration_Declaration => -- Add entity and architecture. -- find all sub-configuration Load_Design_Unit (Unit, From); if Nbr_Errors = 0 then Lib_Unit := Get_Library_Unit (Unit); Add_Design_Unit (Get_Design_Unit (Get_Entity (Lib_Unit)), Loc); declare Blk : Iir_Block_Configuration; Prev_Configuration : Iir_Configuration_Declaration; Arch : Iir; begin Prev_Configuration := Current_Configuration; Current_Configuration := Lib_Unit; Blk := Get_Block_Configuration (Lib_Unit); Add_Design_Block_Configuration (Blk); Current_Configuration := Prev_Configuration; Arch := Strip_Denoting_Name (Get_Block_Specification (Blk)); if Arch /= Null_Iir then Add_Design_Unit (Get_Design_Unit (Arch), Loc); end if; end; end if; when Iir_Kind_Architecture_Body => -- Add entity -- find all entity/architecture/configuration instantiation declare Ent : constant Iir := Get_Entity (Lib_Unit); begin if Ent /= Null_Iir then -- In case of errors. Add_Design_Unit (Get_Design_Unit (Ent), Loc); end if; Add_Design_Concurrent_Stmts (Lib_Unit); end; when Iir_Kinds_Verification_Unit => Add_Verification_Unit_Items (Lib_Unit); when Iir_Kind_Entity_Declaration | Iir_Kind_Foreign_Module | Iir_Kind_Package_Body | Iir_Kind_Context_Declaration => null; end case; -- Add it in the table, after the dependencies. Design_Units.Append (Unit); Set_Configuration_Done_Flag (Unit, True); if Get_Kind (Lib_Unit) = Iir_Kind_Package_Declaration then -- Add body (if any). declare Bod : Iir_Design_Unit; begin Bod := Libraries.Find_Secondary_Unit (Unit, Null_Identifier); if Get_Need_Body (Lib_Unit) then if not Flags.Flag_Elaborate_With_Outdated then -- LIB_UNIT requires a body. if Bod = Null_Iir then Error_Msg_Elab (Lib_Unit, "body of %n was never analyzed", +Lib_Unit); elsif Get_Date (Bod) < Get_Date (Unit) then -- Cannot use BOD as location, as the location may not -- exist. Error_Msg_Elab (Lib_Unit, "%n is outdated", +Bod); Bod := Null_Iir; end if; end if; else if Bod /= Null_Iir and then Get_Date (Bod) < Get_Date (Unit) then -- There is a body for LIB_UNIT (which doesn't -- require it) but it is outdated. Bod := Null_Iir; end if; end if; if Bod /= Null_Iir then Add_Design_Unit (Bod, Loc); end if; end; end if; end Add_Design_Unit; procedure Add_Design_Concurrent_Stmt (Stmt : Iir) is begin case Get_Kind (Stmt) is when Iir_Kind_Component_Instantiation_Statement => if Is_Entity_Instantiation (Stmt) then -- Entity or configuration instantiation. Add_Design_Aspect (Get_Instantiated_Unit (Stmt), True); end if; when Iir_Kind_Block_Statement => Add_Design_Concurrent_Stmts (Stmt); when Iir_Kind_For_Generate_Statement => Add_Design_Concurrent_Stmts (Get_Generate_Statement_Body (Stmt)); when Iir_Kind_If_Generate_Statement => declare Clause : Iir; begin Clause := Stmt; while Clause /= Null_Iir loop Add_Design_Concurrent_Stmts (Get_Generate_Statement_Body (Clause)); Clause := Get_Generate_Else_Clause (Clause); end loop; end; when Iir_Kind_Case_Generate_Statement => declare Alt : Iir; begin Alt := Get_Case_Statement_Alternative_Chain (Stmt); while Alt /= Null_Iir loop if not Get_Same_Alternative_Flag (Alt) then Add_Design_Concurrent_Stmts (Get_Associated_Block (Alt)); end if; Alt := Get_Chain (Alt); end loop; end; when Iir_Kinds_Simple_Concurrent_Statement | Iir_Kind_Psl_Default_Clock | Iir_Kind_Psl_Declaration | Iir_Kind_Psl_Endpoint_Declaration | Iir_Kind_Simple_Simultaneous_Statement => null; when others => Error_Kind ("add_design_concurrent_stmts(2)", Stmt); end case; end Add_Design_Concurrent_Stmt; procedure Add_Design_Concurrent_Stmts (Parent : Iir) is Stmt : Iir; begin Stmt := Get_Concurrent_Statement_Chain (Parent); while Stmt /= Null_Iir loop Add_Design_Concurrent_Stmt (Stmt); Stmt := Get_Chain (Stmt); end loop; end Add_Design_Concurrent_Stmts; procedure Add_Verification_Unit_Items (Unit : Iir) is Item : Iir; begin Item := Get_Vunit_Item_Chain (Unit); while Item /= Null_Iir loop if Get_Kind (Item) in Iir_Kinds_Concurrent_Statement then Add_Design_Concurrent_Stmt (Item); end if; Item := Get_Chain (Item); end loop; end Add_Verification_Unit_Items; -- ASPECT is an entity_aspect_entity. procedure Add_Design_Aspect_Entity (Aspect : Iir; Add_Default : Boolean) is Loc : constant Location_Type := Get_Location (Aspect); Entity_Lib : constant Iir := Get_Entity (Aspect); Entity : Iir; Arch_Name : Iir; Arch : Iir; Config : Iir; Arch_Lib : Iir; Id : Name_Id; begin if Entity_Lib = Null_Iir then -- In case of error (using -c). return; end if; -- Add the entity. Entity := Get_Design_Unit (Entity_Lib); Add_Design_Unit (Entity, Loc); if Get_Kind (Entity_Lib) = Iir_Kind_Foreign_Module then return; end if; -- Extract and add the architecture. Arch_Name := Get_Architecture (Aspect); if Arch_Name /= Null_Iir then case Get_Kind (Arch_Name) is when Iir_Kind_Simple_Name => Id := Get_Identifier (Arch_Name); Arch := Load_Secondary_Unit (Entity, Id, Aspect); if Arch = Null_Iir then Error_Msg_Elab ("cannot find architecture %i of %n", (+Id, +Entity_Lib)); return; else Set_Named_Entity (Arch_Name, Get_Library_Unit (Arch)); end if; when Iir_Kind_Reference_Name => Arch := Get_Design_Unit (Get_Named_Entity (Arch_Name)); when others => Error_Kind ("add_design_aspect", Arch_Name); end case; else Arch := Libraries.Get_Latest_Architecture (Entity_Lib); if Arch = Null_Iir then Error_Msg_Elab (Aspect, "no architecture in library for %n", +Entity_Lib); return; end if; Arch := Get_Design_Unit (Arch); end if; Load_Design_Unit (Arch, Aspect); -- Add the default configuration if required. Must be done -- before the architecture in case of recursive instantiation: -- the configuration depends on the architecture. if Add_Default then Arch_Lib := Get_Library_Unit (Arch); -- The default configuration may already exist due to a -- previous instantiation. Create it if it doesn't exist. Config := Get_Default_Configuration_Declaration (Arch_Lib); if Is_Null (Config) then Config := Vhdl.Canon.Create_Default_Configuration_Declaration (Arch_Lib); Set_Default_Configuration_Declaration (Arch_Lib, Config); end if; if Get_Configuration_Mark_Flag (Config) and then not Get_Configuration_Done_Flag (Config) then -- Recursive instantiation. return; else Add_Design_Unit (Config, Loc); end if; end if; -- Otherwise, simply the architecture. Add_Design_Unit (Arch, Loc); end Add_Design_Aspect_Entity; procedure Add_Design_Aspect (Aspect : Iir; Add_Default : Boolean) is begin if Aspect = Null_Iir then return; end if; case Get_Kind (Aspect) is when Iir_Kind_Entity_Aspect_Entity => Add_Design_Aspect_Entity (Aspect, Add_Default); when Iir_Kind_Entity_Aspect_Configuration => Add_Design_Unit (Get_Design_Unit (Get_Configuration (Aspect)), Get_Location (Aspect)); when Iir_Kind_Entity_Aspect_Open => null; when others => Error_Kind ("add_design_aspect", Aspect); end case; end Add_Design_Aspect; -- Return TRUE is PORT must not be open, and emit an error message only if -- LOC is not NULL_IIR. function Check_Open_Port (Port : Iir; Loc : Iir) return Boolean is begin case Get_Mode (Port) is when Iir_In_Mode => -- LRM93 1.1.1.2 Ports -- A port of mode IN may be unconnected or unassociated only if -- its declaration includes a default expression. if Get_Default_Value (Port) = Null_Iir then if Loc /= Null_Iir then Error_Msg_Elab_Relaxed (Loc, Warnid_Port, "IN %n must be connected (or have a default value)", (1 => +Port)); end if; return True; end if; when Iir_Out_Mode | Iir_Inout_Mode | Iir_Buffer_Mode | Iir_Linkage_Mode => -- LRM93 1.1.1.2 Ports -- A port of any mode other than IN may be unconnected or -- unassociated as long as its type is not an unconstrained array -- type. if Get_Kind (Get_Type (Port)) in Iir_Kinds_Array_Type_Definition and then (Get_Constraint_State (Get_Type (Port)) /= Fully_Constrained) then if Loc /= Null_Iir then Error_Msg_Elab (Loc, "unconstrained %n must be connected", +Port); end if; return True; end if; when Iir_Unknown_Mode => raise Internal_Error; end case; return False; end Check_Open_Port; procedure Check_Binding_Indication (Conf : Iir) is Comp : constant Iir := Get_Named_Entity (Get_Component_Name (Conf)); Bind : constant Iir_Binding_Indication := Get_Binding_Indication (Conf); Aspect : constant Iir := Get_Entity_Aspect (Bind); Ent : constant Iir := Get_Entity_From_Entity_Aspect (Aspect); Assoc_Chain : constant Iir := Get_Port_Map_Aspect_Chain (Bind); Inter_Chain : Iir; Assoc : Iir; Inter : Iir; Inst_Assoc_Chain : Iir; Inst_Inter_Chain : Iir; Err : Boolean; Inst : Iir; Inst_List : Iir_Flist; Formal : Iir; Assoc_1 : Iir; Inter_1 : Iir; Actual : Iir; begin if Get_Kind (Ent) = Iir_Kind_Foreign_Module then return; end if; Inter_Chain := Get_Port_Chain (Ent); Err := False; -- Note: the assoc chain is already canonicalized. -- First pass: check for open associations in configuration. Assoc := Assoc_Chain; Inter := Inter_Chain; while Assoc /= Null_Iir loop if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then Formal := Get_Association_Interface (Assoc, Inter); Err := Err or Check_Open_Port (Formal, Assoc); if Is_Warning_Enabled (Warnid_Binding) and then not Get_Artificial_Flag (Assoc) then Report_Start_Group; Warning_Msg_Elab (Warnid_Binding, Assoc, "%n of %n is not bound", (+Formal, +Get_Parent (Formal))); Warning_Msg_Elab (Warnid_Binding, Current_Configuration, "(in %n)", +Current_Configuration); Report_End_Group; end if; end if; Next_Association_Interface (Assoc, Inter); end loop; if Err then return; end if; -- Second pass: check for port connected to open in instantiation. Inst_List := Get_Instantiation_List (Conf); for I in Flist_First .. Flist_Last (Inst_List) loop Inst := Get_Nth_Element (Inst_List, I); Inst := Get_Named_Entity (Inst); Err := False; -- Mark component ports not associated. Inst_Assoc_Chain := Get_Port_Map_Aspect_Chain (Inst); Inst_Inter_Chain := Get_Port_Chain (Comp); Assoc := Inst_Assoc_Chain; Inter := Inst_Inter_Chain; while Assoc /= Null_Iir loop if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then Formal := Get_Association_Interface (Assoc, Inter); Set_Open_Flag (Formal, True); Err := True; end if; Next_Association_Interface (Assoc, Inter); end loop; -- If there is any component port open, search them in the -- configuration. if Err then Assoc := Assoc_Chain; Inter := Inter_Chain; while Assoc /= Null_Iir loop Formal := Get_Association_Interface (Assoc, Inter); if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then Actual := Null_Iir; else Actual := Get_Actual (Assoc); Actual := Name_To_Object (Actual); if Actual /= Null_Iir then Actual := Get_Object_Prefix (Actual); end if; end if; if Actual /= Null_Iir and then Get_Open_Flag (Actual) and then Check_Open_Port (Formal, Null_Iir) then -- For a better message, find the location. Assoc_1 := Inst_Assoc_Chain; Inter_1 := Inst_Inter_Chain; while Assoc_1 /= Null_Iir loop if Get_Kind (Assoc_1) = Iir_Kind_Association_Element_Open and then Actual = Get_Association_Interface (Assoc_1, Inter_1) then Err := Check_Open_Port (Formal, Assoc_1); exit; end if; Next_Association_Interface (Assoc_1, Inter_1); end loop; end if; Next_Association_Interface (Assoc, Inter); end loop; -- Clear open flag. Assoc := Inst_Assoc_Chain; Inter := Inst_Inter_Chain; while Assoc /= Null_Iir loop if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then Formal := Get_Association_Interface (Assoc, Inter); Set_Open_Flag (Formal, False); end if; Next_Association_Interface (Assoc, Inter); end loop; end if; end loop; end Check_Binding_Indication; function Is_In_Vendor_Library (Inst : Iir) return Boolean is Parent : Iir; begin Parent := Strip_Denoting_Name (Inst); if Is_Error (Parent) then return False; end if; loop Parent := Get_Parent (Parent); if Get_Kind (Parent) = Iir_Kind_Library_Declaration then return Get_Vendor_Library_Flag (Parent); end if; end loop; end Is_In_Vendor_Library; -- CONF is either a configuration specification or a component -- configuration. -- If ADD_DEFAULT is true, then the default configuration for the design -- binding must be added if required. procedure Add_Design_Binding_Indication (Conf : Iir; Add_Default : Boolean) is Bind : constant Iir_Binding_Indication := Get_Binding_Indication (Conf); Aspect : Iir; Inst : Iir; Comp : Iir; begin if Bind = Null_Iir then if Is_Warning_Enabled (Warnid_Binding) then Inst := Get_Nth_Element (Get_Instantiation_List (Conf), 0); Inst := Strip_Denoting_Name (Inst); Comp := Get_Instantiated_Unit (Inst); if not Is_In_Vendor_Library (Comp) then Report_Start_Group; Warning_Msg_Elab (Warnid_Binding, Conf, "instance %i of component %i is not bound", (+Inst, +Comp)); Warning_Msg_Elab (Warnid_Binding, Current_Configuration, "(in %n)", +Current_Configuration); Report_End_Group; end if; end if; return; end if; Aspect := Get_Entity_Aspect (Bind); if Is_Valid (Aspect) and then Get_Kind (Aspect) /= Iir_Kind_Entity_Aspect_Open then Check_Binding_Indication (Conf); Add_Design_Aspect (Aspect, Add_Default); end if; end Add_Design_Binding_Indication; procedure Add_Design_Block_Configuration (Blk : Iir_Block_Configuration) is Item : Iir; Sub_Config : Iir; begin if Blk = Null_Iir then return; end if; Item := Get_Configuration_Item_Chain (Blk); while Item /= Null_Iir loop case Get_Kind (Item) is when Iir_Kind_Configuration_Specification => Add_Design_Binding_Indication (Item, True); when Iir_Kind_Component_Configuration => Sub_Config := Get_Block_Configuration (Item); Add_Design_Binding_Indication (Item, Sub_Config = Null_Iir); Add_Design_Block_Configuration (Sub_Config); when Iir_Kind_Block_Configuration => Add_Design_Block_Configuration (Item); when others => Error_Kind ("add_design_block_configuration", Item); end case; Item := Get_Chain (Item); end loop; end Add_Design_Block_Configuration; -- elaboration of a design hierarchy: -- creates a list of design unit. -- -- find top configuration (may be a default one), add it to the list. -- For each element of the list: -- add direct dependences (packages, entity, arch) if not in the list -- for architectures and configuration: find instantiations and add -- corresponding configurations. -- -- Return the configuration declaration for the design. function Configure (Library_Id: Name_Id; Primary_Id : Name_Id; Secondary_Id : Name_Id) return Iir is use Libraries; Library : Iir; Unit : Iir_Design_Unit; Lib_Unit : Iir; Top : Iir; begin if Library_Id /= Null_Identifier then Library := Get_Library (Library_Id, Command_Line_Location); if Library = Null_Iir then return Null_Iir; end if; else Library := Work_Library; end if; Unit := Find_Primary_Unit (Library, Primary_Id); if Unit = Null_Iir then Error_Msg_Elab ("cannot find entity or configuration " & Name_Table.Image (Primary_Id)); return Null_Iir; end if; if Get_Kind (Unit) = Iir_Kind_Foreign_Module then return Unit; end if; Lib_Unit := Get_Library_Unit (Unit); case Get_Kind (Lib_Unit) is when Iir_Kind_Entity_Declaration => -- Use WORK as location (should use a command line location ?) Load_Design_Unit (Unit, Work_Library); Lib_Unit := Get_Library_Unit (Unit); if Secondary_Id /= Null_Identifier then Unit := Find_Secondary_Unit (Unit, Secondary_Id); if Unit = Null_Iir then Error_Msg_Elab ("cannot find architecture %i of %n", (+Secondary_Id, +Lib_Unit)); return Null_Iir; end if; else declare Arch_Unit : Iir_Architecture_Body; begin Arch_Unit := Get_Latest_Architecture (Lib_Unit); if Arch_Unit = Null_Iir then Error_Msg_Elab ("%n has no architecture in library %i", (+Lib_Unit, +Work_Library)); return Null_Iir; end if; Unit := Get_Design_Unit (Arch_Unit); end; end if; Load_Design_Unit (Unit, Lib_Unit); if Nbr_Errors /= 0 then return Null_Iir; end if; Lib_Unit := Get_Library_Unit (Unit); pragma Assert (Is_Null (Get_Default_Configuration_Declaration (Lib_Unit))); Top := Vhdl.Canon.Create_Default_Configuration_Declaration (Lib_Unit); Set_Default_Configuration_Declaration (Lib_Unit, Top); pragma Assert (Is_Valid (Top)); when Iir_Kind_Configuration_Declaration => if Secondary_Id /= Null_Identifier then Error_Msg_Elab ("no secondary unit allowed after configuration %i", +Primary_Id); return Null_Iir; end if; Top := Unit; when Iir_Kind_Foreign_Module => Top := Unit; when others => Error_Msg_Elab ("%i is neither an entity nor a configuration", +Primary_Id); return Null_Iir; end case; -- Exclude std.standard Set_Configuration_Mark_Flag (Vhdl.Std_Package.Std_Standard_Unit, True); Set_Configuration_Done_Flag (Vhdl.Std_Package.Std_Standard_Unit, True); Add_Design_Unit (Top, Command_Line_Location); return Top; end Configure; procedure Add_Verification_Unit (Vunit : Iir) is Hier_Name : constant Iir := Get_Hierarchical_Name (Vunit); Name : Iir; begin -- Not bound. if Hier_Name = Null_Iir then return; end if; Name := Get_Architecture (Hier_Name); if Name /= Null_Node then Name := Get_Named_Entity (Name); pragma Assert (Get_Kind (Name) = Iir_Kind_Architecture_Body); else Name := Get_Entity_Name (Hier_Name); Name := Get_Named_Entity (Name); pragma Assert (Get_Kind (Name) = Iir_Kind_Entity_Declaration); end if; if not Get_Configuration_Mark_Flag (Get_Design_Unit (Name)) then -- Not for a configured unit. return; end if; Set_Bound_Vunit_Chain (Vunit, Get_Bound_Vunit_Chain (Name)); Set_Bound_Vunit_Chain (Name, Vunit); Add_Design_Unit (Get_Design_Unit (Vunit), Get_Location (Vunit)); end Add_Verification_Unit; procedure Add_Verification_Units is Library : Iir; File : Iir; Unit : Iir; Lib : Iir; begin -- For each units: Library := Libraries.Get_Libraries_Chain; while Library /= Null_Iir loop File := Get_Design_File_Chain (Library); while File /= Null_Iir loop Unit := Get_First_Design_Unit (File); while Unit /= Null_Iir loop if Get_Kind (Unit) = Iir_Kind_Design_Unit then Lib := Get_Library_Unit (Unit); if Get_Kind (Lib) = Iir_Kind_Vunit_Declaration then -- Load it. Load_Design_Unit (Unit, Unit); Add_Verification_Unit (Get_Library_Unit (Unit)); end if; end if; Unit := Get_Chain (Unit); end loop; File := Get_Chain (File); end loop; Library := Get_Chain (Library); end loop; end Add_Verification_Units; procedure Check_Entity_Declaration_Top (Entity : Iir_Entity_Declaration; Enable_Override : Boolean) is Has_Error : Boolean := False; -- Return TRUE if GRT supports override of generic GEN. function Allow_Generic_Override (Gen : Iir) return Boolean is Gen_Type : constant Iir := Get_Type (Gen); begin case Get_Kind (Gen_Type) is when Iir_Kind_Integer_Type_Definition | Iir_Kind_Integer_Subtype_Definition | Iir_Kind_Enumeration_Type_Definition | Iir_Kind_Enumeration_Subtype_Definition => return True; when Iir_Kind_Array_Type_Definition | Iir_Kind_Array_Subtype_Definition => -- Only one-dimensional arrays of enumeration are allowed. -- If unconstrained, the index must be of integer type. if Get_Kind (Get_Base_Type (Get_Element_Subtype (Gen_Type))) /= Iir_Kind_Enumeration_Type_Definition then -- Not an array of enumeration type. return False; end if; declare Indexes : constant Iir_Flist := Get_Index_Subtype_List (Gen_Type); begin if Get_Nbr_Elements (Indexes) /= 1 then -- Not a one-dimensional array. return False; end if; if Get_Constraint_State (Gen_Type) /= Fully_Constrained and then (Get_Kind (Get_Index_Type (Indexes, 0)) /= Iir_Kind_Integer_Subtype_Definition) then -- Index not constrained or not of integer subtype. return False; end if; end; return True; when others => return False; end case; end Allow_Generic_Override; procedure Error (Loc : Iir; Msg : String; Arg1 : Earg_Type) is begin if not Has_Error then Error_Msg_Elab ("%n cannot be at the top of a design", +Entity); Has_Error := True; end if; Error_Msg_Elab (Loc, Msg, Arg1); end Error; El : Iir; begin -- Check generics. El := Get_Generic_Chain (Entity); while El /= Null_Iir loop case Iir_Kinds_Interface_Declaration (Get_Kind (El)) is when Iir_Kinds_Interface_Object_Declaration => if Get_Default_Value (El) = Null_Iir and then not Is_Fully_Constrained_Type (Get_Type (El)) and then not (Enable_Override and Allow_Generic_Override (El)) then Error (El, "(%n has no default value)", +El); end if; when Iir_Kinds_Interface_Subprogram_Declaration => Error (El, "(%n is a subprogram generic)", +El); when Iir_Kind_Interface_Type_Declaration => Error (El, "(%n is a type generic)", +El); when Iir_Kind_Interface_Package_Declaration => Error (El, "(%n is a package generic)", +El); when Iir_Kind_Interface_Terminal_Declaration => null; end case; El := Get_Chain (El); end loop; -- Check port. El := Get_Port_Chain (Entity); while El /= Null_Iir loop if not Is_Fully_Constrained_Type (Get_Type (El)) and then Get_Default_Value (El) = Null_Iir then Error (El, "(%n is unconstrained and has no default value)", +El); end if; El := Get_Chain (El); end loop; end Check_Entity_Declaration_Top; package Top is procedure Mark_Instantiated_Units (Lib : Iir_Library_Declaration; Loc : Location_Type); Nbr_Top_Entities : Natural; First_Top_Entity : Iir; procedure Find_First_Top_Entity (Lib : Iir_Library_Declaration); end Top; package body Top is use Nodes_Walk; Loc_Err : Location_Type; -- Add entities to the name table (so that they easily could be found). function Add_Entity_Cb (Design : Iir) return Walk_Status is Lib_Unit : Iir; begin if not Flags.Flag_Elaborate_With_Outdated then -- Discard obsolete or non-analyzed units. if Get_Date (Design) < Date_Analyzed then return Walk_Continue; end if; end if; Lib_Unit := Get_Library_Unit (Design); case Iir_Kinds_Library_Unit (Get_Kind (Lib_Unit)) is when Iir_Kind_Architecture_Body | Iir_Kind_Configuration_Declaration | Iir_Kinds_Verification_Unit => Load_Design_Unit (Design, Loc_Err); when Iir_Kind_Entity_Declaration => Load_Design_Unit (Design, Loc_Err); -- Library unit has changed (loaded). Lib_Unit := Get_Library_Unit (Design); Vhdl.Sem_Scopes.Add_Name (Lib_Unit); when Iir_Kind_Foreign_Module => Vhdl.Sem_Scopes.Add_Name (Lib_Unit); when Iir_Kind_Package_Declaration | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Package_Body | Iir_Kind_Context_Declaration => null; end case; if Nbr_Errors /= 0 then return Walk_Abort; end if; return Walk_Continue; end Add_Entity_Cb; procedure Mark_Aspect (Aspect : Iir) is Unit : Iir; begin case Iir_Kinds_Entity_Aspect (Get_Kind (Aspect)) is when Iir_Kind_Entity_Aspect_Entity => Unit := Get_Entity (Aspect); if Unit /= Null_Node then -- There may be an error (unit not found). Set_Elab_Flag (Get_Parent (Unit), True); end if; when Iir_Kind_Entity_Aspect_Configuration | Iir_Kind_Entity_Aspect_Open => null; end case; end Mark_Aspect; function Mark_Instantiation_Cb (Stmt : Iir) return Walk_Status is Inst : Iir; begin if Get_Kind (Stmt) /= Iir_Kind_Component_Instantiation_Statement then return Walk_Continue; end if; Inst := Get_Instantiated_Unit (Stmt); case Get_Kind (Inst) is when Iir_Kinds_Denoting_Name => -- TODO: look at default_binding_indication -- or configuration_specification ? declare Config : constant Iir := Get_Configuration_Specification (Stmt); begin if Is_Valid (Config) then Mark_Aspect (Get_Entity_Aspect (Get_Binding_Indication (Config))); return Walk_Continue; end if; end; declare use Vhdl.Sem_Scopes; Comp : constant Iir := Get_Named_Entity (Inst); Interp : Name_Interpretation_Type; Decl : Iir; begin if Is_Error (Comp) then return Walk_Continue; end if; Interp := Get_Interpretation (Get_Identifier (Comp)); if Valid_Interpretation (Interp) then Decl := Get_Declaration (Interp); Set_Elab_Flag (Get_Design_Unit (Decl), True); else -- If there is no corresponding entity name for the -- component name, assume it belongs to a different -- library (or will be set by a configuration unit). null; end if; end; when Iir_Kinds_Entity_Aspect => Mark_Aspect (Inst); when others => Error_Kind ("mark_instantiation_cb", Stmt); end case; return Walk_Continue; end Mark_Instantiation_Cb; function Mark_Units_Cb (Design : Iir) return Walk_Status is Unit : Iir; Status : Walk_Status; begin if not Flags.Flag_Elaborate_With_Outdated then if Get_Date (Design) < Date_Analyzed then -- Skip outdated units. return Walk_Continue; end if; end if; Unit := Get_Library_Unit (Design); case Iir_Kinds_Library_Unit (Get_Kind (Unit)) is when Iir_Kind_Architecture_Body => Status := Walk_Concurrent_Statements_Chain (Get_Concurrent_Statement_Chain (Unit), Mark_Instantiation_Cb'Access); pragma Assert (Status = Walk_Continue); when Iir_Kind_Configuration_Declaration => -- Just ignored. null; when Iir_Kinds_Verification_Unit => declare Item : Iir; begin Item := Get_Vunit_Item_Chain (Unit); while Item /= Null_Iir loop if Get_Kind (Item) in Iir_Kinds_Concurrent_Statement then Status := Walk_Concurrent_Statement (Item, Mark_Instantiation_Cb'Access); pragma Assert (Status = Walk_Continue); end if; Item := Get_Chain (Item); end loop; end; when Iir_Kind_Foreign_Module => if Mark_Foreign_Module = null then raise Internal_Error; end if; Mark_Foreign_Module.all (Get_Foreign_Node (Unit)); when Iir_Kind_Package_Declaration | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Package_Body | Iir_Kind_Entity_Declaration | Iir_Kind_Context_Declaration => null; end case; return Walk_Continue; end Mark_Units_Cb; procedure Mark_Instantiated_Units (Lib : Iir_Library_Declaration; Loc : Location_Type) is Status : Walk_Status; begin pragma Assert (Loc /= No_Location); Loc_Err := Loc; -- Name table is used to map names to entities. 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); if Status = Walk_Abort then return; end if; pragma Assert (Status = Walk_Continue); -- 2. Walk architecture and configurations, and mark instantiated -- entities. Status := Walk_Design_Units (Lib, Mark_Units_Cb'Access); pragma Assert (Status = Walk_Continue); Vhdl.Sem_Scopes.Close_Declarative_Region; Vhdl.Sem_Scopes.Pop_Interpretations; end Mark_Instantiated_Units; function Extract_Entity_Cb (Design : Iir) return Walk_Status is Unit : Iir; begin Unit := Get_Library_Unit (Design); if not Kind_In (Unit, Iir_Kind_Entity_Declaration, Iir_Kind_Foreign_Module) then return Walk_Continue; end if; if Get_Elab_Flag (Design) then -- Clean elab flag. Set_Elab_Flag (Design, False); else if Flags.Verbose then Report_Msg (Msgid_Note, Elaboration, +Unit, "candidate for top entity: %n", (1 => +Unit)); end if; Nbr_Top_Entities := Nbr_Top_Entities + 1; if Nbr_Top_Entities = 1 then First_Top_Entity := Unit; end if; end if; return Walk_Continue; end Extract_Entity_Cb; procedure Find_First_Top_Entity (Lib : Iir_Library_Declaration) is Status : Walk_Status; begin Nbr_Top_Entities := 0; First_Top_Entity := Null_Iir; Status := Walk_Design_Units (Lib, Extract_Entity_Cb'Access); pragma Assert (Status = Walk_Continue); end Find_First_Top_Entity; end Top; function Find_Top_Entity (From : Iir; Loc : Location_Type) return Iir is begin -- FROM is a library or a design file. Top.Mark_Instantiated_Units (From, Loc); if Nbr_Errors > 0 then return Null_Iir; end if; Top.Find_First_Top_Entity (From); if Top.Nbr_Top_Entities = 1 then return Top.First_Top_Entity; else return Null_Iir; end if; end Find_Top_Entity; type Override_Entry is record Gen : String_Acc; Value : String_Acc; end record; package Override_Table is new Tables (Table_Component_Type => Override_Entry, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 16); procedure Add_Generic_Override (Name : String; Value : String) is begin Override_Table.Append (Override_Entry'(Gen => new String'(Name), Value => new String'(Value))); end Add_Generic_Override; function Override_String_Generic (Value : String_Acc; Formal_Type : Iir) return Iir is use Str_Table; use Vhdl.Evaluation; El_Type : constant Iir := Get_Base_Type (Get_Element_Subtype (Formal_Type)); F : constant Positive := Value'First; Elist : Iir_Flist; Res : Iir; Str8 : String8_Id; Ntype : Iir; Len : Int32; begin if Get_Kind (El_Type) /= Iir_Kind_Enumeration_Type_Definition then return Null_Iir; end if; Elist := Get_Enumeration_Literal_List (El_Type); Str8 := Create_String8; if Value'Last >= F + 2 and then (Value (F) = 'x' or Value (F) = 'X') and then Value (F + 1) = '"' and then Value (Value'Last) = '"' then -- Hexa string. declare C : Character; V : Natural; E0, E1 : Iir; E : Iir; begin E0 := Find_Name_In_Flist (Elist, Get_Identifier ('0')); E1 := Find_Name_In_Flist (Elist, Get_Identifier ('1')); if E0 = Null_Iir or E1 = Null_Iir then return Null_Iir; end if; Len := 0; for I in F + 2 .. Value'Last - 1 loop C := Value (I); case C is when '0' .. '9' => V := Character'Pos (C) - Character'Pos ('0'); when 'A' .. 'F' => V := Character'Pos (C) - Character'Pos ('A') + 10; when 'a' .. 'f' => V := Character'Pos (C) - Character'Pos ('a') + 10; when '_' => V := 16; when others => Error_Msg_Elab ("incorrect character in bit string"); V := 16; end case; if V < 16 then Len := Len + 4; for J in 1 .. 4 loop if V >= 8 then E := E1; V := V - 8; else E := E0; end if; Append_String8 (Nat8 (Get_Enum_Pos (E))); V := V * 2; end loop; end if; end loop; end; else declare Eid : Name_Id; Elit : Iir; begin for I in Value'Range loop Eid := Get_Identifier (Value (I)); Elit := Find_Name_In_Flist (Elist, Eid); if Elit = Null_Iir then Error_Msg_Elab ("incorrect character %i in string", +Eid); Elit := Get_Nth_Element (Elist, 0); end if; Append_String8 (Nat8 (Get_Enum_Pos (Elit))); end loop; end; Len := Value'Length; end if; Res := Create_Iir (Iir_Kind_String_Literal8); Set_String8_Id (Res, Str8); -- FIXME: check characters are in the type. Set_String_Length (Res, Len); Set_Expr_Staticness (Res, Locally); Ntype := Create_Unidim_Array_By_Length (Get_Base_Type (Formal_Type), Value'Length, Res); Set_Type (Res, Ntype); Set_Literal_Subtype (Res, Ntype); return Res; end Override_String_Generic; procedure Override_Generic (Gen : Iir; Value : String_Acc) is use Vhdl.Evaluation; Formal_Type : constant Iir := Get_Type (Gen); Formal_Btype : constant Iir := Get_Base_Type (Formal_Type); Res : Iir; begin case Get_Kind (Formal_Btype) is when Iir_Kind_Integer_Type_Definition | Iir_Kind_Enumeration_Type_Definition => Res := Eval_Value_Attribute (Value.all, Formal_Type, Gen); if not Eval_Is_In_Bound (Res, Formal_Type) then Error_Msg_Elab ("override for %n is out of bounds", +Gen); return; end if; Set_Literal_Origin (Res, Null_Iir); when Iir_Kind_Array_Type_Definition => if Is_One_Dimensional_Array_Type (Formal_Btype) then Res := Override_String_Generic (Value, Formal_Type); else Res := Null_Iir; end if; when others => Res := Null_Iir; end case; if Res = Null_Iir then Error_Msg_Elab ("unhandled override for %n", +Gen); return; end if; if Get_Is_Ref (Gen) then Set_Is_Ref (Gen, False); else if Get_Has_Identifier_List (Gen) then -- Transfer ownership to the next interface. Set_Is_Ref (Get_Chain (Gen), False); end if; end if; Set_Location (Res, No_Location); Set_Default_Value (Gen, Res); end Override_Generic; procedure Apply_Generic_Override (Ent : Iir) is begin for I in Override_Table.First .. Override_Table.Last loop declare Over : constant Override_Entry := Override_Table.Table (I); begin case Get_Kind (Ent) is when Iir_Kind_Entity_Declaration => declare Inter_Chain : constant Iir := Get_Generic_Chain (Ent); Gen_Name : String := Over.Gen.all; Gen_Id : Name_Id; Inter : Iir; Err : Boolean; begin Vhdl.Scanner.Convert_Identifier (Gen_Name, Err); if Err then Error_Msg_Option ("incorrect name in generic override option"); Gen_Id := Null_Identifier; else Gen_Id := Name_Table.Get_Identifier (Gen_Name); Inter := Inter_Chain; while Inter /= Null_Iir loop exit when Get_Identifier (Inter) = Gen_Id; Inter := Get_Chain (Inter); end loop; end if; if Gen_Id = Null_Identifier then -- Skip it null; elsif Inter = Null_Iir then Error_Msg_Elab ("no generic %i for -g", +Gen_Id); elsif (Get_Kind (Inter) /= Iir_Kind_Interface_Constant_Declaration) then -- Could be a generic package, a generic type... Error_Msg_Elab ("generic %n cannot be overriden (not a constant)", +Gen_Id); else Override_Generic (Inter, Over.Value); end if; end; when Iir_Kind_Foreign_Module => Apply_Foreign_Override (Get_Foreign_Node (Ent), Over.Gen.all, Over.Value.all); when others => raise Internal_Error; end case; end; end loop; end Apply_Generic_Override; end Vhdl.Configuration;