2009-06-21 Ed Falis <falis@adacore.com>

	* env.c (__gnat_environ): return NULL for vThreads - unimplemented

2009-06-21  Eric Botcazou  <ebotcazou@adacore.com>

	* einfo.ads: Update comments.

2009-06-21  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_disp.adb (Check_Direct_Call): New routine. Dispatching calls
	where the controlling formal is of private class-wide type whose
	completion is a synchronized type can be converted into direct calls.

2009-06-21  Vincent Celier  <celier@adacore.com>

	* gnatcmd.adb (Check_Files): When all sources of the project are to be
	indicated to gnatcheck, gnatpp or gnatmetric, always specify the list
	of sources using -files=, so that the distinction can be made by the
	tool of a call with no source (to display the usage) from a call with
	a project file that contains no source.

2009-06-21  Jerome Lambourg  <lambourg@adacore.com>

	* exp_ch3.adb (Build_Array_Init_Proc): Do not build the init proc in
	case of VM convention arrays.



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

6 files changed, 154 insertions, 69 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 9f75f4e52da..46a610ac01c 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,30 @@
+2009-06-21  Ed Falis  <falis@adacore.com>
+
+	* env.c (__gnat_environ): return NULL for vThreads - unimplemented
+
+2009-06-21  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* einfo.ads: Update comments.
+
+2009-06-21  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* sem_disp.adb (Check_Direct_Call): New routine. Dispatching calls
+	where the controlling formal is of private class-wide type whose
+	completion is a synchronized type can be converted into direct calls.
+
+2009-06-21  Vincent Celier  <celier@adacore.com>
+
+	* gnatcmd.adb (Check_Files): When all sources of the project are to be
+	indicated to gnatcheck, gnatpp or gnatmetric, always specify the list
+	of sources using -files=, so that the distinction can be made by the
+	tool of a call with no source (to display the usage) from a call with
+	a project file that contains no source.
+
+2009-06-21  Jerome Lambourg  <lambourg@adacore.com>
+
+	* exp_ch3.adb (Build_Array_Init_Proc): Do not build the init proc in
+	case of VM convention arrays.
+
 2009-06-20  Robert Dewar  <dewar@adacore.com>
 
 	* a-nudira.adb: Minor reformatting
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 049faab5a2b..29eea5ecce5 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -239,9 +239,12 @@ package Einfo is
 --  The RM_Size field keeps track of the RM Size as needed in these
 --  three situations.
 
---  For types other than discrete and fixed-point types, the Object_Size
---  and Value_Size are the same (and equivalent to the RM attribute Size).
---  Only Size may be specified for such types.
+--  For elementary types other than discrete and fixed-point types, the
+--  Object_Size and Value_Size are the same (and equivalent to the RM
+--  attribute Size).  Only Size may be specified for such types.
+
+--  For composite types, Object_Size and Value_Size are computed from their
+--  respective value for the type of each element as well as the layout.
 
 --  All size attributes are stored as Uint values. Negative values are used to
 --  reference GCC expressions for the case of non-static sizes, as explained
