diff mbox series

[COMMITTED] ada: Reject non-statically compatible extended return statement

Message ID 20240507080000.36766-1-poulhies@adacore.com
State Committed
Headers
Series [COMMITTED] ada: Reject non-statically compatible extended return statement |

Checks

Context Check Description
linaro-tcwg-bot/tcwg_gcc_build--master-arm warning Patch is already merged
linaro-tcwg-bot/tcwg_gcc_build--master-aarch64 warning Patch is already merged

Commit Message

Marc Poulhiès May 7, 2024, 8 a.m. UTC 
  From: Javier Miranda <miranda@adacore.com>

Add missing check of RM 6.5(5.3/5): when the result subtype of the
function is defined by a subtype mark, the subtype defined by the
subtype indication of the extended return statement shall be
statically compatible with the result subtype of the function.

gcc/ada/

	* sem_ch3.adb (Check_Return_Subtype_Indication): Add missing check
	on statically compatible subtypes.
	* sem_eval.adb (Subtypes_Statically_Compatible): Ensure that both
	types are either scalar types or access types to evaluate this
	predicate.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/sem_ch3.adb  | 25 +++++++++++++++++++++++++
 gcc/ada/sem_eval.adb |  4 ++--
 2 files changed, 27 insertions(+), 2 deletions(-)
diff mbox series

Patch

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 578c57c10fa..c15f0bfc283 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -4129,6 +4129,31 @@  package body Sem_Ch3 is
                if not Subtypes_Statically_Match (Obj_Typ, R_Typ) then
                   Error_No_Match (Indic);
                end if;
+
+            --  If the result subtype of the function is defined by a
+            --  subtype_mark, the return_subtype_indication shall be a
+            --  subtype_indication. The subtype defined by the subtype_
+            --  indication shall be statically compatible with the result
+            --  subtype of the function (RM 6.5(5.3/5)).
+
+            --  We exclude the extended return statement of the predefined
+            --  stream input to avoid reporting spurious errors, because its
+            --  code is expanded on the basis of the base type (see subprogram
+            --  Stream_Base_Type).
+
+            elsif Nkind (Indic) = N_Subtype_Indication
+              and then not Subtypes_Statically_Compatible (Obj_Typ, R_Typ)
+              and then not Is_TSS (Func_Id, TSS_Stream_Input)
+            then
+               Error_Msg_N
+                 ("result subtype must be statically compatible with the " &
+                  "function result type", Indic);
+
+               if not Predicates_Compatible (Obj_Typ, R_Typ) then
+                  Error_Msg_NE
+                    ("\predicate on result subtype is not compatible with &",
+                     Indic, R_Typ);
+               end if;
             end if;
 
          --  All remaining cases are illegal
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 42f2668bb93..03006b63070 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -6507,7 +6507,7 @@  package body Sem_Eval is
 
       --  Scalar types
 
-      elsif Is_Scalar_Type (T1) then
+      elsif Is_Scalar_Type (T1) and then Is_Scalar_Type (T2) then
 
          --  Definitely compatible if we match
 
@@ -6560,7 +6560,7 @@  package body Sem_Eval is
 
       --  Access types
 
-      elsif Is_Access_Type (T1) then
+      elsif Is_Access_Type (T1) and then Is_Access_Type (T2) then
          return
            (not Is_Constrained (T2)
              or else Subtypes_Statically_Match