2009-07-28 Emmanuel Briot <briot@adacore.com>

	* prj.adb, prj.ads (Compute_All_Imported_Projects): Make sure the
	importing project does not end up in the list, in the case of extending
	projects.
	* make.adb, makeutl.adb, makeutl.ads (File_Not_A_Source_Of): Moved to
	makeutl.ads, for better sharing with gprbuild.

2009-07-28  Arnaud Charlet  <charlet@adacore.com>

	* gnat_ugn.texi: Fix typo.

2009-07-28  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Build_Derived_Concurrent_Type): Handle properly a
	derivation that renames some discriminants and constrain others.
	* exp_ch9.adb (Build_Protected_Subprogram_Call): If the type of the
	prefix is a derived untagged type, convert to the root type to conform
	to the signature of the protected operations.

2009-07-28  Robert Dewar  <dewar@adacore.com>

	* sinfo.ads: Update comments.
	* exp_attr.adb: Minor reformatting



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150152 138bc75d-0d04-0410-961f-82ee72b054a4

10 files changed, 344 insertions, 159 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index d1077cb9850..69c8fee93f4 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,28 @@
+2009-07-28  Emmanuel Briot  <briot@adacore.com>
+
+	* prj.adb, prj.ads (Compute_All_Imported_Projects): Make sure the
+	importing project does not end up in the list, in the case of extending
+	projects.
+	* make.adb, makeutl.adb, makeutl.ads (File_Not_A_Source_Of): Moved to
+	makeutl.ads, for better sharing with gprbuild.
+
+2009-07-28  Arnaud Charlet  <charlet@adacore.com>
+
+	* gnat_ugn.texi: Fix typo.
+
+2009-07-28  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch3.adb (Build_Derived_Concurrent_Type): Handle properly a
+	derivation that renames some discriminants and constrain others.
+	* exp_ch9.adb (Build_Protected_Subprogram_Call): If the type of the
+	prefix is a derived untagged type, convert to the root type to conform
+	to the signature of the protected operations.
+
+2009-07-28  Robert Dewar  <dewar@adacore.com>
+
+	* sinfo.ads: Update comments.
+	* exp_attr.adb: Minor reformatting
+
 2009-07-28  Ed Schonberg  <schonberg@adacore.com>
 
 	* sem_aggr.adb (Get_Value): A named association in a record aggregate
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 56fa4c46a03..d5cce9b43ee 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -358,7 +358,7 @@ package body Exp_Attr is
 
       Sub_Ref :=
         Make_Attribute_Reference (Loc,
-          Prefix => Sub,
+          Prefix         => Sub,
           Attribute_Name => Name_Access);
 
       --  We set the type of the access reference to the already generated
@@ -370,17 +370,13 @@ package body Exp_Attr is
 
       Agg :=
         Make_Aggregate (Loc,
-          Expressions =>
-            New_List (
-              Obj_Ref, Sub_Ref));
+          Expressions => New_List (Obj_Ref, Sub_Ref));
 
       Rewrite (N, Agg);
-
       Analyze_And_Resolve (N, E_T);
 
-      --  For subsequent analysis,  the node must retain its type.
-      --  The backend will replace it with the equivalent type where
-      --  needed.
+      --  For subsequent analysis, the node must retain its type. The backend
+      --  will replace it with the equivalent type where needed.
 
       Set_Etype (N, Typ);
    end Expand_Access_To_Protected_Op;
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index e75ceca4ea5..3a7fa25065d 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -3193,6 +3193,18 @@ package body Exp_Ch9 is
          Params := New_List;
       end if;
 
+      --  If the type is an untagged derived type, convert to the root type,
+      --  which is the one on which the operations are defined.
+
+      if Nkind (Rec) = N_Unchecked_Type_Conversion
+        and then not Is_Tagged_Type (Etype (Rec))
+        and then Is_Derived_Type (Etype (Rec))
+      then
+         Set_Etype (Rec, Root_Type (Etype (Rec)));
+         Set_Subtype_Mark (Rec,
+           New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N)));
+      end if;
+
       Prepend (Rec, Params);
 
       if Ekind (Sub) = E_Procedure then
@@ -4358,8 +4370,8 @@ package body Exp_Ch9 is
          return N;
       else
          return
