A type derived from a private type that specifies
Default_Initial_Condition can lead to an assertion failure when the
compiler builds the body of the derived type's DIC procedure. Some code
inherited from type invariants doesn't apply in the DIC case, and
performed an incorrect assertion testing for the presence of a full type
on such a derived type. There was also additional unneeded and
ineffective code related to full types that is not needed or appropriate
for the DIC aspect (which can only be applied to private types, not full
types, unlike the Type_Invariant aspect). The problematic
assertion and dead code is removed.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* exp_util.adb (Build_DIC_Procedure_Body): Remove inappropriate
Assert pragma. Remove unneeded and dead code related to derived
private types.diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -2035,14 +2035,11 @@ package body Exp_Util is
Stmts => Stmts);
end if;
- -- Otherwise the "full" DIC procedure verifies the DICs of the full
- -- view, well as DICs inherited from parent types. In addition, it
- -- indirectly verifies the DICs of the partial view by calling the
- -- "partial" DIC procedure.
+ -- Otherwise, the "full" DIC procedure verifies the DICs inherited from
+ -- parent types, as well as indirectly verifying the DICs of the partial
+ -- view by calling the "partial" DIC procedure.
else
- pragma Assert (Present (Full_Typ));
-
-- Check the DIC of the partial view by calling the "partial" DIC
-- procedure, unless the partial DIC body is empty. Generate:
@@ -2056,44 +2053,6 @@ package body Exp_Util is
New_Occurrence_Of (Obj_Id, Loc))));
end if;
- -- Derived subtypes do not have a partial view
-
- if Present (Priv_Typ) then
-
- -- The processing of the "full" DIC procedure intentionally
- -- skips the partial view because a) this may result in changes of
- -- visibility and b) lead to duplicate checks. However, when the
- -- full view is the underlying full view of an untagged derived
- -- type whose parent type is private, partial DICs appear on
- -- the rep item chain of the partial view only.
-
- -- package Pack_1 is
- -- type Root ... is private;
- -- private
- -- <full view of Root>
- -- end Pack_1;
-
- -- with Pack_1;
- -- package Pack_2 is
- -- type Child is new Pack_1.Root with Type_DIC => ...;
- -- <underlying full view of Child>
- -- end Pack_2;
-
- -- As a result, the processing of the full view must also consider
- -- all DICs of the partial view.
-
- if Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ) then
- null;
-
- -- Otherwise the DICs of the partial view are ignored
-
- else
- -- Ignore the DICs of the partial view by eliminating the view
-
- Priv_Typ := Empty;
- end if;
- end if;
-
-- Process inherited Default_Initial_Conditions for all parent types
Add_Parent_DICs (Work_Typ, Obj_Id, Stmts);
