diff options
| -rw-r--r-- | src/vhdl/sem.adb | 8 | ||||
| -rw-r--r-- | src/vhdl/sem_assocs.adb | 77 | ||||
| -rw-r--r-- | src/vhdl/sem_assocs.ads | 3 | ||||
| -rw-r--r-- | src/vhdl/sem_expr.adb | 139 | ||||
| -rw-r--r-- | src/vhdl/sem_expr.ads | 10 | ||||
| -rw-r--r-- | src/vhdl/sem_names.adb | 10 | ||||
| -rw-r--r-- | src/vhdl/sem_specs.adb | 2 |
7 files changed, 152 insertions, 97 deletions
diff --git a/src/vhdl/sem.adb b/src/vhdl/sem.adb index 0540242..12ec15c 100644 --- a/src/vhdl/sem.adb +++ b/src/vhdl/sem.adb @@ -354,7 +354,7 @@ package body Sem is (Inter_Parent : Iir; Assoc_Parent : Iir) return Boolean is El : Iir; - Match : Boolean; + Match : Compatibility_Level; Assoc_Chain : Iir; Inter_Chain : Iir; Miss : Missing_Type; @@ -418,7 +418,7 @@ package body Sem is Sem_Association_Chain (Inter_Chain, Assoc_Chain, True, Miss, Assoc_Parent, Match); Set_Generic_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain); - if not Match then + if Match = Not_Compatible then return False; end if; @@ -461,7 +461,7 @@ package body Sem is Actual : Iir; Prefix : Iir; Object : Iir; - Match : Boolean; + Match : Compatibility_Level; Assoc_Chain : Iir; Miss : Missing_Type; Inter : Iir; @@ -506,7 +506,7 @@ package body Sem is Sem_Association_Chain (Get_Port_Chain (Inter_Parent), Assoc_Chain, True, Miss, Assoc_Parent, Match); Set_Port_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain); - if not Match then + if Match = Not_Compatible then return; end if; diff --git a/src/vhdl/sem_assocs.adb b/src/vhdl/sem_assocs.adb index 492e79a..f75a1fb 100644 --- a/src/vhdl/sem_assocs.adb +++ b/src/vhdl/sem_assocs.adb @@ -21,7 +21,6 @@ with Flags; use Flags; with Types; use Types; with Iirs_Utils; use Iirs_Utils; with Sem_Names; use Sem_Names; -with Sem_Expr; use Sem_Expr; with Iir_Chains; use Iir_Chains; with Xrefs; @@ -1277,7 +1276,7 @@ package body Sem_Assocs is (Assoc : Iir; Inter : Iir; Finish : Boolean; - Match : out Boolean) + Match : out Compatibility_Level) is Formal : Iir; Assoc_Kind : Param_Assoc_Type; @@ -1287,7 +1286,7 @@ package body Sem_Assocs is if Formal /= Null_Iir then Assoc_Kind := Sem_Formal (Formal, Inter); if Assoc_Kind = None then - Match := False; + Match := Not_Compatible; return; end if; Set_Whole_Association_Flag (Assoc, Assoc_Kind = Whole); @@ -1298,7 +1297,7 @@ package body Sem_Assocs is if Get_Kind (Formal) in Iir_Kinds_Denoting_Name and then Is_Error (Get_Named_Entity (Formal)) then - Match := False; + Match := Not_Compatible; return; end if; @@ -1313,28 +1312,32 @@ package body Sem_Assocs is else Set_Whole_Association_Flag (Assoc, True); end if; - Match := True; + Match := Fully_Compatible; end Sem_Association_Open; procedure Sem_Association_Package (Assoc : Iir; Inter : Iir; Finish : Boolean; - Match : out Boolean) + Match : out Compatibility_Level) is Formal : constant Iir := Get_Formal (Assoc); Actual : Iir; Package_Inter : Iir; begin if not Finish then - Match := Get_Associated_Interface (Assoc) = Inter; + if Get_Associated_Interface (Assoc) = Inter then + Match := Fully_Compatible; + else + Match := Not_Compatible; + end if; return; end if; -- Always match (as this is a generic association, there is no -- need to resolve overload). pragma Assert (Get_Associated_Interface (Assoc) = Inter); - Match := True; + Match := Fully_Compatible; if Formal /= Null_Iir then pragma Assert (Get_Kind (Formal) = Iir_Kind_Simple_Name); @@ -1398,7 +1401,7 @@ package body Sem_Assocs is (Assoc : Iir; Inter : Iir; Finish : Boolean; - Match : out Boolean) + Match : out Compatibility_Level) is Formal : Iir; Formal_Type : Iir; @@ -1414,7 +1417,7 @@ package body Sem_Assocs is if Formal /= Null_Iir then Assoc_Kind := Sem_Formal (Formal, Inter); if Assoc_Kind = None then - Match := False; + Match := Not_Compatible; return; end if; Set_Whole_Association_Flag (Assoc, Assoc_Kind = Whole); @@ -1457,20 +1460,18 @@ package body Sem_Assocs is if Out_Conv = Null_Iir and then In_Conv = Null_Iir then Match := Is_Expr_Compatible (Formal_Type, Actual); else - Match := True; + Match := Fully_Compatible; if In_Conv /= Null_Iir then - if not Is_Expr_Compatible (Formal_Type, In_Conv) then - Match := False; - end if; + Match := Compatibility_Level'Min + (Match, Is_Expr_Compatible (Formal_Type, In_Conv)); end if; if Out_Conv /= Null_Iir then - if not Is_Expr_Compatible (Get_Type (Out_Conv), Actual) then - Match := False; - end if; + Match := Compatibility_Level'Min + (Match, Is_Expr_Compatible (Get_Type (Out_Conv), Actual)); end if; end if; - if not Match then + if Match = Not_Compatible then if Finish then Error_Msg_Sem ("can't associate " & Disp_Node (Actual) & " with " @@ -1512,7 +1513,7 @@ package body Sem_Assocs is if Res_Type = Null_Iir then -- In case of error, do not go farther. - Match := False; + Match := Not_Compatible; return; end if; @@ -1586,8 +1587,10 @@ package body Sem_Assocs is -- Associate ASSOC with interface INTERFACE -- This sets MATCH. - procedure Sem_Association - (Assoc : Iir; Inter : Iir; Finish : Boolean; Match : out Boolean) is + procedure Sem_Association (Assoc : Iir; + Inter : Iir; + Finish : Boolean; + Match : out Compatibility_Level) is begin case Get_Kind (Assoc) is when Iir_Kind_Association_Element_Open => @@ -1610,14 +1613,14 @@ package body Sem_Assocs is Finish: Boolean; Missing : Missing_Type; Loc : Iir; - Match : out Boolean) + Match : out Compatibility_Level) is -- Set POS and INTERFACE to *the* matching interface if any of ASSOC. procedure Search_Interface (Assoc : Iir; Inter : out Iir; Pos : out Integer) is - I_Match : Boolean; + I_Match : Compatibility_Level; begin Inter := Interface_Chain; Pos := 0; @@ -1626,7 +1629,7 @@ package body Sem_Assocs is -- be a conversion function, or even an indexed or -- selected name. Sem_Association (Assoc, Inter, False, I_Match); - if I_Match then + if I_Match /= Not_Compatible then return; end if; Inter := Get_Chain (Inter); @@ -1650,7 +1653,7 @@ package body Sem_Assocs is Pos_1 : Integer; Assoc_1 : Iir; begin - Match := True; + Match := Fully_Compatible; Has_Individual := False; -- Loop on every assoc element, try to match it. @@ -1668,7 +1671,7 @@ package body Sem_Assocs is -- Sem_Actual_Of_Association_Chain (because it is called only -- once, while sem_association_chain may be called several -- times). - Match := False; + Match := Not_Compatible; return; end if; -- Try to match actual of ASSOC with the interface. @@ -1677,11 +1680,11 @@ package body Sem_Assocs is Error_Msg_Sem ("too many actuals for " & Disp_Node (Loc), Assoc); end if; - Match := False; + Match := Not_Compatible; return; end if; Sem_Association (Assoc, Inter, Finish, Match); - if not Match then + if Match = Not_Compatible then return; end if; if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then @@ -1752,7 +1755,7 @@ package body Sem_Assocs is Error_Msg_Sem (Disp_Node (Inter) & " already associated", Assoc); end if; - Match := False; + Match := Not_Compatible; return; end if; else @@ -1766,7 +1769,7 @@ package body Sem_Assocs is Error_Msg_Sem ("non consecutive individual association for " & Disp_Node (Inter), Assoc); - Match := False; + Match := Not_Compatible; return; end if; Last_Individual := Inter; @@ -1775,14 +1778,14 @@ package body Sem_Assocs is if Finish then Error_Msg_Sem (Disp_Node (Inter) & " already associated", Assoc); - Match := False; + Match := Not_Compatible; return; end if; end if; end if; if Finish then Sem_Association (Assoc, Inter, True, Match); - -- MATCH can be false du to errors. + -- MATCH can be Not_Compatible due to errors. end if; else -- Not found. @@ -1793,7 +1796,7 @@ package body Sem_Assocs is ("no interface for " & Disp_Node (Get_Formal (Assoc)) & " in association", Assoc); end if; - Match := False; + Match := Not_Compatible; return; end if; end if; @@ -1849,7 +1852,7 @@ package body Sem_Assocs is Error_Msg_Sem ("no actual for " & Disp_Node (Inter), Loc); end if; - Match := False; + Match := Not_Compatible; return; when Missing_Port => case Get_Mode (Inter) is @@ -1860,7 +1863,7 @@ package body Sem_Assocs is Error_Msg_Sem (Disp_Node (Inter) & " of mode IN must be connected", Loc); - Match := False; + Match := Not_Compatible; return; when Iir_Out_Mode | Iir_Linkage_Mode @@ -1875,7 +1878,7 @@ package body Sem_Assocs is Error_Msg_Sem ("unconstrained " & Disp_Node (Inter) & " must be connected", Loc); - Match := False; + Match := Not_Compatible; return; end if; when Iir_Unknown_Mode => @@ -1888,7 +1891,7 @@ package body Sem_Assocs is when Iir_Kind_Interface_Package_Declaration => Error_Msg_Sem (Disp_Node (Inter) & " must be associated", Loc); - Match := False; + Match := Not_Compatible; when others => Error_Kind ("sem_association_chain", Inter); end case; diff --git a/src/vhdl/sem_assocs.ads b/src/vhdl/sem_assocs.ads index ec460e0..b1f978c 100644 --- a/src/vhdl/sem_assocs.ads +++ b/src/vhdl/sem_assocs.ads @@ -16,6 +16,7 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with Iirs; use Iirs; +with Sem_Expr; use Sem_Expr; package Sem_Assocs is -- Change the kind of association corresponding to non-object interfaces. @@ -44,7 +45,7 @@ package Sem_Assocs is Finish: Boolean; Missing : Missing_Type; Loc : Iir; - Match : out Boolean); + Match : out Compatibility_Level); -- Do port Sem_Association_Chain checks for subprograms. procedure Check_Subprogram_Associations diff --git a/src/vhdl/sem_expr.adb b/src/vhdl/sem_expr.adb index dc24d59..cb7b9cf 100644 --- a/src/vhdl/sem_expr.adb +++ b/src/vhdl/sem_expr.adb @@ -127,19 +127,43 @@ package body Sem_Expr is -- LEFT are RIGHT must be really a type (not a subtype). function Are_Basetypes_Compatible (Left: Iir; Right: Iir) - return Boolean is + return Compatibility_Level is begin - return Get_Common_Basetype (Left, Right) /= Null_Iir; + if Left = Right then + return Fully_Compatible; + end if; + case Get_Kind (Left) is + when Iir_Kind_Integer_Type_Definition => + if Right = Convertible_Integer_Type_Definition then + return Via_Conversion; + elsif Left = Convertible_Integer_Type_Definition + and then Get_Kind (Right) = Iir_Kind_Integer_Type_Definition + then + return Via_Conversion; + end if; + when Iir_Kind_Floating_Type_Definition => + if Right = Convertible_Real_Type_Definition then + return Via_Conversion; + elsif Left = Convertible_Real_Type_Definition + and then Get_Kind (Right) = Iir_Kind_Floating_Type_Definition + then + return Via_Conversion; + end if; + when others => + null; + end case; + return Not_Compatible; end Are_Basetypes_Compatible; - function Are_Types_Compatible (Left: Iir; Right: Iir) return Boolean is + function Are_Types_Compatible (Left: Iir; Right: Iir) + return Compatibility_Level is begin - return Get_Common_Basetype (Get_Base_Type (Left), - Get_Base_Type (Right)) /= Null_Iir; + return Are_Basetypes_Compatible (Get_Base_Type (Left), + Get_Base_Type (Right)); end Are_Types_Compatible; function Are_Nodes_Compatible (Left: Iir; Right: Iir) - return Boolean is + return Compatibility_Level is begin return Are_Types_Compatible (Get_Type (Left), Get_Type (Right)); end Are_Nodes_Compatible; @@ -147,23 +171,27 @@ package body Sem_Expr is -- Return TRUE iif LEFT_TYPE and RIGHT_TYPES are compatible. RIGHT_TYPES -- may be an overload list. function Compatibility_Types1 (Left_Type : Iir; Right_Types : Iir) - return Boolean + return Compatibility_Level is El : Iir; Right_List : Iir_List; + Level : Compatibility_Level; begin pragma Assert (not Is_Overload_List (Left_Type)); if Is_Overload_List (Right_Types) then Right_List := Get_Overload_List (Right_Types); + Level := Not_Compatible; for I in Natural loop El := Get_Nth_Element (Right_List, I); exit when El = Null_Iir; - if Are_Types_Compatible (Left_Type, El) then - return True; + Level := Compatibility_Level'Max + (Level, Are_Types_Compatible (Left_Type, El)); + if Level = Fully_Compatible then + return Fully_Compatible; end if; end loop; - return False; + return Level; else return Are_Types_Compatible (Left_Type, Right_Types); end if; @@ -174,7 +202,7 @@ package body Sem_Expr is -- Type of RIGHT can be an overload_list -- RIGHT might be implicitly converted to LEFT. function Compatibility_Nodes (Left : Iir; Right : Iir) - return Boolean + return Compatibility_Level is Left_Type, Right_Type : Iir; begin @@ -275,9 +303,11 @@ package body Sem_Expr is end Is_Allocator_Type; -- Return TRUE iff the type of EXPR is compatible with A_TYPE - function Is_Expr_Compatible (A_Type : Iir; Expr : Iir) return Boolean + function Is_Expr_Compatible (A_Type : Iir; Expr : Iir) + return Compatibility_Level is Expr_Type : constant Iir := Get_Type (Expr); + Is_Compatible : Boolean; begin if Expr_Type /= Null_Iir then return Compatibility_Types1 (A_Type, Expr_Type); @@ -285,21 +315,26 @@ package body Sem_Expr is case Get_Kind (Expr) is when Iir_Kind_Aggregate => - return Is_Aggregate_Type (A_Type); + Is_Compatible := Is_Aggregate_Type (A_Type); when Iir_Kind_String_Literal8 => - return Is_String_Literal_Type (A_Type, Expr); + Is_Compatible := Is_String_Literal_Type (A_Type, Expr); when Iir_Kind_Null_Literal => - return Is_Null_Literal_Type (A_Type); + Is_Compatible := Is_Null_Literal_Type (A_Type); when Iir_Kind_Allocator_By_Expression | Iir_Kind_Allocator_By_Subtype => - return Is_Allocator_Type (A_Type, Expr); + Is_Compatible := Is_Allocator_Type (A_Type, Expr); when Iir_Kind_Parenthesis_Expression => return Is_Expr_Compatible (A_Type, Get_Expression (Expr)); when others => -- Error while EXPR was typed. FIXME: should create an ERROR -- node? - return False; + Is_Compatible := False; end case; + if Is_Compatible then + return Fully_Compatible; + else + return Not_Compatible; + end if; end Is_Expr_Compatible; function Check_Is_Expression (Expr : Iir; Loc : Iir) return Iir @@ -556,17 +591,17 @@ package body Sem_Expr is Expr_Type := Search_Compatible_Type (Left_Type, Right_Type); if Expr_Type = Null_Iir then if Compatibility_Types1 (Universal_Integer_Type_Definition, - Left_Type) + Left_Type) /= Not_Compatible and then Compatibility_Types1 (Universal_Integer_Type_Definition, - Right_Type) + Right_Type) /= Not_Compatible then Expr_Type := Universal_Integer_Type_Definition; elsif Compatibility_Types1 (Universal_Real_Type_Definition, - Left_Type) + Left_Type) /= Not_Compatible and then Compatibility_Types1 (Universal_Real_Type_Definition, - Right_Type) + Right_Type) /= Not_Compatible then Expr_Type := Universal_Real_Type_Definition; else @@ -603,7 +638,7 @@ package body Sem_Expr is -- FIXME: resolve overload raise Internal_Error; else - if not Are_Types_Compatible (Expr_Type, A_Type) then + if Are_Types_Compatible (Expr_Type, A_Type) = Not_Compatible then Error_Msg_Sem ("type of range doesn't match expected type", Expr); return Null_Iir; @@ -621,7 +656,7 @@ package body Sem_Expr is Get_Expr_Staticness (Right))); if A_Type /= Null_Iir - and then not Are_Types_Compatible (Expr_Type, A_Type) + and then Are_Types_Compatible (Expr_Type, A_Type) = Not_Compatible then Error_Msg_Sem ("type of range doesn't match expected type", Expr); return Null_Iir; @@ -735,8 +770,9 @@ package body Sem_Expr is Res_Type := Res; if A_Type /= Null_Iir - and then (not Are_Types_Compatible - (A_Type, Get_Type_Of_Subtype_Indication (Res))) + and then (Are_Types_Compatible + (A_Type, Get_Type_Of_Subtype_Indication (Res)) + = Not_Compatible) then -- A_TYPE is known when analyzing an index_constraint within -- a subtype indication. @@ -1186,7 +1222,7 @@ package body Sem_Expr is Inter_Chain : Iir; Res_Type: Iir_List; Inter: Iir; - Match : Boolean; + Match : Compatibility_Level; begin -- Sem_Name has gathered all the possible names for the prefix of this -- call. Reduce this list to only names that match the types. @@ -1217,12 +1253,13 @@ package body Sem_Expr is -- Keep this interpretation only if compatible. if A_Type = Null_Iir - or else Compatibility_Nodes (A_Type, Get_Return_Type (A_Func)) + or else (Compatibility_Nodes (A_Type, Get_Return_Type (A_Func)) + /= Not_Compatible) then Sem_Association_Chain (Get_Interface_Declaration_Chain (A_Func), Assoc_Chain, False, Missing_Parameter, Expr, Match); - if Match then + if Match /= Not_Compatible then Replace_Nth_Element (Imp_List, Nbr_Inter, A_Func); Nbr_Inter := Nbr_Inter + 1; end if; @@ -1255,9 +1292,7 @@ package body Sem_Expr is (Inter_Chain, Assoc_Chain, True, Missing_Parameter, Expr, Match); Set_Parameter_Association_Chain (Expr, Assoc_Chain); - if not Match then - raise Internal_Error; - end if; + pragma Assert (Match /= Not_Compatible); Check_Subprogram_Associations (Inter_Chain, Assoc_Chain); Sem_Subprogram_Call_Finish (Expr, Inter); return Expr; @@ -1308,7 +1343,7 @@ package body Sem_Expr is Param_Chain : Iir; Inter: Iir; Assoc_Chain : Iir; - Match : Boolean; + Match : Compatibility_Level; begin if Is_Func then Res_Type := Get_Type (Expr); @@ -1349,7 +1384,7 @@ package body Sem_Expr is (Param_Chain, Assoc_Chain, True, Missing_Parameter, Expr, Match); Set_Parameter_Association_Chain (Expr, Assoc_Chain); - if not Match then + if Match = Not_Compatible then -- No need to disp an error message, this is done by -- sem_subprogram_arguments. return Null_Iir; @@ -1384,6 +1419,7 @@ package body Sem_Expr is exit when Inter = Null_Iir; if Are_Basetypes_Compatible (A_Type, Get_Base_Type (Get_Return_Type (Inter))) + /= Not_Compatible then if Res /= Null_Iir then Error_Overload (Expr); @@ -1397,6 +1433,7 @@ package body Sem_Expr is else if Are_Basetypes_Compatible (A_Type, Get_Base_Type (Get_Return_Type (Inter_List))) + /= Not_Compatible then Res := Inter_List; end if; @@ -1429,7 +1466,7 @@ package body Sem_Expr is Sem_Association_Chain (Param_Chain, Assoc_Chain, True, Missing_Parameter, Expr, Match); Set_Parameter_Association_Chain (Expr, Assoc_Chain); - if not Match then + if Match = Not_Compatible then return Null_Iir; end if; Check_Subprogram_Associations (Param_Chain, Assoc_Chain); @@ -1738,8 +1775,8 @@ package body Sem_Expr is -- Check return type. if Res_Type /= Null_Iir - and then - not Are_Types_Compatible (Res_Type, Get_Return_Type (Decl)) + and then (Are_Types_Compatible (Res_Type, Get_Return_Type (Decl)) + = Not_Compatible) then goto Next; end if; @@ -1761,12 +1798,15 @@ package body Sem_Expr is end if; -- Check operands. - if not Is_Expr_Compatible (Get_Type (Interface_Chain), Left) then + if Is_Expr_Compatible (Get_Type (Interface_Chain), Left) + = Not_Compatible + then goto Next; end if; if Arity = 2 then - if not Is_Expr_Compatible - (Get_Type (Get_Chain (Interface_Chain)), Right) + if Is_Expr_Compatible (Get_Type (Get_Chain (Interface_Chain)), + Right) + = Not_Compatible then goto Next; end if; @@ -1861,7 +1901,9 @@ package body Sem_Expr is Decl := Get_Nth_Element (Overload_List, I); exit when Decl = Null_Iir; -- FIXME: wrong: compatibilty with return type and args. - if Are_Types_Compatible (Get_Return_Type (Decl), Res_Type) then + if Are_Types_Compatible (Get_Return_Type (Decl), Res_Type) + /= Not_Compatible + then if Full_Compat /= Null_Iir then Error_Operator_Overload (Overload_List); return Null_Iir; @@ -2285,7 +2327,7 @@ package body Sem_Expr is N_Choice : Iir; Name1 : Iir; begin - if not Are_Types_Compatible (Range_Type, Sub_Type) then + if Are_Types_Compatible (Range_Type, Sub_Type) = Not_Compatible then Not_Match (Name, Sub_Type); return False; end if; @@ -2825,7 +2867,7 @@ package body Sem_Expr is Ass_Type := Get_Type (Rec_El); if El_Type = Null_Iir then El_Type := Ass_Type; - elsif not Are_Types_Compatible (El_Type, Ass_Type) then + elsif Are_Types_Compatible (El_Type, Ass_Type) = Not_Compatible then Error_Msg_Sem ("elements are not of the same type", El); Ok := False; end if; @@ -3625,7 +3667,7 @@ package body Sem_Expr is N_Type := Get_Type (N_Type); Set_Type (Expr, N_Type); if A_Type /= Null_Iir - and then not Are_Types_Compatible (A_Type, N_Type) + and then Are_Types_Compatible (A_Type, N_Type) = Not_Compatible then Not_Match (Expr, A_Type); return Null_Iir; @@ -3903,8 +3945,8 @@ package body Sem_Expr is return Null_Iir; end if; if A_Type /= Null_Iir - and then not Are_Basetypes_Compatible - (A_Type, Get_Base_Type (Get_Type (Expr))) + and then Are_Basetypes_Compatible + (A_Type, Get_Base_Type (Get_Type (Expr))) = Not_Compatible then Not_Match (Expr, A_Type); return Null_Iir; @@ -4051,7 +4093,7 @@ package body Sem_Expr is -- with A_TYPE set to NULL_IIR and results in setting the type of -- EXPR. if A_Type /= Null_Iir - and then not Are_Types_Compatible (Expr_Type, A_Type) + and then Are_Types_Compatible (Expr_Type, A_Type) = Not_Compatible then Not_Match (Expr, A_Type); return Null_Iir; @@ -4278,6 +4320,7 @@ package body Sem_Expr is -- Only one result. Operator "??" is not applied if the result -- is of type boolean. if Are_Types_Compatible (Get_Type (Res), Boolean_Type_Definition) + /= Not_Compatible then Check_Read (Res); return Res; @@ -4296,7 +4339,9 @@ package body Sem_Expr is for I in Natural loop El := Get_Nth_Element (Res_List, I); exit when El = Null_Iir; - if Are_Types_Compatible (El, Boolean_Type_Definition) then + if Are_Types_Compatible (El, Boolean_Type_Definition) + /= Not_Compatible + then Nbr_Booleans := Nbr_Booleans + 1; end if; end loop; diff --git a/src/vhdl/sem_expr.ads b/src/vhdl/sem_expr.ads index a0422e7..ef0afad 100644 --- a/src/vhdl/sem_expr.ads +++ b/src/vhdl/sem_expr.ads @@ -160,16 +160,20 @@ package Sem_Expr is -- one-dimensional character array type. procedure Sem_String_Choices_Range (Choice_Chain : Iir; Sel : Iir); + type Compatibility_Level is + (Not_Compatible, Via_Conversion, Fully_Compatible); + -- LEFT are RIGHT must be really a type (not a subtype). function Are_Basetypes_Compatible (Left: Iir; Right: Iir) - return Boolean; + return Compatibility_Level; -- Return TRUE iif types of LEFT and RIGHT are compatible. function Are_Nodes_Compatible (Left: Iir; Right: Iir) - return Boolean; + return Compatibility_Level; -- Return TRUE iff the type of EXPR is compatible with A_TYPE - function Is_Expr_Compatible (A_Type : Iir; Expr : Iir) return Boolean; + function Is_Expr_Compatible (A_Type : Iir; Expr : Iir) + return Compatibility_Level; -- LIST1, LIST2 are either a type node or an overload list of types. -- Return THE type which is compatible with LIST1 are LIST2. diff --git a/src/vhdl/sem_names.adb b/src/vhdl/sem_names.adb index 6299826..a49a7c7 100644 --- a/src/vhdl/sem_names.adb +++ b/src/vhdl/sem_names.adb @@ -2212,14 +2212,14 @@ package body Sem_Names is procedure Sem_Parenthesis_Function (Sub_Name : Iir) is Used : Boolean; R : Iir; - Match : Boolean; + Match : Compatibility_Level; begin Used := False; if Get_Kind (Sub_Name) = Iir_Kind_Function_Declaration then Sem_Association_Chain (Get_Interface_Declaration_Chain (Sub_Name), Assoc_Chain, False, Missing_Parameter, Name, Match); - if Match then + if Match /= Not_Compatible then Add_Result (Res, Sem_As_Function_Call (Prefix_Name, Sub_Name, Assoc_Chain)); @@ -2240,7 +2240,7 @@ package body Sem_Names is procedure Error_Parenthesis_Function (Spec : Iir) is - Match : Boolean; + Match : Compatibility_Level; begin Error_Msg_Sem ("cannot match " & Disp_Node (Prefix) & " with actuals", Name); @@ -3518,7 +3518,8 @@ package body Sem_Names is if Res_Type = Null_Iir then return Null_Iir; end if; - if not Are_Basetypes_Compatible (Get_Base_Type (Res_Type), A_Type) + if Are_Basetypes_Compatible (Get_Base_Type (Res_Type), A_Type) + = Not_Compatible then Error_Not_Match (Res, A_Type, Name); return Null_Iir; @@ -3537,6 +3538,7 @@ package body Sem_Names is exit when El = Null_Iir; if Are_Basetypes_Compatible (Get_Base_Type (Get_Type (El)), A_Type) + /= Not_Compatible then Add_Result (Res, El); end if; diff --git a/src/vhdl/sem_specs.adb b/src/vhdl/sem_specs.adb index 47807a0..6ac2b2e 100644 --- a/src/vhdl/sem_specs.adb +++ b/src/vhdl/sem_specs.adb @@ -1590,7 +1590,7 @@ package body Sem_Specs is Assoc := Create_Iir (Iir_Kind_Association_Element_Open); Location_Copy (Assoc, Parent); else - if not Are_Nodes_Compatible (Comp_El, Ent_El) then + if Are_Nodes_Compatible (Comp_El, Ent_El) = Not_Compatible then if not Error then Error_Msg_Sem ("for default port binding of " & Disp_Node (Parent) |