FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
2012-07-30  Robert Dewar  <dewar@adacore.com>

	* bindusg.adb: Clarify file in -A lines.

2012-07-30  Robert Dewar  <dewar@adacore.com>

	* freeze.adb: Minor reformatting.

2012-07-30  Robert Dewar  <dewar@adacore.com>

	* gnatcmd.adb, makeutl.adb, makeutl.ads: Minor code reorganization.

2012-07-30  Vincent Pucci  <pucci@adacore.com>

	* exp_ch9.adb (Build_Lock_Free_Unprotected_Subprogram_Body): Minor
	reformatting.
	* sem_ch9.adb (Allows_Lock_Free_Implementation): Minor reformatting.
	Capture the correct error message in case of a quantified expression.

2012-07-30  Thomas Quinot  <quinot@adacore.com>

	* g-socket.adb (Get_Socket_Option, Set_Socket_Option): On Windows, the
	value is a milliseconds count in a DWORD, not a struct timeval.

From-SVN: r189979
This commit is contained in:
Arnaud Charlet 2012-07-30 17:21:46 +02:00
parent ea2af26ac9
commit a5fe079c34
9 changed files with 340 additions and 252 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

24
gcc/ada/ChangeLog
View file

@ -1,3 +1,27 @@
2012-07-30 Robert Dewar <dewar@adacore.com>
* bindusg.adb: Clarify file in -A lines.
2012-07-30 Robert Dewar <dewar@adacore.com>
* freeze.adb: Minor reformatting.
2012-07-30 Robert Dewar <dewar@adacore.com>
* gnatcmd.adb, makeutl.adb, makeutl.ads: Minor code reorganization.
2012-07-30 Vincent Pucci <pucci@adacore.com>
* exp_ch9.adb (Build_Lock_Free_Unprotected_Subprogram_Body): Minor
reformatting.
* sem_ch9.adb (Allows_Lock_Free_Implementation): Minor reformatting.
Capture the correct error message in case of a quantified expression.
2012-07-30 Thomas Quinot <quinot@adacore.com>
* g-socket.adb (Get_Socket_Option, Set_Socket_Option): On Windows, the
value is a milliseconds count in a DWORD, not a struct timeval.
2012-07-30 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch12.adb (Earlier): Add local variables T1 and T2. Minor code

5
gcc/ada/bindusg.adb
View file

@ -76,9 +76,10 @@ package body Bindusg is
Write_Line (" -a Automatically initialize elaboration " &
"procedure");
-- Line for -A switch
-- Lines for -A switch
Write_Line (" -A[=file] Give list of ALI files in partition");
Write_Line (" -A Give list of ALI files in partition");
Write_Line (" -A=file Write ALI file list to named file");
-- Line for -b switch

11
gcc/ada/exp_ch9.adb
View file

@ -3260,9 +3260,6 @@ package body Exp_Ch9 is
begin
-- Get the type size
-- Surely this should be Known_Static_Esize if you are about
-- to assume you can do UI_To_Int on it! ???
if Known_Esize (Comp_Type) then
Typ_Size := UI_To_Int (Esize (Comp_Type));
@ -3270,10 +3267,14 @@ package body Exp_Ch9 is
-- the RM_Size (Value_Size) since it may have been set by an
-- explicit representation clause.
-- And how do we know this is statically known???
elsif Known_RM_Size (Comp_Type) then
Typ_Size := UI_To_Int (RM_Size (Comp_Type));
-- Should not happen since this has already been checked in
-- Allows_Lock_Free_Implementation (see Sem_Ch9).
else
Typ_Size := UI_To_Int (RM_Size (Comp_Type));
raise Program_Error;
end if;
-- Retrieve all relevant atomic routines and types

4
gcc/ada/freeze.adb
View file

@ -4204,12 +4204,12 @@ package body Freeze is
elsif Is_Access_Type (E)
and then not Is_Access_Subprogram_Type (E)
then
-- If a pragma Default_Storage_Pool applies, and this type has no
-- Storage_Pool or Storage_Size clause (which must have occurred
-- before the freezing point), then use the default. This applies
-- only to base types.
-- None of this applies to access to subprogramss, for which there
-- None of this applies to access to subprograms, for which there
-- are clearly no pools.
if Present (Default_Pool)

