This deals with 3 very old reports about illegal constructs being silently
accepted by the compiler, in two different ways:
PR ada/18762: the compiler accepts the renaming of an inherited subprogram of
a derived untagged type, because it sets convention Ada instead of Intrinsic
on the subprogram.
PR ada/31417: the compiler accepts nonstatic constraints for the discriminants
of the ancestor part of a private extension, whereas only statically matching
ones are legal, because it checks only the full conformance of constraints.
PR ada/38330: the compiler accepts simple aggregates for the extension of a
formal tagged private type, whereas only extension aggregates are legal.
The first 2 cases are benign and cannot be rejected without breaking working
code, so the tweaks are mostly made to the commentary for them; the latter
case is more problematic and, therefore, is fully fixed.
Tested on x86-64/Linux, applied on the mainline.
2026-10-21 Eric Botcazou <[email protected]>
PR ada/18762
PR ada/31417
PR ada/38330
* sem_ch3.adb (Build_Derived_Record_Type): Set Has_Private_Ancestor
on the extension of a formal tagged private type. Implement the RM
7.3(13) subclause consistently independently of whether the derived
type itself is declared with discriminants.
(Derive_Subprogram): Document the implementation of RM 6.3.1(7).
(Process_Full_View): Remove obsolete comment about RM 7.3(13).
2026-10-21 Eric Botcazou <[email protected]>
* gnat.dg/specs/private4.ads: New test.
--
Eric Botcazou
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 9dafd710799..f95cea479d6 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -9448,7 +9448,9 @@ package body Sem_Ch3 is
-- type, mark it accordingly.
if Is_Private_Type (Parent_Type) then
- if Scope (Parent_Base) = Scope (Derived_Type) then
+ if Scope (Parent_Base) = Scope (Derived_Type)
+ and then not Is_Generic_Type (Parent_Base)
+ then
null;
elsif In_Open_Scopes (Scope (Parent_Base))
@@ -9593,14 +9595,15 @@ package body Sem_Ch3 is
New_Discrs := No_Elist;
end if;
+ -- RM 7.3(13) says that the constraints on the full view must
+ -- statically match those given in the partial view, but we
+ -- implement full conformance instead for historical reasons.
+
if Has_Discriminants (Derived_Type)
and then Has_Private_Declaration (Derived_Type)
and then Present (Discriminant_Constraint (Derived_Type))
and then Present (New_Discrs)
then
- -- Verify that constraints of the full view statically match
- -- those given in the partial view.
-
declare
C1, C2 : Elmt_Id;
@@ -9620,8 +9623,8 @@ package body Sem_Ch3 is
else
if Constraint_Present then
Error_Msg_N
- ("constraint not conformant to previous declaration",
- Node (C1));
+ ("constraint not conformant with previous "
+ & "declaration", Node (C1));
else
Error_Msg_N
("constraint of full view is incompatible "
@@ -9935,32 +9938,32 @@ package body Sem_Ch3 is
Discs := Build_Discriminant_Constraints (Parent_Type, Indic, True);
- -- For untagged types all new discriminants must rename
- -- discriminants in the parent. For private extensions new
- -- discriminants cannot rename old ones (implied by [7.3(13)]).
-
Discrim := First_Discriminant (Derived_Type);
while Present (Discrim) loop
+ -- For untagged types, all new discriminants must rename
+ -- discriminants in the parent.
+
if not Is_Tagged
and then No (Corresponding_Discriminant (Discrim))
then
Error_Msg_N
("new discriminants must constrain old ones", Discrim);
+ -- For private extensions, new discriminants cannot rename
+ -- old ones (implied by RM 7.3(13)).
+
elsif Private_Extension
and then Present (Corresponding_Discriminant (Discrim))
then
Error_Msg_N
("only static constraints allowed for parent"
& " discriminants in the partial view", Indic);
- exit;
- end if;
-- If a new discriminant is used in the constraint, then its
-- subtype must be statically compatible with the subtype of
-- the parent discriminant (RM 3.7(15)).
- if Present (Corresponding_Discriminant (Discrim)) then
+ elsif Present (Corresponding_Discriminant (Discrim)) then
Check_Constraining_Discriminant
(Discrim, Corresponding_Discriminant (Discrim));
end if;
@@ -9968,10 +9971,14 @@ package body Sem_Ch3 is
Next_Discriminant (Discrim);
end loop;
- -- Check whether the constraints of the full view statically
- -- match those imposed by the parent subtype [7.3(13)].
+ -- RM 7.3(13) says that the constraints on the full view must
+ -- statically match those given in the partial view, but we
+ -- implement full conformance instead for historical reasons.
- if Present (Stored_Constraint (Derived_Type)) then
+ if Has_Private_Declaration (Derived_Type)
+ and then Present (Stored_Constraint (Derived_Type))
+ and then Present (Discs)
+ then
declare
C1, C2 : Elmt_Id;
@@ -9979,12 +9986,19 @@ package body Sem_Ch3 is
C1 := First_Elmt (Discs);
C2 := First_Elmt (Stored_Constraint (Derived_Type));
while Present (C1) and then Present (C2) loop
- if not
- Fully_Conformant_Expressions (Node (C1), Node (C2))
+ if Fully_Conformant_Expressions (Node (C1), Node (C2))
+ or else
+ (Is_OK_Static_Expression (Node (C1))
+ and then Is_OK_Static_Expression (Node (C2))
+ and then
+ Expr_Value (Node (C1)) = Expr_Value (Node (C2)))
then
+ null;
+
+ else
Error_Msg_N
- ("not conformant with previous declaration",
- Node (C1));
+ ("constraint not conformant with previous "
+ & "declaration", Node (C1));
end if;
Next_Elmt (C1);
@@ -16949,7 +16963,8 @@ package body Sem_Ch3 is
-- Derived subprograms of a tagged type must inherit the convention
-- of the parent subprogram (a requirement of AI95-117). Derived
- -- subprograms of untagged types simply get convention Ada by default.
+ -- subprograms of untagged types get convention Ada by default for
+ -- historical reasons, although RM 6.3.1(7) says it is intrinsic.
-- If the derived type is a tagged generic formal type with unknown
-- discriminants, its convention is intrinsic (RM 6.3.1 (8)).
@@ -22020,12 +22035,6 @@ package body Sem_Ch3 is
("full view must define a constrained type if partial view "
& "has no discriminants", Full_T);
end if;
-
- -- Do we implement the following properly???
- -- If the ancestor subtype of a private extension has constrained
- -- discriminants, then the parent subtype of the full view shall
- -- impose a statically matching constraint on those discriminants
- -- [7.3(13)].
end if;
else
-- { dg-do compile }
generic
type T1 is tagged private;
package Private4 is
type T2 is new T1 with record
I : Integer;
J : Integer;
end record;
X : T2 := T2'(2,3); -- { dg-error "private ancestor|extension aggregate" }
Y : T2 := T2'(T1 with 2,3);
end Private4;
