errout.ads: Comment clarification

2007-10-15  Robert Dewar  <dewar@adacore.com>

	* errout.ads: Comment clarification

	* exp_ch4.adb (Expand_N_Allocator): Code cleanup.
	(Expand_N_Op_Eq): Improve handling of array equality with -gnatVa

	* lib.ads: Comment update

	* init.c: Minor reformatting.

	* sem_attr.adb: Minor formatting

	* osint-b.ads: Minor reformatting

	* sem_ch9.adb: Implement -gnatd.I switch

	* g-comlin.adb: (Start): Fix handling of empty command line.

	* gnatcmd.adb (GNATCmd): Do not put the -rules in the -cargs section,
	even when -rules follows the -cargs section.

From-SVN: r129343

9 files changed, 116 insertions, 55 deletions

diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index 704f221..f58181e 100644
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -670,6 +670,8 @@ package Errout is
    --  is posted (with the same effect as Error_Msg_N (Msg, N) if and only
    --  if Eflag is True and if the node N is within the main extended source
    --  unit and comes from source. Typically this is a warning mode flag.
+   --  This routine can only be called during semantic analysis. It may not
+   --  be called during parsing.
 
    procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String);
    --  The error message text of the message identified by Id is replaced by
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index bd5ddfb..c1b88be 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -3189,26 +3189,20 @@ package body Exp_Ch4 is
             Nod  := N;
             Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
 
-            --  Construct argument list for the initialization routine call.
-            --  The CPP constructor needs the address directly
+            --  Construct argument list for the initialization routine call
 
-            if Is_CPP_Class (T) then
-               Arg1 := New_Reference_To (Temp, Loc);
-               Temp_Type := T;
+            Arg1 :=
+              Make_Explicit_Dereference (Loc,
+                Prefix => New_Reference_To (Temp, Loc));
+            Set_Assignment_OK (Arg1);
+            Temp_Type := PtrT;
 
-            else
-               Arg1 := Make_Explicit_Dereference (Loc,
-                         Prefix => New_Reference_To (Temp, Loc));
-               Set_Assignment_OK (Arg1);
-               Temp_Type := PtrT;
-
-               --  The initialization procedure expects a specific type. if
-               --  the context is access to class wide, indicate that the
-               --  object being allocated has the right specific type.
+            --  The initialization procedure expects a specific type. if the
+            --  context is access to class wide, indicate that the object being
+            --  allocated has the right specific type.
 
-               if Is_Class_Wide_Type (Dtyp) then
-                  Arg1 := Unchecked_Convert_To (T, Arg1);
-               end if;
+            if Is_Class_Wide_Type (Dtyp) then
+               Arg1 := Unchecked_Convert_To (T, Arg1);
             end if;
 
             --  If designated type is a concurrent type or if it is private
@@ -3405,11 +3399,6 @@ package body Exp_Ch4 is
                 Expression          => Nod);
 
             Set_Assignment_OK (Temp_Decl);
-
-            if Is_CPP_Class (T) then
-               Set_Aliased_Present (Temp_Decl);
-            end if;
-
             Insert_Action (N, Temp_Decl, Suppress => All_Checks);
 
             --  If the designated type is a task type or contains tasks,
@@ -3480,15 +3469,7 @@ package body Exp_Ch4 is
                end if;
             end if;
 
-            if Is_CPP_Class (T) then
-               Rewrite (N,
-                 Make_Attribute_Reference (Loc,
-                   Prefix => New_Reference_To (Temp, Loc),
-                   Attribute_Name => Name_Unchecked_Access));
-            else
-               Rewrite (N, New_Reference_To (Temp, Loc));
-            end if;
-
+            Rewrite (N, New_Reference_To (Temp, Loc));
             Analyze_And_Resolve (N, PtrT);
          end if;
       end;
@@ -5125,10 +5106,13 @@ package body Exp_Ch4 is
 
       elsif Is_Array_Type (Typl) then
 
-         --  If we are doing full validity checking, then expand out array
-         --  comparisons to make sure that we check the array elements.
+         --  If we are doing full validity checking, and it is possible for the
+         --  array elements to be invalid then expand out array comparisons to
+         --  make sure that we check the array elements.
 