70
gcc/ada/g-socket.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2011, AdaCore --
-- Copyright (C) 2001-2012, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -1112,6 +1112,7 @@ package body GNAT.Sockets is
Level : Level_Type := Socket_Level;
Name : Option_Name) return Option_Type
is
use SOSC;
use type C.unsigned_char;
V8 : aliased Two_Ints;
@ -1144,8 +1145,22 @@ package body GNAT.Sockets is
when Send_Timeout |
Receive_Timeout =>
Len := VT'Size / 8;
Add := VT'Address;
-- The standard argument for SO_RCVTIMEO and SO_SNDTIMEO is a
-- struct timeval, but on Windows it is a milliseconds count in
-- a DWORD.
pragma Warnings (Off);
if Target_OS = Windows then
pragma Warnings (On);
Len := V4'Size / 8;
Add := V4'Address;
else
Len := VT'Size / 8;
Add := VT'Address;
end if;
when Linger |
Add_Membership |
@ -1201,7 +1216,23 @@ package body GNAT.Sockets is
when Send_Timeout |
Receive_Timeout =>
Opt.Timeout := To_Duration (VT);
pragma Warnings (Off);
if Target_OS = Windows then
pragma Warnings (On);
-- Timeout is in milliseconds, actual value is 500 ms +
-- returned value (unless it is 0).
if V4 = 0 then
Opt.Timeout := 0.0;
else
Opt.Timeout := Natural (V4) * 0.001 + 0.500;
end if;
else
Opt.Timeout := To_Duration (VT);
end if;
end case;
return Opt;
@ -2176,6 +2207,8 @@ package body GNAT.Sockets is
Level : Level_Type := Socket_Level;
Option : Option_Type)
is
use SOSC;
V8 : aliased Two_Ints;
V4 : aliased C.int;
V1 : aliased C.unsigned_char;
@ -2236,9 +2269,32 @@ package body GNAT.Sockets is
when Send_Timeout |
Receive_Timeout =>
VT := To_Timeval (Option.Timeout);
Len := VT'Size / 8;
Add := VT'Address;
pragma Warnings (Off);
if Target_OS = Windows then
pragma Warnings (On);
-- On Windows, the timeout is a DWORD in milliseconds, and
-- the actual timeout is 500 ms + the given value (unless it
-- is 0).
V4 := C.int (Option.Timeout / 0.001);
if V4 > 500 then
V4 := V4 - 500;
elsif V4 > 0 then
V4 := 1;
end if;
Len := V4'Size / 8;
Add := V4'Address;
else
VT := To_Timeval (Option.Timeout);
Len := VT'Size / 8;
Add := VT'Address;
end if;
end case;

172
gcc/ada/gnatcmd.adb
View file

