[multiple changes]

2014-07-31  Gary Dismukes  <dismukes@adacore.com>

	* exp_util.adb: Minor reformatting.

2014-07-31  Vincent Celier  <celier@adacore.com>

	* errutil.adb (Error_Msg): Make sure that all components of
	the error message object are initialized.

2014-07-31  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Try_Container_Indexing): If the container type is
	class-wide, use specific type to locate iteration primitives.
	* sem_ch13.adb (Check_Indexing_Functions): Add legality checks for
	rules in RM 4.1.6 (Illegal_Indexing): New diagnostic procedure.
	Minor error message reformating.
	* exp_ch5.adb (Expand_Iterator_Loop): Handle properly Iterator
	aspect for a derived type.

2014-07-31  Robert Dewar  <dewar@adacore.com>

	* debug.adb: Document debug flag d.X.

From-SVN: r213346

gcc/ada/ChangeLog

+2014-07-31  Gary Dismukes  <dismukes@adacore.com>
+
+	* exp_util.adb: Minor reformatting.
+
+2014-07-31  Vincent Celier  <celier@adacore.com>
+
+	* errutil.adb (Error_Msg): Make sure that all components of
+	the error message object are initialized.
+
+2014-07-31  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch4.adb (Try_Container_Indexing): If the container type is
+	class-wide, use specific type to locate iteration primitives.
+	* sem_ch13.adb (Check_Indexing_Functions): Add legality checks for
+	rules in RM 4.1.6 (Illegal_Indexing): New diagnostic procedure.
+	Minor error message reformating.
+	* exp_ch5.adb (Expand_Iterator_Loop): Handle properly Iterator
+	aspect for a derived type.
+
+2014-07-31  Robert Dewar  <dewar@adacore.com>
+
+	* debug.adb: Document debug flag d.X.
+
 2014-07-31  Ed Schonberg  <schonberg@adacore.com>
 
 	* sem_util.ads (Find_Specific_Type): Moved here from exp_disp.adb.

gcc/ada/debug.adb

@@ -141,7 +141,7 @@ package body Debug is
    --  d.U  Ignore indirect calls for static elaboration
    --  d.V
    --  d.W  Print out debugging information for Walk_Library_Items
-   --  d.X
+   --  d.X  Old treatment of indexing aspects
    --  d.Y
    --  d.Z
 
@@ -685,6 +685,12 @@ package body Debug is
    --       the order in which units are walked. This is primarily for use in
    --       debugging CodePeer mode.
 
+   --  d.X  A previous version of GNAT allowed indexing aspects to be
+   --       redefined on derived container types, while the default iterator
+   --       was inherited from the aprent type. This non-standard extension
+   --       is preserved temporarily for use by the modelling project under
+   --       debug flag d.X.
+
    --  d1   Error messages have node numbers where possible. Normally error
    --       messages have only source locations. This option is useful when
    --       debugging errors caused by expanded code, where the source location

gcc/ada/errutil.adb

@@ -201,24 +201,27 @@ package body Errutil is
 
       --  Otherwise build error message object for new message
 
