This change fixes the processing of a type conversion to a derived
type with a private non-discriminated ancestor whose full view has a
discriminant with default. Previous compiler versions would crash or produce
a junk error message.
The following compilation must be accepted quietly:
$ gcc -c der.adb
package Pvt is
type T is private;
private
type T (D : Integer := 0) is null record;
end Pvt;
with Pvt;
package Der is
type DT is new Pvt.T;
function F (X : Pvt.T) return DT;
end Der;
package body Der is
function F (X : Pvt.T) return DT is
begin
return DT (X);
end F;
end Der;
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-29 Thomas Quinot <qui...@adacore.com>
* checks.adb (Apply_Type_Conversion_Checks): Use the Underlying_Type of
the operand type.
Index: checks.adb
===================================================================
--- checks.adb (revision 178155)
+++ checks.adb (working copy)
@@ -1545,7 +1545,7 @@
-- Lo_OK be True.
-- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
-- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
- -- Hi_OK be False
+ -- Hi_OK be True.
procedure Apply_Float_Conversion_Check
(Ck_Node : Node_Id;
@@ -2325,7 +2325,10 @@
Target_Type : constant Entity_Id := Etype (N);
Target_Base : constant Entity_Id := Base_Type (Target_Type);
Expr : constant Node_Id := Expression (N);
- Expr_Type : constant Entity_Id := Etype (Expr);
+ Expr_Type : constant Entity_Id := Underlying_Type (Etype (Expr));
+ -- Note: if Etype (Expr) is a private type without discriminants, its
+ -- full view might have discriminants with defaults, so we need the
+ -- full view here to retrieve the constraints.
begin
if Inside_A_Generic then
@@ -2383,7 +2386,7 @@
and then not Is_Constrained (Target_Type)
and then Present (Stored_Constraint (Target_Type))
then
- -- An unconstrained derived type may have inherited discriminant
+ -- An unconstrained derived type may have inherited discriminant.
-- Build an actual discriminant constraint list using the stored
-- constraint, to verify that the expression of the parent type
-- satisfies the constraints imposed by the (unconstrained!)
