diff options
author | Javier Miranda <miranda@adacore.com> | 2023-08-15 12:57:10 +0000 |
---|---|---|
committer | Marc Poulhiès <poulhies@adacore.com> | 2023-09-05 13:05:14 +0200 |
commit | 67138e097ee2af4633fbf904f4251dda5589fc6f (patch) | |
tree | c528bd59dc7802007a7f98f636139e23acfa6ced | |
parent | 9fc6f15bfe7ebfeef6ebbea48b2c551f79cd25bd (diff) | |
download | gcc-67138e097ee2af4633fbf904f4251dda5589fc6f.zip gcc-67138e097ee2af4633fbf904f4251dda5589fc6f.tar.gz gcc-67138e097ee2af4633fbf904f4251dda5589fc6f.tar.bz2 |
ada: Crash on function returning empty Ada 2022 aggregate
The compiler crashes processing a function that returns an empty
aggregate when its returned type is a record type which defined
its container aggregate aspects.
gcc/ada/
* exp_aggr.adb (Expand_Container_Aggregate): Report warning on
infinite recursion if an empty container aggregate appears in the
return statement of its Empty function. Fix typo in comment.
* sem_aggr.adb (Resolve_Aggregate): Resolve Ada 2022 empty
aggregate that initializes a record type that has defined its
container aggregate aspects.
(Resolve_Iterated_Association): Protect access to attribute Etype.
* sem_ch13.adb (Resolve_Aspect_Aggregate): Fix typo in comment.
-rw-r--r-- | gcc/ada/exp_aggr.adb | 23 | ||||
-rw-r--r-- | gcc/ada/sem_aggr.adb | 14 | ||||
-rw-r--r-- | gcc/ada/sem_ch13.adb | 2 |
3 files changed, 37 insertions, 2 deletions
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index cd5cc0b..cdca24b 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -6917,6 +6917,10 @@ package body Exp_Aggr is Siz := Aggregate_Size; + --------------------- + -- Empty function -- + --------------------- + if Ekind (Entity (Empty_Subp)) = E_Function and then Present (First_Formal (Entity (Empty_Subp))) then @@ -6984,7 +6988,7 @@ package body Exp_Aggr is Append (Init_Stat, Aggr_Code); - -- Size is dynamic: Create declaration for object, and intitialize + -- Size is dynamic: Create declaration for object, and initialize -- with a call to the null container, or an assignment to it. else @@ -7013,6 +7017,23 @@ package body Exp_Aggr is Append (Init_Stat, Aggr_Code); end if; + -- Report warning on infinite recursion if an empty container aggregate + -- appears in the return statement of its Empty function. + + if Ekind (Entity (Empty_Subp)) = E_Function + and then Nkind (Parent (N)) = N_Simple_Return_Statement + and then Is_Empty_List (Expressions (N)) + and then Is_Empty_List (Component_Associations (N)) + and then Entity (Empty_Subp) = Current_Scope + then + Error_Msg_Warn := SPARK_Mode /= On; + Error_Msg_N + ("!empty aggregate returned by the empty function of a container" + & " aggregate<<<", Parent (N)); + Error_Msg_N + ("\this will result in infinite recursion??", Parent (N)); + end if; + --------------------------- -- Positional aggregate -- --------------------------- diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 364217d..e929fea 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1065,6 +1065,19 @@ package body Sem_Aggr is Resolve_Container_Aggregate (N, Typ); + -- Check Ada 2022 empty aggregate [] initializing a record type that has + -- aspect aggregate; the empty aggregate will be expanded into a call to + -- the empty function specified in the aspect aggregate. + + elsif Has_Aspect (Typ, Aspect_Aggregate) + and then Ekind (Typ) = E_Record_Type + and then Is_Homogeneous_Aggregate (N) + and then Is_Empty_List (Expressions (N)) + and then Is_Empty_List (Component_Associations (N)) + and then Ada_Version >= Ada_2022 + then + Resolve_Container_Aggregate (N, Typ); + elsif Is_Record_Type (Typ) then Resolve_Record_Aggregate (N, Typ); @@ -3328,6 +3341,7 @@ package body Sem_Aggr is if Present (Add_Unnamed_Subp) and then No (New_Indexed_Subp) + and then Present (Etype (Add_Unnamed_Subp)) and then Etype (Add_Unnamed_Subp) /= Any_Type then declare diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 7cd0800..f891359 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -16470,7 +16470,7 @@ package body Sem_Ch13 is Op_Name := Chars (First (Choices (Assoc))); -- When verifying the consistency of aspects between the freeze point - -- and the end of declarqtions, we use a copy which is not analyzed + -- and the end of declarations, we use a copy which is not analyzed -- yet, so do it now. Subp_Id := Expression (Assoc); |