[multiple changes]

2014-10-10  Robert Dewar  <dewar@adacore.com>

	* errout.adb (Adjust_Name_Case): New procedure.
	(Set_Msg_Node): Use Adjust_Name_Case.
	* errout.ads (Adjust_Name_Case): New procedure.
	* exp_intr.adb (Add_Source_Info): Minor code reorganization
	(use Ekind_In).
	(Write_Entity_Name): Use Errout.Adjust_Name_Case.
	* sem_prag.adb (Is_Non_Significant_Pragma_Reference): Review
	and fix up entries in Sig_Flags, and correct logical errors in
	function itself.
	* sprint.adb (Sprint_Node_Actual): Properly print string for
	raise statement.

2014-10-10  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Analyze_Object_Declaration): For an object of an
	anonymous array type with delayed aspects, defer freezing of
	type until object itself is frozen.
	* freeze.adb (Freeze_Entity): When freezing an object of an
	anonymous array type with delayed aspects, remove freeze node of
	object after freezing type, to prevent out-of-order elaboration
	in the back-end. The initialization call for the object has
	already been constructed when expanding the object declaration.

From-SVN: r216089

gcc/ada/ChangeLog

 2014-10-10  Robert Dewar  <dewar@adacore.com>
 
+	* errout.adb (Adjust_Name_Case): New procedure.
+	(Set_Msg_Node): Use Adjust_Name_Case.
+	* errout.ads (Adjust_Name_Case): New procedure.
+	* exp_intr.adb (Add_Source_Info): Minor code reorganization
+	(use Ekind_In).
+	(Write_Entity_Name): Use Errout.Adjust_Name_Case.
+	* sem_prag.adb (Is_Non_Significant_Pragma_Reference): Review
+	and fix up entries in Sig_Flags, and correct logical errors in
+	function itself.
+	* sprint.adb (Sprint_Node_Actual): Properly print string for
+	raise statement.
+
+2014-10-10  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch3.adb (Analyze_Object_Declaration): For an object of an
+	anonymous array type with delayed aspects, defer freezing of
+	type until object itself is frozen.
+	* freeze.adb (Freeze_Entity): When freezing an object of an
+	anonymous array type with delayed aspects, remove freeze node of
+	object after freezing type, to prevent out-of-order elaboration
+	in the back-end. The initialization call for the object has
+	already been constructed when expanding the object declaration.
+
+2014-10-10  Robert Dewar  <dewar@adacore.com>
+
 	* exp_intr.adb (Write_Entity_Name): Moved to outer level
 	(Write_Entity_Name): Properly handle operator names
 	(Expand_Source_Info): New procedure.

gcc/ada/errout.adb

@@ -2318,6 +2318,67 @@ package body Errout is
       end if;
    end Remove_Warning_Messages;
 
+   ----------------------
+   -- Adjust_Name_Case --
+   ----------------------
+
+   procedure Adjust_Name_Case (Loc : Source_Ptr) is
+   begin
+      --  We have an all lower case name from Namet, and now we want to set
+      --  the appropriate case. If possible we copy the actual casing from
+      --  the source. If not we use standard identifier casing.
+
+      declare
+         Src_Ind : constant Source_File_Index := Get_Source_File_Index (Loc);
+         Sbuffer : Source_Buffer_Ptr;
+         Ref_Ptr : Integer;
+         Src_Ptr : Source_Ptr;
+
+      begin
+         Ref_Ptr := 1;
+         Src_Ptr := Loc;
+
+         --  For standard locations, always use mixed case
+
+         if Loc <= No_Location then
+            Set_Casing (Mixed_Case);
+
+         else
+            --  Determine if the reference we are dealing with corresponds to
+            --  text at the point of the error reference. This will often be
+            --  the case for simple identifier references, and is the case
+            --  where we can copy the casing from the source.
+
+            Sbuffer := Source_Text (Src_Ind);
+
+            while Ref_Ptr <= Name_Len loop
+               exit when
+                 Fold_Lower (Sbuffer (Src_Ptr)) /=
+                   Fold_Lower (Name_Buffer (Ref_Ptr));
+               Ref_Ptr := Ref_Ptr + 1;
+               Src_Ptr := Src_Ptr + 1;
+            end loop;
+
+            --  If we get through the loop without a mismatch, then output the
+            --  name the way it is cased in the source program
+
+            if Ref_Ptr > Name_Len then
+               Src_Ptr := Loc;
+
+               for J in 1 .. Name_Len loop
+                  Name_Buffer (J) := Sbuffer (Src_Ptr);
+                  Src_Ptr := Src_Ptr + 1;
+               end loop;
+
+            --  Otherwise set the casing using the default identifier casing
+
+            else
+               Set_Casing (Identifier_Casing (Src_Ind), Mixed_Case);
+            end if;
+         end if;
+      end;
+   end Adjust_Name_Case;
+
    ---------------------------
    -- Set_Identifier_Casing --
    ---------------------------