-      Errors.Increment_Last;
-      Cur_Msg := Errors.Last;
-      Errors.Table (Cur_Msg).Text     := new String'(Msg_Buffer (1 .. Msglen));
-      Errors.Table (Cur_Msg).Next     := No_Error_Msg;
-      Errors.Table (Cur_Msg).Sptr     := Sptr;
-      Errors.Table (Cur_Msg).Optr     := Optr;
-      Errors.Table (Cur_Msg).Sfile    := Get_Source_File_Index (Sptr);
-      Errors.Table (Cur_Msg).Line     := Get_Physical_Line_Number (Sptr);
-      Errors.Table (Cur_Msg).Col      := Get_Column_Number (Sptr);
-      Errors.Table (Cur_Msg).Style    := Is_Style_Msg;
-      Errors.Table (Cur_Msg).Warn     := Is_Warning_Msg;
-      Errors.Table (Cur_Msg).Info     := Is_Info_Msg;
-      Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char;
-      Errors.Table (Cur_Msg).Serious  := Is_Serious_Error;
-      Errors.Table (Cur_Msg).Uncond   := Is_Unconditional_Msg;
-      Errors.Table (Cur_Msg).Msg_Cont := Continuation;
-      Errors.Table (Cur_Msg).Deleted  := False;
-
+      Errors.Append
+        (New_Val =>
+           (Text     => new String'(Msg_Buffer (1 .. Msglen)),
+            Next     => No_Error_Msg,
+            Prev     => No_Error_Msg,
+            Sfile    => Get_Source_File_Index (Sptr),
+            Sptr     => Sptr,
+            Optr     => Optr,
+            Line     => Get_Physical_Line_Number (Sptr),
+            Col      => Get_Column_Number (Sptr),
+            Warn     => Is_Warning_Msg,
+            Info     => Is_Info_Msg,
+            Warn_Err => Warning_Mode = Treat_As_Error,
+            Warn_Chr => Warning_Msg_Char,
+            Style    => Is_Style_Msg,
+            Serious  => Is_Serious_Error,
+            Uncond   => Is_Unconditional_Msg,
+            Msg_Cont => Continuation,
+            Deleted  => False));
+
+      Cur_Msg  := Errors.Last;
       Prev_Msg := No_Error_Msg;
       Next_Msg := First_Error_Msg;
 

gcc/ada/exp_ch5.adb

@@ -28,6 +28,7 @@ with Atree;    use Atree;
 with Checks;   use Checks;
 with Debug;    use Debug;
 with Einfo;    use Einfo;
+with Elists;   use Elists;
 with Errout;   use Errout;
 with Exp_Aggr; use Exp_Aggr;
 with Exp_Ch6;  use Exp_Ch6;
@@ -58,6 +59,7 @@ with Stand;    use Stand;
 with Stringt;  use Stringt;
 with Targparm; use Targparm;
 with Tbuild;   use Tbuild;
+with Uintp;    use Uintp;
 with Validsw;  use Validsw;
 
 package body Exp_Ch5 is
@@ -3292,17 +3294,90 @@ package body Exp_Ch5 is
          --  type of the iterator must be obtained from the aspect.
 
          if Of_Present (I_Spec) then
-            declare
-               Default_Iter : constant Entity_Id :=
-                                Entity
-                                  (Find_Value_Of_Aspect
-                                    (Etype (Container),
-                                     Aspect_Default_Iterator));
-
+            Handle_Of : declare
+               Default_Iter  : Entity_Id;
                Container_Arg : Node_Id;
                Ent           : Entity_Id;
 
+               function Get_Default_Iterator
+                 (T : Entity_Id) return Entity_Id;
+               --  If the container is a derived type, the aspect holds the
+               --  parent operation. The required one is a primitive of the
+               --  derived type and is either inherited or overridden.
+
+               --------------------------
+               -- Get_Default_Iterator --
+               --------------------------
+
+               function Get_Default_Iterator
+                 (T : Entity_Id) return Entity_Id
+               is
+                  Iter : constant Entity_Id :=
+                    Entity (Find_Value_Of_Aspect (T, Aspect_Default_Iterator));
+                  Prim : Elmt_Id;
+                  Op   : Entity_Id;
+
+               begin
+                  Container_Arg := New_Copy_Tree (Container);
+
+                  --  A previous version of GNAT allowed indexing aspects to
+                  --  be redefined on derived container types, while the
+                  --  default iterator was inherited from the aprent type.
+                  --  This non-standard extension is preserved temporarily for
+                  --  use by the modelling project under debug flag d.X.
+
+                  if Debug_Flag_Dot_XX then
+                     if Base_Type (Etype (Container)) /=
+                        Base_Type (Etype (First_Formal (Iter)))
+                     then
+                        Container_Arg :=
+                          Make_Type_Conversion (Loc,
+                            Subtype_Mark =>
+                              New_Occurrence_Of
+                                (Etype (First_Formal (Iter)), Loc),
+                            Expression   => Container_Arg);
+                     end if;
+
+                     return Iter;
+
+                  elsif Is_Derived_Type (T) then
+
+                     --  The default iterator must be a primitive operation
+                     --  of the type, at the same dispatch slot position.
+
+                     Prim := First_Elmt (Primitive_Operations (T));
+                     while Present (Prim) loop
+                        Op := Node (Prim);
+
+                        if Chars (Op) = Chars (Iter)
+                          and then DT_Position (Op) = DT_Position (Iter)
+                        then
+                           return Op;
+                        end if;
+
+                        Next_Elmt (Prim);
+                     end loop;
+
+                     --  default iterator must exist.
+
+                     pragma Assert (False);
+
+                  else              --  not a derived type
+                     return Iter;
+                  end if;
+               end Get_Default_Iterator;
+
+            --  Start of processing for Handle_Of
+
             begin