-           Unchecked_Convert_To (Corresponding_Record_Type (Typ),
-             New_Copy_Tree (N));
+           Unchecked_Convert_To
+             (Corresponding_Record_Type (Typ), New_Copy_Tree (N));
       end if;
    end Convert_Concurrent;
 
diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb
index 25124fa8314..3e1a8640375 100644
--- a/gcc/ada/make.adb
+++ b/gcc/ada/make.adb
@@ -557,25 +557,6 @@ package body Make is
    procedure List_Bad_Compilations;
    --  Prints out the list of all files for which the compilation failed
 
-   procedure Verbose_Msg
-     (N1                : Name_Id;
-      S1                : String;
-      N2                : Name_Id := No_Name;
-      S2                : String  := "";
-      Prefix            : String  := "  -> ";
-      Minimum_Verbosity : Verbosity_Level_Type := Opt.Low);
-   procedure Verbose_Msg
-     (N1                : File_Name_Type;
-      S1                : String;
-      N2                : File_Name_Type := No_File;
-      S2                : String  := "";
-      Prefix            : String  := "  -> ";
-      Minimum_Verbosity : Verbosity_Level_Type := Opt.Low);
-   --  If the verbose flag (Verbose_Mode) is set and the verbosity level is
-   --  at least equal to Minimum_Verbosity, then print Prefix to standard
-   --  output followed by N1 and S1. If N2 /= No_Name then N2 is printed after
-   --  S1. S2 is printed last. Both N1 and N2 are printed in quotation marks.
-
    Usage_Needed : Boolean := True;
    --  Flag used to make sure Makeusg is call at most once
 
@@ -1434,10 +1415,6 @@ package body Make is
       O_File         : out File_Name_Type;
       O_Stamp        : out Time_Stamp_Type)
    is
-      function File_Not_A_Source_Of
-        (Uname : Name_Id;
-         Sfile : File_Name_Type) return Boolean;
-
       function First_New_Spec (A : ALI_Id) return File_Name_Type;
       --  Looks in the with table entries of A and returns the spec file name
       --  of the first withed unit (subprogram) for which no spec existed when
@@ -1452,34 +1429,6 @@ package body Make is
       --  services, but this causes the whole compiler to be dragged along
       --  for gnatbind and gnatmake.
 
-      --------------------------
-      -- File_Not_A_Source_Of --
-      --------------------------
-
-      function File_Not_A_Source_Of
-        (Uname : Name_Id;
-         Sfile : File_Name_Type) return Boolean
-      is
-         UID    : Prj.Unit_Index;
-
-      begin
-         UID := Units_Htable.Get (Project_Tree.Units_HT, Uname);
-
-         if UID /= Prj.No_Unit_Index then
-            if (UID.File_Names (Impl) = null
-                 or else UID.File_Names (Impl).File /= Sfile)
-              and then
-                (UID.File_Names (Spec) = null
-                  or else UID.File_Names (Spec).File /= Sfile)
-            then
-               Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile));
-               return True;
-            end if;
-         end if;
-
-         return False;
-      end File_Not_A_Source_Of;
-
       --------------------
       -- First_New_Spec --
       --------------------
@@ -8240,52 +8189,6 @@ package body Make is
       end if;
    end Usage;
 
