From 4f91a2557f88fd788380e3059bb7f475418002a6 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Sun, 21 Jun 2009 15:11:41 +0200 Subject: [PATCH] [multiple changes] 2009-06-21 Ed Falis * env.c (__gnat_environ): return NULL for vThreads - unimplemented 2009-06-21 Eric Botcazou * einfo.ads: Update comments. 2009-06-21 Hristian Kirtchev * 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 * 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 * exp_ch3.adb (Build_Array_Init_Proc): Do not build the init proc in case of VM convention arrays. From-SVN: r148763 --- gcc/ada/ChangeLog | 27 +++++++++++++ gcc/ada/einfo.ads | 9 +++-- gcc/ada/env.c | 2 +- gcc/ada/exp_ch3.adb | 5 ++- gcc/ada/gnatcmd.adb | 112 ++++++++++++++++++++++----------------------------- gcc/ada/sem_disp.adb | 68 +++++++++++++++++++++++++++++++ 6 files changed, 154 insertions(+), 69 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9f75f4e..46a610a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,30 @@ +2009-06-21 Ed Falis + + * env.c (__gnat_environ): return NULL for vThreads - unimplemented + +2009-06-21 Eric Botcazou + + * einfo.ads: Update comments. + +2009-06-21 Hristian Kirtchev + + * 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 + + * 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 + + * exp_ch3.adb (Build_Array_Init_Proc): Do not build the init proc in + case of VM convention arrays. + 2009-06-20 Robert Dewar * a-nudira.adb: Minor reformatting diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 049faab..29eea5e 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 e6720e3..bcb8bdb 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 87beb49..c0cf131 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 8194a42..9e335d1 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= + 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 7c69da1..9a0f878 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 -- 2.7.4