[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/sem_prag.adb

@@ -24755,7 +24755,7 @@ package body Sem_Prag is
    --  0   indicates that appearance in any argument is not significant
    --  +n  indicates that appearance as argument n is significant, but all
    --      other arguments are not significant
-   --  99  special processing required (e.g. for pragma Check)
+   --  9n  arguments from n on are significant, before n inisignificant
 
    Sig_Flags : constant array (Pragma_Id) of Int :=
      (Pragma_Abort_Defer                    => -1,
@@ -24767,8 +24767,8 @@ package body Sem_Prag is
       Pragma_Ada_12                         => -1,
       Pragma_Ada_2012                       => -1,
       Pragma_All_Calls_Remote               => -1,
-      Pragma_Allow_Integer_Address          =>  0,
-      Pragma_Annotate                       => -1,
+      Pragma_Allow_Integer_Address          => -1,
+      Pragma_Annotate                       => 93,
       Pragma_Assert                         => -1,
       Pragma_Assert_And_Cut                 => -1,
       Pragma_Assertion_Policy               =>  0,
@@ -24776,53 +24776,53 @@ package body Sem_Prag is
       Pragma_Assume_No_Invalid_Values       =>  0,
       Pragma_Async_Readers                  =>  0,
       Pragma_Async_Writers                  =>  0,
-      Pragma_Asynchronous                   => -1,
+      Pragma_Asynchronous                   =>  0,
       Pragma_Atomic                         =>  0,
       Pragma_Atomic_Components              =>  0,
       Pragma_Attach_Handler                 => -1,
-      Pragma_Attribute_Definition           => +3,
-      Pragma_Check                          => 99,
+      Pragma_Attribute_Definition           => 92,
+      Pragma_Check                          => -1,
       Pragma_Check_Float_Overflow           =>  0,
       Pragma_Check_Name                     =>  0,
       Pragma_Check_Policy                   =>  0,
-      Pragma_CIL_Constructor                => -1,
+      Pragma_CIL_Constructor                =>  0,
       Pragma_CPP_Class                      =>  0,
       Pragma_CPP_Constructor                =>  0,
       Pragma_CPP_Virtual                    =>  0,
       Pragma_CPP_Vtable                     =>  0,
       Pragma_CPU                            => -1,
       Pragma_C_Pass_By_Copy                 =>  0,
-      Pragma_Comment                        =>  0,
-      Pragma_Common_Object                  => -1,
+      Pragma_Comment                        => -1,
+      Pragma_Common_Object                  =>  0,
       Pragma_Compile_Time_Error             => -1,
       Pragma_Compile_Time_Warning           => -1,
-      Pragma_Compiler_Unit                  =>  0,
-      Pragma_Compiler_Unit_Warning          =>  0,
+      Pragma_Compiler_Unit                  => -1,
+      Pragma_Compiler_Unit_Warning          => -1,
       Pragma_Complete_Representation        =>  0,
       Pragma_Complex_Representation         =>  0,
-      Pragma_Component_Alignment            => -1,
+      Pragma_Component_Alignment            =>  0,
       Pragma_Contract_Cases                 => -1,
       Pragma_Controlled                     =>  0,
       Pragma_Convention                     =>  0,
       Pragma_Convention_Identifier          =>  0,
       Pragma_Debug                          => -1,
       Pragma_Debug_Policy                   =>  0,
-      Pragma_Detect_Blocking                => -1,
+      Pragma_Detect_Blocking                =>  0,
       Pragma_Default_Initial_Condition      => -1,
       Pragma_Default_Scalar_Storage_Order   =>  0,
-      Pragma_Default_Storage_Pool           => -1,
+      Pragma_Default_Storage_Pool           =>  0,
       Pragma_Depends                        => -1,
-      Pragma_Disable_Atomic_Synchronization => -1,
+      Pragma_Disable_Atomic_Synchronization =>  0,
       Pragma_Discard_Names                  =>  0,
       Pragma_Dispatching_Domain             => -1,
       Pragma_Effective_Reads                =>  0,
       Pragma_Effective_Writes               =>  0,
-      Pragma_Elaborate                      => -1,
-      Pragma_Elaborate_All                  => -1,
-      Pragma_Elaborate_Body                 => -1,
-      Pragma_Elaboration_Checks             => -1,
-      Pragma_Eliminate                      => -1,
-      Pragma_Enable_Atomic_Synchronization  => -1,
+      Pragma_Elaborate                      =>  0,
+      Pragma_Elaborate_All                  =>  0,
+      Pragma_Elaborate_Body                 =>  0,
+      Pragma_Elaboration_Checks             =>  0,
+      Pragma_Eliminate                      =>  0,
+      Pragma_Enable_Atomic_Synchronization  =>  0,
       Pragma_Export                         => -1,
       Pragma_Export_Function                => -1,
       Pragma_Export_Object                  => -1,
@@ -24830,18 +24830,18 @@ package body Sem_Prag is
       Pragma_Export_Value                   => -1,
       Pragma_Export_Valued_Procedure        => -1,
       Pragma_Extend_System                  => -1,
-      Pragma_Extensions_Allowed             => -1,
+      Pragma_Extensions_Allowed             =>  0,
       Pragma_External                       => -1,
-      Pragma_Favor_Top_Level                => -1,
-      Pragma_External_Name_Casing           => -1,
-      Pragma_Fast_Math                      => -1,
+      Pragma_Favor_Top_Level                =>  0,
+      Pragma_External_Name_Casing           =>  0,
+      Pragma_Fast_Math                      =>  0,
       Pragma_Finalize_Storage_Only          =>  0,
       Pragma_Global                         => -1,
       Pragma_Ident                          => -1,
       Pragma_Implementation_Defined         => -1,
       Pragma_Implemented                    => -1,
       Pragma_Implicit_Packing               =>  0,
-      Pragma_Import                         => +2,
+      Pragma_Import                         => 93,
       Pragma_Import_Function                =>  0,
       Pragma_Import_Object                  =>  0,
       Pragma_Import_Procedure               =>  0,
@@ -24849,14 +24849,14 @@ package body Sem_Prag is
       Pragma_Independent                    =>  0,
       Pragma_Independent_Components         =>  0,
       Pragma_Initial_Condition              => -1,
-      Pragma_Initialize_Scalars             => -1,
+      Pragma_Initialize_Scalars             =>  0,
       Pragma_Initializes                    => -1,
       Pragma_Inline                         =>  0,
       Pragma_Inline_Always                  =>  0,
       Pragma_Inline_Generic                 =>  0,
       Pragma_Inspection_Point               => -1,
-      Pragma_Interface                      => +2,
-      Pragma_Interface_Name                 => +2,
+      Pragma_Interface                      => 92,
+      Pragma_Interface_Name                 =>  0,
       Pragma_Interrupt_Handler              => -1,
       Pragma_Interrupt_Priority             => -1,
       Pragma_Interrupt_State                => -1,
@@ -24864,41 +24864,41 @@ package body Sem_Prag is
       Pragma_Java_Constructor               => -1,
       Pragma_Java_Interface                 => -1,
       Pragma_Keep_Names                     =>  0,
-      Pragma_License                        => -1,
+      Pragma_License                        =>  0,
       Pragma_Link_With                      => -1,
       Pragma_Linker_Alias                   => -1,
       Pragma_Linker_Constructor             => -1,
       Pragma_Linker_Destructor              => -1,
       Pragma_Linker_Options                 => -1,
-      Pragma_Linker_Section                 => -1,
-      Pragma_List                           => -1,
-      Pragma_Lock_Free                      => -1,
-      Pragma_Locking_Policy                 => -1,
+      Pragma_Linker_Section                 =>  0,
+      Pragma_List                           =>  0,
+      Pragma_Lock_Free                      =>  0,
+      Pragma_Locking_Policy                 =>  0,
       Pragma_Loop_Invariant                 => -1,
-      Pragma_Loop_Optimize                  => -1,
+      Pragma_Loop_Optimize                  =>  0,
       Pragma_Loop_Variant                   => -1,
       Pragma_Machine_Attribute              => -1,
       Pragma_Main                           => -1,
       Pragma_Main_Storage                   => -1,
-      Pragma_Memory_Size                    => -1,
+      Pragma_Memory_Size                    =>  0,
       Pragma_No_Return                      =>  0,
       Pragma_No_Body                        =>  0,
-      Pragma_No_Elaboration_Code_All        => -1,
+      Pragma_No_Elaboration_Code_All        =>  0,
       Pragma_No_Inline                      =>  0,
       Pragma_No_Run_Time                    => -1,
       Pragma_No_Strict_Aliasing             => -1,
-      Pragma_Normalize_Scalars              => -1,
+      Pragma_Normalize_Scalars              =>  0,
       Pragma_Obsolescent                    =>  0,
-      Pragma_Optimize                       => -1,
-      Pragma_Optimize_Alignment             => -1,
+      Pragma_Optimize                       =>  0,
+      Pragma_Optimize_Alignment             =>  0,
       Pragma_Overflow_Mode                  =>  0,
       Pragma_Overriding_Renamings           =>  0,
-      Pragma_Ordered                        => -1,
+      Pragma_Ordered                        =>  0,
       Pragma_Pack                           =>  0,
-      Pragma_Page                           => -1,
-      Pragma_Part_Of                        => -1,
-      Pragma_Partition_Elaboration_Policy   => -1,
-      Pragma_Passive                        => -1,
+      Pragma_Page                           =>  0,
+      Pragma_Part_Of                        =>  0,
+      Pragma_Partition_Elaboration_Policy   =>  0,
+      Pragma_Passive                        =>  0,
       Pragma_Persistent_BSS                 =>  0,
       Pragma_Polling                        =>  0,
       Pragma_Prefix_Exception_Messages      =>  0,
@@ -24909,81 +24909,81 @@ package body Sem_Prag is
       Pragma_Precondition                   => -1,
       Pragma_Predicate                      => -1,
       Pragma_Preelaborable_Initialization   => -1,
-      Pragma_Preelaborate                   => -1,
+      Pragma_Preelaborate                   =>  0,
       Pragma_Pre_Class                      => -1,
       Pragma_Priority                       => -1,
-      Pragma_Priority_Specific_Dispatching  => -1,
+      Pragma_Priority_Specific_Dispatching  =>  0,
       Pragma_Profile                        =>  0,
       Pragma_Profile_Warnings               =>  0,
-      Pragma_Propagate_Exceptions           => -1,
-      Pragma_Provide_Shift_Operators        => -1,
-      Pragma_Psect_Object                   => -1,
-      Pragma_Pure                           => -1,
-      Pragma_Pure_Function                  => -1,
-      Pragma_Queuing_Policy                 => -1,
-      Pragma_Rational                       => -1,
-      Pragma_Ravenscar                      => -1,
+      Pragma_Propagate_Exceptions           =>  0,
+      Pragma_Provide_Shift_Operators        =>  0,
+      Pragma_Psect_Object                   =>  0,
+      Pragma_Pure                           =>  0,
+      Pragma_Pure_Function                  =>  0,
+      Pragma_Queuing_Policy                 =>  0,
+      Pragma_Rational                       =>  0,
+      Pragma_Ravenscar                      =>  0,
       Pragma_Refined_Depends                => -1,
       Pragma_Refined_Global                 => -1,
       Pragma_Refined_Post                   => -1,
       Pragma_Refined_State                  => -1,
-      Pragma_Relative_Deadline              => -1,
+      Pragma_Relative_Deadline              =>  0,
       Pragma_Remote_Access_Type             => -1,
       Pragma_Remote_Call_Interface          => -1,
       Pragma_Remote_Types                   => -1,
-      Pragma_Restricted_Run_Time            => -1,
-      Pragma_Restriction_Warnings           => -1,
-      Pragma_Restrictions                   => -1,
+      Pragma_Restricted_Run_Time            =>  0,
+      Pragma_Restriction_Warnings           =>  0,
+      Pragma_Restrictions                   =>  0,
       Pragma_Reviewable                     => -1,
-      Pragma_Short_Circuit_And_Or           => -1,
-      Pragma_Share_Generic                  => -1,
-      Pragma_Shared                         => -1,
-      Pragma_Shared_Passive                 => -1,
+      Pragma_Short_Circuit_And_Or           =>  0,
+      Pragma_Share_Generic                  =>  0,
+      Pragma_Shared                         =>  0,
+      Pragma_Shared_Passive                 =>  0,
       Pragma_Short_Descriptors              =>  0,
       Pragma_Simple_Storage_Pool_Type       =>  0,
-      Pragma_Source_File_Name               => -1,
-      Pragma_Source_File_Name_Project       => -1,
-      Pragma_Source_Reference               => -1,
+      Pragma_Source_File_Name               =>  0,
+      Pragma_Source_File_Name_Project       =>  0,
+      Pragma_Source_Reference               =>  0,
       Pragma_SPARK_Mode                     =>  0,
       Pragma_Storage_Size                   => -1,
-      Pragma_Storage_Unit                   => -1,
-      Pragma_Static_Elaboration_Desired     => -1,
-      Pragma_Stream_Convert                 => -1,
-      Pragma_Style_Checks                   => -1,
-      Pragma_Subtitle                       => -1,
+      Pragma_Storage_Unit                   =>  0,
+      Pragma_Static_Elaboration_Desired     =>  0,
+      Pragma_Stream_Convert                 =>  0,
+      Pragma_Style_Checks                   =>  0,
+      Pragma_Subtitle                       =>  0,
       Pragma_Suppress                       =>  0,
       Pragma_Suppress_Exception_Locations   =>  0,
-      Pragma_Suppress_All                   => -1,
+      Pragma_Suppress_All                   =>  0,
       Pragma_Suppress_Debug_Info            =>  0,
       Pragma_Suppress_Initialization        =>  0,
-      Pragma_System_Name                    => -1,
-      Pragma_Task_Dispatching_Policy        => -1,
+      Pragma_System_Name                    =>  0,
+      Pragma_Task_Dispatching_Policy        =>  0,
       Pragma_Task_Info                      => -1,
       Pragma_Task_Name                      => -1,
-      Pragma_Task_Storage                   =>  0,
+      Pragma_Task_Storage                   => -1,
       Pragma_Test_Case                      => -1,
-      Pragma_Thread_Local_Storage           =>  0,
+      Pragma_Thread_Local_Storage           => -1,
       Pragma_Time_Slice                     => -1,
-      Pragma_Title                          => -1,
+      Pragma_Title                          =>  0,
       Pragma_Type_Invariant                 => -1,
       Pragma_Type_Invariant_Class           => -1,
       Pragma_Unchecked_Union                =>  0,
-      Pragma_Unimplemented_Unit             => -1,
-      Pragma_Universal_Aliasing             => -1,
-      Pragma_Universal_Data                 => -1,
-      Pragma_Unmodified                     => -1,
-      Pragma_Unreferenced                   => -1,
-      Pragma_Unreferenced_Objects           => -1,
-      Pragma_Unreserve_All_Interrupts       => -1,
+      Pragma_Unimplemented_Unit             =>  0,
+      Pragma_Universal_Aliasing             =>  0,
+      Pragma_Universal_Data                 =>  0,
+      Pragma_Unmodified                     =>  0,
+      Pragma_Unreferenced                   =>  0,
+      Pragma_Unreferenced_Objects           =>  0,
+      Pragma_Unreserve_All_Interrupts       =>  0,
       Pragma_Unsuppress                     =>  0,
       Pragma_Unevaluated_Use_Of_Old         =>  0,
-      Pragma_Use_VADS_Size                  => -1,
-      Pragma_Validity_Checks                => -1,
+      Pragma_Use_VADS_Size                  =>  0,
+      Pragma_Validity_Checks                =>  0,
       Pragma_Volatile                       =>  0,
       Pragma_Volatile_Components            =>  0,
-      Pragma_Warning_As_Error               => -1,
-      Pragma_Warnings                       => -1,
-      Pragma_Weak_External                  => -1,
+      Pragma_Warning_As_Error               =>  0,
+      Pragma_Warnings                       =>  0,
+      Pragma_Weak_External                  =>  0,
       Pragma_Wide_Character_Encoding        =>  0,
       Unknown_Pragma                        =>  0);
 
@@ -24991,7 +24991,36 @@ package body Sem_Prag is
       Id : Pragma_Id;
       P  : Node_Id;
       C  : Int;
-      A  : Node_Id;
+      AN : Nat;
+
+      function Arg_No return Nat;
+      --  Returns an integer showing what argument we are in. A value of
+      --  zero means we are not in any of the arguments.
+
+      ------------
+      -- Arg_No --
+      ------------
+
+      function Arg_No return Nat is
+         A : Node_Id;
+         N : Nat;
+
+      begin
+         A := First (Pragma_Argument_Associations (Parent (P)));
+         N := 1;
+         loop
+            if No (A) then
+               return 0;
+            elsif A = P then
+               return N;
+            end if;
+
+            Next (A);
+            N := N + 1;
+         end loop;
+      end Arg_No;
+
+   --  Start of processing for Non_Significant_Pragma_Reference
 
    begin
       P := Parent (N);
@@ -25002,6 +25031,11 @@ package body Sem_Prag is
       else
          Id := Get_Pragma_Id (Parent (P));
          C := Sig_Flags (Id);
+         AN := Arg_No;
+
+         if AN = 0 then
+            return False;
+         end if;
 
          case C is
             when -1 =>
@@ -25010,32 +25044,11 @@ package body Sem_Prag is
             when 0 =>
                return True;
 
-            when 99 =>
-               case Id is
-
-                  --  For pragma Check, the first argument is not significant,
-                  --  the second and the third (if present) arguments are
-                  --  significant.
-
-                  when Pragma_Check =>
-                     return
-                       P = First (Pragma_Argument_Associations (Parent (P)));
-
-                  when others =>
-                     raise Program_Error;
-               end case;
+            when 92 .. 99 =>
+               return AN < (C - 90);
 
             when others =>
-               A := First (Pragma_Argument_Associations (Parent (P)));
-               for J in 1 .. C - 1 loop
-                  if No (A) then
-                     return False;
-                  end if;
-
-                  Next (A);
-               end loop;
-
-               return A = P; -- is this wrong way round ???
+               return AN /= C;
          end case;
       end if;
    end Is_Non_Significant_Pragma_Reference;

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 =>