git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[multiple changes] 

2009-08-10  Robert Dewar  <dewar@adacore.com>

	* exp_ch7.adb: Add ??? comment for last change

2009-08-10  Vincent Celier  <celier@adacore.com>

	* prj-env.adb (Add_To_Buffer): New procedure
	(Create_Config_Pragmas_File): Write to temporary file in one shot
	(Create_Mapping_File): Ditto
	(Set_Ada_Paths): Ditto

From-SVN: r150618
This commit is contained in:
Arnaud Charlet 2009-08-10 10:25:49 +02:00
parent 6d93ae145e
commit 68716ad5f6
3 changed files with 182 additions and 133 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
gcc/ada/ChangeLog
View File

@ -1,3 +1,14 @@
2009-08-10 Robert Dewar <dewar@adacore.com>
* exp_ch7.adb: Add ??? comment for last change
2009-08-10 Vincent Celier <celier@adacore.com>
* prj-env.adb (Add_To_Buffer): New procedure
(Create_Config_Pragmas_File): Write to temporary file in one shot
(Create_Mapping_File): Ditto
(Set_Ada_Paths): Ditto
2009-08-10 Vincent Celier <celier@adacore.com> 2009-08-10 Vincent Celier <celier@adacore.com>
PR ada/17566 PR ada/17566

4
gcc/ada/exp_ch7.adb
View File

@ -3554,7 +3554,9 @@ package body Exp_Ch7 is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
E : constant Entity_Id := Make_Temporary (Loc, 'E', N); E : constant Entity_Id := Make_Temporary (Loc, 'E', N);
Etyp : constant Entity_Id := Etype (N); Etyp : constant Entity_Id := Etype (N);
Expr : constant Node_Id := Relocate_Node (N);
Expr : constant Node_Id := Relocate_Node (N);
-- Capture this node because the call to Adjust_SCIL_Node can ???
begin begin
-- If the relocated node is a function call then check if some SCIL -- If the relocated node is a function call then check if some SCIL

300
gcc/ada/prj-env.adb
View File