-   -----------------
-   -- Verbose_Msg --
-   -----------------
-
-   procedure Verbose_Msg
-     (N1                : Name_Id;
-      S1                : String;
-      N2                : Name_Id := No_Name;
-      S2                : String  := "";
-      Prefix            : String := "  -> ";
-      Minimum_Verbosity : Verbosity_Level_Type := Opt.Low)
-   is
-   begin
-      if (not Verbose_Mode) or else (Minimum_Verbosity > Verbosity_Level) then
-         return;
-      end if;
-
-      Write_Str (Prefix);
-      Write_Str ("""");
-      Write_Name (N1);
-      Write_Str (""" ");
-      Write_Str (S1);
-
-      if N2 /= No_Name then
-         Write_Str (" """);
-         Write_Name (N2);
-         Write_Str (""" ");
-      end if;
-
-      Write_Str (S2);
-      Write_Eol;
-   end Verbose_Msg;
-
-   procedure Verbose_Msg
-     (N1                : File_Name_Type;
-      S1                : String;
-      N2                : File_Name_Type := No_File;
-      S2                : String  := "";
-      Prefix            : String := "  -> ";
-      Minimum_Verbosity : Verbosity_Level_Type := Opt.Low)
-   is
-   begin
-      Verbose_Msg
-        (Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity);
-   end Verbose_Msg;
-
 begin
    --  Make sure that in case of failure, the temp files will be deleted
 
diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb
index 46169d5fa62..af5e7d6d8dd 100644
--- a/gcc/ada/makeutl.adb
+++ b/gcc/ada/makeutl.adb
@@ -26,6 +26,7 @@
 with Debug;
 with Osint;    use Osint;
 with Output;   use Output;
+with Opt;      use Opt;
 with Prj.Ext;
 with Prj.Util;
 with Snames;   use Snames;
@@ -264,6 +265,47 @@ package body Makeutl is
       end;
    end Executable_Prefix_Path;
 
+   --------------------------
+   -- File_Not_A_Source_Of --
+   --------------------------
+
+   function File_Not_A_Source_Of
+     (Uname : Name_Id;
+      Sfile : File_Name_Type) return Boolean
+   is
+      Unit : constant Unit_Index :=
+               Units_Htable.Get (Project_Tree.Units_HT, Uname);
+
+      At_Least_One_File : Boolean := False;
+
+   begin
+      if Unit /= No_Unit_Index then
+         for F in Unit.File_Names'Range loop
+            if Unit.File_Names (F) /= null then
+               At_Least_One_File := True;
+               if Unit.File_Names (F).File = Sfile then
+                  return False;
+               end if;
+            end if;
+         end loop;
+
+         if not At_Least_One_File then
+
+            --  The unit was probably created initially for a separate unit
+            --  (which are initially created as IMPL when both suffixes are the
+            --  same). Later on, Override_Kind changed the type of the file,
+            --  and the unit is no longer valid in fact.
+
+            return False;
+         end if;
+
+         Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile));
+         return True;
+      end if;
+
+      return False;
+   end File_Not_A_Source_Of;
+
    ----------
    -- Hash --
    ----------
@@ -749,4 +791,52 @@ package body Makeutl is
       return Result;
    end Unit_Index_Of;
 
+   -----------------
+   -- Verbose_Msg --
+   -----------------
+
+   procedure Verbose_Msg
+     (N1                : Name_Id;
+      S1                : String;
+      N2                : Name_Id := No_Name;
+      S2                : String  := "";
+      Prefix            : String := "  -> ";
+      Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
+   is
+   begin
+      if not Opt.Verbose_Mode
+        or else Minimum_Verbosity > Opt.Verbosity_Level
+      then
+         return;
+      end if;
+
+      Write_Str (Prefix);
+      Write_Str ("""");
+      Write_Name (N1);
+      Write_Str (""" ");
+      Write_Str (S1);
+
+      if N2 /= No_Name then
+         Write_Str (" """);
+         Write_Name (N2);
+         Write_Str (""" ");
+      end if;
+
+      Write_Str (S2);
+      Write_Eol;
+   end Verbose_Msg;
+
+   procedure Verbose_Msg
+     (N1                : File_Name_Type;
+      S1                : String;
+      N2                : File_Name_Type := No_File;
+      S2                : String  := "";
+      Prefix            : String := "  -> ";
+      Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
+   is
+   begin
+      Verbose_Msg
+        (Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity);
+   end Verbose_Msg;
+
 end Makeutl;
diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads
index ae55ebbe62a..e33369f4bd3 100644
--- a/gcc/ada/makeutl.ads
+++ b/gcc/ada/makeutl.ads
@@ -24,6 +24,7 @@
 ------------------------------------------------------------------------------
 
 with Namet; use Namet;
+with Opt;
 with Osint;
 with Prj;   use Prj;
 with Types; use Types;
@@ -69,6 +70,13 @@ package Makeutl is
    procedure Inform (N : File_Name_Type; Msg : String);
    --  Prints out the program name followed by a colon, N and S
 
+   function File_Not_A_Source_Of
+     (Uname : Name_Id;
+      Sfile : File_Name_Type) return Boolean;
+   --  Check that file name Sfile is one of the source of unit Uname.
+   --  Returns True if the unit is in one of the project file, but the file
+   --  name is not one of its source. Returns False otherwise.
+
    function Is_External_Assignment (Argv : String) return Boolean;
    --  Verify that an external assignment switch is syntactically correct
    --
@@ -82,6 +90,25 @@ package Makeutl is
    --  been entered by a call to Prj.Ext.Add, so that in a project
    --  file, External ("name") will return "value".
 
+   procedure Verbose_Msg
+     (N1                : Name_Id;
+      S1                : String;
+      N2                : Name_Id := No_Name;
+      S2                : String  := "";
+      Prefix            : String  := "  -> ";
+      Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low);
+   procedure Verbose_Msg
+     (N1                : File_Name_Type;
+      S1                : String;
+      N2                : File_Name_Type := No_File;
+      S2                : String  := "";
+      Prefix            : String  := "  -> ";
+      Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low);
+   --  If the verbose flag (Verbose_Mode) is set and the verbosity level is
+   --  at least equal to Minimum_Verbosity, then print Prefix to standard
+   --  output followed by N1 and S1. If N2 /= No_Name then N2 is printed after
+   --  S1. S2 is printed last. Both N1 and N2 are printed in quotation marks.
+
    function Linker_Options_Switches
      (Project  : Project_Id;
       In_Tree  : Project_Tree_Ref) return String_List;
diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb
index a4b9de11bd9..0f4e0505210 100644
--- a/gcc/ada/prj.adb
+++ b/gcc/ada/prj.adb
@@ -1069,8 +1069,8 @@ package body Prj is
       begin
          --  A project is not importing itself
 
-         if Project /= Prj then
-            Prj2 := Ultimate_Extending_Project_Of (Prj);
+         Prj2 := Ultimate_Extending_Project_Of (Prj);
+         if Project /= Prj2 then
 
             --  Check that the project is not already in the list. We know the
             --  one passed to Recursive_Add have never been visited before, but
diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads
index e3c04916572..8f95c08b59f 100644
--- a/gcc/ada/prj.ads
+++ b/gcc/ada/prj.ads
@@ -1061,7 +1061,8 @@ package Prj is
       --  The list of all directly imported projects, if any
 
       All_Imported_Projects : Project_List;
-      --  The list of all projects imported directly or indirectly, if any
+      --  The list of all projects imported directly or indirectly, if any.
+      --  This does not include the project itself.
 
       -----------------
       -- Directories --
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index ff8dd6e5253..5696a1c64bb 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -4826,17 +4826,72 @@ package body Sem_Ch3 is
       Parent_Type  : Entity_Id;
       Derived_Type : Entity_Id)
    is
-      D_Constraint : Node_Id;
-      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;
+      Loc              : constant Source_Ptr := Sloc (N);
+
+      Corr_Record      : constant Entity_Id
+              := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
+      Corr_Decl        : Node_Id;
+      Corr_Decl_Needed : Boolean;
+      --  If the derived type has fewer discriminants than its parent,
+      --  the corresponding record is also a derived type, in order to
+      --  account for the bound discriminants. We create a full type
+      --  declaration for it in this case.
+
+      Constraint_Present : constant Boolean
+        := Nkind (Subtype_Indication (Type_Definition (N)))
+            = N_Subtype_Indication;
+
+      D_Constraint   : Node_Id;
+      New_Constraint : Elist_Id;
+      Old_Disc       : Entity_Id;
+      New_Disc       : Entity_Id;
+      New_N          : Node_Id;
 
    begin
       Set_Stored_Constraint (Derived_Type, No_Elist);
+      Corr_Decl_Needed := False;
+      Old_Disc := Empty;
+
+      if Present (Discriminant_Specifications (N))
+        and then Constraint_Present
+      then
+         Old_Disc := First_Discriminant (Parent_Type);
+         New_Disc := First (Discriminant_Specifications (N));
+         while Present (New_Disc) and then Present (Old_Disc) loop
+            Next_Discriminant (Old_Disc);
+            Next (New_Disc);
+         end loop;
+      end if;
+
+      if Present (Old_Disc) then
+
+         --  The new type has fewer discriminants, so we need to create a new
+         --  corresponding record, which is derived from the corresponding
+         --  record of the parent, and has a stored constraint that
+         --  captures the values of the discriminant constraints.
+         --  The type declaration for the derived corresponding record has
+         --  the same discriminant part and constraints as the current
+         --  declaration. Copy the unanalyzed tree to build declaration.
+
+         Corr_Decl_Needed := True;
+         New_N := Copy_Separate_Tree (N);
+
+         Corr_Decl :=
+           Make_Full_Type_Declaration (Loc,
+             Defining_Identifier => Corr_Record,
+             Discriminant_Specifications =>
+                Discriminant_Specifications (New_N),
+             Type_Definition =>
+               Make_Derived_Type_Definition (Loc,
+                 Subtype_Indication =>
+                   Make_Subtype_Indication (Loc,
+                     Subtype_Mark =>
+                        New_Occurrence_Of
+                          (Corresponding_Record_Type (Parent_Type), Loc),
+                     Constraint =>
+                       Constraint
+                         (Subtype_Indication (Type_Definition (New_N))))));
+      end if;
 
       --  Copy Storage_Size and Relative_Deadline variables if task case
 
@@ -4850,6 +4905,16 @@ package body Sem_Ch3 is
       if Present (Discriminant_Specifications (N)) then
          Push_Scope (Derived_Type);
          Check_Or_Process_Discriminants (N, Derived_Type);
+
+         if Constraint_Present then
+            New_Constraint :=
+              Expand_To_Stored_Constraint
+                (Parent_Type,
+                 Build_Discriminant_Constraints
+                   (Parent_Type,
+                    Subtype_Indication (Type_Definition (N)), True));
+         end if;
+
          End_Scope;
 
       elsif Constraint_Present then
@@ -4880,9 +4945,9 @@ package body Sem_Ch3 is
          end;
       end if;
 
-      --  All attributes are inherited from parent. In particular,
-      --  entries and the corresponding record type are the same.
-      --  Discriminants may be renamed, and must be treated separately.
+      --  By default, operations and private data are inherited from parent.
+      --  However, in the presence of bound discriminants, a new corresponding
+      --  record will be created, see below.
 
       Set_Has_Discriminants
         (Derived_Type, Has_Discriminants         (Parent_Type));
@@ -4910,44 +4975,99 @@ package body Sem_Ch3 is
                 (Constraints
                   (Constraint (Subtype_Indication (Type_Definition (N)))));
 
-            Old_Disc  := First_Discriminant (Parent_Type);
-            New_Disc  := First_Discriminant (Derived_Type);
-            Disc_Spec := First (Discriminant_Specifications (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));
+            Old_Disc := First_Discriminant (Parent_Type);
 
-                  if not Subtypes_Statically_Compatible (
-                             Etype (Discriminant_Type (Disc_Spec)),
-                               Etype (Old_Disc))
-                  then
-                     Error_Msg_N
-                       ("not statically compatible with parent discriminant",
-                        Discriminant_Type (Disc_Spec));
+            while Present (D_Constraint) loop
+               if Nkind (D_Constraint) /= N_Discriminant_Association then
+
+                  --  Positional constraint. If it is a reference to a
+                  --  new discriminant, it constrains the corresponding
+                  --  old one.
+
+                  if Nkind (D_Constraint) = N_Identifier then
+                     New_Disc := First_Discriminant (Derived_Type);
+                     while Present (New_Disc) loop
+                        exit when
+                          Chars (New_Disc) = Chars (D_Constraint);
+                        Next_Discriminant (New_Disc);
+                     end loop;
+
+                     if Present (New_Disc) then
+                        Set_Corresponding_Discriminant (New_Disc, Old_Disc);
+                     end if;
+                  end if;
+
+                  Next_Discriminant (Old_Disc);
+
+                  --  if this is a named constraint, search by name for the
+                  --  old discriminants constrained by the new one.
+
+               elsif Nkind (Expression (D_Constraint)) = N_Identifier then
+
+                  --  Find new discriminant with that name.
+
+                  New_Disc := First_Discriminant (Derived_Type);
+                  while Present (New_Disc) loop
+                     exit when
+                       Chars (New_Disc) = Chars (Expression (D_Constraint));
+                     Next_Discriminant (New_Disc);
+                  end loop;
+
+                  if Present (New_Disc) then
+
+                     --  Verify that the new discriminant renames
+                     --  some discriminant of the parent type, and
+                     --  associate the new discriminant with an old
+                     --  one that it renames (may be more than one).
+
+                     declare
+                        Selector : Node_Id;
+
+                     begin
+                        Selector := First (Selector_Names (D_Constraint));
+
+                        while Present (Selector) loop
+                           Old_Disc := First_Discriminant (Parent_Type);
+
+                           while Present (Old_Disc) loop
+                              exit when Chars (Old_Disc) = Chars (Selector);
+                              Next_Discriminant (Old_Disc);
+                           end loop;
+
+                           if Present (Old_Disc) then
+                              Set_Corresponding_Discriminant
+                                (New_Disc, Old_Disc);
+
+                           end if;
+
+                           Next (Selector);
+                        end loop;
+                     end;
                   end if;
                end if;
 
-               if Nkind (D_Constraint) = N_Identifier
-                 and then Chars (D_Constraint) /=
-                          Chars (Defining_Identifier (Disc_Spec))
+               Next (D_Constraint);
+            end loop;
+
+            New_Disc  := First_Discriminant (Derived_Type);
+            while Present (New_Disc) loop
+               if No (Corresponding_Discriminant (New_Disc)) then
+                  Error_Msg_NE
+                    ("new discriminant& must constraint old one",
+                     N, New_Disc);
+               elsif not
+                 Subtypes_Statically_Compatible (
+                   Etype (New_Disc),
+                     Etype (Corresponding_Discriminant (New_Disc)))
                then
-                  Error_Msg_N ("new discriminants must constrain old ones",
-                    D_Constraint);
-               else
-                  Set_Corresponding_Discriminant (New_Disc, Old_Disc);
+                  Error_Msg_NE
+                    ("& not statically compatible with parent discriminant",
+                      N, New_Disc);
+
                end if;
 
-               Next_Discriminant (Old_Disc);
                Next_Discriminant (New_Disc);
-               Next (Disc_Spec);
             end loop;
-
-            if Present (Old_Disc) or else Present (Disc_Spec) then
-               Error_Msg_N ("discriminant mismatch in derivation", N);
-            end if;
-
          end if;
 
       elsif Present (Discriminant_Specifications (N)) then
@@ -4956,6 +5076,9 @@ package body Sem_Ch3 is
             N);
       end if;
 
+      --  The entity chain of the derived type includes the new
+      --  discriminants but shares operations with the parent.
+
       if Present (Discriminant_Specifications (N)) then
          Old_Disc := First_Discriminant (Parent_Type);
          while Present (Old_Disc) loop
@@ -4983,6 +5106,13 @@ package body Sem_Ch3 is
       Set_Last_Entity  (Derived_Type, Last_Entity  (Parent_Type));
 
       Set_Has_Completion (Derived_Type);
+
+      if Corr_Decl_Needed then
+         Set_Stored_Constraint (Derived_Type, New_Constraint);
+         Insert_After (N, Corr_Decl);
+         Analyze (Corr_Decl);
+         Set_Corresponding_Record_Type (Derived_Type, Corr_Record);
+      end if;
    end Build_Derived_Concurrent_Type;
 
    ------------------------------------
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 2b51273a939..b598b771de3 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -6850,15 +6850,16 @@ package Sinfo is
       --  SCIL Nodes --
       -----------------
 
-      --  SCIL nodes are special nodes added to the tree when the CodePeer mode
-      --  is active. They help CodePeer backend to locate nodes that require
-      --  special processing.
-
-      --  Where is the detailed description of what these nodes are for??? The
-      --  above is not sufficient. The description should be here, or perhaps
-      --  it could be in a new Sem_SCIL unit, with a pointer from here. But
-      --  right now I am afraid this documentation is missing and the purpose
-      --  of these nodes remains secret???
+      --  SCIL nodes are special nodes added to the tree when the CodePeer
+      --  mode is active. They help the CodePeer backend to locate nodes that
+      --  require special processing.
+
+      --  Major documentation on the general design of the SCIL interface, and
+      --  in particular detailed description of these nodes is missing and is
+      --  to be supplied in the future, when the design has finalized ???
+
+      --  Meanwhile these nodes should be considered in experimental form, and
+      --  should be ignored by all code generating back ends. ???
 
       --  N_SCIL_Dispatch_Table_Object_Init
       --  Sloc references a declaration node containing a dispatch table