summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/ada/ChangeLog27
-rw-r--r--gcc/ada/einfo.ads9
-rw-r--r--gcc/ada/env.c2
-rw-r--r--gcc/ada/exp_ch3.adb5
-rw-r--r--gcc/ada/gnatcmd.adb112
-rw-r--r--gcc/ada/sem_disp.adb68
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
OpenPOWER on IntegriCloud