OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [g-socthi.adb] - Blame information for rev 847

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                    G N A T . S O C K E T S . T H I N                     --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--                     Copyright (C) 2001-2009, AdaCore                     --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17
-- for  more details.  You should have  received  a copy of the GNU General --
18
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
19
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
20
-- Boston, MA 02110-1301, USA.                                              --
21
--                                                                          --
22
-- As a special exception,  if other files  instantiate  generics from this --
23
-- unit, or you link  this unit with other files  to produce an executable, --
24
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
25
-- covered  by the  GNU  General  Public  License.  This exception does not --
26
-- however invalidate  any other reasons why  the executable file  might be --
27
-- covered by the  GNU Public License.                                      --
28
--                                                                          --
29
-- GNAT was originally developed  by the GNAT team at  New York University. --
30
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
31
--                                                                          --
32
------------------------------------------------------------------------------
33
 
34
--  This package provides a target dependent thin interface to the sockets
35
--  layer for use by the GNAT.Sockets package (g-socket.ads). This package
36
--  should not be directly with'ed by an applications program.
37
 
38
--  This is the default version
39
 
40
with GNAT.OS_Lib; use GNAT.OS_Lib;
41
with GNAT.Task_Lock;
42
 
43
with Interfaces.C; use Interfaces.C;
44
 
45
package body GNAT.Sockets.Thin is
46
 
47
   Non_Blocking_Sockets : aliased Fd_Set;
48
   --  When this package is initialized with Process_Blocking_IO set
49
   --  to True, sockets are set in non-blocking mode to avoid blocking
50
   --  the whole process when a thread wants to perform a blocking IO
51
   --  operation. But the user can also set a socket in non-blocking
52
   --  mode by purpose. In order to make a difference between these
53
   --  two situations, we track the origin of non-blocking mode in
54
   --  Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
55
   --  been set in non-blocking mode by the user.
56
 
57
   Quantum : constant Duration := 0.2;
58
   --  When SOSC.Thread_Blocking_IO is False, we set sockets in
59
   --  non-blocking mode and we spend a period of time Quantum between
60
   --  two attempts on a blocking operation.
61
 
62
   Unknown_System_Error : constant C.Strings.chars_ptr :=
63
                            C.Strings.New_String ("Unknown system error");
64
 
65
   --  Comments required for following functions ???
66
 
67
   function Syscall_Accept
68
     (S       : C.int;
69
      Addr    : System.Address;
70
      Addrlen : not null access C.int) return C.int;
71
   pragma Import (C, Syscall_Accept, "accept");
72
 
73
   function Syscall_Connect
74
     (S       : C.int;
75
      Name    : System.Address;
76
      Namelen : C.int) return C.int;
77
   pragma Import (C, Syscall_Connect, "connect");
78
 
79
   function Syscall_Recv
80
     (S     : C.int;
81
      Msg   : System.Address;
82
      Len   : C.int;
83
      Flags : C.int) return C.int;
84
   pragma Import (C, Syscall_Recv, "recv");
85
 
86
   function Syscall_Recvfrom
87
     (S       : C.int;
88
      Msg     : System.Address;
89
      Len     : C.int;
90
      Flags   : C.int;
91
      From    : System.Address;
92
      Fromlen : not null access C.int) return C.int;
93
   pragma Import (C, Syscall_Recvfrom, "recvfrom");
94
 
95
   function Syscall_Recvmsg
96
     (S     : C.int;
97
      Msg   : System.Address;
98
      Flags : C.int) return ssize_t;
99
   pragma Import (C, Syscall_Recvmsg, "recvmsg");
100
 
101
   function Syscall_Sendmsg
102
     (S     : C.int;
103
      Msg   : System.Address;
104
      Flags : C.int) return ssize_t;
105
   pragma Import (C, Syscall_Sendmsg, "sendmsg");
106
 
107
   function Syscall_Sendto