-         if Validity_Check_Operands then
+         if Validity_Check_Operands
+           and then not Is_Known_Valid (Component_Type (Typl))
+         then
             declare
                Save_Force_Validity_Checks : constant Boolean :=
                                               Force_Validity_Checks;
@@ -5828,6 +5812,8 @@ package body Exp_Ch4 is
       Rhi : Uint;
       ROK : Boolean;
 
+      pragma Warnings (Off, Lhi);
+
    begin
       Binary_Op_Validity_Checks (N);
 
@@ -6416,6 +6402,8 @@ package body Exp_Ch4 is
       Rhi : Uint;
       ROK : Boolean;
 
+      pragma Warnings (Off, Lhi);
+
    begin
       Binary_Op_Validity_Checks (N);
 
diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb
index 61a0d87d..95b1fbe 100644
--- a/gcc/ada/g-comlin.adb
+++ b/gcc/ada/g-comlin.adb
@@ -1606,6 +1606,11 @@ package body GNAT.Command_Line is
       Expanded : Boolean)
    is
    begin
+      if Cmd.Expanded = null then
+         Iter.List := null;
+         return;
+      end if;
+
       --  Coalesce the switches as much as possible
 
       if not Expanded
diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb
index 7ffc558..debf0c3 100644
--- a/gcc/ada/gnatcmd.adb
+++ b/gcc/ada/gnatcmd.adb
@@ -711,6 +711,7 @@ procedure GNATCmd is
 
    procedure Delete_Temp_Config_Files is
       Success : Boolean;
+      pragma Warnings (Off, Success);
 
    begin
       if not Keep_Temporary_Files then
@@ -2017,20 +2018,81 @@ begin
 
             for J in 1 .. First_Switches.Last loop
                if First_Switches.Table (J).all = "-cargs" then
-                  for K in J + 1 .. First_Switches.Last loop
-                     Add_To_Carg_Switches (First_Switches.Table (K));
-                  end loop;
-                  First_Switches.Set_Last (J - 1);
+                  declare
+                     K    : Positive;
+                     Last : Natural;
+
+                  begin
+                     --  Move the switches that are before -rules when the
+                     --  command is CHECK.
+
+                     K := J + 1;
+                     while K <= First_Switches.Last
+                       and then
+                        (The_Command /= Check
+                           or else First_Switches.Table (K).all /= "-rules")
+                     loop
+                        Add_To_Carg_Switches (First_Switches.Table (K));
+                        K := K + 1;
+                     end loop;
+
+                     if K > First_Switches.Last then
+                        First_Switches.Set_Last (J - 1);
+
+                     else
+                        Last := J - 1;
+                        while K <= First_Switches.Last loop
+                           Last := Last + 1;
+                           First_Switches.Table (Last) :=
+                             First_Switches.Table (K);
+                           K := K + 1;
+                        end loop;
+
+                        First_Switches.Set_Last (Last);
+                     end if;
+                  end;
+
                   exit;
                end if;
             end loop;
 
             for J in 1 .. Last_Switches.Last loop
                if Last_Switches.Table (J).all = "-cargs" then
-                  for K in J + 1 .. Last_Switches.Last loop
-                     Add_To_Carg_Switches (Last_Switches.Table (K));
-                  end loop;
-                  Last_Switches.Set_Last (J - 1);
+                  declare
+                     K    : Positive;
+                     Last : Natural;
+
+                  begin
+                     --  Move the switches that are before -rules when the
+                     --  command is CHECK.
+
+                     K := J + 1;
+                     while K <= Last_Switches.Last
+                       and then
+                        (The_Command /= Check
+                         or else
+                         Last_Switches.Table (K).all /= "-rules")
+                     loop
+                        Add_To_Carg_Switches (Last_Switches.Table (K));
+                        K := K + 1;
+                     end loop;
+
+                     if K > Last_Switches.Last then
+                        Last_Switches.Set_Last (J - 1);
+
+                     else
+                        Last := J - 1;
+                        while K <= Last_Switches.Last loop
+                           Last := Last + 1;
+                           Last_Switches.Table (Last) :=
+                             Last_Switches.Table (K);
+                           K := K + 1;
+                        end loop;
+
+                        Last_Switches.Set_Last (Last);
+                     end if;
+                  end;
+
                   exit;
                end if;
             end loop;