@ -238,12 +238,7 @@ procedure GNATCmd is
function Configuration_Pragmas_File return Path_Name_Type;
-- Return an argument, if there is a configuration pragmas file to be
-- specified for Project, otherwise return No_Name. Used for gnatstub (GNAT
-- STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric (GNAT
-- METRIC).
function Mapping_File return Path_Name_Type;
-- Create and return the path name of a mapping file. Used for gnatstub
-- specified for Project, otherwise return No_Name. Used for gnatstub
-- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric
-- (GNAT METRIC).
@ -251,10 +246,22 @@ procedure GNATCmd is
-- Delete all temporary config files. The caller is responsible for
-- ensuring that Keep_Temporary_Files is False.
procedure Ensure_Absolute_Path
(Switch : in out String_Access;
Parent : String);
-- Test if Switch is a relative search path switch. If it is and it
-- includes directory information, prepend the path with Parent. This
-- subprogram is only called when using project files.
procedure Get_Closure;
-- Get the sources in the closure of the ASIS_Main and add them to the
-- list of arguments.
function Mapping_File return Path_Name_Type;
-- Create and return the path name of a mapping file. Used for gnatstub
-- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric
-- (GNAT METRIC).
procedure Non_VMS_Usage;
-- Display usage for platforms other than VMS
@ -268,17 +275,9 @@ procedure GNATCmd is
-- If Project is a library project, add the correct -L and -l switches to
-- the linker invocation.
procedure Set_Libraries is
new For_Every_Project_Imported (Boolean, Set_Library_For);
-- Add the -L and -l switches to the linker for all of the library
-- projects.
procedure Ensure_Absolute_Path
(Switch : in out String_Access;
Parent : String);
-- Test if Switch is a relative search path switch. If it is and it
-- includes directory information, prepend the path with Parent. This
-- subprogram is only called when using project files.
procedure Set_Libraries is new
For_Every_Project_Imported (Boolean, Set_Library_For);
-- Add the -L and -l switches to the linker for all the library projects
--------------------------
-- Add_To_Carg_Switches --
@ -789,6 +788,22 @@ procedure GNATCmd is
end if;
end Delete_Temp_Config_Files;
---------------------------
-- Ensure_Absolute_Path --
---------------------------
procedure Ensure_Absolute_Path
(Switch : in out String_Access;
Parent : String)
is
begin
Makeutl.Ensure_Absolute_Path
(Switch, Parent,
Do_Fail => Osint.Fail'Access,
Including_Non_Switch => False,
Including_RTS => True);
end Ensure_Absolute_Path;
-----------------
-- Get_Closure --
-----------------
@ -962,6 +977,59 @@ procedure GNATCmd is
return Result;
end Mapping_File;
-------------------
-- Non_VMS_Usage --
-------------------
procedure Non_VMS_Usage is
begin
Output_Version;
New_Line;
Put_Line ("List of available commands");
New_Line;
for C in Command_List'Range loop
-- No usage for VMS only command or for Sync
if not Command_List (C).VMS_Only and then C /= Sync then
if Targparm.AAMP_On_Target then
Put ("gnaampcmd ");
else
Put ("gnat ");
end if;
Put (To_Lower (Command_List (C).Cname.all));
Set_Col (25);
-- Never call gnatstack with a prefix
if C = Stack then
Put (Command_List (C).Unixcmd.all);
else
Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all);
end if;
declare
Sws : Argument_List_Access renames Command_List (C).Unixsws;
begin
if Sws /= null then
for J in Sws'Range loop
Put (' ');
Put (Sws (J).all);
end loop;
end if;
end;
New_Line;
end if;
end loop;
New_Line;
Put_Line ("All commands except chop, krunch and preprocess " &
"accept project file switches -vPx, -Pprj and -Xnam=val");
New_Line;
end Non_VMS_Usage;
------------------
-- Process_Link --
------------------
@ -1302,76 +1370,6 @@ procedure GNATCmd is
end if;
end Set_Library_For;
---------------------------
-- Ensure_Absolute_Path --
---------------------------
procedure Ensure_Absolute_Path
(Switch : in out String_Access;
Parent : String)
is
begin
Makeutl.Ensure_Absolute_Path
(Switch, Parent,
Do_Fail => Osint.Fail'Access,
Including_Non_Switch => False,
Including_RTS => True);
end Ensure_Absolute_Path;
-------------------
-- Non_VMS_Usage --
-------------------
procedure Non_VMS_Usage is
begin
Output_Version;
New_Line;
Put_Line ("List of available commands");
New_Line;
for C in Command_List'Range loop
-- No usage for VMS only command or for Sync
if not Command_List (C).VMS_Only and then C /= Sync then
if Targparm.AAMP_On_Target then
Put ("gnaampcmd ");
else
Put ("gnat ");
end if;
Put (To_Lower (Command_List (C).Cname.all));
Set_Col (25);
-- Never call gnatstack with a prefix
if C = Stack then
Put (Command_List (C).Unixcmd.all);
else
Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all);
end if;
declare
Sws : Argument_List_Access renames Command_List (C).Unixsws;
begin
if Sws /= null then
for J in Sws'Range loop
Put (' ');
Put (Sws (J).all);
end loop;
end if;
end;
New_Line;
end if;
end loop;
New_Line;
Put_Line ("All commands except chop, krunch and preprocess " &
"accept project file switches -vPx, -Pprj and -Xnam=val");
New_Line;
end Non_VMS_Usage;
-- Start of processing for GNATCmd
begin

