OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
e8f79869d7
gcc/gcc/ada/g-socthi-vxworks.adb
Arnaud Charlet b29def532d [multiple changes] 
2010-06-17  Robert Dewar  <dewar@adacore.com>

	* exp_ch3.adb, exp_ch6.adb, exp_smem.adb, exp_util.adb: Use Ekind_In.
	* layout.adb, freeze.adb: Use Make_Temporary.

2010-06-17  Jerome Lambourg  <lambourg@adacore.com>

	* exp_ch11.adb (Expand_N_Raise_Statement): Expand raise statements in
	.NET/JVM normally as this is now perfectly supported by the backend.

2010-06-17  Pascal Obry  <obry@adacore.com>

	* gnat_rm.texi: Fix minor typo, remove duplicate blank lines.

2010-06-17  Vincent Celier  <celier@adacore.com>

	* make.adb (Collect_Arguments_And_Compile): Create include path file
	only when -x is specified.
	(Gnatmake): Ditto
	* opt.ads (Use_Include_Path_File): New Boolean flag, initialized to
	False.
	* prj-env.adb (Set_Ada_Paths): New Boolean parameters Include_Path and
	Objects_Path, defaulted to True. Only create include path file if
	Include_Path is True, only create objects path file if Objects_Path is
	True.
	* prj-env.ads (Set_Ada_Paths): New Boolean parameters Include_Path and
	Objects_Path, defaulted to True.
	* switch-m.adb (Scan_Make_Switches): Set Use_Include_Path_File to True
	when -x is used.

2010-06-17  Ed Schonberg  <schonberg@adacore.com>

	* exp_disp.adb (Build_Interface_Thunk): Use base type of formal to
	determine whether it has the controlling type, when the formal is an
	access parameter.

2010-06-17  Eric Botcazou  <ebotcazou@adacore.com>

	* s-crtl.ads (ssize_t): New type.
	(read): Fix signature.
	(write): Likewise.
	* g-socthi.ads: Add 'with System.CRTL' clause.  Remove ssize_t and
	'use type' directive for C.size_t, add one for System.CRTL.ssize_t.
	(C_Recvmsg): Replace ssize_t with System.CRTL.ssize_t.
	(C_Sendmsg): Likewise.
	* g-socthi.adb (Syscall_Recvmsg): Likewise.
	(Syscall_Sendmsg): Likewise.
	(C_Recvmsg): Likewise.
	(C_Sendmsg): Likewise.
	* g-socthi-mingw.ads: Add 'with System.CRTL' clause.  Remove ssize_t
	and 'use type' directive for C.size_t, add one for System.CRTL.ssize_t.
	(C_Recvmsg): Replace ssize_t with System.CRTL.ssize_t.
	(C_Sendmsg): Likewise.
	* g-socthi-mingw.adb (C_Recvmsg): Likewise.
	(C_Sendmsg): Likewise.
	* g-socthi-vms.ads: Add 'with System.CRTL' clause.  Remove ssize_t and
	'use type' directive for C.size_t, add one for System.CRTL.ssize_t.
	(C_Recvmsg): Replace ssize_t with System.CRTL.ssize_t.
	(C_Sendmsg): Likewise.
	* g-socthi-vms.adb (C_Recvmsg): Likewise.
	(C_Sendmsg): Likewise.
	* g-socthi-vxworks.ads Add 'with System.CRTL' clause.  Remove ssize_t
	and 'use type' directive for C.size_t, add one for System.CRTL.ssize_t.
	(C_Recvmsg): Replace ssize_t with System.CRTL.ssize_t.
	(C_Sendmsg): Likewise.
	* g-socthi-vxworks.adb (C_Recvmsg): Likewise.
	(C_Sendmsg): Likewise.
	* g-sercom-linux.adb (Read): Use correct types to call 'read'.
	(Write): Likewise to call 'write'.
	* s-os_lib.adb (Read): Use correct type to call System.CRTL.read.
	(Write): Use correct type to call System.CRTL.write.
	* s-tasdeb.adb (Write): Likewise.