108
     (S     : C.int;
109
      Msg   : System.Address;
110
      Len   : C.int;
111
      Flags : C.int;
112
      To    : System.Address;
113
      Tolen : C.int) return C.int;
114
   pragma Import (C, Syscall_Sendto, "sendto");
115
 
116
   function Syscall_Socket
117
     (Domain   : C.int;
118
      Typ      : C.int;
119
      Protocol : C.int) return C.int;
120
   pragma Import (C, Syscall_Socket, "socket");
121
 
122
   procedure Disable_SIGPIPE (S : C.int);
123
   pragma Import (C, Disable_SIGPIPE, "__gnat_disable_sigpipe");
124
 
125
   procedure Disable_All_SIGPIPEs;
126
   pragma Import (C, Disable_All_SIGPIPEs, "__gnat_disable_all_sigpipes");
127
   --  Sets the process to ignore all SIGPIPE signals on platforms that
128
   --  don't support Disable_SIGPIPE for particular streams.
129
 
130
   function Non_Blocking_Socket (S : C.int) return Boolean;
131
   procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
132
 
133
   --------------
134
   -- C_Accept --
135
   --------------
136
 
137
   function C_Accept
138
     (S       : C.int;
139
      Addr    : System.Address;
140
      Addrlen : not null access C.int) return C.int
141
   is
142
      R   : C.int;
143
      Val : aliased C.int := 1;
144
 
145
      Discard : C.int;
146
      pragma Warnings (Off, Discard);
147
 
148
   begin
149
      loop
150
         R := Syscall_Accept (S, Addr, Addrlen);
151
         exit when SOSC.Thread_Blocking_IO
152
           or else R /= Failure
153
           or else Non_Blocking_Socket (S)
154
           or else Errno /= SOSC.EWOULDBLOCK;
155
         delay Quantum;
156
      end loop;
157
 
158
      if not SOSC.Thread_Blocking_IO
159
        and then R /= Failure
160
      then
161
         --  A socket inherits the properties ot its server especially
162
         --  the FIONBIO flag. Do not use Socket_Ioctl as this subprogram
163
         --  tracks sockets set in non-blocking mode by user.
164
 
165
         Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
166
         Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
167
      end if;
168
 
169
      Disable_SIGPIPE (R);
170
      return R;
171
   end C_Accept;
172
 
173
   ---------------
174
   -- C_Connect --
175
   ---------------
176
 
177
   function C_Connect
178
     (S       : C.int;
179
      Name    : System.Address;
180
      Namelen : C.int) return C.int
181
   is
182
      Res : C.int;
183
 
184
   begin
185
      Res := Syscall_Connect (S, Name, Namelen);
186
 
187
      if SOSC.Thread_Blocking_IO
188
        or else Res /= Failure
189
        or else Non_Blocking_Socket (S)
190
        or else Errno /= SOSC.EINPROGRESS
191
      then
192
         return Res;
193
      end if;
194
 
195
      declare
196
         WSet : aliased Fd_Set;
197
         Now  : aliased Timeval;
198
 
199
      begin
