sem_ch3.adb (Build_Derived_Concurrent_Type): If derivation imposes a constraint...

	* 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

From-SVN: r47687

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 1f92e12c202827b1bf421708161b5767a3254e1e..2f6dc9a707f2326cb5ab6be10186e3d8ffd11404 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+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
+
 2001-12-05  Robert Dewar <dewar@gnat.com>
 
        * checks.adb (Determine_Range): Increase cache size for checks. 

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 89c5ac6d59a1acb5a55dfbc58eb30b151ee2824d..975fd7c4ef1c1c4fc1d1ae739b813e4e91e82871 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -657,8 +657,8 @@ package body Sem_Ch3 is
       return        Entity_Id
    is
       Anon_Type : constant Entity_Id :=
-        Create_Itype (E_Anonymous_Access_Type, Related_Nod,
-          Scope_Id => Scope (Current_Scope));
+                    Create_Itype (E_Anonymous_Access_Type, Related_Nod,
+                                  Scope_Id => Scope (Current_Scope));
       Desig_Type : Entity_Id;
 
    begin
@@ -2979,9 +2979,10 @@ package body Sem_Ch3 is
       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;
+                             Nkind (Subtype_Indication (Type_Definition (N)))
+                                                     = N_Subtype_Indication;
 
    begin
       Set_Girder_Constraint (Derived_Type, No_Elist);
@@ -2995,6 +2996,32 @@ package body Sem_Ch3 is
          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,
@@ -3002,10 +3029,9 @@ package body Sem_Ch3 is
       --  Discriminants may be renamed, and must be treated separately.
 
       Set_Has_Discriminants
-                       (Derived_Type, Has_Discriminants (Parent_Type));
+        (Derived_Type, Has_Discriminants         (Parent_Type));
       Set_Corresponding_Record_Type
-                       (Derived_Type, Corresponding_Record_Type
-                                                        (Parent_Type));
+        (Derived_Type, Corresponding_Record_Type (Parent_Type));
 
       if Constraint_Present then
 
@@ -3021,15 +3047,17 @@ package body Sem_Ch3 is
             New_Disc   := First_Discriminant (Derived_Type);
             Disc_Spec  := First (Discriminant_Specifications (N));
             D_Constraint :=
-              First (Constraints (
-                Constraint (Subtype_Indication (Type_Definition (N)))));
+              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
+                                              N_Access_Definition
                then
                   Analyze (Discriminant_Type (Disc_Spec));
+
                   if not Subtypes_Statically_Compatible (
                              Etype (Discriminant_Type (Disc_Spec)),
                                Etype (Old_Disc))
@@ -3086,6 +3114,10 @@ package body Sem_Ch3 is
 
       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));