From: Javier Miranda <miranda@adacore.com>
Date: Tue, 23 Jul 2024 11:46:19 +0000 (+0000)
Subject: ada: Spurious error on the default value of a derived scalar type
X-Git-Tag: basepoints/gcc-16~6805
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=3e2b3dd728d851480bb752055bb0937cd4812ef1;p=thirdparty%2Fgcc.git

ada: Spurious error on the default value of a derived scalar type

When the aspect Default_Value is inherited by a derived scalar
type, and both the parent type T and the derived type DT are
declared in the same scope, a spurious error may be reported.
This occurs if a subprogram declared in the same scope has a
parameter of type DT with a default value, leading the compiler
to incorrectly flag the default value specified in the aspect
of type T as having the wrong type.

gcc/ada/

	* freeze.adb (Freeze_Entity): For scalar derived types that
	inherit the aspect Default_Value, do not analyze and resolve the
	inherited aspect, as the type of the aspect remains the parent
	type.
---

diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index a947018052c..7d5be6b6744 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -7820,7 +7820,24 @@ package body Freeze is
          --  type itself, and we treat Default_Component_Value similarly for
          --  the sake of uniformity).
 
-         if Is_First_Subtype (E) and then Has_Default_Aspect (E) then
+         --  But for an inherited Default_Value aspect specification, the type
+         --  of the aspect remains the parent type. RM 3.3.1(11.1), a dynamic
+         --  semantics rule, says "The implicit initial value for a scalar
+         --  subtype that has the Default_Value aspect specified is the value
+         --  of that aspect converted to the nominal subtype". For an inherited
+         --  Default_Value aspect specification, no conversion is evaluated at
+         --  the point of the derived type declaration.
+
+         if Is_First_Subtype (E)
+           and then Has_Default_Aspect (E)
+           and then
+             (not Is_Scalar_Type (E)
+                or else
+              not Is_Derived_Type (E)
+                or else
+              Default_Aspect_Value (E)
+                /= Default_Aspect_Value (Etype (Base_Type (E))))
+         then
             declare
                Nam : Name_Id;
                Exp : Node_Id;