ada: Fix Constraint_Error on mutable assignment

For an assignment statement "X := Y;", where X is a formal parameter
of a "late overriding" subprogram (i.e. it has no spec, and the body
is overriding), and the subtype of X is an unconstrained record with
defaulted discriminants, if the actual parameter passed to X is
unconstrained, then X is unconstrained. This patch fixes a bug
where X was incorrectly considered constrained, so that if Y's
discriminants are different from X, Constraint_Error was raised.

The bug was caused by the fact that an extra "constrained" formal
parameter was missing in both caller and callee.

gcc/ada/

	* sem_disp.adb (Check_Dispatching_Operation): Call
	Create_Extra_Formals, so that the caller will have an extra
	"constrained" parameter, which will be checked on assignment in
	the callee, and will be passed in by the caller.

diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 525a9f7f0a1a213a955ed852e8cdcd2eeb547dc7..fd521a09bc0fdeb55a23cdd2cd065c14d68e1baf 100644 (file)
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -1514,10 +1514,10 @@ package body Sem_Disp is
                         Subp);
 
                   else
-
                      --  The subprogram body declares a primitive operation.
                      --  We must update its dispatching information here. The
                      --  information is taken from the overridden subprogram.
+                     --  Such a late-overriding body also needs extra formals.
                      --  We must also generate a cross-reference entry because
                      --  references to other primitives were already created
                      --  when type was frozen.
@@ -1527,6 +1527,7 @@ package body Sem_Disp is
                      if Present (DTC_Entity (Old_Subp)) then
                         Set_DTC_Entity (Subp, DTC_Entity (Old_Subp));
                         Set_DT_Position_Value (Subp, DT_Position (Old_Subp));
+                        Create_Extra_Formals (Subp);
 
                         if not Restriction_Active (No_Dispatching_Calls) then
                            if Building_Static_DT (Tagged_Type) then