@ -32,6 +32,9 @@ with Tempdir;
package body Prj.Env is package body Prj.Env is
Buffer_Initial : constant := 1_000;
-- Initial size of Buffer
----------------------- -----------------------
-- Local Subprograms -- -- Local Subprograms --
----------------------- -----------------------
@ -52,6 +55,12 @@ package body Prj.Env is
Table_Increment => 100); Table_Increment => 100);
-- A table to store the object dirs, before creating the object path file -- A table to store the object dirs, before creating the object path file
procedure Add_To_Buffer
(S : String;
Buffer : in out String_Access;
Buffer_Last : in out Natural);
-- Add a string to Buffer, extending Buffer if needed
procedure Add_To_Path procedure Add_To_Path
(Source_Dirs : String_List_Id; (Source_Dirs : String_List_Id;
In_Tree : Project_Tree_Ref; In_Tree : Project_Tree_Ref;
@ -209,6 +218,33 @@ package body Prj.Env is
return Project.Ada_Objects_Path; return Project.Ada_Objects_Path;
end Ada_Objects_Path; end Ada_Objects_Path;
-------------------
-- Add_To_Buffer --
-------------------
procedure Add_To_Buffer
(S : String;
Buffer : in out String_Access;
Buffer_Last : in out Natural)
is
Last : constant Natural := Buffer_Last + S'Length;
begin
while Last > Buffer'Last loop
declare
New_Buffer : constant String_Access :=
new String (1 .. 2 * Buffer'Last);
begin
New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
Free (Buffer);
Buffer := New_Buffer;
end;
end loop;
Buffer (Buffer_Last + 1 .. Last) := S;
Buffer_Last := Last;
end Add_To_Buffer;
------------------------ ------------------------
-- Add_To_Object_Path -- -- Add_To_Object_Path --
------------------------ ------------------------
@ -410,6 +446,9 @@ package body Prj.Env is
Namings : Naming_Table.Instance; Namings : Naming_Table.Instance;
-- Table storing the naming data for gnatmake/gprmake -- Table storing the naming data for gnatmake/gprmake
Buffer : String_Access := new String (1 .. Buffer_Initial);
Buffer_Last : Natural := 0;
File_Name : Path_Name_Type := No_Path; File_Name : Path_Name_Type := No_Path;
File : File_Descriptor := Invalid_FD; File : File_Descriptor := Invalid_FD;
@ -417,25 +456,22 @@ package body Prj.Env is
Iter : Source_Iterator; Iter : Source_Iterator;
Source : Source_Id; Source : Source_Id;
Status : Boolean;
-- For call to Close
procedure Check (Project : Project_Id; State : in out Integer); procedure Check (Project : Project_Id; State : in out Integer);
-- Recursive procedure that put in the config pragmas file any non -- Recursive procedure that put in the config pragmas file any non
-- standard naming schemes, if it is not already in the file, then call -- standard naming schemes, if it is not already in the file, then call
-- itself for any imported project. -- itself for any imported project.
procedure Check_Temp_File;
-- Check that a temporary file has been opened.
-- If not, create one, and put its name in the project data,
-- with the indication that it is a temporary file.
procedure Put (Source : Source_Id); procedure Put (Source : Source_Id);
-- Put an SFN pragma in the temporary file -- Put an SFN pragma in the temporary file
procedure Put (File : File_Descriptor; S : String); procedure Put (S : String);
procedure Put_Line (File : File_Descriptor; S : String); procedure Put_Line (S : String);
-- Output procedures, analogous to normal Text_IO procs of same name -- Output procedures, analogous to normal Text_IO procs of same name.
-- The text is put in Buffer, then it will be writen into a temporary
-- file with procedure Write_Temp_File below.
procedure Write_Temp_File;
-- Create a temporary file and put the content of the buffer in it.
----------- -----------
-- Check -- -- Check --
@ -485,113 +521,86 @@ package body Prj.Env is
Naming_Table.Increment_Last (Namings); Naming_Table.Increment_Last (Namings);
Namings.Table (Naming_Table.Last (Namings)) := Naming; Namings.Table (Naming_Table.Last (Namings)) := Naming;
-- We need a temporary file to be created
Check_Temp_File;
-- Put the SFN pragmas for the naming scheme -- Put the SFN pragmas for the naming scheme
-- Spec -- Spec
Put_Line Put_Line
(File, "pragma Source_File_Name_Project"); ("pragma Source_File_Name_Project");
Put_Line Put_Line
(File, " (Spec_File_Name => ""*" & (" (Spec_File_Name => ""*" &
Get_Name_String (Naming.Spec_Suffix) & ""","); Get_Name_String (Naming.Spec_Suffix) & """,");
Put_Line Put_Line
(File, " Casing => " & (" Casing => " &
Image (Naming.Casing) & ","); Image (Naming.Casing) & ",");
Put_Line Put_Line
(File, " Dot_Replacement => """ & (" Dot_Replacement => """ &
Get_Name_String (Naming.Dot_Replacement) & """);"); Get_Name_String (Naming.Dot_Replacement) & """);");
-- and body -- and body
Put_Line Put_Line
(File, "pragma Source_File_Name_Project"); ("pragma Source_File_Name_Project");
Put_Line Put_Line
(File, " (Body_File_Name => ""*" & (" (Body_File_Name => ""*" &
Get_Name_String (Naming.Body_Suffix) & ""","); Get_Name_String (Naming.Body_Suffix) & """,");
Put_Line Put_Line
(File, " Casing => " & (" Casing => " &
Image (Naming.Casing) & ","); Image (Naming.Casing) & ",");
Put_Line Put_Line
(File, " Dot_Replacement => """ & (" Dot_Replacement => """ &
Get_Name_String (Naming.Dot_Replacement) & Get_Name_String (Naming.Dot_Replacement) &
""");"); """);");
-- and maybe separate -- and maybe separate
if Naming.Body_Suffix /= Naming.Separate_Suffix then if Naming.Body_Suffix /= Naming.Separate_Suffix then
Put_Line (File, "pragma Source_File_Name_Project"); Put_Line ("pragma Source_File_Name_Project");
Put_Line Put_Line
(File, " (Subunit_File_Name => ""*" & (" (Subunit_File_Name => ""*" &
Get_Name_String (Naming.Separate_Suffix) & ""","); Get_Name_String (Naming.Separate_Suffix) & """,");
Put_Line Put_Line
(File, " Casing => " & (" Casing => " &
Image (Naming.Casing) & ","); Image (Naming.Casing) & ",");
Put_Line Put_Line
(File, " Dot_Replacement => """ & (" Dot_Replacement => """ &
Get_Name_String (Naming.Dot_Replacement) & Get_Name_String (Naming.Dot_Replacement) &
""");"); """);");
end if; end if;
end if; end if;
end Check; end Check;
---------------------
-- Check_Temp_File --
---------------------
procedure Check_Temp_File is
begin
if File = Invalid_FD then
Create_Temp_File
(In_Tree, File, File_Name, "configuration pragmas");
end if;
end Check_Temp_File;
--------- ---------
-- Put -- -- Put --
--------- ---------
procedure Put (Source : Source_Id) is procedure Put (Source : Source_Id) is
begin begin
-- A temporary file needs to be open
Check_Temp_File;
-- Put the pragma SFN for the unit kind (spec or body) -- Put the pragma SFN for the unit kind (spec or body)
Put (File, "pragma Source_File_Name_Project ("); Put ("pragma Source_File_Name_Project (");
Put (File, Namet.Get_Name_String (Source.Unit.Name)); Put (Namet.Get_Name_String (Source.Unit.Name));
if Source.Kind = Spec then if Source.Kind = Spec then
Put (File, ", Spec_File_Name => """); Put (", Spec_File_Name => """);
else else
Put (File, ", Body_File_Name => """); Put (", Body_File_Name => """);
end if; end if;
Put (File, Namet.Get_Name_String (Source.File)); Put (Namet.Get_Name_String (Source.File));
Put (File, """"); Put ("""");
if Source.Index /= 0 then if Source.Index /= 0 then
Put (File, ", Index =>"); Put (", Index =>");
Put (File, Source.Index'Img); Put (Source.Index'Img);
end if; end if;
Put_Line (File, ");"); Put_Line (");");
end Put; end Put;
procedure Put (File : File_Descriptor; S : String) is procedure Put (S : String) is
Last : Natural;
begin begin
Last := Write (File, S (S'First)'Address, S'Length); Add_To_Buffer (S, Buffer, Buffer_Last);
if Last /= S'Length then
Prj.Com.Fail
("Disk full when creating " & Get_Name_String (File_Name));
end if;
if Current_Verbosity = High then if Current_Verbosity = High then
Write_Str (S); Write_Str (S);
@ -602,10 +611,7 @@ package body Prj.Env is
-- Put_Line -- -- Put_Line --
-------------- --------------
procedure Put_Line (File : File_Descriptor; S : String) is procedure Put_Line (S : String) is
S0 : String (1 .. S'Length + 1);
Last : Natural;
begin begin
-- Add an ASCII.LF to the string. As this config file is supposed to -- Add an ASCII.LF to the string. As this config file is supposed to
-- be used only by the compiler, we don't care about the characters -- be used only by the compiler, we don't care about the characters
@ -613,20 +619,35 @@ package body Prj.Env is
-- it is more convenient to be able to read gnat.adc during -- it is more convenient to be able to read gnat.adc during
-- development, for which the ASCII.LF is fine. -- development, for which the ASCII.LF is fine.
S0 (1 .. S'Length) := S; Put (S);
S0 (S0'Last) := ASCII.LF; Put (S => (1 => ASCII.LF));
Last := Write (File, S0'Address, S0'Length);
if Last /= S'Length + 1 then
Prj.Com.Fail
("Disk full when creating " & Get_Name_String (File_Name));
end if;
if Current_Verbosity = High then
Write_Line (S);
end if;
end Put_Line; end Put_Line;
---------------------
-- Write_Temp_File --
---------------------
procedure Write_Temp_File is
Status : Boolean := False;
Last : Natural;
begin
Tempdir.Create_Temp_File (File, File_Name);
if File /= Invalid_FD then
Last := Write (File, Buffer (1)'Address, Buffer_Last);
if Last = Buffer_Last then
Close (File, Status);
end if;
end if;
if not Status then
Prj.Com.Fail
("could not create temporary file " &
Get_Name_String (File_Name));
end if;
end Write_Temp_File;
procedure Check_Imported_Projects is new For_Every_Project_Imported procedure Check_Imported_Projects is new For_Every_Project_Imported
(Integer, Check); (Integer, Check);
Dummy : Integer := 0; Dummy : Integer := 0;
@ -662,31 +683,25 @@ package body Prj.Env is
-- standard naming scheme. This will tell the compiler that -- standard naming scheme. This will tell the compiler that
-- a project file is used and will forbid any pragma SFN. -- a project file is used and will forbid any pragma SFN.
if File = Invalid_FD then if Buffer_Last = 0 then
Check_Temp_File;
Put_Line (File, "pragma Source_File_Name_Project"); Put_Line ("pragma Source_File_Name_Project");
Put_Line (File, " (Spec_File_Name => ""*.ads"","); Put_Line (" (Spec_File_Name => ""*.ads"",");
Put_Line (File, " Dot_Replacement => ""-"","); Put_Line (" Dot_Replacement => ""-"",");
Put_Line (File, " Casing => lowercase);"); Put_Line (" Casing => lowercase);");
Put_Line (File, "pragma Source_File_Name_Project"); Put_Line ("pragma Source_File_Name_Project");
Put_Line (File, " (Body_File_Name => ""*.adb"","); Put_Line (" (Body_File_Name => ""*.adb"",");
Put_Line (File, " Dot_Replacement => ""-"","); Put_Line (" Dot_Replacement => ""-"",");
Put_Line (File, " Casing => lowercase);"); Put_Line (" Casing => lowercase);");
end if; end if;
-- Close the temporary file -- Close the temporary file
GNAT.OS_Lib.Close (File, Status); Write_Temp_File;
if not Status then
Prj.Com.Fail
("Disk full when creating " & Get_Name_String (File_Name));
end if;
if Opt.Verbose_Mode then if Opt.Verbose_Mode then
Write_Str ("Closing configuration file """); Write_Str ("Created configuration file """);
Write_Str (Get_Name_String (File_Name)); Write_Str (Get_Name_String (File_Name));
Write_Line (""""); Write_Line ("""");
end if; end if;
@ -695,6 +710,8 @@ package body Prj.Env is
For_Project.Config_File_Temp := True; For_Project.Config_File_Temp := True;
For_Project.Config_Checked := True; For_Project.Config_Checked := True;
end if; end if;
Free (Buffer);
end Create_Config_Pragmas_File; end Create_Config_Pragmas_File;
-------------------- --------------------
@ -739,33 +756,30 @@ package body Prj.Env is
Name : out Path_Name_Type) Name : out Path_Name_Type)
is is
File : File_Descriptor := Invalid_FD; File : File_Descriptor := Invalid_FD;
Status : Boolean;
Buffer : String_Access := new String (1 .. Buffer_Initial);
Buffer_Last : Natural := 0;
procedure Put_Name_Buffer; procedure Put_Name_Buffer;
-- Put the line contained in the Name_Buffer in the mapping file -- Put the line contained in the Name_Buffer in the global buffer
procedure Process (Project : Project_Id; State : in out Integer); procedure Process (Project : Project_Id; State : in out Integer);
-- Generate the mapping file for Project (not recursively) -- Generate the mapping file for Project (not recursively)
--------- ---------------------
-- Put -- -- Put_Name_Buffer --
--------- ---------------------
procedure Put_Name_Buffer is procedure Put_Name_Buffer is
Last : Natural;
begin begin
Name_Len := Name_Len + 1; Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ASCII.LF; Name_Buffer (Name_Len) := ASCII.LF;
Last := Write (File, Name_Buffer (1)'Address, Name_Len);
if Current_Verbosity = High then if Current_Verbosity = High then
Write_Str ("Mapping file: " & Name_Buffer (1 .. Name_Len)); Write_Str ("Mapping file: " & Name_Buffer (1 .. Name_Len));
end if; end if;
if Last /= Name_Len then Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
Prj.Com.Fail ("Disk full, cannot write mapping file");
end if;
end Put_Name_Buffer; end Put_Name_Buffer;
------------- -------------
@ -851,22 +865,29 @@ package body Prj.Env is
-- Start of processing for Create_Mapping_File -- Start of processing for Create_Mapping_File
begin begin
-- Create the temporary file
Create_Temp_File (In_Tree, File, Name, "mapping");
For_Every_Imported_Project (Project, Dummy); For_Every_Imported_Project (Project, Dummy);
GNAT.OS_Lib.Close (File, Status);
if not Status then declare
Last : Natural;
Status : Boolean := False;
-- We were able to create the temporary file, so there is no problem begin
-- of protection. However, we are not able to close it, so there must Create_Temp_File (In_Tree, File, Name, "mapping");
-- be a capacity problem that we express using "disk full".
Prj.Com.Fail ("disk full, could not write mapping file"); if File /= Invalid_FD then
end if; Last := Write (File, Buffer (1)'Address, Buffer_Last);
if Last = Buffer_Last then
GNAT.OS_Lib.Close (File, Status);
end if;
end if;
if not Status then
Prj.Com.Fail ("could not write mapping file");
end if;
end;
Free (Buffer);
end Create_Mapping_File; end Create_Mapping_File;
---------------------- ----------------------
@ -1505,7 +1526,10 @@ package body Prj.Env is
Status : Boolean; Status : Boolean;
-- For calls to Close -- For calls to Close
Len : Natural; Last : Natural;
Buffer : String_Access := new String (1 .. Buffer_Initial);
Buffer_Last : Natural := 0;
procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean); procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean);
-- Recursive procedure to add the source/object paths of extended/ -- Recursive procedure to add the source/object paths of extended/
@ -1594,44 +1618,54 @@ package body Prj.Env is
-- the previous version of the file. -- the previous version of the file.
if Source_FD /= Invalid_FD then if Source_FD /= Invalid_FD then
Buffer_Last := 0;
for Index in Source_Path_Table.First .. for Index in Source_Path_Table.First ..
Source_Path_Table.Last (Source_Paths) Source_Path_Table.Last (Source_Paths)
loop loop
Get_Name_String (Source_Paths.Table (Index)); Get_Name_String (Source_Paths.Table (Index));
Name_Len := Name_Len + 1; Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ASCII.LF; Name_Buffer (Name_Len) := ASCII.LF;
Len := Write (Source_FD, Name_Buffer (1)'Address, Name_Len); Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
if Len /= Name_Len then
Prj.Com.Fail ("disk full");
end if;
end loop; end loop;
Close (Source_FD, Status); Last := Write (Source_FD, Buffer (1)'Address, Buffer_Last);
if Last = Buffer_Last then
Close (Source_FD, Status);
else
Status := False;
end if;
if not Status then if not Status then
Prj.Com.Fail ("disk full"); Prj.Com.Fail ("could not write temporary file");
end if; end if;
end if; end if;
if Object_FD /= Invalid_FD then if Object_FD /= Invalid_FD then
Buffer_Last := 0;
for Index in Object_Path_Table.First .. for Index in Object_Path_Table.First ..
Object_Path_Table.Last (Object_Paths) Object_Path_Table.Last (Object_Paths)
loop loop
Get_Name_String (Object_Paths.Table (Index)); Get_Name_String (Object_Paths.Table (Index));
Name_Len := Name_Len + 1; Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ASCII.LF; Name_Buffer (Name_Len) := ASCII.LF;
Len := Write (Object_FD, Name_Buffer (1)'Address, Name_Len); Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
if Len /= Name_Len then
Prj.Com.Fail ("disk full");
end if;
end loop; end loop;
Close (Object_FD, Status); Last := Write (Object_FD, Buffer (1)'Address, Buffer_Last);
if Last = Buffer_Last then
Close (Object_FD, Status);
else
Status := False;
end if;
if not Status then if not Status then
Prj.Com.Fail ("disk full"); Prj.Com.Fail ("could not write temporary file");
end if; end if;
end if; end if;
@ -1672,6 +1706,8 @@ package body Prj.Env is
(In_Tree.Private_Part.Current_Object_Path_File)); (In_Tree.Private_Part.Current_Object_Path_File));
end if; end if;
end if; end if;
Free (Buffer);
end Set_Ada_Paths; end Set_Ada_Paths;
----------------------- -----------------------