@@ -2085,8 +2147,8 @@ begin
 
          elsif The_Command = Stub then
             declare
-               Data : constant Prj.Project_Data :=
-                        Project_Tree.Projects.Table (Project);
+               Data       : constant Prj.Project_Data :=
+                              Project_Tree.Projects.Table (Project);
                File_Index : Integer := 0;
                Dir_Index  : Integer := 0;
                Last       : constant Integer := Last_Switches.Last;
@@ -2122,7 +2184,7 @@ begin
 
                         if Spec'Length > Name_Len
                           and then Spec (Last - Name_Len + 1 .. Last) =
-                          Name_Buffer (1 .. Name_Len)
+                                                  Name_Buffer (1 .. Name_Len)
                         then
                            Last := Last - Name_Len;
                            Get_Name_String
@@ -2147,7 +2209,7 @@ begin
                if File_Index /= 0 then
                   for Index in File_Index + 1 .. Last loop
                      if Last_Switches.Table (Index)
-                       (Last_Switches.Table (Index)'First) /= '-'
+                         (Last_Switches.Table (Index)'First) /= '-'
                      then
                         Dir_Index := Index;
                         exit;
@@ -2186,7 +2248,7 @@ begin
 
          if The_Command = Check then
             declare
-               New_Last          : Natural;
+               New_Last : Natural;
                --  Set to rank of options preceding "-rules"
 
                In_Rules_Switches : Boolean;
diff --git a/gcc/ada/init.c b/gcc/ada/init.c
index ba36d38..3fa5977 100644
--- a/gcc/ada/init.c
+++ b/gcc/ada/init.c
@@ -1510,7 +1510,7 @@ __gnat_handle_vms_condition (int *sigargs, void *mechargs)
 	break;
       }
 
- Raise_From_Signal_Handler (exception, msg);
+  Raise_From_Signal_Handler (exception, msg);
 }
 
 long
diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads
index 19cfa18..bff54f0 100644
--- a/gcc/ada/lib.ads
+++ b/gcc/ada/lib.ads
@@ -509,10 +509,11 @@ package Lib is
    --  Same function as above but argument is a source pointer
 
    function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean;
-   --  Given two Sloc values  for which In_Same_Extended_Unit is true,
-   --  determine if S1 appears before S2. Returns True if S1 appears before
-   --  S2, and False otherwise. The result is undefined if S1 and S2 are
-   --  not in the same extended unit.
+   --  Given two Sloc values for which In_Same_Extended_Unit is true, determine
+   --  if S1 appears before S2. Returns True if S1 appears before S2, and False
+   --  otherwise. The result is undefined if S1 and S2 are not in the same
+   --  extended unit. Note: this routine will not give reliable results if
+   --  called after Sprint has been called with -gnatD set.
 
    function Compilation_Switches_Last return Nat;
    --  Return the count of stored compilation switches
diff --git a/gcc/ada/osint-b.ads b/gcc/ada/osint-b.ads
index a0fa2bb..2f9460c 100644
--- a/gcc/ada/osint-b.ads
+++ b/gcc/ada/osint-b.ads
@@ -79,7 +79,6 @@ package Osint.B is
    --  buffers etc from writes by Write_Binder_Info.
 
    procedure Set_Current_File_Name_Index (To : Int);
-   --  Set the value of Current_File_Name_Index (in the private part of Osint)
-   --  to To.
+   --  Set value of Current_File_Name_Index (in private part of Osint) to To
 
 end Osint.B;
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 903aad0..6c3e3dc 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -7905,6 +7905,10 @@ package body Sem_Attr is
             Process_Partition_Id (N);
             return;
 
+         ------------------
+         -- Pool_Address --
+         ------------------
+
          when Attribute_Pool_Address =>
             Resolve (P);
 
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index 5483e9a..b61e58a 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -1399,7 +1399,7 @@ package body Sem_Ch9 is
          Generate_Reference (Entry_Id, Entry_Name);
 
          if Present (First_Formal (Entry_Id)) then
-            if VM_Target = JVM_Target then
+            if VM_Target = JVM_Target and then not Inspector_Mode then
                Error_Msg_N
                  ("arguments unsupported in requeue statement",
                   First_Formal (Entry_Id));