200
         Reset_Socket_Set (WSet'Access);
201
         loop
202
            Insert_Socket_In_Set (WSet'Access, S);
203
            Now := Immediat;
204
            Res := C_Select
205
              (S + 1,
206
               No_Fd_Set_Access,
207
               WSet'Access,
208
               No_Fd_Set_Access,
209
               Now'Unchecked_Access);
210
 
211
            exit when Res > 0;
212
 
213
            if Res = Failure then
214
               return Res;
215
            end if;
216
 
217
            delay Quantum;
218
         end loop;
219
      end;
220
 
221
      Res := Syscall_Connect (S, Name, Namelen);
222
 
223
      if Res = Failure
224
        and then Errno = SOSC.EISCONN
225
      then
226
         return Thin_Common.Success;
227
      else
228
         return Res;
229
      end if;
230
   end C_Connect;
231
 
232
   ------------------
233
   -- Socket_Ioctl --
234
   ------------------
235
 
236
   function Socket_Ioctl
237
     (S   : C.int;
238
      Req : C.int;
239
      Arg : access C.int) return C.int
240
   is
241
   begin
242
      if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then
243
         if Arg.all /= 0 then
244
            Set_Non_Blocking_Socket (S, True);
245
         end if;
246
      end if;
247
 
248
      return C_Ioctl (S, Req, Arg);
249
   end Socket_Ioctl;
250
 
251
   ------------
252
   -- C_Recv --
253
   ------------
254
 
255
   function C_Recv
256
     (S     : C.int;
257
      Msg   : System.Address;
258
      Len   : C.int;
259
      Flags : C.int) return C.int
260
   is
261
      Res : C.int;
262
 
263
   begin
264
      loop
265
         Res := Syscall_Recv (S, Msg, Len, Flags);
266
         exit when SOSC.Thread_Blocking_IO
267
           or else Res /= Failure
268
           or else Non_Blocking_Socket (S)
269
           or else Errno /= SOSC.EWOULDBLOCK;
270
         delay Quantum;
271
      end loop;
272
 
273
      return Res;
274
   end C_Recv;
275
 
276
   ----------------
277
   -- C_Recvfrom --
278
   ----------------
279
 
280
   function C_Recvfrom
281
     (S       : C.int;
282
      Msg     : System.Address;
283
      Len     : C.int;
284
      Flags   : C.int;
285
      From    : System.Address;
286
      Fromlen : not null access C.int) return C.int
287
   is
288
      Res : C.int;
289
 
290
   begin
291
      loop
292
         Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
293
         exit when SOSC.Thread_Blocking_IO
294
           or else Res /= Failure
295
           or else Non_Blocking_Socket (S)
296
           or else Errno /= SOSC.EWOULDBLOCK;
297
         delay Quantum;
298
      end loop;
299
 
300
      return Res;
301
   end C_Recvfrom;
302
 
303
   ---------------
304
   -- C_Recvmsg --
305
   ---------------
306
 
307
   function C_Recvmsg
308
     (S     : C.int;
309
      Msg   : System.Address;
310
      Flags : C.int) return ssize_t
311
   is
312
      Res : ssize_t;
313
 
314
   begin
315
      loop
316
         Res := Syscall_Recvmsg (S, Msg, Flags);
317
         exit when SOSC.Thread_Blocking_IO
318
           or else Res /= ssize_t (Failure)
319
           or else Non_Blocking_Socket (S)
320
           or else Errno /= SOSC.EWOULDBLOCK;
321
         delay Quantum;
322
      end loop;
323
 
324
      return Res;
325
   end C_Recvmsg;
326
 
327
   ---------------
328
   -- C_Sendmsg --
329
   ---------------
330
 
331
   function C_Sendmsg
332
     (S     : C.int;
333
      Msg   : System.Address;
334
      Flags : C.int) return ssize_t
335
   is
336
      Res : ssize_t;
337
 
338
   begin
339
      loop
340
         Res := Syscall_Sendmsg (S, Msg, Flags);
341
         exit when SOSC.Thread_Blocking_IO
342
           or else Res /= ssize_t (Failure)
343
           or else Non_Blocking_Socket (S)
344
           or else Errno /= SOSC.EWOULDBLOCK;
345
         delay Quantum;
346
      end loop;
347
 
348
      return Res;
349
   end C_Sendmsg;
350
 
351
   --------------
352
   -- C_Sendto --
353
   --------------
354
 
355
   function C_Sendto
356
     (S     : C.int;
357
      Msg   : System.Address;
358
      Len   : C.int;
359
      Flags : C.int;
360
      To    : System.Address;
361
      Tolen : C.int) return C.int
362
   is
363
      Res : C.int;
364
 
365
   begin
366
      loop
367
         Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
368
         exit when SOSC.Thread_Blocking_IO
369
           or else Res /= Failure
370
           or else Non_Blocking_Socket (S)
371
           or else Errno /= SOSC.EWOULDBLOCK;
372
         delay Quantum;
373
      end loop;
374
 
375
      return Res;
376
   end C_Sendto;
377
 
378
   --------------
379
   -- C_Socket --
380
   --------------
381
 
382
   function C_Socket
383
     (Domain   : C.int;
384
      Typ      : C.int;
385
      Protocol : C.int) return C.int
386
   is
387
      R   : C.int;
388
      Val : aliased C.int := 1;
389
 
390
      Discard : C.int;
391
      pragma Unreferenced (Discard);
392
 
393
   begin
394
      R := Syscall_Socket (Domain, Typ, Protocol);
395
 
396
      if not SOSC.Thread_Blocking_IO
397
        and then R /= Failure
398
      then
399
         --  Do not use Socket_Ioctl as this subprogram tracks sockets set
400
         --  in non-blocking mode by user.
401
 
402
         Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
403
         Set_Non_Blocking_Socket (R, False);
404
      end if;
405
      Disable_SIGPIPE (R);
406
      return R;
407
   end C_Socket;
408
 
409
   --------------
410
   -- Finalize --
411
   --------------
412
 
413
   procedure Finalize is
414
   begin
415
      null;
416
   end Finalize;
417
 
418
   -------------------------
419
   -- Host_Error_Messages --
420
   -------------------------
421
 
422
   package body Host_Error_Messages is separate;
423
 
424
   ----------------
425
   -- Initialize --
426
   ----------------
427
 
428
   procedure Initialize is
429
   begin
430
      Disable_All_SIGPIPEs;
431
      Reset_Socket_Set (Non_Blocking_Sockets'Access);
432
   end Initialize;
433
 
434
   -------------------------
435
   -- Non_Blocking_Socket --
436
   -------------------------
437
 
438
   function Non_Blocking_Socket (S : C.int) return Boolean is
439
      R : Boolean;
440
   begin
441
      Task_Lock.Lock;
442
      R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
443
      Task_Lock.Unlock;
444
      return R;
445
   end Non_Blocking_Socket;
446
 
447
   -----------------------------
448
   -- Set_Non_Blocking_Socket --
449
   -----------------------------
450
 
451
   procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
452
   begin
453
      Task_Lock.Lock;
454
 
455
      if V then
456
         Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
457
      else
458
         Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
459
      end if;
460
 
461
      Task_Lock.Unlock;
462
   end Set_Non_Blocking_Socket;
463
 
464
   --------------------
465
   -- Signalling_Fds --
466
   --------------------
467
 
468
   package body Signalling_Fds is
469
 
470
      --  In this default implementation, we use a C version of these
471
      --  subprograms provided by socket.c.
472
 
473
      function C_Create (Fds : not null access Fd_Pair) return C.int;
474
      function C_Read (Rsig : C.int) return C.int;
475
      function C_Write (Wsig : C.int) return C.int;
476
      procedure C_Close (Sig : C.int);
477
 
478
      pragma Import (C, C_Create, "__gnat_create_signalling_fds");
479
      pragma Import (C, C_Read,   "__gnat_read_signalling_fd");
480
      pragma Import (C, C_Write,  "__gnat_write_signalling_fd");
481
      pragma Import (C, C_Close,  "__gnat_close_signalling_fd");
482
 
483
      function Create
484
        (Fds : not null access Fd_Pair) return C.int renames C_Create;
485
      function Read (Rsig : C.int) return C.int renames C_Read;
486
      function Write (Wsig : C.int) return C.int renames C_Write;
487
      procedure Close (Sig : C.int) renames C_Close;
488
 
489
   end Signalling_Fds;
490
 
491
   --------------------------
492
   -- Socket_Error_Message --
493
   --------------------------
494
 
495
   function Socket_Error_Message
496
     (Errno : Integer) return C.Strings.chars_ptr
497
   is separate;
498
 
499
end GNAT.Sockets.Thin;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.