This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Ada] Fix bug in derivation imposing a constraint
- From: Geert Bosch <bosch at darwin dot gnat dot com>
- To: gcc-patches at gcc dot gnu dot org
- Date: Wed, 5 Dec 2001 15:01:21 -0500 (EST)
- Subject: [Ada] Fix bug in derivation imposing a constraint
2001-12-05 Ed Schonberg <schonber@gnat.com>
* sem_ch3.adb (Build_Derived_Concurrent_Type): If derivation imposes a
constraint, introduce explicit subtype declaration and derive from it.
* sem_ch3.adb: Minor reformatting
*** sem_ch3.adb 2001/10/14 16:47:59 1.1358
--- sem_ch3.adb 2001/10/21 14:08:12 1.1359
***************
*** 2997,3002 ****
--- 2997,3027 ----
New_Scope (Derived_Type);
Check_Or_Process_Discriminants (N, Derived_Type);
End_Scope;
+
+ elsif Constraint_Present then
+ -- Build constrained subtype and derive from it.
+
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ Anon : Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ New_External_Name (Chars (Derived_Type), 'T'));
+ Decl : Node_Id;
+
+ begin
+ Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Anon,
+ Subtype_Indication =>
+ New_Copy_Tree (Subtype_Indication (Type_Definition (N))));
+ Insert_Before (N, Decl);
+ Rewrite (Subtype_Indication (Type_Definition (N)),
+ New_Occurrence_Of (Anon, Loc));
+ Analyze (Decl);
+ Set_Analyzed (Derived_Type, False);
+ Analyze (N);
+ return;
+ end;
end if;
-- All attributes are inherited from parent. In particular,
***************
*** 3088,3093 ****
--- 3113,3122 ----
else
Set_First_Entity (Derived_Type, First_Entity (Parent_Type));
+ if Has_Discriminants (Parent_Type) then
+ Set_Discriminant_Constraint (
+ Derived_Type, Discriminant_Constraint (Parent_Type));
+ end if;
end if;
Set_Last_Entity (Derived_Type, Last_Entity (Parent_Type));
*** sem_ch3.adb 2001/10/21 14:08:12 1.1359
--- sem_ch3.adb 2001/10/21 22:08:51 1.1360
***************
*** 657,664 ****
return Entity_Id
is
Anon_Type : constant Entity_Id :=
! Create_Itype (E_Anonymous_Access_Type, Related_Nod,
! Scope_Id => Scope (Current_Scope));
Desig_Type : Entity_Id;
begin
--- 657,664 ----
return Entity_Id
is
Anon_Type : constant Entity_Id :=
! Create_Itype (E_Anonymous_Access_Type, Related_Nod,
! Scope_Id => Scope (Current_Scope));
Desig_Type : Entity_Id;
begin
***************
*** 2981,2989 ****
Disc_Spec : Node_Id;
Old_Disc : Entity_Id;
New_Disc : Entity_Id;
Constraint_Present : constant Boolean :=
! Nkind (Subtype_Indication (Type_Definition (N))) =
! N_Subtype_Indication;
begin
Set_Girder_Constraint (Derived_Type, No_Elist);
--- 2981,2990 ----
Disc_Spec : Node_Id;
Old_Disc : Entity_Id;
New_Disc : Entity_Id;
+
Constraint_Present : constant Boolean :=
! Nkind (Subtype_Indication (Type_Definition (N)))
! = N_Subtype_Indication;
begin
Set_Girder_Constraint (Derived_Type, No_Elist);
***************
*** 2999,3011 ****
End_Scope;
elsif Constraint_Present then
! -- Build constrained subtype and derive from it.
declare
Loc : constant Source_Ptr := Sloc (N);
Anon : Entity_Id :=
! Make_Defining_Identifier (Loc,
! New_External_Name (Chars (Derived_Type), 'T'));
Decl : Node_Id;
begin
--- 3000,3013 ----
End_Scope;
elsif Constraint_Present then
!
! -- Build constrained subtype and derive from it
declare
Loc : constant Source_Ptr := Sloc (N);
Anon : Entity_Id :=
! Make_Defining_Identifier (Loc,
! New_External_Name (Chars (Derived_Type), 'T'));
Decl : Node_Id;
begin
***************
*** 3029,3038 ****
-- Discriminants may be renamed, and must be treated separately.
Set_Has_Discriminants
! (Derived_Type, Has_Discriminants (Parent_Type));
Set_Corresponding_Record_Type
! (Derived_Type, Corresponding_Record_Type
! (Parent_Type));
if Constraint_Present then
--- 3031,3039 ----
-- Discriminants may be renamed, and must be treated separately.
Set_Has_Discriminants
! (Derived_Type, Has_Discriminants (Parent_Type));
Set_Corresponding_Record_Type
! (Derived_Type, Corresponding_Record_Type (Parent_Type));
if Constraint_Present then
***************
*** 3048,3062 ****
New_Disc := First_Discriminant (Derived_Type);
Disc_Spec := First (Discriminant_Specifications (N));
D_Constraint :=
! First (Constraints (
! Constraint (Subtype_Indication (Type_Definition (N)))));
while Present (Old_Disc) and then Present (Disc_Spec) loop
if Nkind (Discriminant_Type (Disc_Spec)) /=
! N_Access_Definition
then
Analyze (Discriminant_Type (Disc_Spec));
if not Subtypes_Statically_Compatible (
Etype (Discriminant_Type (Disc_Spec)),
Etype (Old_Disc))
--- 3049,3065 ----
New_Disc := First_Discriminant (Derived_Type);
Disc_Spec := First (Discriminant_Specifications (N));
D_Constraint :=
! First
! (Constraints
! (Constraint (Subtype_Indication (Type_Definition (N)))));
while Present (Old_Disc) and then Present (Disc_Spec) loop
if Nkind (Discriminant_Type (Disc_Spec)) /=
! N_Access_Definition
then
Analyze (Discriminant_Type (Disc_Spec));
+
if not Subtypes_Statically_Compatible (
Etype (Discriminant_Type (Disc_Spec)),
Etype (Old_Disc))