OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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.

From-SVN: r148763
This commit is contained in:
Arnaud Charlet 2009-06-21 15:11:41 +02:00
parent c64c5552f1
commit 4f91a2557f
6 changed files with 156 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
gcc/ada/ChangeLog
View File

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

9
gcc/ada/einfo.ads
View File

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

2
gcc/ada/env.c
View File

@ -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__)

5
gcc/ada/exp_ch3.adb
View File

@ -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;

116
gcc/ada/gnatcmd.adb
View File

@ -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));
Get_Name_String
(Unit_Data.File_Names
(Kind).Path.Display_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 Status /= Name_Len then
Osint.Fail ("disk full");
end if;
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;
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 FD /= Invalid_FD then
Close (FD, Success);
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;
begin
Create_Temp_File (Temp_File_FD, Temp_File_Name);
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 OK then
Close (Temp_File_FD, OK);
else
Close (Temp_File_FD, OK);
OK := False;
end if;
-- 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>
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;

68
gcc/ada/sem_disp.adb
View File

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