206
gcc/ada/makeutl.adb
View file

@ -507,6 +507,109 @@ package body Makeutl is
return Name_Find;
end Create_Name;
---------------------------
-- Ensure_Absolute_Path --
---------------------------
procedure Ensure_Absolute_Path
(Switch : in out String_Access;
Parent : String;
Do_Fail : Fail_Proc;
For_Gnatbind : Boolean := False;
Including_Non_Switch : Boolean := True;
Including_RTS : Boolean := False)
is
begin
if Switch /= null then
declare
Sw : String (1 .. Switch'Length);
Start : Positive;
begin
Sw := Switch.all;
if Sw (1) = '-' then
if Sw'Length >= 3
and then (Sw (2) = 'I'
or else (not For_Gnatbind
and then (Sw (2) = 'L'
or else Sw (2) = 'A')))
then
Start := 3;
if Sw = "-I-" then
return;
end if;
elsif Sw'Length >= 4
and then (Sw (2 .. 3) = "aL"
or else
Sw (2 .. 3) = "aO"
or else
Sw (2 .. 3) = "aI"
or else
(For_Gnatbind and then Sw (2 .. 3) = "A="))
then
Start := 4;
elsif Including_RTS
and then Sw'Length >= 7
and then Sw (2 .. 6) = "-RTS="
then
Start := 7;
else
return;
end if;
-- Because relative path arguments to --RTS= may be relative to
-- the search directory prefix, those relative path arguments
-- are converted only when they include directory information.
if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
if Parent'Length = 0 then
Do_Fail
("relative search path switches ("""
& Sw
& """) are not allowed");
elsif Including_RTS then
for J in Start .. Sw'Last loop
if Sw (J) = Directory_Separator then
Switch :=
new String'
(Sw (1 .. Start - 1) &
Parent &
Directory_Separator &
Sw (Start .. Sw'Last));
return;
end if;
end loop;
else
Switch :=
new String'
(Sw (1 .. Start - 1) &
Parent &
Directory_Separator &
Sw (Start .. Sw'Last));
end if;
end if;
elsif Including_Non_Switch then
if not Is_Absolute_Path (Sw) then
if Parent'Length = 0 then
Do_Fail
("relative paths (""" & Sw & """) are not allowed");
else
Switch := new String'(Parent & Directory_Separator & Sw);
end if;
end if;
end if;
end;
end if;
end Ensure_Absolute_Path;
----------------------------
-- Executable_Prefix_Path --
----------------------------
@ -1936,109 +2039,6 @@ package body Makeutl is
end if;
end Path_Or_File_Name;
---------------------------
-- Ensure_Absolute_Path --
---------------------------
procedure Ensure_Absolute_Path
(Switch : in out String_Access;
Parent : String;
Do_Fail : Fail_Proc;
For_Gnatbind : Boolean := False;
Including_Non_Switch : Boolean := True;
Including_RTS : Boolean := False)
is
begin
if Switch /= null then
declare
Sw : String (1 .. Switch'Length);
Start : Positive;
begin
Sw := Switch.all;
if Sw (1) = '-' then
if Sw'Length >= 3
and then (Sw (2) = 'I'
or else (not For_Gnatbind
and then (Sw (2) = 'L'
or else Sw (2) = 'A')))
then
Start := 3;
if Sw = "-I-" then
return;
end if;
elsif Sw'Length >= 4
and then (Sw (2 .. 3) = "aL"
or else
Sw (2 .. 3) = "aO"
or else
Sw (2 .. 3) = "aI"
or else
(For_Gnatbind and then Sw (2 .. 3) = "A="))
then
Start := 4;
elsif Including_RTS
and then Sw'Length >= 7
and then Sw (2 .. 6) = "-RTS="
then
Start := 7;
else
return;
end if;
-- Because relative path arguments to --RTS= may be relative to
-- the search directory prefix, those relative path arguments
-- are converted only when they include directory information.
if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
if Parent'Length = 0 then
Do_Fail
("relative search path switches ("""
& Sw
& """) are not allowed");
elsif Including_RTS then
for J in Start .. Sw'Last loop
if Sw (J) = Directory_Separator then
Switch :=
new String'
(Sw (1 .. Start - 1) &
Parent &
Directory_Separator &
Sw (Start .. Sw'Last));
return;
end if;
end loop;
else
Switch :=
new String'
(Sw (1 .. Start - 1) &
Parent &
Directory_Separator &
Sw (Start .. Sw'Last));
end if;
end if;
elsif Including_Non_Switch then
if not Is_Absolute_Path (Sw) then
if Parent'Length = 0 then
Do_Fail
("relative paths (""" & Sw & """) are not allowed");
else
Switch := new String'(Parent & Directory_Separator & Sw);
end if;
end if;
end if;
end;
end if;
end Ensure_Absolute_Path;
-------------------
-- Unit_Index_Of --
-------------------

87
gcc/ada/makeutl.ads
View file

@ -128,6 +128,20 @@ package Makeutl is
-- source files are still associated with the same units). Return the name
-- of the unit if everything is still valid. Return No_Name otherwise.
procedure Ensure_Absolute_Path
(Switch : in out String_Access;
Parent : String;
Do_Fail : Fail_Proc;
For_Gnatbind : Boolean := False;
Including_Non_Switch : Boolean := True;
Including_RTS : Boolean := False);
-- Do nothing if Switch is an absolute path switch. If relative, fail if
-- Parent is the empty string, otherwise prepend the path with Parent. This
-- subprogram is only used when using project files. If For_Gnatbind is
-- True, gnatbind switches that are not paths (-L, -A) are left unchaned.
-- If Including_RTS is True, process also switches --RTS=. Do_Fail is
-- called in case of error. Using Osint.Fail might be appropriate.
function Is_Subunit (Source : Source_Id) return Boolean;
-- Return True if source is a subunit
@ -151,26 +165,6 @@ package Makeutl is
-- entered by a call to Prj.Ext.Add, so that in a project file, External
-- ("name") will return "value".
procedure Verbose_Msg
(N1 : Name_Id;
S1 : String;
N2 : Name_Id := No_Name;
S2 : String := "";
Prefix : String := " -> ";
Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low);
procedure Verbose_Msg
(N1 : File_Name_Type;
S1 : String;
N2 : File_Name_Type := No_File;
S2 : String := "";
Prefix : String := " -> ";
Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low);
-- If the verbose flag (Verbose_Mode) is set and the verbosity level is at
-- least equal to Minimum_Verbosity, then print Prefix to standard output
-- followed by N1 and S1. If N2 /= No_Name then N2 is printed after S1. S2
-- is printed last. Both N1 and N2 are printed in quotation marks. The two
-- forms differ only in taking Name_Id or File_name_Type arguments.
type Name_Ids is array (Positive range <>) of Name_Id;
No_Names : constant Name_Ids := (1 .. 0 => No_Name);
-- Name_Ids is used for list of language names in procedure Get_Directories
@ -231,26 +225,32 @@ package Makeutl is
-- of project Project, in project tree In_Tree, and in the projects that
-- it imports directly or indirectly, and returns the result.
function Path_Or_File_Name (Path : Path_Name_Type) return String;
-- Returns a file name if -df is used, otherwise return a path name
function Unit_Index_Of (ALI_File : File_Name_Type) return Int;
-- Find the index of a unit in a source file. Return zero if the file is
-- not a multi-unit source file.
procedure Ensure_Absolute_Path
(Switch : in out String_Access;
Parent : String;
Do_Fail : Fail_Proc;
For_Gnatbind : Boolean := False;
Including_Non_Switch : Boolean := True;
Including_RTS : Boolean := False);
-- Do nothing if Switch is an absolute path switch. If relative, fail if
-- Parent is the empty string, otherwise prepend the path with Parent. This
-- subprogram is only used when using project files. If For_Gnatbind is
-- True, gnatbind switches that are not paths (-L, -A) are left unchaned.
-- If Including_RTS is True, process also switches --RTS=. Do_Fail is
-- called in case of error. Using Osint.Fail might be appropriate.
function Path_Or_File_Name (Path : Path_Name_Type) return String;
-- Returns a file name if -df is used, otherwise return a path name
procedure Verbose_Msg
(N1 : Name_Id;
S1 : String;
N2 : Name_Id := No_Name;
S2 : String := "";
Prefix : String := " -> ";
Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low);
procedure Verbose_Msg
(N1 : File_Name_Type;
S1 : String;
N2 : File_Name_Type := No_File;
S2 : String := "";
Prefix : String := " -> ";
Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low);
-- If the verbose flag (Verbose_Mode) is set and the verbosity level is at
-- least equal to Minimum_Verbosity, then print Prefix to standard output
-- followed by N1 and S1. If N2 /= No_Name then N2 is printed after S1. S2
-- is printed last. Both N1 and N2 are printed in quotation marks. The two
-- forms differ only in taking Name_Id or File_name_Type arguments.
-------------------------
-- Program termination --
@ -279,10 +279,11 @@ package Makeutl is
For_Lang : Name_Id;
For_Builder : Boolean;
Has_Global_Compilation_Switches : Boolean) return Boolean;
-- For_Builder is true if we have a builder switch
-- This function should return True in case of success (the switch is
-- valid), False otherwise. The error message will be displayed by
-- For_Builder is true if we have a builder switch. This function
-- should return True in case of success (the switch is valid),
-- False otherwise. The error message will be displayed by
-- Compute_Builder_Switches itself.
--
-- Has_Global_Compilation_Switches is True if the attribute
-- Global_Compilation_Switches is defined in the project.
@ -291,10 +292,10 @@ package Makeutl is
Root_Environment : in out Prj.Tree.Environment;
Main_Project : Project_Id;
Only_For_Lang : Name_Id := No_Name);
-- Compute the builder switches and global compilation switches.
-- Every time a switch is found in the project, it is passed to Add_Switch.
-- You can provide a value for Only_For_Lang so that we only look for
-- this language when parsing the global compilation switches.
-- Compute the builder switches and global compilation switches. Every time
-- a switch is found in the project, it is passed to Add_Switch. You can
-- provide a value for Only_For_Lang so that we only look for this language
-- when parsing the global compilation switches.
-----------------------
-- Project_Tree data --

13
gcc/ada/sem_ch9.adb
View file

@ -530,7 +530,10 @@ package body Sem_Ch9 is
-- Quantified expression restricted
elsif Kind = N_Quantified_Expression then
elsif Kind = N_Quantified_Expression
or else Nkind (Original_Node (N)) =
N_Quantified_Expression
then
if Lock_Free_Given then
Error_Msg_N ("quantified expression not allowed",
N);
@ -552,7 +555,7 @@ package body Sem_Ch9 is
Id : constant Entity_Id := Entity (N);
Comp_Decl : Node_Id;
Comp_Id : Entity_Id := Empty;
Comp_Size : Int;
Comp_Size : Int := 0;
Comp_Type : Entity_Id;
begin
@ -579,6 +582,10 @@ package body Sem_Ch9 is
Layout_Type (Comp_Type);
-- Note that Known_Esize is used and not
-- Known_Static_Esize in order to capture the
-- errors properly at the instantiation point.
if Known_Esize (Comp_Type) then
Comp_Size := UI_To_Int (Esize (Comp_Type));
@ -587,7 +594,7 @@ package body Sem_Ch9 is
-- (Value_Size) since it may have been set by an
-- explicit representation clause.
else
elsif Known_RM_Size (Comp_Type) then
Comp_Size := UI_To_Int (RM_Size (Comp_Type));
end if;