2010-06-17  Vincent Celier  <celier@adacore.com>

	* prj-proc.adb (Copy_Package_Declarations): Change argument name
	Naming_Restricted to Restricted. If Restricted is True, do not copy the
	value of attribute Linker_Options.

From-SVN: r160905
2010-06-17 14:26:10 +02:00

495 lines
14 KiB
Ada
Raw Blame History

------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . S O C K E T S . T H I N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2009, 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides a target dependent thin interface to the sockets
-- layer for use by the GNAT.Sockets package (g-socket.ads). This package
-- should not be directly with'ed by an applications program.
-- This version is for VxWorks
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Task_Lock;
with Interfaces.C; use Interfaces.C;
package body GNAT.Sockets.Thin is
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
-- operation. But the user can also set a socket in non-blocking
-- mode by purpose. In order to make a difference between these
-- two situations, we track the origin of non-blocking mode in
-- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
-- been set in non-blocking mode by the user.
Quantum : constant Duration := 0.2;
-- When SOSC.Thread_Blocking_IO is False, we set sockets in
-- non-blocking mode and we spend a period of time Quantum between
-- two attempts on a blocking operation.
Unknown_System_Error : constant C.Strings.chars_ptr :=
C.Strings.New_String ("Unknown system error");
-----------------------
-- Local Subprograms --
-----------------------
-- All these require comments ???
function Syscall_Accept
(S : C.int;
Addr : System.Address;
Addrlen : not null access C.int) return C.int;
pragma Import (C, Syscall_Accept, "accept");
function Syscall_Connect
(S : C.int;
Name : System.Address;
Namelen : C.int) return C.int;
pragma Import (C, Syscall_Connect, "connect");
function Syscall_Recv
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int) return C.int;
pragma Import (C, Syscall_Recv, "recv");
function Syscall_Recvfrom
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int;
From : System.Address;
Fromlen : not null access C.int) return C.int;
pragma Import (C, Syscall_Recvfrom, "recvfrom");
function Syscall_Recvmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return C.int;
pragma Import (C, Syscall_Recvmsg, "recvmsg");
function Syscall_Sendmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return C.int;
pragma Import (C, Syscall_Sendmsg, "sendmsg");
function Syscall_Send
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int) return C.int;
pragma Import (C, Syscall_Send, "send");
function Syscall_Sendto
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int;
To : System.Address;
Tolen : C.int) return C.int;
pragma Import (C, Syscall_Sendto, "sendto");
function Syscall_Socket
(Domain : C.int;
Typ : C.int;
Protocol : C.int) return C.int;
pragma Import (C, Syscall_Socket, "socket");
function Non_Blocking_Socket (S : C.int) return Boolean;
procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
--------------
-- C_Accept --
--------------
function C_Accept
(S : C.int;
Addr : System.Address;
Addrlen : not null access C.int) return C.int
is
R : C.int;
Val : aliased C.int := 1;
Res : C.int;
pragma Unreferenced (Res);
begin
loop
R := Syscall_Accept (S, Addr, Addrlen);
exit when SOSC.Thread_Blocking_IO
or else R /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
if not SOSC.Thread_Blocking_IO
and then R /= Failure
then
-- A socket inherits the properties of its server especially
-- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram
-- tracks sockets set in non-blocking mode by user.
Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
-- Is it OK to ignore result ???
end if;
return R;
end C_Accept;
---------------
-- C_Connect --
---------------
function C_Connect
(S : C.int;
Name : System.Address;
Namelen : C.int) return C.int
is
Res : C.int;
begin
Res := Syscall_Connect (S, Name, Namelen);
if SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EINPROGRESS
then
return Res;
end if;
declare
WSet : aliased Fd_Set;
Now : aliased Timeval;
begin
Reset_Socket_Set (WSet'Access);
loop
Insert_Socket_In_Set (WSet'Access, S);
Now := Immediat;
Res := C_Select
(S + 1,
No_Fd_Set_Access,
WSet'Access,
No_Fd_Set_Access,
Now'Unchecked_Access);
exit when Res > 0;
if Res = Failure then
return Res;
end if;
delay Quantum;
end loop;
end;
Res := Syscall_Connect (S, Name, Namelen);
if Res = Failure
and then Errno = SOSC.EISCONN
then
return Thin_Common.Success;
else
return Res;
end if;
end C_Connect;
------------------
-- Socket_Ioctl --
------------------
function Socket_Ioctl
(S : C.int;
Req : C.int;
Arg : access C.int) return C.int
is
begin
if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then
if Arg.all /= 0 then
Set_Non_Blocking_Socket (S, True);
end if;
end if;
return C_Ioctl (S, Req, Arg);
end Socket_Ioctl;
------------
-- C_Recv --
------------
function C_Recv
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int) return C.int
is
Res : C.int;
begin
loop
Res := Syscall_Recv (S, Msg, Len, Flags);
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
return Res;
end C_Recv;
----------------
-- C_Recvfrom --
----------------
function C_Recvfrom
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int;
From : System.Address;
Fromlen : not null access C.int) return C.int
is
Res : C.int;
begin
loop
Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
return Res;
end C_Recvfrom;
---------------
-- C_Recvmsg --
---------------
function C_Recvmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return System.CRTL.ssize_t
is
Res : C.int;
begin
loop
Res := Syscall_Recvmsg (S, Msg, Flags);
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
return System.CRTL.ssize_t (Res);
end C_Recvmsg;
---------------
-- C_Sendmsg --
---------------
function C_Sendmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return System.CRTL.ssize_t
is
Res : C.int;
begin
loop
Res := Syscall_Sendmsg (S, Msg, Flags);
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
return System.CRTL.ssize_t (Res);
end C_Sendmsg;
--------------
-- C_Sendto --
--------------
function C_Sendto
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int;
To : System.Address;
Tolen : C.int) return C.int
is
use System;
Res : C.int;
begin
loop
if To = Null_Address then
-- In violation of the standard sockets API, VxWorks does not
-- support sendto(2) calls on connected sockets with a null
-- destination address, so use send(2) instead in that case.
Res := Syscall_Send (S, Msg, Len, Flags);
-- Normal case where destination address is non-null
else
Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
end if;
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
return Res;
end C_Sendto;
--------------
-- C_Socket --
--------------
function C_Socket
(Domain : C.int;
Typ : C.int;
Protocol : C.int) return C.int
is
R : C.int;
Val : aliased C.int := 1;
Res : C.int;
pragma Unreferenced (Res);
begin
R := Syscall_Socket (Domain, Typ, Protocol);
if not SOSC.Thread_Blocking_IO
and then R /= Failure
then
-- Do not use Socket_Ioctl as this subprogram tracks sockets set
-- in non-blocking mode by user.
Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
-- Is it OK to ignore result ???
Set_Non_Blocking_Socket (R, False);
end if;
return R;
end C_Socket;
--------------
-- Finalize --
--------------
procedure Finalize is
begin
null;
end Finalize;
-------------------------
-- Host_Error_Messages --
-------------------------
package body Host_Error_Messages is separate;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
Reset_Socket_Set (Non_Blocking_Sockets'Access);
end Initialize;
-------------------------
-- Non_Blocking_Socket --
-------------------------
function Non_Blocking_Socket (S : C.int) return Boolean is
R : Boolean;
begin
Task_Lock.Lock;
R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
Task_Lock.Unlock;
return R;
end Non_Blocking_Socket;
-----------------------------
-- Set_Non_Blocking_Socket --
-----------------------------
procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
begin
Task_Lock.Lock;
if V then
Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
else
Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
end if;
Task_Lock.Unlock;
end Set_Non_Blocking_Socket;
--------------------
-- Signalling_Fds --
--------------------
package body Signalling_Fds is separate;
--------------------------
-- Socket_Error_Message --
--------------------------
function Socket_Error_Message
(Errno : Integer) return C.Strings.chars_ptr
is separate;
end GNAT.Sockets.Thin;
Reference in New Issue View Git Blame Copy Permalink