+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
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
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));
-- 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
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)
-- --
-- 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- --
Level : Level_Type := Socket_Level;
Name : Option_Name) return Option_Type
is
+ use SOSC;
use type C.unsigned_char;
V8 : aliased Two_Ints;
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 |
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;
Level : Level_Type := Socket_Level;
Option : Option_Type)
is
+ use SOSC;
+
V8 : aliased Two_Ints;
V4 : aliased C.int;
V1 : aliased C.unsigned_char;
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;
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).
-- 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
-- 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 --
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 --
-----------------
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 --
------------------
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
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 --
----------------------------
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 --
-------------------
-- 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
-- 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
-- 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 --
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.
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 --
-- 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);
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
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));
-- (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;
projects / thirdparty / gcc.git / commitdiff
