2009-04-07 Robert Dewar <dewar@adacore.com>
+ (Osint.Fail): Change calling sequence to have one string arg
+ (Make.Make_Failed): Same change
+ All callers are adjusted to use concatenation
+
+2009-04-07 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch4.adb: Fix documentation typo
+
+2009-04-07 Robert Dewar <dewar@adacore.com>
+
+ * tbuild.ads: Minor reformatting
+
+2009-04-07 Javier Miranda <miranda@adacore.com>
+
+ * exp_disp.adb (Make_DT): Avoid the generation of the OSD_Table
+ when compiling under ZFP runtime.
+
+2009-04-07 Robert Dewar <dewar@adacore.com>
+
+ * g-comlin.adb: Minor reformatting
+
+2009-04-07 Thomas Quinot <quinot@adacore.com>
+
+ * socket.c, g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.adb,
+ g-socthi-vxworks.ads, g-socthi-mingw.adb, g-socthi-mingw.ads,
+ g-socthi.adb, g-socthi.ads, g-socket.adb, g-socket.ads, g-sothco.ads:
+ Remove dynamic allocation of Fd_Set in Socket_Set_Type objects.
+
+2009-04-07 Robert Dewar <dewar@adacore.com>
+
* gnat_ugn.texi: Document -gnatDnn/-gnatGnn
* opt.ads (Sprint_Line_Limit): New parameter
end if;
Osint.Fail
- ("could not find unit ",
- Withed (Withed'First .. Last_Withed) & " needed by " &
- Withing (Withing'First .. Last_Withing) & Spec_Body);
+ ("could not find unit "
+ & Withed (Withed'First .. Last_Withed) & " needed by "
+ & Withing (Withing'First .. Last_Withing) & Spec_Body);
end;
end if;
procedure Bad_Argument is
begin
- Fail ("invalid argument """, Arg, """");
+ Fail ("invalid argument """ & Arg & """");
end Bad_Argument;
begin
Dir : constant String := Arg (3 .. Arg'Last);
begin
if not Is_Directory (Dir) then
- Fail (Dir, " is not a directory");
+ Fail (Dir & " is not a directory");
else
Add_Lib_Search_Dir (Dir);
end if;
Dir : constant String := Argument (Index);
begin
if not Is_Directory (Dir) then
- Fail (Dir, " is not a directory");
+ Fail (Dir & " is not a directory");
else
Add_Lib_Search_Dir (Dir);
end if;
else
Fail
- ("illegal external assignment '",
- Ext_Asgn, "'");
+ ("illegal external assignment '"
+ & Ext_Asgn
+ & "'");
end if;
end;
--
-- 0 None available
-- 2 RE_Str_Concat available, RE_Str_Concat_3 not available
- -- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
- -- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
+ -- 3 RE_Str_Concat/Concat_3 available, RE_Str_Concat_4 not available
+ -- 4 RE_Str_Concat/Concat_3/4 available, RE_Str_Concat_5 not available
-- 5 All routines including RE_Str_Concat_5 available
Char_Concat_Available : Boolean;
or else not Is_Limited_Type (Typ)
or else not Has_Interfaces (Typ)
or else not Build_Thunks
+ or else not RTE_Record_Component_Available (RE_OSD_Table)
then
-- No OSD table required
if Source_Config_File = No_Source_File then
Osint.Fail
- ("cannot find configuration pragmas file ",
- Config_File_Names (Index).all);
+ ("cannot find configuration pragmas file "
+ & Config_File_Names (Index).all);
end if;
Initialize_Scanner (No_Unit, Source_Config_File);
function Group_Analysis
(Prefix : String;
Group : String) return Boolean;
- -- Perform the analysis of a group of switches.
+ -- Perform the analysis of a group of switches
--------------------
-- Group_Analysis --
TPtr : Timeval_Access;
begin
- begin
- Status := Completed;
-
- -- No timeout or Forever is indicated by a null timeval pointer
-
- if Timeout = Forever then
- TPtr := null;
- else
- TVal := To_Timeval (Timeout);
- TPtr := TVal'Unchecked_Access;
- end if;
+ Status := Completed;
- -- Copy R_Socket_Set in RSet and add read signalling socket
+ -- No timeout or Forever is indicated by a null timeval pointer
- RSet := (Set => New_Socket_Set (R_Socket_Set.Set),
- Last => R_Socket_Set.Last);
- Set (RSet, RSig);
+ if Timeout = Forever then
+ TPtr := null;
+ else
+ TVal := To_Timeval (Timeout);
+ TPtr := TVal'Unchecked_Access;
+ end if;
- -- Copy W_Socket_Set in WSet
+ -- Copy R_Socket_Set in RSet and add read signalling socket
- WSet := (Set => New_Socket_Set (W_Socket_Set.Set),
- Last => W_Socket_Set.Last);
+ RSet := R_Socket_Set;
+ Set (RSet, RSig);
- -- Copy E_Socket_Set in ESet
+ -- Copy W_Socket_Set in WSet
- ESet := (Set => New_Socket_Set (E_Socket_Set.Set),
- Last => E_Socket_Set.Last);
+ WSet := W_Socket_Set;
- Last := C.int'Max (C.int'Max (C.int (RSet.Last),
- C.int (WSet.Last)),
- C.int (ESet.Last));
+ -- Copy E_Socket_Set in ESet
- Res :=
- C_Select
- (Last + 1,
- RSet.Set,
- WSet.Set,
- ESet.Set,
- TPtr);
+ ESet := E_Socket_Set;
- if Res = Failure then
- Raise_Socket_Error (Socket_Errno);
- end if;
+ Last := C.int'Max (C.int'Max (C.int (RSet.Last),
+ C.int (WSet.Last)),
+ C.int (ESet.Last));
- -- If Select was resumed because of read signalling socket, read this
- -- data and remove socket from set.
+ Res :=
+ C_Select
+ (Last + 1,
+ RSet.Set'Access,
+ WSet.Set'Access,
+ ESet.Set'Access,
+ TPtr);
- if Is_Set (RSet, RSig) then
- Clear (RSet, RSig);
+ if Res = Failure then
+ Raise_Socket_Error (Socket_Errno);
+ end if;
- Res := Signalling_Fds.Read (C.int (RSig));
+ -- If Select was resumed because of read signalling socket, read this
+ -- data and remove socket from set.
- if Res = Failure then
- Raise_Socket_Error (Socket_Errno);
- end if;
+ if Is_Set (RSet, RSig) then
+ Clear (RSet, RSig);
- Status := Aborted;
+ Res := Signalling_Fds.Read (C.int (RSig));
- elsif Res = 0 then
- Status := Expired;
+ if Res = Failure then
+ Raise_Socket_Error (Socket_Errno);
end if;
- -- Update RSet, WSet and ESet in regard to their new socket sets
+ Status := Aborted;
- Narrow (RSet);
- Narrow (WSet);
- Narrow (ESet);
-
- -- Reset RSet as it should be if R_Sig_Socket was not added
-
- if Is_Empty (RSet) then
- Empty (RSet);
- end if;
-
- if Is_Empty (WSet) then
- Empty (WSet);
- end if;
+ elsif Res = 0 then
+ Status := Expired;
+ end if;
- if Is_Empty (ESet) then
- Empty (ESet);
- end if;
+ -- Update RSet, WSet and ESet in regard to their new socket sets
- -- Deliver RSet, WSet and ESet
+ Narrow (RSet);
+ Narrow (WSet);
+ Narrow (ESet);
- Empty (R_Socket_Set);
- R_Socket_Set := RSet;
+ -- Reset RSet as it should be if R_Sig_Socket was not added
- Empty (W_Socket_Set);
- W_Socket_Set := WSet;
+ if Is_Empty (RSet) then
+ Empty (RSet);
+ end if;
- Empty (E_Socket_Set);
- E_Socket_Set := ESet;
+ if Is_Empty (WSet) then
+ Empty (WSet);
+ end if;
- exception
- when Socket_Error =>
+ if Is_Empty (ESet) then
+ Empty (ESet);
+ end if;
- -- The local socket sets must be emptied before propagating
- -- Socket_Error so the associated storage is freed.
+ -- Deliver RSet, WSet and ESet
- Empty (RSet);
- Empty (WSet);
- Empty (ESet);
- raise;
- end;
+ R_Socket_Set := RSet;
+ W_Socket_Set := WSet;
+ E_Socket_Set := ESet;
end Check_Selector;
-----------
Last : aliased C.int := C.int (Item.Last);
begin
if Item.Last /= No_Socket then
- Remove_Socket_From_Set (Item.Set, C.int (Socket));
- Last_Socket_In_Set (Item.Set, Last'Unchecked_Access);
+ Remove_Socket_From_Set (Item.Set'Access, C.int (Socket));
+ Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
Item.Last := Socket_Type (Last);
end if;
end Clear;
Target : in out Socket_Set_Type)
is
begin
- Empty (Target);
- if Source.Last /= No_Socket then
- Target.Set := New_Socket_Set (Source.Set);
- Target.Last := Source.Last;
- end if;
+ Target := Source;
end Copy;
---------------------
procedure Empty (Item : in out Socket_Set_Type) is
begin
- if Item.Set /= No_Fd_Set_Access then
- Free_Socket_Set (Item.Set);
- Item.Set := No_Fd_Set_Access;
- end if;
-
+ Reset_Socket_Set (Item.Set'Access);
Item.Last := No_Socket;
end Empty;
begin
if Item.Last /= No_Socket then
Get_Socket_From_Set
- (Item.Set, L'Unchecked_Access, S'Unchecked_Access);
+ (Item.Set'Access, L'Unchecked_Access, S'Unchecked_Access);
Item.Last := Socket_Type (L);
Socket := Socket_Type (S);
else
begin
return Item.Last /= No_Socket
and then Socket <= Item.Last
- and then Is_Socket_In_Set (Item.Set, C.int (Socket)) /= 0;
+ and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0;
end Is_Set;
-------------------
procedure Narrow (Item : in out Socket_Set_Type) is
Last : aliased C.int := C.int (Item.Last);
begin
- if Item.Set /= No_Fd_Set_Access then
- Last_Socket_In_Set (Item.Set, Last'Unchecked_Access);
+ if Item.Last /= No_Socket then
+ Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
Item.Last := Socket_Type (Last);
end if;
end Narrow;
procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
begin
- if Item.Set = No_Fd_Set_Access then
- Item.Set := New_Socket_Set (No_Fd_Set_Access);
+ if Item.Last = No_Socket then
+ -- Uninitialized socket set, make sure it is properly zeroed out
+
+ Reset_Socket_Set (Item.Set'Access);
Item.Last := Socket;
elsif Item.Last < Socket then
Item.Last := Socket;
end if;
-
- Insert_Socket_In_Set (Item.Set, C.int (Socket));
+ Insert_Socket_In_Set (Item.Set'Access, C.int (Socket));
end Set;
----------------------
with Ada.Streams;
with Ada.Unchecked_Deallocation;
+with Interfaces.C;
+
with System.OS_Constants;
+with System.Storage_Elements;
package GNAT.Sockets is
type Socket_Set_Type is limited private;
-- This type allows to manipulate sets of sockets. It allows to wait for
- -- events on multiple endpoints at one time. This is an access type on a
- -- system dependent structure. To avoid memory leaks it is highly
- -- recommended to clean the access value with procedure Empty.
+ -- events on multiple endpoints at one time. This type used to contain
+ -- a pointer to dynamically allocated storage, but this is not the case
+ -- anymore, and no special precautions are required to avoid memory leaks.
procedure Clear (Item : in out Socket_Set_Type; Socket : Socket_Type);
-- Remove Socket from Item
-- Copy Source into Target as Socket_Set_Type is limited private
procedure Empty (Item : in out Socket_Set_Type);
- -- Remove all Sockets from Item and deallocate internal data
+ -- Remove all Sockets from Item
procedure Get (Item : in out Socket_Set_Type; Socket : out Socket_Type);
-- Extract a Socket from socket set Item. Socket is set to
procedure Abort_Selector (Selector : Selector_Type);
-- Send an abort signal to the selector
- type Fd_Set_Access is private;
- No_Fd_Set_Access : constant Fd_Set_Access;
+ type Fd_Set is private;
-- ??? This type must not be used directly, it needs to be visible because
-- it is used in the visible part of GNAT.Sockets.Thin_Common. This is
-- really an inversion of abstraction. The private part of GNAT.Sockets
pragma Volatile (Selector_Type);
- type Fd_Set is null record;
+ type Fd_Set is
+ new System.Storage_Elements.Storage_Array (1 .. SOSC.SIZEOF_fd_set);
+ for Fd_Set'Alignment use Interfaces.C.int'Alignment;
+
type Fd_Set_Access is access all Fd_Set;
pragma Convention (C, Fd_Set_Access);
No_Fd_Set_Access : constant Fd_Set_Access := null;
type Socket_Set_Type is record
- Last : Socket_Type := No_Socket;
- Set : Fd_Set_Access;
+ Last : Socket_Type := No_Socket;
+ Set : aliased Fd_Set;
end record;
subtype Inet_Addr_Comp_Type is Natural range 0 .. 255;
function Standard_Select
(Nfds : C.int;
- Readfds : Fd_Set_Access;
- Writefds : Fd_Set_Access;
- Exceptfds : Fd_Set_Access;
+ Readfds : access Fd_Set;
+ Writefds : access Fd_Set;
+ Exceptfds : access Fd_Set;
Timeout : Timeval_Access) return C.int;
pragma Import (Stdcall, Standard_Select, "select");
function C_Select
(Nfds : C.int;
- Readfds : Fd_Set_Access;
- Writefds : Fd_Set_Access;
- Exceptfds : Fd_Set_Access;
+ Readfds : access Fd_Set;
+ Writefds : access Fd_Set;
+ Exceptfds : access Fd_Set;
Timeout : Timeval_Access) return C.int
is
pragma Warnings (Off, Exceptfds);
- RFS : constant Fd_Set_Access := Readfds;
- WFS : constant Fd_Set_Access := Writefds;
- WFSC : Fd_Set_Access := No_Fd_Set_Access;
- EFS : Fd_Set_Access := Exceptfds;
+ Original_WFS : aliased constant Fd_Set := Writefds.all;
+
Res : C.int;
S : aliased C.int;
Last : aliased C.int;
-- the initial write fd set, then move the socket from the
-- exception fd set to the write fd set.
- if WFS /= No_Fd_Set_Access then
+ if Writefds /= No_Fd_Set_Access then
-- Add any socket present in write fd set into exception fd set
- if EFS = No_Fd_Set_Access then
- EFS := New_Socket_Set (WFS);
-
- else
- WFSC := New_Socket_Set (WFS);
-
+ declare
+ WFS : aliased Fd_Set := Writefds.all;
+ begin
Last := Nfds - 1;
loop
Get_Socket_From_Set
- (WFSC, S'Unchecked_Access, Last'Unchecked_Access);
+ (WFS'Access, S'Unchecked_Access, Last'Unchecked_Access);
exit when S = -1;
- Insert_Socket_In_Set (EFS, S);
+ Insert_Socket_In_Set (Exceptfds, S);
end loop;
-
- Free_Socket_Set (WFSC);
- end if;
-
- -- Keep a copy of write fd set
-
- WFSC := New_Socket_Set (WFS);
+ end;
end if;
- Res := Standard_Select (Nfds, RFS, WFS, EFS, Timeout);
+ Res := Standard_Select (Nfds, Readfds, Writefds, Exceptfds, Timeout);
- if EFS /= No_Fd_Set_Access then
+ if Exceptfds /= No_Fd_Set_Access then
declare
- EFSC : constant Fd_Set_Access := New_Socket_Set (EFS);
+ EFSC : aliased Fd_Set := Exceptfds.all;
Flag : constant C.int := SOSC.MSG_PEEK + SOSC.MSG_OOB;
Buffer : Character;
Length : C.int;
Last := Nfds - 1;
loop
Get_Socket_From_Set
- (EFSC, S'Unchecked_Access, Last'Unchecked_Access);
+ (EFSC'Access, S'Unchecked_Access, Last'Unchecked_Access);
-- No more sockets in EFSC
-- Check out-of-band data
Length := C_Recvfrom
- (S, Buffer'Address, 1, Flag,
- null, Fromlen'Unchecked_Access);
+ (S, Buffer'Address, 1, Flag, null, Fromlen'Unchecked_Access);
-- If the signal is not an out-of-band data, then it
-- is a connection failure notification.
if Length = -1 then
- Remove_Socket_From_Set (EFS, S);
+ Remove_Socket_From_Set (Exceptfds, S);
- -- If S is present in the initial write fd set,
- -- move it from exception fd set back to write fd
- -- set. Otherwise, ignore this event since the user
- -- is not watching for it.
+ -- If S is present in the initial write fd set, move it from
+ -- exception fd set back to write fd set. Otherwise, ignore
+ -- this event since the user is not watching for it.
- if WFSC /= No_Fd_Set_Access
- and then (Is_Socket_In_Set (WFSC, S) /= 0)
+ if Writefds /= No_Fd_Set_Access
+ and then (Is_Socket_In_Set (Original_WFS'Access, S) /= 0)
then
- Insert_Socket_In_Set (WFS, S);
+ Insert_Socket_In_Set (Writefds, S);
end if;
end if;
end loop;
-
- Free_Socket_Set (EFSC);
end;
-
- if Exceptfds = No_Fd_Set_Access then
- Free_Socket_Set (EFS);
- end if;
end if;
-
- -- Free any copy of write fd set
-
- if WFSC /= No_Fd_Set_Access then
- Free_Socket_Set (WFSC);
- end if;
-
return Res;
end C_Select;
function C_Select
(Nfds : C.int;
- Readfds : Fd_Set_Access;
- Writefds : Fd_Set_Access;
- Exceptfds : Fd_Set_Access;
+ Readfds : access Fd_Set;
+ Writefds : access Fd_Set;
+ Exceptfds : access Fd_Set;
Timeout : Timeval_Access) return C.int;
function C_Send
package body GNAT.Sockets.Thin is
- Non_Blocking_Sockets : constant Fd_Set_Access :=
- New_Socket_Set (No_Fd_Set_Access);
+ Non_Blocking_Sockets : aliased Fd_Set;
-- When this package is initialized with Process_Blocking_IO set
-- to True, sockets are set in non-blocking mode to avoid blocking
-- the whole process when a thread wants to perform a blocking IO
(Domain, Typ, Protocol : C.int) return C.int;
pragma Import (C, Syscall_Socket, "socket");
- function Non_Blocking_Socket (S : C.int) return Boolean;
+ function Non_Blocking_Socket (S : C.int) return Boolean;
procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
--------------
end if;
declare
- WSet : Fd_Set_Access;
+ WSet : aliased Fd_Set;
Now : aliased Timeval;
begin
- WSet := New_Socket_Set (No_Fd_Set_Access);
+ Reset_Socket_Set (WSet'Access);
loop
- Insert_Socket_In_Set (WSet, S);
+ Insert_Socket_In_Set (WSet'Access, S);
Now := Immediat;
Res := C_Select
(S + 1,
No_Fd_Set_Access,
- WSet,
+ WSet'Access,
No_Fd_Set_Access,
Now'Unchecked_Access);
exit when Res > 0;
if Res = Failure then
- Free_Socket_Set (WSet);
return Res;
end if;
delay Quantum;
end loop;
-
- Free_Socket_Set (WSet);
end;
Res := Syscall_Connect (S, Name, Namelen);
procedure Initialize is
begin
- null;
+ Reset_Socket_Set (Non_Blocking_Sockets'Access);
end Initialize;
-------------------------
R : Boolean;
begin
Task_Lock.Lock;
- R := (Is_Socket_In_Set (Non_Blocking_Sockets, S) /= 0);
+ R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
Task_Lock.Unlock;
return R;
end Non_Blocking_Socket;
Task_Lock.Lock;
if V then
- Insert_Socket_In_Set (Non_Blocking_Sockets, S);
+ Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
else
- Remove_Socket_From_Set (Non_Blocking_Sockets, S);
+ Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
end if;
Task_Lock.Unlock;
function C_Select
(Nfds : C.int;
- Readfds : Fd_Set_Access;
- Writefds : Fd_Set_Access;
- Exceptfds : Fd_Set_Access;
+ Readfds : access Fd_Set;
+ Writefds : access Fd_Set;
+ Exceptfds : access Fd_Set;
Timeout : Timeval_Access) return C.int;
function C_Send
package body GNAT.Sockets.Thin is
- Non_Blocking_Sockets : constant Fd_Set_Access :=
- New_Socket_Set (No_Fd_Set_Access);
+ Non_Blocking_Sockets : aliased Fd_Set;
-- When this package is initialized with Process_Blocking_IO set
-- to True, sockets are set in non-blocking mode to avoid blocking
-- the whole process when a thread wants to perform a blocking IO
Protocol : C.int) return C.int;
pragma Import (C, Syscall_Socket, "socket");
- function Non_Blocking_Socket (S : C.int) return Boolean;
+ function Non_Blocking_Socket (S : C.int) return Boolean;
procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
--------------
end if;
declare
- WSet : Fd_Set_Access;
+ WSet : aliased Fd_Set;
Now : aliased Timeval;
-
begin
- WSet := New_Socket_Set (No_Fd_Set_Access);
-
+ Reset_Socket_Set (WSet'Access);
loop
- Insert_Socket_In_Set (WSet, S);
+ Insert_Socket_In_Set (WSet'Access, S);
Now := Immediat;
Res := C_Select
(S + 1,
No_Fd_Set_Access,
- WSet,
+ WSet'Access,
No_Fd_Set_Access,
Now'Unchecked_Access);
exit when Res > 0;
if Res = Failure then
- Free_Socket_Set (WSet);
return Res;
end if;
delay Quantum;
end loop;
-
- Free_Socket_Set (WSet);
end;
Res := Syscall_Connect (S, Name, Namelen);
procedure Initialize is
begin
- null;
+ Reset_Socket_Set (Non_Blocking_Sockets'Access);
end Initialize;
-------------------------
R : Boolean;
begin
Task_Lock.Lock;
- R := (Is_Socket_In_Set (Non_Blocking_Sockets, S) /= 0);
+ R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
Task_Lock.Unlock;
return R;
end Non_Blocking_Socket;
begin
Task_Lock.Lock;
if V then
- Insert_Socket_In_Set (Non_Blocking_Sockets, S);
+ Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
else
- Remove_Socket_From_Set (Non_Blocking_Sockets, S);
+ Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
end if;
Task_Lock.Unlock;
function C_Select
(Nfds : C.int;
- Readfds : Fd_Set_Access;
- Writefds : Fd_Set_Access;
- Exceptfds : Fd_Set_Access;
+ Readfds : access Fd_Set;
+ Writefds : access Fd_Set;
+ Exceptfds : access Fd_Set;
Timeout : Timeval_Access) return C.int;
function C_Send
package body GNAT.Sockets.Thin is
- Non_Blocking_Sockets : constant Fd_Set_Access :=
- New_Socket_Set (No_Fd_Set_Access);
+ Non_Blocking_Sockets : aliased Fd_Set;
-- When this package is initialized with Process_Blocking_IO set
-- to True, sockets are set in non-blocking mode to avoid blocking
-- the whole process when a thread wants to perform a blocking IO
end if;
declare
- WSet : Fd_Set_Access;
+ WSet : aliased Fd_Set;
Now : aliased Timeval;
begin
- WSet := New_Socket_Set (No_Fd_Set_Access);
+ Reset_Socket_Set (WSet'Access);
loop
- Insert_Socket_In_Set (WSet, S);
+ Insert_Socket_In_Set (WSet'Access, S);
Now := Immediat;
Res := C_Select
(S + 1,
No_Fd_Set_Access,
- WSet,
+ WSet'Access,
No_Fd_Set_Access,
Now'Unchecked_Access);
exit when Res > 0;
if Res = Failure then
- Free_Socket_Set (WSet);
return Res;
end if;
delay Quantum;
end loop;
-
- Free_Socket_Set (WSet);
end;
Res := Syscall_Connect (S, Name, Namelen);
procedure Initialize is
begin
Disable_All_SIGPIPEs;
+ Reset_Socket_Set (Non_Blocking_Sockets'Access);
end Initialize;
-------------------------
R : Boolean;
begin
Task_Lock.Lock;
- R := (Is_Socket_In_Set (Non_Blocking_Sockets, S) /= 0);
+ R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
Task_Lock.Unlock;
return R;
end Non_Blocking_Socket;
Task_Lock.Lock;
if V then
- Insert_Socket_In_Set (Non_Blocking_Sockets, S);
+ Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
else
- Remove_Socket_From_Set (Non_Blocking_Sockets, S);
+ Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
end if;
Task_Lock.Unlock;
function C_Select
(Nfds : C.int;
- Readfds : Fd_Set_Access;
- Writefds : Fd_Set_Access;
- Exceptfds : Fd_Set_Access;
+ Readfds : access Fd_Set;
+ Writefds : access Fd_Set;
+ Exceptfds : access Fd_Set;
Timeout : Timeval_Access) return C.int;
function C_Send
pragma Convention (C, Int_Access);
-- Access to C integers
- procedure Free_Socket_Set (Set : Fd_Set_Access);
- -- Free system-dependent socket set
-
procedure Get_Socket_From_Set
- (Set : Fd_Set_Access;
+ (Set : access Fd_Set;
Socket : Int_Access;
Last : Int_Access);
-- Get last socket in Socket and remove it from the socket set. The
-- socket set.
procedure Insert_Socket_In_Set
- (Set : Fd_Set_Access;
+ (Set : access Fd_Set;
Socket : C.int);
-- Insert socket in the socket set
function Is_Socket_In_Set
- (Set : Fd_Set_Access;
+ (Set : access constant Fd_Set;
Socket : C.int) return C.int;
-- Check whether Socket is in the socket set, return a non-zero
-- value if it is, zero if it is not.
procedure Last_Socket_In_Set
- (Set : Fd_Set_Access;
+ (Set : access Fd_Set;
Last : Int_Access);
-- Find the largest socket in the socket set. This is needed for select().
-- When Last_Socket_In_Set is called, parameter Last is a maximum value of
-- socket sets. After the call, Last is set back to the real largest socket
-- in the socket set.
- function New_Socket_Set
- (Set : Fd_Set_Access) return Fd_Set_Access;
- -- Allocate a new socket set which is a system-dependent structure and
- -- initialize by copying Set if it is non-null, by making it empty
- -- otherwise.
-
- procedure Remove_Socket_From_Set
- (Set : Fd_Set_Access;
- Socket : C.int);
+ procedure Remove_Socket_From_Set (Set : access Fd_Set; Socket : C.int);
-- Remove socket from the socket set
+ procedure Reset_Socket_Set (Set : access Fd_Set);
+ -- Make Set empty
+
------------------------------------------
-- Pairs of signalling file descriptors --
------------------------------------------
-- file descriptors.
private
-
- pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set");
pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set");
pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set");
pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set");
- pragma Import (C, New_Socket_Set, "__gnat_new_socket_set");
pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set");
pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set");
+ pragma Import (C, Reset_Socket_Set, "__gnat_reset_socket_set");
end GNAT.Sockets.Thin_Common;
if Targparm.GCC_ZCX_Support_On_Target then
Exception_Mechanism := Back_End_Exceptions;
else
- Osint.Fail
- ("Zero Cost Exceptions not supported on this target");
+ Osint.Fail ("Zero Cost Exceptions not supported on this target");
end if;
end if;
if Command_List (The_Command).VMS_Only then
Non_VMS_Usage;
Fail
- ("Command """,
- Command_List (The_Command).Cname.all,
- """ can only be used on VMS");
+ ("Command """
+ & Command_List (The_Command).Cname.all
+ & """ can only be used on VMS");
end if;
exception
exception
when Constraint_Error =>
Non_VMS_Usage;
- Fail ("Unknown command: ", Argument (Command_Arg));
+ Fail ("Unknown command: " & Argument (Command_Arg));
end;
end;
when '2' =>
Current_Verbosity := Prj.High;
when others =>
- Fail ("Invalid switch: ", Argv.all);
+ Fail ("Invalid switch: " & Argv.all);
end case;
Remove_Switch (Arg_Num);
if Project_File /= null then
Fail
- (Argv.all,
- ": second project file forbidden (first is """,
- Project_File.all & """)");
+ (Argv.all
+ & ": second project file forbidden (first is """
+ & Project_File.all
+ & """)");
-- The two style project files (-p and -P) cannot be
-- used together.
Value => Argv (Equal_Pos + 1 .. Argv'Last));
else
Fail
- (Argv.all,
- " is not a valid external assignment.");
+ (Argv.all
+ & " is not a valid external assignment.");
end if;
end;
Packages_To_Check => Packages_To_Check);
if Project = Prj.No_Project then
- Fail ("""", Project_File.all, """ processing failed");
+ Fail ("""" & Project_File.all & """ processing failed");
end if;
-- Check if a package with the name of the tool is in the project
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- --
-- 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- --
elsif (Argv'Length = 3 and then Argv (3) = '-')
or else (Argv'Length = 4 and then Argv (4) = '-')
then
- Fail ("Trailing ""-"" at the end of ", Argv, " forbidden.");
+ Fail ("Trailing ""-"" at the end of " & Argv & " forbidden.");
-- Processing for -Idir
Excluded_Pattern_Expected : Boolean;
procedure Check_Regular_Expression (S : String);
- -- Compile string S into a Regexp. Fail if any error.
+ -- Compile string S into a Regexp, fail if any error
-----------------------------
-- Check_Regular_Expression--
Dummy := Compile (S, Glob => True);
exception
when Error_In_Regexp =>
- Fail ("invalid regular expression """, S, """");
+ Fail ("invalid regular expression """ & S & """");
end Check_Regular_Expression;
-- Start of processing for Scan_Args
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2008, Free Software Foundation, Inc. --
-- --
-- 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- --
Version_String := new String'(GNAT.Command_Line.Parameter);
when others =>
- Fail ("invalid switch: ", Full_Switch);
+ Fail ("invalid switch: " & Full_Switch);
end case;
end loop;
exception
when Invalid_Switch =>
Usage;
- Fail ("invalid switch : ", Full_Switch);
+ Fail ("invalid switch : " & Full_Switch);
end Parse_Cmd_Line;
-----------
Sinput.Main_Source_File := Deffile;
if Deffile = No_Source_File then
- Fail ("unable to find definition file """,
- Get_Name_String (Deffile_Name),
- """");
+ Fail ("unable to find definition file """
+ & Get_Name_String (Deffile_Name)
+ & """");
end if;
Scanner.Initialize_Scanner (Deffile);
if Total_Errors_Detected > 0 then
Errutil.Finalize (Source_Type => "definition");
- Fail ("errors in definition file """,
- Get_Name_String (Deffile_Name), """");
+ Fail ("errors in definition file """
+ & Get_Name_String (Deffile_Name)
+ & """");
end if;
-- If -s switch was specified, print a sorted list of symbol names and
exception
when others =>
Fail
- ("unable to create output file """,
- Get_Name_String (Outfile_Name), """");
+ ("unable to create output file """
+ & Get_Name_String (Outfile_Name)
+ & """");
end;
-- Load the input file
Infile := Sinput.C.Load_File (Get_Name_String (Infile_Name));
if Infile = No_Source_File then
- Fail ("unable to find input file """,
- Get_Name_String (Infile_Name), """");
+ Fail ("unable to find input file """
+ & Get_Name_String (Infile_Name)
+ & """");
end if;
-- Set Main_Source_File to the input file for the benefit of
exception
when Directory_Error =>
- Fail ("could not create directory """,
- Output, """");
+ Fail ("could not create directory """
+ & Output
+ & """");
end;
end if;
Link_With_Shared_Libgcc : Argument_List_Access :=
No_Shared_Libgcc_Switch'Access;
- procedure Make_Failed (S1 : String; S2 : String := ""; S3 : String := "");
- -- Delete all temp files created by Gnatmake and call Osint.Fail,
- -- with the parameter S1, S2 and S3 (see osint.ads).
- -- This is called from the Prj hierarchy and the MLib hierarchy.
+ procedure Make_Failed (S : String);
+ -- Delete all temp files created by Gnatmake and call Osint.Fail, with the
+ -- parameter S (see osint.ads). This is called from the Prj hierarchy and
+ -- the MLib hierarchy.
--------------------------
-- Obsolete Executables --
"it to Global_Compilation_Switches.",
Element.Location);
Errutil.Finalize;
- Make_Failed
- ("*** illegal switch """, Argv, """");
+ Make_Failed ("*** illegal switch """ & Argv & """");
end if;
end;
end if;
Display (Gnatbind.all, Bind_Args (Args'First .. Bind_Last));
if Gnatbind_Path = null then
- Make_Failed ("error, unable to locate ", Gnatbind.all);
+ Make_Failed ("error, unable to locate " & Gnatbind.all);
end if;
GNAT.OS_Lib.Spawn
Display (Gcc.all, Comp_Args (Args'First .. Comp_Last));
if Gcc_Path = null then
- Make_Failed ("error, unable to locate ", Gcc.all);
+ Make_Failed ("error, unable to locate " & Gcc.all);
end if;
return
and then Arguments_Project = No_Project
and then not External_Unit_Compilation_Allowed
then
- Make_Failed ("external source (",
- Get_Name_String (Source_File),
- ") is not part of any project;"
- & " cannot be compiled without" &
- " gnatmake switch -x");
+ Make_Failed ("external source ("
+ & Get_Name_String (Source_File)
+ & ") is not part of any project;"
+ & " cannot be compiled without"
+ & " gnatmake switch -x");
end if;
-- Is this the first file we have to compile?
if not Is_Regular_File (Path) then
if Debug.Debug_Flag_F then
Make_Failed
- ("cannot find configuration pragmas file ",
- File_Name (Path));
+ ("cannot find configuration pragmas file "
+ & File_Name (Path));
else
Make_Failed
- ("cannot find configuration pragmas file ",
- Path);
+ ("cannot find configuration pragmas file " & Path);
end if;
end if;
if not Is_Regular_File (Path) then
if Debug.Debug_Flag_F then
Make_Failed
- ("cannot find configuration pragmas file ",
- File_Name (Path));
+ ("cannot find configuration pragmas file "
+ & File_Name (Path));
else
Make_Failed
- ("cannot find configuration pragmas file ", Path);
+ ("cannot find configuration pragmas file " & Path);
end if;
end if;
if Proj = No_Project then
Make_Failed
- ("""" & Main &
- """ is not a source of any project");
+ ("""" & Main & """ is not a source of any project");
else
-- If there is directory information, check that
-- Fail if the file cannot be found
if Real_Path = null then
- Make_Failed
- ("file """ & Main & """ does not exist");
+ Make_Failed ("file """ & Main & """ does not exist");
end if;
declare
if not At_Least_One_Main then
Make_Failed
- ("no Ada mains; use -B to build foreign main");
+ ("no Ada mains, use -B to build foreign main");
end if;
end;
-- We fail if we cannot find the main source file
if Main_Unit_File_Name = "" then
- Make_Failed ('"' & Main_Source_File_Name,
- """ is not a unit of project ",
- Project_File_Name.all & ".");
+ Make_Failed ('"' & Main_Source_File_Name
+ & """ is not a unit of project "
+ & Project_File_Name.all & ".");
else
-- Remove any directory information from the main
-- source file name.
No_Path_Information
then
Make_Failed
- ("no object files to build library for project """,
- Get_Name_String
- (Project_Tree.Projects.Table (Proj).Name),
- """");
+ ("no object files to build library for project """
+ & Get_Name_String
+ (Project_Tree.Projects.Table (Proj).Name)
+ & """");
Project_Tree.Projects.Table
(Proj).Need_To_Build_Lib := False;
-- as an immediate source of the main project file.
if Main_Unit_File_Name = "" then
- Make_Failed ('"' & Main_Source_File_Name,
- """ is not a unit of project ",
- Project_File_Name.all & ".");
+ Make_Failed ('"' & Main_Source_File_Name
+ & """ is not a unit of project "
+ & Project_File_Name.all & ".");
else
-- Remove any directory information from the main
end if;
if Main_Project = No_Project then
- Make_Failed ("""", Project_File_Name.all, """ processing failed");
+ Make_Failed
+ ("""" & Project_File_Name.all & """ processing failed");
end if;
Create_Mapping_File := True;
Display (Gnatlink.all, Link_Args);
if Gnatlink_Path = null then
- Make_Failed ("error, unable to locate ", Gnatlink.all);
+ Make_Failed ("error, unable to locate " & Gnatlink.all);
end if;
GNAT.OS_Lib.Spawn (Gnatlink_Path.all, Link_Args, Success);
-- Make_Failed --
-----------------
- procedure Make_Failed (S1 : String; S2 : String := ""; S3 : String := "") is
+ procedure Make_Failed (S : String) is
begin
Delete_All_Temp_Files;
- Osint.Fail (S1, S2, S3);
+ Osint.Fail (S);
end Make_Failed;
--------------------
Make_Failed ("object directory path name missing after -D");
elsif not Is_Directory (Argv) then
- Make_Failed ("cannot find object directory """, Argv, """");
+ Make_Failed ("cannot find object directory """ & Argv & """");
else
Add_Lib_Search_Dir (Argv);
or else (Argv'Length > 10 and then Argv (1 .. 10) = "-GNATLINK=")
or else (Argv'Length > 10 and then Argv (1 .. 10) = "-GNATBIND=")
then
- Make_Failed ("option ", Argv, " should start with '--'");
+ Make_Failed ("option " & Argv & " should start with '--'");
-- -I-
elsif (Argv'Length = 3 and then Argv (3) = '-')
or else (Argv'Length = 4 and then Argv (4) = '-')
then
- Make_Failed ("trailing ""-"" at the end of ", Argv, " forbidden.");
+ Make_Failed
+ ("trailing ""-"" at the end of " & Argv & " forbidden.");
-- -Idir
elsif Argv'Last > 2 and then Argv (2) = 'C' then
if And_Save then
if Argv (3) /= '=' or else Argv'Last <= 3 then
- Make_Failed ("illegal switch ", Argv);
+ Make_Failed ("illegal switch " & Argv);
end if;
Gnatmake_Mapping_File := new String'(Argv (4 .. Argv'Last));
if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
if Parent = null or else Parent'Length = 0 then
Do_Fail
- ("relative search path switches (""",
- Sw,
- """) are not allowed");
+ ("relative search path switches ("""
+ & Sw
+ & """) are not allowed");
else
Switch :=
if not Is_Absolute_Path (Sw) then
if Parent = null or else Parent'Length = 0 then
Do_Fail
- ("relative paths (""", Sw, """) are not allowed");
+ ("relative paths (""" & Sw & """) are not allowed");
else
Switch :=
package Makeutl is
- type Fail_Proc is access procedure
- (S1 : String;
- S2 : String := "";
- S3 : String := "");
+ type Fail_Proc is access procedure (S : String);
Do_Fail : Fail_Proc := Osint.Fail'Access;
-- Failing procedure called from procedure Test_If_Relative_Path below.
-- May be redirected.
-- Fail if project is not a library project
if not Data.Library then
- Com.Fail ("project """, Project_Name, """ has no library");
+ Com.Fail ("project """ & Project_Name & """ has no library");
end if;
-- Do not attempt to build the library if it is externally built
if Bind then
if Gnatbind_Path = null then
- Com.Fail ("unable to locate ", Gnatbind);
+ Com.Fail ("unable to locate " & Gnatbind);
end if;
if Gcc_Path = null then
- Com.Fail ("unable to locate ", Gcc);
+ Com.Fail ("unable to locate " & Gcc);
end if;
-- Allocate Arguments, if it is the first time we see a standalone
end if;
if not Success then
- Com.Fail ("could not bind standalone library ",
- Get_Name_String (Data.Library_Name));
+ Com.Fail ("could not bind standalone library "
+ & Get_Name_String (Data.Library_Name));
end if;
end if;
if not Success then
Com.Fail
- ("could not compile binder generated file for library ",
- Get_Name_String (Data.Library_Name));
+ ("could not compile binder generated file for library "
+ & Get_Name_String (Data.Library_Name));
end if;
-- Process binder generated file for pragmas Linker_Options
exception
when Directory_Error =>
- Com.Fail ("cannot find object directory """,
- Get_Name_String
- (Data.Object_Directory.Display_Name),
- """");
+ Com.Fail ("cannot find object directory """
+ & Get_Name_String
+ (Data.Object_Directory.Display_Name)
+ & """");
end;
end if;
exception
when others =>
Com.Fail
- ("unable to access library directory """,
- Name_Buffer (1 .. Name_Len),
- """");
+ ("unable to access library directory """
+ & Name_Buffer (1 .. Name_Len)
+ & """");
end;
Open (Dir, ".");
exception
when others =>
Com.Fail
- ("unable to access library source copy directory """,
- Name_Buffer (1 .. Name_Len),
- """");
+ ("unable to access library source copy directory """
+ & Name_Buffer (1 .. Name_Len)
+ & """");
end;
declare
procedure Check (Filename : String) is
begin
if not Is_Regular_File (Filename) then
- Com.Fail (Filename, " not found.");
+ Com.Fail (Filename & " not found.");
end if;
end Check;
exception
when Constraint_Error =>
- Fail ("illegal version """, Lib_Version,
- """ (on VMS version must be a positive number)");
+ Fail ("illegal version """
+ & Lib_Version
+ & """ (on VMS version must be a positive number)");
return "";
end;
end if;
Gnatsym_Path := Locate_Exec_On_Path (Gnatsym_Name);
if Gnatsym_Path = null then
- Fail (Gnatsym_Name, " not found in path");
+ Fail (Gnatsym_Name & " not found in path");
end if;
end if;
end if;
if not OK then
- Fail ("creation of auto-init assembly file """,
- Macro_File_Name, """ failed");
+ Fail ("creation of auto-init assembly file """
+ & Macro_File_Name
+ & """ failed");
end if;
end;
mode (mode'First)'Address);
if Popen_Result = Null_Address then
- Fail ("assembly of auto-init assembly file """,
- Macro_File_Name, """ failed");
+ Fail ("assembly of auto-init assembly file """
+ & Macro_File_Name
+ & """ failed");
end if;
-- Wait for the end of execution of the macro-assembler
Pclose_Result := pclose (Popen_Result);
if Pclose_Result < 0 then
- Fail ("assembly of auto init assembly file """,
- Macro_File_Name, """ failed");
+ Fail ("assembly of auto init assembly file """
+ & Macro_File_Name
+ & """ failed");
end if;
-- Add the generated object file to the list of objects to be
Success => Success);
if not Success then
- Fail ("unable to create symbol file for library """,
- Lib_Filename, """");
+ Fail ("unable to create symbol file for library """
+ & Lib_Filename
+ & """");
end if;
Free (Arguments);
exception
when Constraint_Error =>
- Fail ("illegal version """, Lib_Version,
- """ (on VMS version must be a positive number)");
+ Fail ("illegal version """
+ & Lib_Version
+ & """ (on VMS version must be a positive number)");
return "";
end;
end if;
then
For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name);
else
- Fail ("Options File """, Opt_File_Name, """ must end with .opt");
+ Fail ("Options File """ & Opt_File_Name & """ must end with .opt");
end if;
VMS_Options (VMS_Options'First) := For_Linker_Opt;
Gnatsym_Path := Locate_Exec_On_Path (Gnatsym_Name);
if Gnatsym_Path = null then
- Fail (Gnatsym_Name, " not found in path");
+ Fail (Gnatsym_Name & " not found in path");
end if;
end if;
end if;
if not OK then
- Fail ("creation of auto-init assembly file """,
- Macro_File_Name, """ failed");
+ Fail ("creation of auto-init assembly file """
+ & Macro_File_Name
+ & """ failed");
end if;
end;
mode (mode'First)'Address);
if Popen_Result = Null_Address then
- Fail ("assembly of auto-init assembly file """,
- Macro_File_Name, """ failed");
+ Fail ("assembly of auto-init assembly file """
+ & Macro_File_Name
+ & """ failed");
end if;
-- Wait for the end of execution of the macro-assembler
Pclose_Result := pclose (Popen_Result);
if Pclose_Result < 0 then
- Fail ("assembly of auto init assembly file """,
- Macro_File_Name, """ failed");
+ Fail ("assembly of auto init assembly file """
+ & Macro_File_Name
+ & """ failed");
end if;
-- Add the generated object file to the list of objects to be
Success => Success);
if not Success then
- Fail ("unable to create symbol file for library """,
- Lib_Filename, """");
+ Fail ("unable to create symbol file for library """
+ & Lib_Filename
+ & """");
end if;
Free (Arguments);
end if;
if Ar_Exec = null then
- Fail (Ar_Name.all, " not found in path");
+ Fail (Ar_Name.all & " not found in path");
elsif Opt.Verbose_Mode then
Write_Str ("found ");
end if;
if not Success then
- Fail (Ar_Name.all, " execution error.");
+ Fail (Ar_Name.all & " execution error.");
end if;
-- If we have found ranlib, run it over the library
Success);
if not Success then
- Fail (Ranlib_Name.all, " execution error.");
+ Fail (Ranlib_Name.all & " execution error.");
end if;
end if;
end Ar;
Gcc_Exec := Locate_Exec_On_Path (Gcc_Name.all);
if Gcc_Exec = null then
- Fail (Gcc_Name.all, " not found in path");
+ Fail (Gcc_Name.all & " not found in path");
end if;
end if;
Driver := Locate_Exec_On_Path (Get_Name_String (Driver_Name));
if Driver = null then
- Fail (Get_Name_String (Driver_Name), " not found in path");
+ Fail (Get_Name_String (Driver_Name) & " not found in path");
end if;
end if;
if not Success then
if Driver_Name = No_Name then
- Fail (Gcc_Name.all, " execution error");
+ Fail (Gcc_Name.all & " execution error");
else
- Fail (Get_Name_String (Driver_Name), " execution error");
+ Fail (Get_Name_String (Driver_Name) & " execution error");
end if;
end if;
end Gcc;
end if;
if Name'Length > Max_Characters_In_Library_Name then
- Prj.Com.Fail ("illegal library name """, Name, """: too long");
+ Prj.Com.Fail ("illegal library name """
+ & Name
+ & """: too long");
end if;
if not Is_Letter (Name (Name'First)) then
- Prj.Com.Fail ("illegal library name """,
- Name,
- """: should start with a letter");
+ Prj.Com.Fail ("illegal library name """
+ & Name
+ & """: should start with a letter");
end if;
for Index in Name'Range loop
if not Is_Alphanumeric (Name (Index)) then
- Prj.Com.Fail ("illegal library name """,
- Name,
- """: should include only letters and digits");
+ Prj.Com.Fail ("illegal library name """
+ & Name
+ & """: should include only letters and digits");
end if;
end loop;
end Check_Library_Name;
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2007, AdaCore --
+-- Copyright (C) 1999-2008, 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- --
-- Maximum number of characters in a library name.
-- Used by Check_Library_Name below.
- type Fail_Proc is access procedure
- (S1 : String; S2 : String := ""; S3 : String := "");
+ type Fail_Proc is access procedure (S1 : String);
Fail : Fail_Proc := Osint.Fail'Access;
-- This procedure is used in the MLib hierarchy, instead of
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2008, Free Software Foundation, Inc. --
-- --
-- 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- --
if not Status then
Fail
- ("error while closing generated file ",
- Get_Name_String (Output_File_Name));
+ ("error while closing generated file "
+ & Get_Name_String (Output_File_Name));
end if;
end Close_Binder_Output;
if not Status then
Fail
- ("error while closing expanded source file ",
- Get_Name_String (Output_File_Name));
+ ("error while closing expanded source file "
+ & Get_Name_String (Output_File_Name));
end if;
end Close_Debug_File;
if not Status then
Fail
- ("error while closing list file ",
- Get_Name_String (Output_File_Name));
+ ("error while closing list file "
+ & Get_Name_String (Output_File_Name));
end if;
end Close_List_File;
if not Status then
Fail
- ("error while closing ALI file ",
- Get_Name_String (Output_File_Name));
+ ("error while closing ALI file "
+ & Get_Name_String (Output_File_Name));
end if;
end Close_Output_Library_Info;
if not Status then
Fail
- ("error while closing representation info file ",
- Get_Name_String (Output_File_Name));
+ ("error while closing representation info file "
+ & Get_Name_String (Output_File_Name));
end if;
end Close_Repinfo_File;
if not Status then
Fail
- ("error while closing tree file ",
- Get_Name_String (Output_File_Name));
+ ("error while closing tree file "
+ & Get_Name_String (Output_File_Name));
end if;
end Tree_Close;
Fdesc := Create_File (Name_Buffer'Address, Fmode);
if Fdesc = Invalid_FD then
- Fail ("Cannot create: ", Name_Buffer (1 .. Name_Len));
+ Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
end if;
end Create_File_And_Check;
-- Fail --
----------
- procedure Fail (S1 : String; S2 : String := ""; S3 : String := "") is
+ procedure Fail (S : String) is
begin
-- We use Output in case there is a special output set up.
-- In this case Set_Standard_Error will have no immediate effect.
Set_Standard_Error;
Osint.Write_Program_Name;
Write_Str (": ");
- Write_Str (S1);
- Write_Str (S2);
- Write_Str (S3);
+ Write_Str (S);
Write_Eol;
Exit_Program (E_Fatal);
if Current_Full_Lib_Name = No_File then
if Fatal_Err then
- Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
+ Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
else
Current_Full_Obj_Stamp := Empty_Time_Stamp;
return null;
if Lib_FD = Invalid_FD then
if Fatal_Err then
- Fail ("Cannot open: ", Name_Buffer (1 .. Name_Len));
+ Fail ("Cannot open: " & Name_Buffer (1 .. Name_Len));
else
Current_Full_Obj_Stamp := Empty_Time_Stamp;
return null;
-- No need to check the status, we fail anyway
- Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
+ Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
else
Current_Full_Obj_Stamp := Empty_Time_Stamp;
if N = Current_Main then
Get_Name_String (N);
- Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
+ Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
end if;
Src := null;
exception
when others =>
- Fail ("erroneous directory spec: ", Host_Dir);
+ Fail ("erroneous directory spec: " & Host_Dir);
return null;
end To_Canonical_Dir_Spec;
exception
when others =>
- Fail ("erroneous file spec: ", Host_File);
+ Fail ("erroneous file spec: " & Host_File);
return null;
end To_Canonical_File_Spec;
exception
when others =>
- Fail ("erroneous path spec: ", Host_Path);
+ Fail ("erroneous path spec: " & Host_Path);
return null;
end To_Canonical_Path_Spec;
-- Writes name of program as invoked to the current output (normally
-- standard output).
- procedure Fail (S1 : String; S2 : String := ""; S3 : String := "");
+ procedure Fail (S : String);
pragma No_Return (Fail);
- -- Outputs error messages S1 & S2 & S3 preceded by the name of the
- -- executing program and exits with E_Fatal. The output goes to standard
- -- error, except if special output is in effect (see Output).
+ -- Outputs error message S preceded by the name of the executing program
+ -- and exits with E_Fatal. The output goes to standard error, except if
+ -- special output is in effect (see Output).
function Is_Directory_Separator (C : Character) return Boolean;
-- Returns True if C is a directory separator
Result := True_Value;
elsif Index = Definition'First then
- Fail ("invalid symbol definition """, Definition, """");
+ Fail ("invalid symbol definition """ & Definition & """");
else
-- Put the symbol in the name buffer
null;
when others =>
- Fail ("illegal value """,
- Definition (Index + 1 .. Definition'Last),
- """");
+ Fail ("illegal value """
+ & Definition (Index + 1 .. Definition'Last)
+ & """");
end case;
end loop;
end if;
if Name_Buffer (1) not in 'a' .. 'z'
and then Name_Buffer (1) not in 'A' .. 'Z'
then
- Fail ("symbol """,
- Name_Buffer (1 .. Name_Len),
- """ does not start with a letter");
+ Fail ("symbol """
+ & Name_Buffer (1 .. Name_Len)
+ & """ does not start with a letter");
end if;
for J in 2 .. Name_Len loop
when '_' =>
if J = Name_Len then
- Fail ("symbol """,
- Name_Buffer (1 .. Name_Len),
- """ end with a '_'");
+ Fail ("symbol """
+ & Name_Buffer (1 .. Name_Len)
+ & """ end with a '_'");
elsif Name_Buffer (J + 1) = '_' then
- Fail ("symbol """,
- Name_Buffer (1 .. Name_Len),
- """ contains consecutive '_'");
+ Fail ("symbol """
+ & Name_Buffer (1 .. Name_Len)
+ & """ contains consecutive '_'");
end if;
when others =>
- Fail ("symbol """,
- Name_Buffer (1 .. Name_Len),
- """ contains illegal character(s)");
+ Fail ("symbol """
+ & Name_Buffer (1 .. Name_Len)
+ & """ contains illegal character(s)");
end case;
end loop;
if Source_Index_Of_Preproc_Data_File = No_Source_File then
Get_Name_String (N);
- Fail ("preprocessing data file """,
- Name_Buffer (1 .. Name_Len),
- """ not found");
+ Fail ("preprocessing data file """
+ & Name_Buffer (1 .. Name_Len)
+ & """ not found");
end if;
-- Initialize scanner and set its behavior for processing a data file
if Total_Errors_Detected > T then
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
- Fail ("errors found in preprocessing data file """,
- Get_Name_String (N),
- """");
+ Fail ("errors found in preprocessing data file """
+ & Get_Name_String (N) & """");
end if;
-- Record the dependency on the preprocessor data file
begin
if Deffile = No_Source_File then
- Fail ("definition file """,
- Get_Name_String (N),
- """ cannot be found");
+ Fail ("definition file """
+ & Get_Name_String (N)
+ & """ cannot be found");
end if;
-- Initialize the preprocessor and set the characteristics of the
if T /= Total_Errors_Detected then
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
- Fail ("errors found in definition file """,
- Get_Name_String (N),
- """");
+ Fail ("errors found in definition file """
+ & Get_Name_String (N)
+ & """");
end if;
for Index in 1 .. Dependencies.Last loop
for Index in First_Package .. Package_Attributes.Last loop
if Package_Name = Package_Attributes.Table (Index).Name then
- Osint.Fail ("duplicate name """,
- Initialization_Data (Start .. Finish - 1),
- """ in predefined packages.");
+ Osint.Fail ("duplicate name """
+ & Initialization_Data (Start .. Finish - 1)
+ & """ in predefined packages.");
end if;
end loop;
for Index in First_Attribute .. Attrs.Last - 1 loop
if Attribute_Name = Attrs.Table (Index).Name then
- Osint.Fail ("duplicate attribute """,
- Initialization_Data (Start .. Finish - 1),
- """ in " & Attribute_Location);
+ Osint.Fail ("duplicate attribute """
+ & Initialization_Data (Start .. Finish - 1)
+ & """ in " & Attribute_Location);
end if;
end loop;
end if;
if In_Package = Empty_Package then
- Fail ("attempt to add attribute """, Name,
- """ to an undefined package");
+ Fail ("attempt to add attribute """
+ & Name
+ & """ to an undefined package");
raise Project_Error;
end if;
Curr_Attr := First_Attr;
while Curr_Attr /= Empty_Attr loop
if Attrs.Table (Curr_Attr).Name = Attr_Name then
- Fail ("duplicate attribute name """, Name,
- """ in package """ &
- Get_Name_String
- (Package_Attributes.Table (In_Package.Value).Name) &
- """");
+ Fail ("duplicate attribute name """
+ & Name
+ & """ in package """
+ & Get_Name_String
+ (Package_Attributes.Table (In_Package.Value).Name)
+ & """");
raise Project_Error;
end if;
for Index in Package_Attributes.First .. Package_Attributes.Last loop
if Package_Attributes.Table (Index).Name = Pkg_Name then
- Fail ("cannot register a package with a non unique name""",
- Name, """");
+ Fail ("cannot register a package with a non unique name"""
+ & Name
+ & """");
Id := Empty_Package;
return;
end if;
for Index in Package_Attributes.First .. Package_Attributes.Last loop
if Package_Attributes.Table (Index).Name = Pkg_Name then
- Fail ("cannot register a package with a non unique name""",
- Name, """");
+ Fail ("cannot register a package with a non unique name"""
+ & Name
+ & """");
raise Project_Error;
end if;
end loop;
Curr_Attr := First_Attr;
while Curr_Attr /= Empty_Attr loop
if Attrs.Table (Curr_Attr).Name = Attr_Name then
- Fail ("duplicate attribute name """, Attributes (Index).Name,
- """ in new package """ & Name & """");
+ Fail ("duplicate attribute name """
+ & Attributes (Index).Name
+ & """ in new package """
+ & Name
+ & """");
raise Project_Error;
end if;
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2008, Free Software Foundation, Inc. --
-- --
-- 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- --
package Prj.Com is
- type Fail_Proc is access procedure
- (S1 : String;
- S2 : String := "";
- S3 : String := "");
+ type Fail_Proc is access procedure (S : String);
Fail : Fail_Proc := Osint.Fail'Access;
-- This procedure is used in the project facility, instead of directly
begin
if Host_Spec = null then
Prj.Com.Fail
- ("could not convert file name """, Value, """ to host spec");
+ ("could not convert file name """ & Value & """ to host spec");
else
Setenv (Name, Host_Spec.all);
Free (Host_Spec);
if Output_FD = Invalid_FD then
Prj.Com.Fail
- ("cannot create new """, Path_Name (1 .. Path_Last), """");
+ ("cannot create new """ & Path_Name (1 .. Path_Last) & """");
end if;
if Project_File then
Success => Discard);
end;
- -- And create a new source list file. Fail if file cannot be created.
+ -- And create a new source list file, fail if file cannot be created
Source_List_FD := Create_New_File
(Name => Source_List_Path (1 .. Source_List_Last),
if Source_List_FD = Invalid_FD then
Prj.Com.Fail
- ("cannot create file """,
- Source_List_Path (1 .. Source_List_Last),
- """");
+ ("cannot create file """
+ & Source_List_Path (1 .. Source_List_Last)
+ & """");
end if;
if Opt.Verbose_Mode then
if Output_FD = Invalid_FD then
Prj.Com.Fail
- ("cannot create new """,
- Project_Naming_File_Name (1 .. Project_Naming_Last),
- """");
+ ("cannot create new """
+ & Project_Naming_File_Name (1 .. Project_Naming_Last)
+ & """");
end if;
-- Output the naming project file
exception
when Directory_Error =>
Prj.Com.Fail
- ("unknown directory """,
- Path_Name (1 .. Directory_Last),
- """");
+ ("unknown directory """
+ & Path_Name (1 .. Directory_Last)
+ & """");
end;
end if;
end Initialize;
Open (Dir, Dir_Name);
exception
when Directory_Error =>
- Prj.Com.Fail ("cannot open directory """, Dir_Name, """");
+ Prj.Com.Fail ("cannot open directory """ & Dir_Name & """");
end;
-- Process each regular file in the directory
if Path_Name = "" then
Prj.Com.Fail
- ("project file """,
- Project_File_Name,
- """ not found in " & Project_Path);
+ ("project file """
+ & Project_File_Name
+ & """ not found in "
+ & Project_Path);
Project := Empty_Node;
return;
end if;
extern int __gnat_read_signalling_fd (int rsig);
extern int __gnat_write_signalling_fd (int wsig);
extern void __gnat_close_signalling_fd (int sig);
-extern void __gnat_free_socket_set (fd_set *);
extern void __gnat_last_socket_in_set (fd_set *, int *);
extern void __gnat_get_socket_from_set (fd_set *, int *, int *);
extern void __gnat_insert_socket_in_set (fd_set *, int);
extern int __gnat_is_socket_in_set (fd_set *, int);
extern fd_set *__gnat_new_socket_set (fd_set *);
extern void __gnat_remove_socket_from_set (fd_set *, int);
+extern void __gnat_reset_socket_set (fd_set *set);
extern int __gnat_get_h_errno (void);
\f
/* Disable the sending of SIGPIPE for writes on a broken stream */
}
#endif
\f
-/* Free socket set. */
-
-void
-__gnat_free_socket_set (fd_set *set)
-{
- __gnat_free (set);
-}
-
/* Find the largest socket in the socket set SET. This is needed for
`select'. LAST is the maximum value for the largest socket. This hint is
used to avoid scanning very large socket sets. On return, LAST is the
return FD_ISSET (socket, set);
}
-/* Allocate a new socket set and set it as empty. */
-
-fd_set *
-__gnat_new_socket_set (fd_set *set)
-{
- fd_set *new;
-
-#ifdef VMS
-extern void *__gnat_malloc32 (__SIZE_TYPE__);
- new = (fd_set *) __gnat_malloc32 (sizeof (fd_set));
-#else
- new = (fd_set *) __gnat_malloc (sizeof (fd_set));
-#endif
-
- if (set)
- memcpy (new, set, sizeof (fd_set));
- else
- FD_ZERO (new);
-
- return new;
-}
-
/* Remove SOCKET from the socket set SET. */
void
FD_CLR (socket, set);
}
+/* Reset SET */
+void
+__gnat_reset_socket_set (fd_set *set)
+{
+ FD_ZERO (set);
+}
+
/* Get the value of the last host error */
int
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2008, Free Software Foundation, Inc. --
-- --
-- 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- --
exception
when Constraint_Error =>
- Osint.Fail
- ("numeric value out of range for switch: ", (1 => S));
+ Osint.Fail ("numeric value out of range for switch: " & S);
end;
return Result;
if Switch_Chars'Last >= Ptr + 3
and then Switch_Chars (Ptr .. Ptr + 3) = "gnat"
then
- Osint.Fail ("invalid switch: """, Switch_Chars, """"
- & " (gnat not needed here)");
+ Osint.Fail ("invalid switch: """ & Switch_Chars & """"
+ & " (gnat not needed here)");
end if;
-- Loop to scan through switches given in switch string
elsif
RTS_Specified.all /= Switch_Chars (Ptr + 4 .. Max)
then
- Osint.Fail
- ("--RTS cannot be specified multiple times");
+ Osint.Fail ("--RTS cannot be specified multiple times");
end if;
-- Valid --RTS switch
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- --
-- 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- --
procedure Bad_Switch (Switch : Character) is
begin
- Osint.Fail ("invalid switch: ", (1 => Switch));
+ Osint.Fail ("invalid switch: " & Switch);
end Bad_Switch;
procedure Bad_Switch (Switch : String) is
begin
- Osint.Fail ("invalid switch: ", Switch);
+ Osint.Fail ("invalid switch: " & Switch);
end Bad_Switch;
------------------------------
Result := 0;
if Ptr > Max or else Switch_Chars (Ptr) not in '0' .. '9' then
- Osint.Fail ("missing numeric value for switch: ", (1 => Switch));
+ Osint.Fail ("missing numeric value for switch: " & Switch);
else
while Ptr <= Max and then Switch_Chars (Ptr) in '0' .. '9' loop
Ptr := Ptr + 1;
if Result > Switch_Max_Value then
- Osint.Fail
- ("numeric value out of range for switch: ", (1 => Switch));
+ Osint.Fail ("numeric value out of range for switch: " & Switch);
end if;
end loop;
end if;
Scan_Nat (Switch_Chars, Max, Ptr, Temp, Switch);
if Temp = 0 then
- Osint.Fail ("numeric value out of range for switch: ", (1 => Switch));
+ Osint.Fail ("numeric value out of range for switch: " & Switch);
end if;
Result := Temp;
function New_Occurrence_Of
(Def_Id : Entity_Id;
Loc : Source_Ptr) return Node_Id;
- -- New_Occurrence_Of creates an N_Identifier node which is an
- -- occurrence of the defining identifier which is passed as its
- -- argument. The Entity and Etype of the result are set from
- -- the given defining identifier as follows: Entity is simply
- -- a copy of Def_Id. Etype is a copy of Def_Id for types, and
- -- a copy of the Etype of Def_Id for other entities.
+ -- New_Occurrence_Of creates an N_Identifier node which is an occurrence
+ -- of the defining identifier which is passed as its argument. The Entity
+ -- and Etype of the result are set from the given defining identifier as
+ -- follows: Entity is simply a copy of Def_Id. Etype is a copy of Def_Id
+ -- for types, and a copy of the Etype of Def_Id for other entities.
function New_Reference_To
(Def_Id : Entity_Id;
OSDN Git Service
