diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/sem_res.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 98 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 4 |
3 files changed, 87 insertions, 29 deletions
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index f618467..4b76595 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8876,6 +8876,20 @@ package body Sem_Res is end if; else + + -- For Ada 2022, check for user-defined literals when the type has + -- the appropriate aspect. + + if Has_Applicable_User_Defined_Literal (L, Etype (R)) then + Resolve (L, Etype (R)); + Set_Etype (N, Standard_Boolean); + end if; + + if Has_Applicable_User_Defined_Literal (R, Etype (L)) then + Resolve (R, Etype (L)); + Set_Etype (N, Standard_Boolean); + end if; + -- Deal with other error cases if T = Any_String or else diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 5d83956..b708764 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7182,7 +7182,51 @@ package body Sem_Util is Typ : constant Entity_Id := Find_Dispatching_Type (Ancestor_Op); Elmt : Elmt_Id; Subp : Entity_Id; - Prim : Entity_Id; + + function Profile_Matches_Ancestor (S : Entity_Id) return Boolean; + -- Returns True if subprogram S has the proper profile for an + -- overriding of Ancestor_Op (that is, corresponding formals either + -- have the same type, or are corresponding controlling formals, + -- and similarly for result types). + + ------------------------------ + -- Profile_Matches_Ancestor -- + ------------------------------ + + function Profile_Matches_Ancestor (S : Entity_Id) return Boolean is + F1 : Entity_Id := First_Formal (Ancestor_Op); + F2 : Entity_Id := First_Formal (S); + + begin + if Ekind (Ancestor_Op) /= Ekind (S) then + return False; + end if; + + -- ??? This should probably account for anonymous access formals, + -- but the parent function (Corresponding_Primitive_Op) is currently + -- only called for user-defined literal functions, which can't have + -- such formals. But if this is ever used in a more general context + -- it should be extended to handle such formals (and result types). + + while Present (F1) and then Present (F2) loop + if Etype (F1) = Etype (F2) + or else Is_Ancestor (Typ, Etype (F2)) + then + Next_Formal (F1); + Next_Formal (F2); + else + return False; + end if; + end loop; + + return No (F1) + and then No (F2) + and then (Etype (Ancestor_Op) = Etype (S) + or else Is_Ancestor (Typ, Etype (S))); + end Profile_Matches_Ancestor; + + -- Start of processing for Corresponding_Primitive_Op + begin pragma Assert (Is_Dispatching_Operation (Ancestor_Op)); pragma Assert (Is_Ancestor (Typ, Descendant_Type) @@ -7193,12 +7237,12 @@ package body Sem_Util is while Present (Elmt) loop Subp := Node (Elmt); - -- For regular primitives we only need to traverse the chain of - -- ancestors when the name matches the name of Ancestor_Op, but - -- for predefined dispatching operations we cannot rely on the - -- name of the primitive to identify a candidate since their name - -- is internally built adding a suffix to the name of the tagged - -- type. + -- For regular primitives we need to check the profile against + -- the ancestor when the name matches the name of Ancestor_Op, + -- but for predefined dispatching operations we cannot rely on + -- the name of the primitive to identify a candidate since their + -- name is internally built by adding a suffix to the name of the + -- tagged type. if Chars (Subp) = Chars (Ancestor_Op) or else Is_Predefined_Dispatching_Operation (Subp) @@ -7214,26 +7258,10 @@ package body Sem_Util is return Alias (Subp); end if; - -- Traverse the chain of ancestors searching for Ancestor_Op. - -- Overridden primitives have attribute Overridden_Operation; - -- inherited primitives have attribute Alias. - - else - Prim := Subp; - - while Present (Overridden_Operation (Prim)) - or else Present (Alias (Prim)) - loop - if Present (Overridden_Operation (Prim)) then - Prim := Overridden_Operation (Prim); - else - Prim := Alias (Prim); - end if; + -- Otherwise, return subprogram when profile matches its ancestor - if Prim = Ancestor_Op then - return Subp; - end if; - end loop; + elsif Profile_Matches_Ancestor (Subp) then + return Subp; end if; end if; @@ -21620,8 +21648,22 @@ package body Sem_Util is N_String_Literal => Aspect_String_Literal); begin - return Nkind (N) in N_Numeric_Or_String_Literal - and then Present (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N)))); + -- Return True when N is either a literal or a named number and the + -- type has the appropriate user-defined literal aspect. + + return (Nkind (N) in N_Numeric_Or_String_Literal + and then Present (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N))))) + or else + (Is_Entity_Name (N) + and then Present (Entity (N)) + and then + ((Ekind (Entity (N)) = E_Named_Integer + and then + Present (Find_Aspect (Typ, Aspect_Integer_Literal))) + or else + (Ekind (Entity (N)) = E_Named_Real + and then + Present (Find_Aspect (Typ, Aspect_Real_Literal))))); end Is_User_Defined_Literal; -------------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 001e58f..132c2b8 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2500,7 +2500,9 @@ package Sem_Util is (N : Node_Id; Typ : Entity_Id) return Boolean; pragma Inline (Is_User_Defined_Literal); - -- Determine whether N is a user-defined literal for Typ + -- Determine whether N is a user-defined literal for Typ, including + -- the case where N denotes a named number of the appropriate kind + -- when Typ has an Integer_Literal or Real_Literal aspect. function Is_Validation_Variable_Reference (N : Node_Id) return Boolean; -- Determine whether N denotes a reference to a variable which captures the |