diff --git a/gcc/ada/env.c b/gcc/ada/env.c
index e6720e3064b..bcb8bdb9a80 100644
--- a/gcc/ada/env.c
+++ b/gcc/ada/env.c
@@ -190,7 +190,7 @@ __gnat_setenv (char *name, char *value)
 char **
 __gnat_environ (void)
 {
-#if defined (VMS) || defined (RTX)
+#if defined (VMS) || defined (RTX) || defined (VTHREADS)
   /* Not implemented */
   return NULL;
 #elif defined (__APPLE__)
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 87beb499f37..c0cf131c565 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -641,10 +641,13 @@ package body Exp_Ch3 is
 
       --    1. Initialization is suppressed for the type
       --    2. The type is a value type, in the CIL sense.
-      --    3. An initialization already exists for the base type
+      --    3. The type has CIL/JVM convention.
+      --    4. An initialization already exists for the base type
 
       if Suppress_Init_Proc (A_Type)
         or else Is_Value_Type (Comp_Type)
+        or else Convention (A_Type) = Convention_CIL
+        or else Convention (A_Type) = Convention_Java
         or else Present (Base_Init_Proc (A_Type))
       then
          return;
diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb
index 8194a42ed8d..9e335d1b5df 100644
--- a/gcc/ada/gnatcmd.adb
+++ b/gcc/ada/gnatcmd.adb
@@ -71,12 +71,9 @@ procedure GNATCmd is
    --  an old fashioned project file. -p cannot be used in conjunction
    --  with -P.
 
-   Max_Files_On_The_Command_Line : constant := 30; --  Arbitrary
-
-   Temp_File_Name : String_Access := null;
+   Temp_File_Name : Path_Name_Type := No_Path;
    --  The name of the temporary text file to put a list of source/object
-   --  files to pass to a tool, when there are more than
-   --  Max_Files_On_The_Command_Line files.
+   --  files to pass to a tool.
 
    ASIS_Main : String_Access := null;
    --  Main for commands Check, Metric and Pretty, when -U is used
@@ -311,6 +308,9 @@ procedure GNATCmd is
       Add_Sources : Boolean := True;
       Unit_Data   : Prj.Unit_Data;
       Subunit     : Boolean := False;
+      FD          : File_Descriptor := Invalid_FD;
+      Status      : Integer;
+      Success     : Boolean;
 
    begin
       --  Check if there is at least one argument that is not a switch
@@ -326,8 +326,22 @@ procedure GNATCmd is
       --  of the main project.
 
       if Add_Sources then
+
+         --  For gnatcheck, gnatpp and gnatmetric , create a temporary file and
+         --  put the list of sources in it.
+
+         if The_Command = Check
+            or else The_Command = Pretty
+            or else The_Command = Metric
+         then
+            Tempdir.Create_Temp_File (FD, Temp_File_Name);
+            Last_Switches.Increment_Last;
+            Last_Switches.Table (Last_Switches.Last) :=
+              new String'("-files=" & Get_Name_String (Temp_File_Name));
+
+         end if;
+
          declare
-            Current_Last : constant Integer := Last_Switches.Last;
             Proj         : Project_List;
 
          begin
@@ -572,70 +586,40 @@ procedure GNATCmd is
                        and then Unit_Data.File_Names (Kind).Name /= No_File
                        and then Unit_Data.File_Names (Kind).Path.Name /= Slash
                      then
-                        Last_Switches.Increment_Last;
-                        Last_Switches.Table (Last_Switches.Last) :=
-                          new String'
-                            (Get_Name_String
-                               (Unit_Data.File_Names
-                                  (Kind).Path.Display_Name));
-                     end if;
-                  end loop;
-               end if;
-            end loop;
-
-            --  If the list of files is too long, create a temporary text file
-            --  that lists these files, and pass this temp file to gnatcheck,
-            --  gnatpp or gnatmetric using switch -files=.
-
-            if Last_Switches.Last - Current_Last >
-              Max_Files_On_The_Command_Line
-            then
-               declare
-                  Temp_File_FD : File_Descriptor;
-                  Buffer       : String (1 .. 1_000);
-                  Len          : Natural;
-                  OK           : Boolean := True;
+                        Get_Name_String
+                          (Unit_Data.File_Names
+                             (Kind).Path.Display_Name);
 
-               begin
-                  Create_Temp_File (Temp_File_FD, Temp_File_Name);
+                        if FD /= Invalid_FD then
+                           Name_Len := Name_Len + 1;
+                           Name_Buffer (Name_Len) := ASCII.LF;
+                           Status :=
+                             Write (FD, Name_Buffer (1)'Address, Name_Len);
 
-                  if Temp_File_Name /= null then
-                     for Index in Current_Last + 1 ..
-                       Last_Switches.Last
-                     loop
-                        Len := Last_Switches.Table (Index)'Length;
-                        Buffer (1 .. Len) := Last_Switches.Table (Index).all;
-                        Len := Len + 1;
-                        Buffer (Len) := ASCII.LF;
-                        Buffer (Len + 1) := ASCII.NUL;
-                        OK :=
-                          Write (Temp_File_FD,
-                                 Buffer (1)'Address,
-                                 Len) = Len;
-                        exit when not OK;
-                     end loop;
+                           if Status /= Name_Len then
+                              Osint.Fail ("disk full");
+                           end if;
 
-                     if OK then
-                        Close (Temp_File_FD, OK);
-                     else
-                        Close (Temp_File_FD, OK);
-                        OK := False;
+                        else
+                           Last_Switches.Increment_Last;
+                           Last_Switches.Table (Last_Switches.Last) :=
+                             new String'
+                               (Get_Name_String
+                                    (Unit_Data.File_Names
+                                         (Kind).Path.Display_Name));
+                        end if;
                      end if;
+                  end loop;
 
-                     --  If there were any problem creating the temp file, then
-                     --  pass the list of files.
-
-                     if OK then
-
-                        --  Replace list of files with -files=<temp file name>
+                  if FD /= Invalid_FD then
+                     Close (FD, Success);
 
-                        Last_Switches.Set_Last (Current_Last + 1);
-                        Last_Switches.Table (Last_Switches.Last) :=
-                          new String'("-files=" & Temp_File_Name.all);
+                     if not Success then
+                        Osint.Fail ("disk full");
                      end if;
                   end if;
-               end;
-            end if;
+               end if;
+            end loop;
          end;
       end if;
    end Check_Files;
@@ -752,8 +736,8 @@ procedure GNATCmd is
       --  If a temporary text file that contains a list of files for a tool
       --  has been created, delete this temporary file.
 
-      if Temp_File_Name /= null then
-         Delete_File (Temp_File_Name.all, Success);
+      if Temp_File_Name /= No_Path then
+         Delete_File (Get_Name_String (Temp_File_Name), Success);
       end if;
    end Delete_Temp_Config_Files;
 
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 7c69da1ade1..9a0f878aa8a 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -301,11 +301,74 @@ package body Sem_Disp is
       --  If a controlling formal has a statically tagged actual, the tag of
       --  this actual is to be used for any tag-indeterminate actual.
 
+      procedure Check_Direct_Call;
+      --  In the case when the controlling actual is a class-wide type whose
+      --  root type's completion is a task or protected type, the call is in
+      --  fact direct. This routine detects the above case and modifies the
+      --  call accordingly.
+
       procedure Check_Dispatching_Context;
       --  If the call is tag-indeterminate and the entity being called is
       --  abstract, verify that the context is a call that will eventually
       --  provide a tag for dispatching, or has provided one already.
 
+      -----------------------
+      -- Check_Direct_Call --
+      -----------------------
+
+      procedure Check_Direct_Call is
+         Typ : Entity_Id := Etype (Control);
+
+      begin
+         if Is_Class_Wide_Type (Typ) then
+            Typ := Root_Type (Typ);
+         end if;
+
+         --  Detect whether the controlling type is a private type completed
+         --  by a task or protected type.
+
+         if Is_Private_Type (Typ)
+           and then Present (Full_View (Typ))
+           and then Is_Concurrent_Type (Full_View (Typ))
+           and then Present (Corresponding_Record_Type (Full_View (Typ)))
+         then
+            Typ := Corresponding_Record_Type (Full_View (Typ));
+
+            --  The concurrent record's list of primitives should contain a
+            --  wrapper for the entity of the call, retrieve it.
+
+            declare
+               Prim          : Entity_Id;
+               Prim_Elmt     : Elmt_Id;
+               Wrapper_Found : Boolean := False;
+
+            begin
+               Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+               while Present (Prim_Elmt) loop
+                  Prim := Node (Prim_Elmt);
+
+                  if Is_Primitive_Wrapper (Prim)
+                    and then Wrapped_Entity (Prim) = Subp_Entity
+                  then
+                     Wrapper_Found := True;
+                     exit;
+                  end if;
+
+                  Next_Elmt (Prim_Elmt);
+               end loop;
+
+               --  A primitive declared between two views should have a
+               --  corresponding wrapper.
+
+               pragma Assert (Wrapper_Found);
+
+               --  Modify the call by setting the proper entity
+
+               Set_Entity (Name (N), Prim);
+            end;
+         end if;
+      end Check_Direct_Call;
+
       -------------------------------
       -- Check_Dispatching_Context --
       -------------------------------
@@ -484,6 +547,11 @@ package body Sem_Disp is
             Set_Controlling_Argument (N, Control);
             Check_Restriction (No_Dispatching_Calls, N);
 
+            --  The dispatching call may need to be converted into a direct
+            --  call in certain cases.
+
+            Check_Direct_Call;
+
          --  If there is a statically tagged actual and a tag-indeterminate
          --  call to a function of the ancestor (such as that provided by a
          --  default), then treat this as a dispatching call and propagate