@@ -2660,6 +2721,7 @@ package body Errout is
    ------------------
 
    procedure Set_Msg_Node (Node : Node_Id) is
+      Loc : Source_Ptr;
       Ent : Entity_Id;
       Nam : Name_Id;
 
@@ -2692,6 +2754,7 @@ package body Errout is
 
       if Nkind (Node) = N_Pragma then
          Nam := Pragma_Name (Node);
+         Loc := Sloc (Node);
 
       --  The other cases have Chars fields, and we want to test for possible
       --  internal names, which generally represent something gone wrong. An
@@ -2712,6 +2775,8 @@ package body Errout is
             Ent := Node;
          end if;
 
+         Loc := Sloc (Ent);
+
          --  If the type is the designated type of an access_to_subprogram,
          --  then there is no name to provide in the call.
 
@@ -2729,6 +2794,7 @@ package body Errout is
 
       else
          Nam := Chars (Node);
+         Loc := Sloc (Node);
       end if;
 
       --  At this stage, the name to output is in Nam
@@ -2736,7 +2802,7 @@ package body Errout is
       Get_Unqualified_Decoded_Name_String (Nam);
 
       --  Remove trailing upper case letters from the name (useful for
-      --  dealing with some cases of internal names.
+      --  dealing with some cases of internal names).
 
       while Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' loop
          Name_Len := Name_Len  - 1;
@@ -2752,63 +2818,9 @@ package body Errout is
          Kill_Message := True;
       end if;
 
-      --  Now we have to set the proper case. If we have a source location
-      --  then do a check to see if the name in the source is the same name
-      --  as the name in the Names table, except for possible differences
-      --  in case, which is the case when we can copy from the source.
-
-      declare
-         Src_Loc : constant Source_Ptr := Sloc (Node);
-         Sbuffer : Source_Buffer_Ptr;
-         Ref_Ptr : Integer;
-         Src_Ptr : Source_Ptr;
-
-      begin
-         Ref_Ptr := 1;
-         Src_Ptr := Src_Loc;
-
-         --  For standard locations, always use mixed case
-
-         if Src_Loc <= No_Location
-           or else Sloc (Node) <= No_Location
-         then
-            Set_Casing (Mixed_Case);
-
-         else
-            --  Determine if the reference we are dealing with corresponds to
-            --  text at the point of the error reference. This will often be
-            --  the case for simple identifier references, and is the case
-            --  where we can copy the spelling from the source.
-
-            Sbuffer := Source_Text (Get_Source_File_Index (Src_Loc));
-
-            while Ref_Ptr <= Name_Len loop
-               exit when
-                 Fold_Lower (Sbuffer (Src_Ptr)) /=
-                 Fold_Lower (Name_Buffer (Ref_Ptr));
-               Ref_Ptr := Ref_Ptr + 1;
-               Src_Ptr := Src_Ptr + 1;
-            end loop;
-
-            --  If we get through the loop without a mismatch, then output the
-            --  name the way it is spelled in the source program
-
-            if Ref_Ptr > Name_Len then
-               Src_Ptr := Src_Loc;
-
-               for J in 1 .. Name_Len loop
-                  Name_Buffer (J) := Sbuffer (Src_Ptr);
-                  Src_Ptr := Src_Ptr + 1;
-               end loop;
-
-            --  Otherwise set the casing using the default identifier casing
-
-            else
-               Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
-            end if;
-         end if;
-      end;
+      --  Remaining step is to adjust casing and possibly add 'Class
 
+      Adjust_Name_Case (Loc);
       Set_Msg_Name_Buffer;
       Add_Class;
    end Set_Msg_Node;

gcc/ada/errout.ads

@@ -879,17 +879,23 @@ package Errout is
    --  Same as Error_Msg_NE, but the error is suppressed if SPARK_Mode is Off.
    --  The routine is inlined because it acts as a simple wrapper.
 
-   ------------------------------------
-   -- Utility Interface for Back End --
-   ------------------------------------
+   ------------------------------------------
+   -- Utility Interface for Casing Control --
+   ------------------------------------------
 
