[Ada] Fix issues with compiling ACATS test for user-defined literals
Commit Message
The draft ACATS test (which we developed) for the Ada 2022 feature of
user-defined literals has compile-time problems that are fixed with this
set of changes. Two of these involve the resolution of named numbers
in the context where an implicit literal conversion can occur, and for
equality when a literal or named number is an operand. Furthermore,
the compiler can hang in some cases when a numeric literal is used
in a context where the expected type is a type derived two levels
down from a tagged type that specifies a literal aspect.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* sem_res.adb
(Resolve_Equality_Op): Add handling for equality ops with
user-defined literal operands.
* sem_util.ads
(Is_User_Defined_Literal): Update spec comment to indicate
inclusion of named number cases.
* sem_util.adb
(Corresponding_Primitive_Op): Rather than following the chain of
ancestor subprograms via Alias and Overridden_Operation links, we
check for matching profiles between primitive subprograms of the
descendant type and the ancestor subprogram (by calling a new
nested function Profile_Matches_Ancestor). This prevents the
compiler from hanging due to circular linkages via those fields
that can occur between inherited and overriding subprograms
(which might indicate a latent bug, but one that may be rather
delicate to resolve).
(Profile_Matches_Ancestor): New nested subprogram to compare the
profile of a primitive subprogram with the profile of a candidate
ancestor subprogram.
(Is_User_Defined_Literal): Also return True in cases where the
node N denotes a named number (E_Name_Integer and E_Named_Real).
@@ -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
@@ -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;
--------------------------------------
@@ -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