-- Semantic analysis. -- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold -- -- GHDL is free software; you can redistribute it and/or modify it under -- the terms of the GNU General Public License as published by the Free -- Software Foundation; either version 2, or (at your option) any later -- version. -- -- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY -- WARRANTY; without even the implied warranty of MERCHANTABILITY or -- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- for more details. -- -- You should have received a copy of the GNU General Public License -- along with GHDL; see the file COPYING. If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with Evaluation; use Evaluation; with Iirs_Utils; use Iirs_Utils; with Libraries; with Errorout; use Errorout; with Flags; use Flags; with Name_Table; with Std_Package; use Std_Package; with Types; use Types; with Iir_Chains; use Iir_Chains; with Std_Names; with Sem; with Sem_Scopes; use Sem_Scopes; with Sem_Expr; use Sem_Expr; with Sem_Stmts; use Sem_Stmts; with Sem_Decls; use Sem_Decls; with Sem_Assocs; use Sem_Assocs; with Sem_Specs; with Sem_Types; with Sem_Psl; with Xrefs; use Xrefs; package body Sem_Names is -- Finish the semantization of NAME using RES as named entity. -- This is called when the semantization is finished and an uniq -- interpretation has been determined (RES). -- -- Error messages are emitted here. function Finish_Sem_Name (Name : Iir; Res : Iir) return Iir; procedure Error_Overload (Expr: Iir) is begin Error_Msg_Sem ("can't resolve overload for " & Disp_Node (Expr), Expr); end Error_Overload; procedure Disp_Overload_List (List : Iir_List; Loc : Iir) is El : Iir; begin Error_Msg_Sem ("possible interpretations are:", Loc); for I in Natural loop El := Get_Nth_Element (List, I); exit when El = Null_Iir; case Get_Kind (El) is when Iir_Kind_Function_Declaration | Iir_Kind_Procedure_Declaration => Error_Msg_Sem (Disp_Subprg (El), El); when Iir_Kind_Function_Call => El := Get_Implementation (El); Error_Msg_Sem (Disp_Subprg (El), El); when others => Error_Msg_Sem (Disp_Node (El), El); end case; end loop; end Disp_Overload_List; -- Create an overload list. -- must be destroyed with free_iir. function Get_Overload_List return Iir_Overload_List is Res : Iir; begin Res := Create_Iir (Iir_Kind_Overload_List); return Res; end Get_Overload_List; function Create_Overload_List (List : Iir_List) return Iir_Overload_List is Res : Iir_Overload_List; begin Res := Get_Overload_List; Set_Overload_List (Res, List); return Res; end Create_Overload_List; procedure Free_Overload_List (N : in out Iir_Overload_List) is List : Iir_List; begin List := Get_Overload_List (N); Destroy_Iir_List (List); Free_Iir (N); N := Null_Iir; end Free_Overload_List; function Simplify_Overload_List (List : Iir_List) return Iir is Res : Iir; L1 : Iir_List; begin case Get_Nbr_Elements (List) is when 0 => L1 := List; Destroy_Iir_List (L1); return Null_Iir; when 1 => L1 := List; Res := Get_First_Element (List); Destroy_Iir_List (L1); return Res; when others => return Create_Overload_List (List); end case; end Simplify_Overload_List; -- Return true if AN_IIR is an overload list. function Is_Overload_List (An_Iir: Iir) return Boolean is begin return Get_Kind (An_Iir) = Iir_Kind_Overload_List; end Is_Overload_List; -- From the list LIST of function or enumeration literal, extract the -- list of (return) types. -- If there is only one type, return it. -- If there is no types, return NULL. -- Otherwise, return the list as an overload list. function Create_List_Of_Types (List : Iir_List) return Iir is Res_List : Iir_List; Decl : Iir; begin -- Create the list of possible return types. Res_List := Create_Iir_List; for I in Natural loop Decl := Get_Nth_Element (List, I); exit when Decl = Null_Iir; case Get_Kind (Decl) is when Iir_Kind_Function_Declaration => Add_Element (Res_List, Get_Return_Type (Decl)); when Iir_Kind_Enumeration_Literal | Iir_Kind_Function_Call | Iir_Kind_Indexed_Name | Iir_Kind_Selected_Element => Add_Element (Res_List, Get_Type (Decl)); when others => Error_Kind ("create_list_of_types", Decl); end case; end loop; return Simplify_Overload_List (Res_List); end Create_List_Of_Types; procedure Add_Result (Res : in out Iir; Decl : Iir) is Nres : Iir; Nres_List : Iir_List; begin if Decl = Null_Iir then return; end if; if Res = Null_Iir then Res := Decl; elsif Is_Overload_List (Res) then Append_Element (Get_Overload_List (Res), Decl); else Nres_List := Create_Iir_List; Nres := Create_Overload_List (Nres_List); Append_Element (Nres_List, Res); Append_Element (Nres_List, Decl); Res := Nres; end if; end Add_Result; -- Extract from overload list RES the function call without implicit -- conversion. Return Null_Iir if there is no function call, or if there -- is an expressions that isn't a function call, or if there is more than -- one function call without implicit conversion. -- Cf Sem_Expr.Get_Non_Implicit_Subprogram function Extract_Call_Without_Implicit_Conversion (Res : Iir) return Iir is pragma Assert (Is_Overload_List (Res)); List : constant Iir_List := Get_Overload_List (Res); Call : Iir; El : Iir; Imp : Iir; Inter : Iir; begin Call := Null_Iir; for I in Natural loop El := Get_Nth_Element (List, I); exit when El = Null_Iir; if Get_Kind (El) = Iir_Kind_Function_Call then Imp := Get_Implementation (El); Inter := Get_Interface_Declaration_Chain (Imp); if Get_Type (Inter) = Universal_Integer_Type_Definition or else Get_Type (Inter) = Universal_Real_Type_Definition then -- The type of the first interface is a universal type. So, -- there were no implicit conversions. Once there is an -- implicit conversion, the only way to 'convert' to a -- universal type is through T'Pos, which has to be resolved. -- Note: there are no interface of convertible types. -- GHDL: this is not proven... if Call /= Null_Iir then -- More than one call without implicit conversion. return Null_Iir; else Call := El; end if; end if; else return Null_Iir; end if; end loop; return Call; end Extract_Call_Without_Implicit_Conversion; -- Move elements of result list LIST to result list RES. -- Destroy LIST if necessary. procedure Add_Result_List (Res : in out Iir; List : Iir); pragma Unreferenced (Add_Result_List); procedure Add_Result_List (Res : in out Iir; List : Iir) is El : Iir; List_List : Iir_List; Res_List : Iir_List; begin if Res = Null_Iir then Res := List; elsif List = Null_Iir then null; elsif not Is_Overload_List (List) then Add_Result (Res, List); else if not Is_Overload_List (Res) then El := Res; Res := Get_Overload_List; Append_Element (Get_Overload_List (Res), El); end if; List_List := Get_Overload_List (List); Res_List := Get_Overload_List (Res); for I in Natural loop El := Get_Nth_Element (List_List, I); exit when El = Null_Iir; Append_Element (Res_List, El); end loop; Free_Iir (List); end if; end Add_Result_List; -- Free interpretations of LIST except KEEP (which can be Null_Iir to free -- the whole list). procedure Sem_Name_Free_Result (List : Iir; Keep : Iir) is procedure Sem_Name_Free (El : Iir) is begin case Get_Kind (El) is when Iir_Kind_Function_Call | Iir_Kind_Indexed_Name | Iir_Kind_Selected_Element => Sem_Name_Free (Get_Prefix (El)); Free_Iir (El); when Iir_Kind_Attribute_Name => Free_Iir (El); when Iir_Kind_Function_Declaration | Iir_Kind_Procedure_Declaration | Iir_Kind_Enumeration_Literal => null; when Iir_Kinds_Denoting_Name => null; when others => Error_Kind ("sem_name_free", El); end case; end Sem_Name_Free; El : Iir; List_List : Iir_List; begin if List = Null_Iir then return; elsif not Is_Overload_List (List) then if List /= Keep then Sem_Name_Free (List); end if; else List_List := Get_Overload_List (List); for I in Natural loop El := Get_Nth_Element (List_List, I); exit when El = Null_Iir; if El /= Keep then Sem_Name_Free (El); end if; end loop; Free_Iir (List); end if; end Sem_Name_Free_Result; procedure Free_Parenthesis_Name (Name : Iir; Res : Iir) is Chain, Next_Chain : Iir; begin pragma Assert (Get_Kind (Res) /= Iir_Kind_Function_Call); Chain := Get_Association_Chain (Name); while Chain /= Null_Iir loop Next_Chain := Get_Chain (Chain); Free_Iir (Chain); Chain := Next_Chain; end loop; Free_Iir (Name); end Free_Parenthesis_Name; -- Find all named declaration whose identifier is ID in DECL_LIST and -- return it. -- The result can be NULL (if no such declaration exist), -- a declaration, or an overload_list containing all declarations. function Find_Declarations_In_List (Decl: Iir; Name : Iir_Selected_Name; Keep_Alias : Boolean) return Iir is Res: Iir := Null_Iir; -- If indentifier of DECL is ID, then add DECL in the result. procedure Handle_Decl (Decl : Iir; Id : Name_Id) is begin -- Use_clauses may appear in a declaration list. case Get_Kind (Decl) is when Iir_Kind_Use_Clause | Iir_Kind_Anonymous_Type_Declaration => return; when Iir_Kind_Non_Object_Alias_Declaration => if Get_Identifier (Decl) = Id then if Keep_Alias then Add_Result (Res, Decl); else Add_Result (Res, Get_Named_Entity (Get_Name (Decl))); end if; end if; when others => -- Consider only visible declarations (case of an implicit -- declaration that is overriden by explicit one). if Get_Identifier (Decl) = Id and Get_Visible_Flag (Decl) then Add_Result (Res, Decl); end if; end case; end Handle_Decl; procedure Iterator_Decl is new Sem_Scopes.Iterator_Decl (Arg_Type => Name_Id, Handle_Decl => Handle_Decl); --procedure Iterator_Decl_List is new Sem_Scopes.Iterator_Decl_List -- (Arg_Type => Name_Id, Handle_Decl => Iterator_Decl); procedure Iterator_Decl_Chain is new Sem_Scopes.Iterator_Decl_Chain (Arg_Type => Name_Id, Handle_Decl => Iterator_Decl); Id : constant Name_Id := Get_Identifier (Name); begin case Get_Kind (Decl) is when Iir_Kind_Function_Declaration | Iir_Kind_Procedure_Declaration => Iterator_Decl_Chain (Get_Interface_Declaration_Chain (Decl), Id); when Iir_Kind_Entity_Declaration => Iterator_Decl_Chain (Get_Generic_Chain (Decl), Id); Iterator_Decl_Chain (Get_Port_Chain (Decl), Id); when Iir_Kind_Architecture_Body => null; when Iir_Kind_If_Generate_Statement | Iir_Kind_For_Generate_Statement => null; when Iir_Kind_Package_Declaration => null; when Iir_Kind_Package_Instantiation_Declaration => Iterator_Decl_Chain (Get_Generic_Chain (Decl), Id); when Iir_Kind_Block_Statement => declare Header : constant Iir := Get_Block_Header (Decl); begin if Header /= Null_Iir then Iterator_Decl_Chain (Get_Generic_Chain (Header), Id); Iterator_Decl_Chain (Get_Port_Chain (Header), Id); end if; end; when Iir_Kind_For_Loop_Statement => Handle_Decl (Get_Parameter_Specification (Decl), Id); when Iir_Kind_Process_Statement | Iir_Kind_Sensitized_Process_Statement => null; when others => Error_Kind ("find_declarations_in_list", Decl); end case; case Get_Kind (Decl) is when Iir_Kind_Function_Declaration | Iir_Kind_Procedure_Declaration => declare Decl_Body : constant Iir := Get_Subprogram_Body (Decl); begin Iterator_Decl_Chain (Get_Declaration_Chain (Decl_Body), Id); Iterator_Decl_Chain (Get_Sequential_Statement_Chain (Decl_Body), Id); end; when Iir_Kind_Architecture_Body | Iir_Kind_Entity_Declaration | Iir_Kind_Block_Statement => Iterator_Decl_Chain (Get_Declaration_Chain (Decl), Id); Iterator_Decl_Chain (Get_Concurrent_Statement_Chain (Decl), Id); when Iir_Kind_For_Generate_Statement => declare Bod : constant Iir := Get_Generate_Statement_Body (Decl); begin Iterator_Decl_Chain (Get_Declaration_Chain (Bod), Id); Iterator_Decl_Chain (Get_Concurrent_Statement_Chain (Bod), Id); end; when Iir_Kind_If_Generate_Statement => declare Clause : Iir; Bod : Iir; begin -- Look only in the current generate_statement_body Clause := Decl; while Clause /= Null_Iir loop Bod := Get_Generate_Statement_Body (Clause); if Get_Is_Within_Flag (Bod) then Iterator_Decl_Chain (Get_Declaration_Chain (Bod), Id); Iterator_Decl_Chain (Get_Concurrent_Statement_Chain (Bod), Id); exit; end if; Clause := Get_Generate_Else_Clause (Clause); end loop; end; when Iir_Kind_Package_Declaration | Iir_Kind_Package_Instantiation_Declaration => Iterator_Decl_Chain (Get_Declaration_Chain (Decl), Id); when Iir_Kind_Process_Statement | Iir_Kind_Sensitized_Process_Statement => Iterator_Decl_Chain (Get_Declaration_Chain (Decl), Id); Iterator_Decl_Chain (Get_Sequential_Statement_Chain (Decl), Id); when Iir_Kind_For_Loop_Statement => null; when others => Error_Kind ("find_declarations_in_list", Decl); end case; --if Res = Null_Iir then -- Error_Msg_Sem ("""" & Name_Table.Image (Id) & """ not defined in " -- & Disp_Node (Decl), Name); --end if; return Res; end Find_Declarations_In_List; -- Create an implicit_dereference node if PREFIX is of type access. -- Return PREFIX otherwise. -- PARENT is used if an implicit dereference node is created, to copy -- location from. function Insert_Implicit_Dereference (Prefix : Iir; Parent : Iir) return Iir is Prefix_Type : Iir; Res : Iir_Implicit_Dereference; begin Prefix_Type := Get_Type (Prefix); case Get_Kind (Prefix_Type) is when Iir_Kind_Access_Type_Definition | Iir_Kind_Access_Subtype_Definition => null; when others => return Prefix; end case; Check_Read (Prefix); Res := Create_Iir (Iir_Kind_Implicit_Dereference); Location_Copy (Res, Parent); Set_Type (Res, Get_Designated_Type (Prefix_Type)); Set_Prefix (Res, Prefix); Set_Base_Name (Res, Res); Set_Expr_Staticness (Res, None); return Res; end Insert_Implicit_Dereference; -- If PREFIX is a function specification that cannot be converted to a -- function call (because of lack of association), return FALSE. function Maybe_Function_Call (Prefix : Iir) return Boolean is Inter : Iir; begin if Get_Kind (Prefix) /= Iir_Kind_Function_Declaration then return True; end if; Inter := Get_Interface_Declaration_Chain (Prefix); while Inter /= Null_Iir loop if Get_Default_Value (Inter) = Null_Iir then return False; end if; Inter := Get_Chain (Inter); end loop; return True; end Maybe_Function_Call; procedure Name_To_Method_Object (Call : Iir; Name : Iir) is Prefix : Iir; Obj : Iir; begin if Get_Kind (Name) /= Iir_Kind_Selected_Name then return; end if; Prefix := Get_Prefix (Name); Obj := Get_Named_Entity (Prefix); if Obj /= Null_Iir and then Kind_In (Obj, Iir_Kind_Variable_Declaration, Iir_Kind_Interface_Variable_Declaration) and then Get_Type (Obj) /= Null_Iir then if Get_Kind (Get_Type (Obj)) /= Iir_Kind_Protected_Type_Declaration then Error_Msg_Sem ("type of the prefix should be a protected type", Prefix); return; end if; Set_Method_Object (Call, Obj); end if; end Name_To_Method_Object; -- NAME is the name of the function (and not the parenthesis name) function Sem_As_Function_Call (Name : Iir; Spec : Iir; Assoc_Chain : Iir) return Iir_Function_Call is Call : Iir_Function_Call; begin -- Check. pragma Assert (Get_Kind (Name) in Iir_Kinds_Denoting_Name); Call := Create_Iir (Iir_Kind_Function_Call); Location_Copy (Call, Name); if Get_Kind (Name) = Iir_Kind_Parenthesis_Name then Set_Prefix (Call, Get_Prefix (Name)); else Set_Prefix (Call, Name); end if; Name_To_Method_Object (Call, Name); Set_Implementation (Call, Spec); Set_Parameter_Association_Chain (Call, Assoc_Chain); Set_Type (Call, Get_Return_Type (Spec)); Set_Base_Name (Call, Call); return Call; end Sem_As_Function_Call; -- If SPEC is a function specification, then return a function call, -- else return SPEC. function Maybe_Insert_Function_Call (Name : Iir; Spec : Iir) return Iir is begin if Get_Kind (Spec) = Iir_Kind_Function_Declaration then return Sem_As_Function_Call (Name, Spec, Null_Iir); else return Spec; end if; end Maybe_Insert_Functi