-   --  The following subprograms can be used by the back end for the purposes
-   --  of concocting error messages that are not output via Errout, e.g. the
-   --  messages generated by the gcc back end.
+   procedure Adjust_Name_Case (Loc : Source_Ptr);
+   --  Given a name stored in Name_Buffer (1 .. Name_Len), set proper casing.
+   --  Loc is an associated source position, if we can find a match between
+   --  the name in Name_Buffer and the name at that source location, we copy
+   --  the casing from the source, otherwise we set appropriate default casing.
 
    procedure Set_Identifier_Casing
      (Identifier_Name : System.Address;
       File_Name       : System.Address);
+   --  This subprogram can be used by the back end for the purposes of
+   --  concocting error messages that are not output via Errout, e.g.
+   --  the messages generated by the gcc back end.
+   --
    --  The identifier is a null terminated string that represents the name of
    --  an identifier appearing in the source program. File_Name is a null
    --  terminated string giving the corresponding file name for the identifier

gcc/ada/exp_intr.adb

@@ -27,6 +27,7 @@ with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
+with Errout;   use Errout;
 with Expander; use Expander;
 with Exp_Atag; use Exp_Atag;
 with Exp_Ch4;  use Exp_Ch4;
@@ -156,8 +157,7 @@ package body Exp_Intr is
 
             Ent := Current_Scope;
             while Present (Ent) loop
-               exit when Ekind (Ent) /= E_Block
-                 and then Ekind (Ent) /= E_Loop;
+               exit when not Ekind_In (Ent, E_Block, E_Loop);
                Ent := Scope (Ent);
             end loop;
 
@@ -203,6 +203,7 @@ package body Exp_Intr is
       Name_Buffer (Save_NL + 1 .. Save_NL + Name_Len) :=
         Name_Buffer (1 .. Name_Len);
       Name_Buffer (1 .. Save_NL) := Save_NB;
+      Name_Len := Name_Len + Save_NL;
    end Add_Source_Info;
 
    ---------------------------------
@@ -1401,65 +1402,104 @@ package body Exp_Intr is
    -----------------------
 
    procedure Write_Entity_Name (E : Entity_Id) is
-      SDef : Source_Ptr;
-      TDef : constant Source_Buffer_Ptr :=
-               Source_Text (Get_Source_File_Index (Sloc (E)));
 
-   begin
-      --  Nothing to do if at outer level
+      procedure Write_Entity_Name_Inner (E : Entity_Id);
+      --  Inner recursive routine, keep outer routine non-recursive to ease
+      --  debugging when we get strange results from this routine.
 
-      if Scope (E) = Standard_Standard then
-         null;
+      -----------------------------
+      -- Write_Entity_Name_Inner --
+      -----------------------------
+
+      procedure Write_Entity_Name_Inner (E : Entity_Id) is
+      begin
+         --  If entity has an internal name, skip by it, and print its scope.
+         --  Note that Is_Internal_Name destroys Name_Buffer, hence the save
+         --  and restore since we depend on its current contents. Note that
+         --  we strip a final R from the name before the test, this is needed
+         --  for some cases of instantiations.
+
+         declare
+            Save_NB : constant String  := Name_Buffer (1 .. Name_Len);
+            Save_NL : constant Natural := Name_Len;
+            Iname   : Boolean;
+
+         begin
+            Get_Name_String (Chars (E));
+
+            if Name_Buffer (Name_Len) = 'R' then
+               Name_Len := Name_Len - 1;
+            end if;
+
+            Iname := Is_Internal_Name;
+
+            Name_Buffer (1 .. Save_NL) := Save_NB;
+            Name_Len := Save_NL;
+
+            if Iname then
+               Write_Entity_Name_Inner (Scope (E));
+               return;
+            end if;
+         end;
 
-         --  If scope comes from source, write its name
+         --  Just print entity name if its scope is at the outer level
+
+         if Scope (E) = Standard_Standard then
+            null;
 
-      elsif Comes_From_Source (Scope (E)) then
-         Write_Entity_Name (Scope (E));
-         Add_Char_To_Name_Buffer ('.');
+         --  If scope comes from source, write scope and entity
+
+         elsif Comes_From_Source (Scope (E)) then
+            Write_Entity_Name (Scope (E));
+            Add_Char_To_Name_Buffer ('.');
 
          --  If in wrapper package skip past it
 
-      elsif Is_Wrapper_Package (Scope (E)) then
-         Write_Entity_Name (Scope (Scope (E)));
-         Add_Char_To_Name_Buffer ('.');
+         elsif Is_Wrapper_Package (Scope (E)) then
+            Write_Entity_Name (Scope (Scope (E)));
+            Add_Char_To_Name_Buffer ('.');
 
          --  Otherwise nothing to output (happens in unnamed block statements)
 