+               if Is_Class_Wide_Type (Container_Typ) then
+                  Default_Iter :=
+                    Get_Default_Iterator (Etype (Base_Type (Container_Typ)));
+
+               else
+                  Default_Iter := Get_Default_Iterator (Etype (Container));
+               end if;
+
                Cursor := Make_Temporary (Loc, 'C');
 
                --  For an container element iterator, the iterator type
@@ -3320,24 +3395,7 @@ package body Exp_Ch5 is
                Pack := Scope (Root_Type (Etype (Iter_Type)));
 
                --  Rewrite domain of iteration as a call to the default
-               --  iterator for the container type. If the container is
-               --  a derived type and the aspect is inherited, convert
-               --  container to parent type. The Cursor type is also
-               --  inherited from the scope of the parent.
-
-               if Base_Type (Etype (Container)) =
-                  Base_Type (Etype (First_Formal (Default_Iter)))
-               then
-                  Container_Arg := New_Copy_Tree (Container);
-
-               else
-                  Container_Arg :=
-                    Make_Type_Conversion (Loc,
-                      Subtype_Mark =>
-                        New_Occurrence_Of
-                          (Etype (First_Formal (Default_Iter)), Loc),
-                      Expression => New_Copy_Tree (Container));
-               end if;
+               --  iterator for the container type.
 
                Rewrite (Name (I_Spec),
                  Make_Function_Call (Loc,
@@ -3367,9 +3425,9 @@ package body Exp_Ch5 is
                Decl :=
                  Make_Object_Renaming_Declaration (Loc,
                    Defining_Identifier => Id,
-                   Subtype_Mark     =>
+                   Subtype_Mark        =>
                      New_Occurrence_Of (Element_Type, Loc),
-                   Name             =>
+                   Name                =>
                      Make_Indexed_Component (Loc,
                        Prefix      => Relocate_Node (Container_Arg),
                        Expressions =>
@@ -3415,7 +3473,7 @@ package body Exp_Ch5 is
                else
                   Prepend_To (Stats, Decl);
                end if;
-            end;
+            end Handle_Of;
 
          --  X in Iterate (S) : type of iterator is type of explicitly
          --  given Iterate function, and the loop variable is the cursor.

gcc/ada/exp_util.adb

@@ -786,7 +786,7 @@ package body Exp_Util is
          if Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ) then
             Append_To (Actuals, New_Occurrence_Of (Alig_Id, Loc));
 
-         --  For deallocation of class wide types we obtain the value of
+         --  For deallocation of class-wide types we obtain the value of
          --  alignment from the Type Specific Record of the deallocated object.
          --  This is needed because the frontend expansion of class-wide types
          --  into equivalent types confuses the backend.
@@ -5860,7 +5860,7 @@ package body Exp_Util is
 
       Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
 
-      --  A class_wide equivalent type does not require initialization
+      --  A class-wide equivalent type does not require initialization
 
       Set_Suppress_Initialization (Equiv_Type);
 
@@ -6097,7 +6097,7 @@ package body Exp_Util is
    --  2. If Expr is a unconstrained discriminated type expression, creates
    --    Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
 
-   --  3. If Expr is class-wide, creates an implicit class wide subtype
+   --  3. If Expr is class-wide, creates an implicit class-wide subtype
 
    function Make_Subtype_From_Expr
      (E       : Node_Id;
@@ -6186,8 +6186,8 @@ package body Exp_Util is
 
             if Expander_Active and then Tagged_Type_Expansion then
 
-               --  If this is the class_wide type of a completion that is a
-               --  record subtype, set the type of the class_wide type to be
+               --  If this is the class-wide type of a completion that is a
+               --  record subtype, set the type of the class-wide type to be
                --  the full base type, for use in the expanded code for the
                --  equivalent type. Should this be done earlier when the
                --  completion is analyzed ???

gcc/ada/sem_ch13.adb

@@ -1671,7 +1671,9 @@ package body Sem_Ch13 is
                     and then not (Is_Type (E)
                                    and then Is_Tagged_Type (E))
                   then
-                     Error_Msg_N ("indexing applies to a tagged type", N);
+                     Error_Msg_N
+                       ("indexing aspect can only apply to a tagged type",
+                         Aspect);
                      goto Continue;
                   end if;
 
@@ -3471,53 +3473,138 @@ package body Sem_Ch13 is
          --  Check one possible interpretation. Sets Indexing_Found True if an
          --  indexing function is found.
 
+         procedure Illegal_Indexing (Msg : String);
+         --  Diagnose illegal indexing function if not overloaded. In the
+         --  overloaded case indicate that no legal interpretation  exists.
+
          ------------------------
          -- Check_One_Function --
          ------------------------
 
          procedure Check_One_Function (Subp : Entity_Id) is
-            Default_Element : constant Node_Id :=
-                                Find_Value_Of_Aspect
-                                  (Etype (First_Formal (Subp)),
-                                   Aspect_Iterator_Element);
+            Default_Element : Node_Id;
+            Ret_Type        : constant Entity_Id := Etype (Subp);
 
          begin
+            if not Is_Overloadable (Subp) then
+               Illegal_Indexing ("illegal indexing function for type&");
+               return;
+
+            elsif Scope (Subp) /= Current_Scope then
+               Illegal_Indexing
+                 ("indexing function must be declared in scope of type&");
+               return;
+
+            elsif No (First_Formal (Subp)) then
+               Illegal_Indexing
+                 ("Indexing requires a function that applies to type&");
+               return;
+
+            elsif No (Next_Formal (First_Formal (Subp))) then
+               Illegal_Indexing
+                  ("indexing function must have at least two parameters");
+               return;
+
+            elsif Is_Derived_Type (Ent) then
+               if (Attr = Name_Constant_Indexing
+                    and then Present
+                      (Find_Aspect (Etype (Ent), Aspect_Constant_Indexing)))
+
+                 or else (Attr = Name_Variable_Indexing
+                    and then Present
+                      (Find_Aspect (Etype (Ent), Aspect_Variable_Indexing)))
+               then
+                  if Debug_Flag_Dot_XX then
+                     null;
+
+                  else
+                     Illegal_Indexing
+                        ("indexing function already inherited "
+                          & "from parent type");
+                  end if;
+
+                  return;
+               end if;
+            end if;
+
             if not Check_Primitive_Function (Subp)
               and then not Is_Overloaded (Expr)
             then
-               Error_Msg_NE
-                 ("aspect Indexing requires a function that applies to type&",
-                    Subp, Ent);
+               Illegal_Indexing
+                 ("Indexing aspect requires a function that applies to type&");
+               return;
             end if;
 
             --  An indexing function must return either the default element of
             --  the container, or a reference type. For variable indexing it
             --  must be the latter.
 
+            Default_Element :=
+              Find_Value_Of_Aspect
+               (Etype (First_Formal (Subp)), Aspect_Iterator_Element);
+
             if Present (Default_Element) then
                Analyze (Default_Element);
 
                if Is_Entity_Name (Default_Element)
-                 and then Covers (Entity (Default_Element), Etype (Subp))
+                 and then not Covers (Entity (Default_Element), Ret_Type)
+                 and then False
                then
-                  Indexing_Found := True;
+                  Illegal_Indexing
+                    ("wrong return type for indexing function");
                   return;
                end if;
             end if;
 
             --  For variable_indexing the return type must be a reference type
 
-            if Attr = Name_Variable_Indexing
-              and then not Has_Implicit_Dereference (Etype (Subp))
-            then
-               Error_Msg_N
-                 ("function for indexing must return a reference type", Subp);
+            if Attr = Name_Variable_Indexing then
+               if not Has_Implicit_Dereference (Ret_Type) then
+                  Illegal_Indexing
+                     ("variable indexing must return a reference type");
+                  return;
+
+               elsif Is_Access_Constant (Etype (First_Discriminant (Ret_Type)))
+               then
+                  Illegal_Indexing
+                    ("variable indexing must return an access to variable");
+                  return;
+               end if;
 
             else
-               Indexing_Found := True;
+               if  Has_Implicit_Dereference (Ret_Type)
+                 and then not
+                   Is_Access_Constant (Etype (First_Discriminant (Ret_Type)))
+               then
+                  Illegal_Indexing
+                    ("constant indexing must return an access to constant");
+                  return;
+
+               elsif Is_Access_Type (Etype (First_Formal (Subp)))
+                 and then not Is_Access_Constant (Etype (First_Formal (Subp)))
+               then
+                  Illegal_Indexing
+                    ("constant indexing must apply to an access to constant");
+                  return;
+               end if;
             end if;
+
+            --  All checks succeeded.
+
+            Indexing_Found := True;
          end Check_One_Function;
 
+         -----------------------
+         --  Illegal_Indexing --
+         -----------------------
+
+         procedure Illegal_Indexing (Msg : String) is
+         begin
+            if not Is_Overloaded (Expr) then
+               Error_Msg_NE (Msg, N, Ent);
+            end if;
+         end Illegal_Indexing;
+
       --  Start of processing for Check_Indexing_Functions
 
       begin

gcc/ada/sem_ch4.adb

@@ -6959,6 +6959,7 @@ package body Sem_Ch4 is
       Exprs  : List_Id) return Boolean
    is
       Loc       : constant Source_Ptr := Sloc (N);
+      C_Type    : Entity_Id;
       Assoc     : List_Id;
       Disc      : Entity_Id;
       Func      : Entity_Id;
@@ -6966,6 +6967,14 @@ package body Sem_Ch4 is
       Indexing  : Node_Id;
 
    begin
+      C_Type := Etype (Prefix);
+
+      --  If indexing a class-wide container, obtain indexing primitive
+      --  from specific type.
+
+      if Is_Class_Wide_Type (C_Type) then
+         C_Type := Etype (Base_Type (C_Type));
+      end if;
 
       --  Check whether type has a specified indexing aspect
 
@@ -7013,10 +7022,10 @@ package body Sem_Ch4 is
       --  Additional machinery may be needed for types that have several user-
       --  defined Reference operations with different signatures ???
 
-      elsif Is_Derived_Type (Etype (Prefix))
+      elsif Is_Derived_Type (C_Type)
         and then Etype (First_Formal (Entity (Func_Name))) /= Etype (Prefix)
       then
-         Func := Find_Prim_Op (Etype (Prefix), Chars (Func_Name));
+         Func := Find_Prim_Op (C_Type, Chars (Func_Name));
          Func_Name := New_Occurrence_Of (Func, Loc);
       end if;