From bcfbe673c08402fc63e2acb4a350d407e14fe993 Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Wed, 21 Sep 2016 06:47:49 +0200 Subject: vhdl08: first working example of interface type. --- src/vhdl/iirs.adb | 16 ++++++++ src/vhdl/iirs.ads | 11 +++++- src/vhdl/nodes_meta.adb | 26 +++++++----- src/vhdl/nodes_meta.ads | 2 + src/vhdl/sem_assocs.adb | 81 +++++++++++++++++++++++++++++++++++++- src/vhdl/sem_inst.adb | 18 ++++++++- src/vhdl/translate/ortho_front.adb | 3 +- src/vhdl/translate/trans_be.adb | 10 +++++ 8 files changed, 152 insertions(+), 15 deletions(-) (limited to 'src/vhdl') diff --git a/src/vhdl/iirs.adb b/src/vhdl/iirs.adb index 01d6bfeac..1cf90d515 100644 --- a/src/vhdl/iirs.adb +++ b/src/vhdl/iirs.adb @@ -4530,6 +4530,22 @@ package body Iirs is Set_Field4 (Target, Chain); end Set_Individual_Association_Chain; + function Get_Subprogram_Association_Chain (Target : Iir) return Iir is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Subprogram_Association_Chain (Get_Kind (Target)), + "no field Subprogram_Association_Chain"); + return Get_Field4 (Target); + end Get_Subprogram_Association_Chain; + + procedure Set_Subprogram_Association_Chain (Target : Iir; Chain : Iir) is + begin + pragma Assert (Target /= Null_Iir); + pragma Assert (Has_Subprogram_Association_Chain (Get_Kind (Target)), + "no field Subprogram_Association_Chain"); + Set_Field4 (Target, Chain); + end Set_Subprogram_Association_Chain; + function Get_Aggregate_Info (Target : Iir) return Iir is begin pragma Assert (Target /= Null_Iir); diff --git a/src/vhdl/iirs.ads b/src/vhdl/iirs.ads index bbafdd816..8b3904e3a 100644 --- a/src/vhdl/iirs.ads +++ b/src/vhdl/iirs.ads @@ -413,8 +413,10 @@ package Iirs is -- Only for Iir_Kind_Association_Element_By_Expression: -- Get/Set_In_Conversion (Field4) -- - -- Only for Iir_Kind_Association_Element_By_Individual: -- Only for Iir_Kind_Association_Element_Type: + -- Get/Set_Subprogram_Association_Chain (Field4) + -- + -- Only for Iir_Kind_Association_Element_By_Individual: -- Get/Set_Actual_Type (Field5) -- -- Only for Iir_Kind_Association_Element_By_Expression: @@ -5877,7 +5879,7 @@ package Iirs is procedure Set_Subtype_Definition (Target : Iir; Def : Iir); -- Implicit operations of an interface type declaration. - -- Field: Field4 + -- Field: Field4 Chain function Get_Interface_Type_Subprograms (Target : Iir) return Iir; procedure Set_Interface_Type_Subprograms (Target : Iir; Subprg : Iir); @@ -6700,6 +6702,11 @@ package Iirs is function Get_Individual_Association_Chain (Target : Iir) return Iir; procedure Set_Individual_Association_Chain (Target : Iir; Chain : Iir); + -- Chain of implicit subprogram associations for a type association. + -- Field: Field4 Chain + function Get_Subprogram_Association_Chain (Target : Iir) return Iir; + procedure Set_Subprogram_Association_Chain (Target : Iir; Chain : Iir); + -- Get/Set info for the aggregate. -- There is one aggregate_info for for each dimension. -- Field: Field2 diff --git a/src/vhdl/nodes_meta.adb b/src/vhdl/nodes_meta.adb index da825a1f1..7bfbc7364 100644 --- a/src/vhdl/nodes_meta.adb +++ b/src/vhdl/nodes_meta.adb @@ -268,6 +268,7 @@ package body Nodes_Meta is Field_Actual_Type => Type_Iir, Field_Association_Chain => Type_Iir, Field_Individual_Association_Chain => Type_Iir, + Field_Subprogram_Association_Chain => Type_Iir, Field_Aggregate_Info => Type_Iir, Field_Sub_Aggregate_Info => Type_Iir, Field_Aggr_Dynamic_Flag => Type_Boolean, @@ -836,6 +837,8 @@ package body Nodes_Meta is return "association_chain"; when Field_Individual_Association_Chain => return "individual_association_chain"; + when Field_Subprogram_Association_Chain => + return "subprogram_association_chain"; when Field_Aggregate_Info => return "aggregate_info"; when Field_Sub_Aggregate_Info => @@ -1669,7 +1672,7 @@ package body Nodes_Meta is when Field_Subtype_Definition => return Attr_None; when Field_Interface_Type_Subprograms => - return Attr_None; + return Attr_Chain; when Field_Nature => return Attr_None; when Field_Mode => @@ -1990,6 +1993,8 @@ package body Nodes_Meta is return Attr_Chain; when Field_Individual_Association_Chain => return Attr_Chain; + when Field_Subprogram_Association_Chain => + return Attr_Chain; when Field_Aggregate_Info => return Attr_None; when Field_Sub_Aggregate_Info => @@ -2262,7 +2267,7 @@ package body Nodes_Meta is Field_Formal, Field_Chain, Field_Actual, - Field_Actual_Type, + Field_Subprogram_Association_Chain, -- Iir_Kind_Association_Element_Subprogram Field_Whole_Association_Flag, Field_Collapse_Signal_Flag, @@ -5137,6 +5142,8 @@ package body Nodes_Meta is return Get_Association_Chain (N); when Field_Individual_Association_Chain => return Get_Individual_Association_Chain (N); + when Field_Subprogram_Association_Chain => + return Get_Subprogram_Association_Chain (N); when Field_Aggregate_Info => return Get_Aggregate_Info (N); when Field_Sub_Aggregate_Info => @@ -5511,6 +5518,8 @@ package body Nodes_Meta is Set_Association_Chain (N, V); when Field_Individual_Association_Chain => Set_Individual_Association_Chain (N, V); + when Field_Subprogram_Association_Chain => + Set_Subprogram_Association_Chain (N, V); when Field_Aggregate_Info => Set_Aggregate_Info (N, V); when Field_Sub_Aggregate_Info => @@ -9490,13 +9499,7 @@ package body Nodes_Meta is function Has_Actual_Type (K : Iir_Kind) return Boolean is begin - case K is - when Iir_Kind_Association_Element_By_Individual - | Iir_Kind_Association_Element_Type => - return True; - when others => - return False; - end case; + return K = Iir_Kind_Association_Element_By_Individual; end Has_Actual_Type; function Has_Association_Chain (K : Iir_Kind) return Boolean is @@ -9509,6 +9512,11 @@ package body Nodes_Meta is return K = Iir_Kind_Association_Element_By_Individual; end Has_Individual_Association_Chain; + function Has_Subprogram_Association_Chain (K : Iir_Kind) return Boolean is + begin + return K = Iir_Kind_Association_Element_Type; + end Has_Subprogram_Association_Chain; + function Has_Aggregate_Info (K : Iir_Kind) return Boolean is begin return K = Iir_Kind_Aggregate; diff --git a/src/vhdl/nodes_meta.ads b/src/vhdl/nodes_meta.ads index 867a96c23..c9fe6e695 100644 --- a/src/vhdl/nodes_meta.ads +++ b/src/vhdl/nodes_meta.ads @@ -308,6 +308,7 @@ package Nodes_Meta is Field_Actual_Type, Field_Association_Chain, Field_Individual_Association_Chain, + Field_Subprogram_Association_Chain, Field_Aggregate_Info, Field_Sub_Aggregate_Info, Field_Aggr_Dynamic_Flag, @@ -806,6 +807,7 @@ package Nodes_Meta is function Has_Actual_Type (K : Iir_Kind) return Boolean; function Has_Association_Chain (K : Iir_Kind) return Boolean; function Has_Individual_Association_Chain (K : Iir_Kind) return Boolean; + function Has_Subprogram_Association_Chain (K : Iir_Kind) return Boolean; function Has_Aggregate_Info (K : Iir_Kind) return Boolean; function Has_Sub_Aggregate_Info (K : Iir_Kind) return Boolean; function Has_Aggr_Dynamic_Flag (K : Iir_Kind) return Boolean; diff --git a/src/vhdl/sem_assocs.adb b/src/vhdl/sem_assocs.adb index f5dc048b9..3ae609ac1 100644 --- a/src/vhdl/sem_assocs.adb +++ b/src/vhdl/sem_assocs.adb @@ -20,8 +20,11 @@ with Errorout; use Errorout; with Flags; use Flags; with Types; use Types; with Iirs_Utils; use Iirs_Utils; +with Std_Names; with Sem_Names; use Sem_Names; with Sem_Types; +with Std_Package; +with Sem_Scopes; with Iir_Chains; use Iir_Chains; with Xrefs; @@ -1444,6 +1447,70 @@ package body Sem_Assocs is return; end Sem_Association_Package; + -- Create an implicit association_element_subprogram for the declaration + -- of function ID for ACTUAL (a name of a type). + function Sem_Implicit_Operator_Association + (Id : Name_Id; Actual : Iir) return Iir + is + use Sem_Scopes; + + Atype : constant Iir := Get_Type (Actual); + + -- Return TRUE if DECL is a function declaration with a comparaison + -- operator profile. + function Has_Comparaison_Profile (Decl : Iir) return Boolean + is + Inter : Iir; + begin + -- A function declaration. + if Get_Kind (Decl) /= Iir_Kind_Function_Declaration then + return False; + end if; + -- That returns a boolean. + if (Get_Base_Type (Get_Return_Type (Decl)) + /= Std_Package.Boolean_Type_Definition) + then + return False; + end if; + + -- With 2 interfaces of type ATYPE. + Inter := Get_Interface_Declaration_Chain (Decl); + for I in 1 .. 2 loop + if Inter = Null_Iir then + return False; + end if; + if Get_Base_Type (Get_Type (Inter)) /= Get_Base_Type (Atype) then + return False; + end if; + Inter := Get_Chain (Inter); + end loop; + if Inter /= Null_Iir then + return False; + end if; + return True; + end Has_Comparaison_Profile; + + Interp : Name_Interpretation_Type; + Decl : Iir; + Res : Iir; + begin + Interp := Get_Interpretation (Id); + while Valid_Interpretation (Interp) loop + Decl := Get_Declaration (Interp); + if Has_Comparaison_Profile (Decl) then + Res := Create_Iir (Iir_Kind_Association_Element_Subprogram); + Location_Copy (Res, Actual); + Set_Actual (Res, Build_Simple_Name (Decl, Get_Location (Actual))); + return Res; + end if; + Interp := Get_Next_Interpretation (Interp); + end loop; + + Error_Msg_Sem (+Actual, "cannot find a %i declaration for type %i", + (+Id, +Actual)); + return Null_Iir; + end Sem_Implicit_Operator_Association; + procedure Sem_Association_Type (Assoc : Iir; Inter : Iir; @@ -1451,6 +1518,7 @@ package body Sem_Assocs is Match : out Compatibility_Level) is Actual : Iir; + Op_Eq, Op_Neq : Iir; begin if not Finish then Sem_Association_Package_Type_Not_Finish (Assoc, Inter, Match); @@ -1466,7 +1534,18 @@ package body Sem_Assocs is -- indication. -- FIXME: ghdl only supports type_mark! Actual := Sem_Types.Sem_Subtype_Indication (Actual); - Set_Actual_Type (Assoc, Get_Type (Actual)); + Set_Actual (Assoc, Actual); + + -- FIXME: it is not clear at all from the LRM how the implicit + -- associations are done... + Op_Eq := Sem_Implicit_Operator_Association + (Std_Names.Name_Op_Equality, Actual); + if Op_Eq /= Null_Iir then + Op_Neq := Sem_Implicit_Operator_Association + (Std_Names.Name_Op_Inequality, Actual); + Set_Chain (Op_Eq, Op_Neq); + Set_Subprogram_Association_Chain (Assoc, Op_Eq); + end if; end Sem_Association_Type; -- Associate ASSOC with interface INTERFACE diff --git a/src/vhdl/sem_inst.adb b/src/vhdl/sem_inst.adb index 996eb06f2..cb52af129 100644 --- a/src/vhdl/sem_inst.adb +++ b/src/vhdl/sem_inst.adb @@ -650,7 +650,7 @@ package body Sem_Inst is declare Inter_Type_Def : constant Iir := Get_Type (Get_Association_Interface (Assoc, Inter)); - Actual_Type : constant Iir := Get_Actual_Type (Assoc); + Actual_Type : constant Iir := Get_Type (Get_Actual (Assoc)); begin Set_Instance (Inter_Type_Def, Actual_Type); end; @@ -744,6 +744,22 @@ package body Sem_Inst is Inter := Get_Association_Interface (Inst_El, Inter_El); Set_Instance (Get_Type (Get_Origin (Inter)), Get_Type (Get_Actual (Inst_El))); + -- Implicit operators. + declare + Imp_Inter : Iir; + Imp_Assoc : Iir; + begin + Imp_Assoc := Get_Subprogram_Association_Chain (Inst_El); + Imp_Inter := Get_Interface_Type_Subprograms + (Get_Origin (Inter_El)); + while Is_Valid (Imp_Inter) and Is_Valid (Imp_Assoc) loop + Set_Instance + (Imp_Inter, + Get_Named_Entity (Get_Actual (Imp_Assoc))); + Imp_Inter := Get_Chain (Imp_Inter); + Imp_Assoc := Get_Chain (Imp_Assoc); + end loop; + end; when Iir_Kind_Association_Element_Package => -- TODO. raise Internal_Error; diff --git a/src/vhdl/translate/ortho_front.adb b/src/vhdl/translate/ortho_front.adb index 2c3da3189..667bbfe5b 100644 --- a/src/vhdl/translate/ortho_front.adb +++ b/src/vhdl/translate/ortho_front.adb @@ -222,8 +222,7 @@ package body Ortho_Front is -- Lighter version of libraries.is_obselete, since DESIGN_UNIT must be in -- the currently analyzed design file. - function Is_Obsolete (Design_Unit : Iir_Design_Unit) - return Boolean + function Is_Obsolete (Design_Unit : Iir_Design_Unit) return Boolean is List : Iir_List; El : Iir; diff --git a/src/vhdl/translate/trans_be.adb b/src/vhdl/translate/trans_be.adb index 64906f85c..81c0efa7e 100644 --- a/src/vhdl/translate/trans_be.adb +++ b/src/vhdl/translate/trans_be.adb @@ -76,6 +76,16 @@ package body Trans_Be is Canon.Canonicalize (Unit); + -- FIXME: for Main only ? + if Get_Kind (Lib) = Iir_Kind_Package_Declaration + and then not Get_Need_Body (Lib) + and then Get_Need_Instance_Bodies (Lib) + then + -- Create the bodies for instances + Set_Package_Instantiation_Bodies_Chain + (Lib, Canon.Create_Instantiation_Bodies (Lib)); + end if; + if (Main or Flags.Dump_All) and then Flags.Dump_Canon then Disp_Tree.Disp_Tree (Unit); end if; -- cgit v1.2.3