-      else
-         null;
-      end if;
+         else
+            null;
+         end if;
 
-      --  Output the name
+         --  Output the name
 
-      SDef := Sloc (E);
+         declare
+            Save_NB : constant String  := Name_Buffer (1 .. Name_Len);
+            Save_NL : constant Natural := Name_Len;
 
-      --  Check for operator name in quotes
+         begin
+            Get_Unqualified_Decoded_Name_String (Chars (E));
 
-      if TDef (SDef) = '"' then
-         Add_Char_To_Name_Buffer ('"');
+            --  Remove trailing upper case letters from the name (useful for
+            --  dealing with some cases of internal names generated in the case
+            --  of references from within a generic.
 
-         --  Loop to output characters of operator name and terminating quote
+            while Name_Len > 1
+              and then Name_Buffer (Name_Len) in 'A' .. 'Z'
+            loop
+               Name_Len := Name_Len  - 1;
+            end loop;
 
-         loop
-            SDef := SDef + 1;
-            Add_Char_To_Name_Buffer (TDef (SDef));
-            exit when TDef (SDef) = '"';
-         end loop;
+            --  Adjust casing appropriately (gets name from source if possible)
 
-      --  Normal case of identifier
+            Adjust_Name_Case (Sloc (E));
 
-      else
-         --  Loop to output the name
+            --  Append to original entry value of Name_Buffer
 
-         --  This is not right wrt wide char encodings ??? ()
+            Name_Buffer (Save_NL + 1 ..  Save_NL + Name_Len) :=
+              Name_Buffer (1 .. Name_Len);
+            Name_Buffer (1 .. Save_NL) := Save_NB;
+            Name_Len := Save_NL + Name_Len;
+         end;
+      end Write_Entity_Name_Inner;
 
-         while TDef (SDef) in '0' .. '9'
-           or else TDef (SDef) >= 'A'
-           or else TDef (SDef) = ASCII.ESC
-         loop
-            Add_Char_To_Name_Buffer (TDef (SDef));
-            SDef := SDef + 1;
-         end loop;
-      end if;
+   --  Start of processing for Write_Entity_Name
+
+   begin
+      Write_Entity_Name_Inner (E);
    end Write_Entity_Name;
 end Exp_Intr;

gcc/ada/freeze.adb

@@ -4415,6 +4415,23 @@ package body Freeze is
               and then Ekind (E) /= E_Generic_Function
             then
                Freeze_And_Append (Etype (E), N, Result);
+
+               --  For an object of an anonymous array type, aspects on the
+               --  object declaration apply to the type itself. This is the
+               --  case for Atomic_Components, Volatile_Components, and
+               --  Independent_Components. In these cases analysis of the
+               --  generated pragma will mark the anonymous types accordingly,
+               --  and the object itself does not require a freeze node.
+
+               if Ekind (E) = E_Variable
+                 and then Is_Itype (Etype (E))
+                 and then Is_Array_Type (Etype (E))
+                 and then Has_Delayed_Aspects (E)
+               then
+                  Set_Has_Delayed_Aspects (E, False);
+                  Set_Has_Delayed_Freeze (E, False);
+                  Set_Freeze_Node (E, Empty);
+               end if;
             end if;
 
             --  Special processing for objects created by object declaration

gcc/ada/sem_ch3.adb

@@ -3407,11 +3407,21 @@ package body Sem_Ch3 is
             end if;
          end if;
 
-      --  If not a deferred constant, then object declaration freezes its type
+      --  If not a deferred constant, then the object declaration freezes
+      --  its type, unless the object is of an anonymous type and has delayed
+      --  aspects. In that case the type is frozen when the object itself is.
 
       else
          Check_Fully_Declared (T, N);
-         Freeze_Before (N, T);
+
+         if Has_Delayed_Aspects (Id)
+           and then Is_Array_Type (T)
+           and then Is_Itype (T)
+         then
+            Set_Has_Delayed_Freeze (T);
+         else
+            Freeze_Before (N, T);
+         end if;
       end if;
 
       --  If the object was created by a constrained array definition, then

gcc/ada/sprint.adb

@@ -3000,6 +3000,12 @@ package body Sprint is
          when N_Raise_Statement =>
             Write_Indent_Str_Sloc ("raise ");
             Sprint_Node (Name (Node));
+
+            if Present (Expression (Node)) then
+               Write_Str_With_Col_Check_Sloc (" with ");
+               Sprint_Node (Expression (Node));
+            end if;
+
             Write_Char (';');
 
          when N_Range =>