1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . O S _ I N T E R F A C E --
9 -- Copyright (C) 1991-1994, Florida State University --
10 -- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
12 -- GNARL is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNARL; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
21 -- Boston, MA 02110-1301, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNARL was developed by the GNARL team at Florida State University. --
31 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
33 ------------------------------------------------------------------------------
35 -- This is a OpenVMS/Alpha version of this package
37 -- This package encapsulates all direct interfaces to OS services
38 -- that are needed by children of System.
40 -- PLEASE DO NOT add any with-clauses to this package or remove the pragma
41 -- Preelaborate. This package is designed to be a bottom-level (leaf) package.
44 with Ada.Unchecked_Conversion;
47 package System.OS_Interface is
50 pragma Linker_Options ("--for-linker=sys$library:pthread$rtl.exe");
51 -- Link in the DEC threads library
53 -- pragma Linker_Options ("--for-linker=/threads_enable");
54 -- Enable upcalls and multiple kernel threads.
56 subtype int is Interfaces.C.int;
57 subtype short is Interfaces.C.short;
58 subtype long is Interfaces.C.long;
59 subtype unsigned is Interfaces.C.unsigned;
60 subtype unsigned_short is Interfaces.C.unsigned_short;
61 subtype unsigned_long is Interfaces.C.unsigned_long;
62 subtype unsigned_char is Interfaces.C.unsigned_char;
63 subtype plain_char is Interfaces.C.plain_char;
64 subtype size_t is Interfaces.C.size_t;
66 -----------------------------
67 -- Signals (Interrupt IDs) --
68 -----------------------------
70 -- Type signal has an arbitrary limit of 31
72 Max_Interrupt : constant := 31;
73 type Signal is new unsigned range 0 .. Max_Interrupt;
74 for Signal'Size use unsigned'Size;
76 type sigset_t is array (Signal) of Boolean;
77 pragma Pack (sigset_t);
79 -- Interrupt_Number_Type
80 -- Unsigned long integer denoting the number of an interrupt
82 subtype Interrupt_Number_Type is unsigned_long;
84 -- OpenVMS system services return values of type Cond_Value_Type
86 subtype Cond_Value_Type is unsigned_long;
87 subtype Short_Cond_Value_Type is unsigned_short;
89 type IO_Status_Block_Type is record
90 Status : Short_Cond_Value_Type;
91 Count : unsigned_short;
92 Dev_Info : unsigned_long;
95 type AST_Handler is access procedure (Param : Address);
96 pragma Convention (C, AST_Handler);
97 No_AST_Handler : constant AST_Handler := null;
99 CMB_M_READONLY : constant := 16#00000001#;
100 CMB_M_WRITEONLY : constant := 16#00000002#;
101 AGN_M_READONLY : constant := 16#00000001#;
102 AGN_M_WRITEONLY : constant := 16#00000002#;
104 IO_WRITEVBLK : constant := 48; -- WRITE VIRTUAL BLOCK
105 IO_READVBLK : constant := 49; -- READ VIRTUAL BLOCK
111 -- Assign I/O Channel
113 -- Status = returned status
114 -- Devnam = address of device name or logical name string
116 -- Chan = address of word to receive channel number assigned
117 -- Acmode = access mode associated with channel
118 -- Mbxnam = address of mailbox logical name string descriptor, if
119 -- mailbox associated with device
120 -- Flags = optional channel flags longword for specifying options
121 -- for the $ASSIGN operation
125 (Status : out Cond_Value_Type;
127 Chan : out unsigned_short;
128 Acmode : unsigned_short := 0;
129 Mbxnam : String := String'Null_Parameter;
130 Flags : unsigned_long := 0);
131 pragma Interface (External, Sys_Assign);
132 pragma Import_Valued_Procedure
133 (Sys_Assign, "SYS$ASSIGN",
134 (Cond_Value_Type, String, unsigned_short,
135 unsigned_short, String, unsigned_long),
136 (Value, Descriptor (s), Reference,
137 Value, Descriptor (s), Value),
146 -- Status = returned status
147 -- Reqidt = ID of timer to be cancelled
148 -- Acmode = Access mode
151 (Status : out Cond_Value_Type;
154 pragma Interface (External, Sys_Cantim);
155 pragma Import_Valued_Procedure
156 (Sys_Cantim, "SYS$CANTIM",
157 (Cond_Value_Type, Address, unsigned),
158 (Value, Value, Value));
166 -- Status = returned status
167 -- Prmflg = permanent flag
169 -- Maxmsg = maximum message
170 -- Bufquo = buufer quote
171 -- Promsk = protection mast
172 -- Acmode = access mode
173 -- Lognam = logical name
177 (Status : out Cond_Value_Type;
178 Prmflg : unsigned_char;
179 Chan : out unsigned_short;
180 Maxmsg : unsigned_long := 0;
181 Bufquo : unsigned_long := 0;
182 Promsk : unsigned_short := 0;
183 Acmode : unsigned_short := 0;
185 Flags : unsigned_long := 0);
186 pragma Interface (External, Sys_Crembx);
187 pragma Import_Valued_Procedure
188 (Sys_Crembx, "SYS$CREMBX",
189 (Cond_Value_Type, unsigned_char, unsigned_short,
190 unsigned_long, unsigned_long, unsigned_short,
191 unsigned_short, String, unsigned_long),
192 (Value, Value, Reference,
194 Value, Descriptor (s), Value));
202 -- Status = Returned status of call
203 -- EFN = event flag to be set when I/O completes
206 -- Iosb = I/O status block
207 -- Astadr = system trap to be generated when I/O completes
208 -- Astprm = AST parameter
209 -- P1-6 = optional parameters
212 (Status : out Cond_Value_Type;
213 EFN : unsigned_long := 0;
214 Chan : unsigned_short;
215 Func : unsigned_long := 0;
216 Iosb : out IO_Status_Block_Type;
217 Astadr : AST_Handler := No_AST_Handler;
218 Astprm : Address := Null_Address;
219 P1 : unsigned_long := 0;
220 P2 : unsigned_long := 0;
221 P3 : unsigned_long := 0;
222 P4 : unsigned_long := 0;
223 P5 : unsigned_long := 0;
224 P6 : unsigned_long := 0);
227 (Status : out Cond_Value_Type;
228 EFN : unsigned_long := 0;
229 Chan : unsigned_short;
230 Func : unsigned_long := 0;
231 Iosb : Address := Null_Address;
232 Astadr : AST_Handler := No_AST_Handler;
233 Astprm : Address := Null_Address;
234 P1 : unsigned_long := 0;
235 P2 : unsigned_long := 0;
236 P3 : unsigned_long := 0;
237 P4 : unsigned_long := 0;
238 P5 : unsigned_long := 0;
239 P6 : unsigned_long := 0);
241 pragma Interface (External, Sys_QIO);
242 pragma Import_Valued_Procedure
244 (Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long,
245 IO_Status_Block_Type, AST_Handler, Address,
246 unsigned_long, unsigned_long, unsigned_long,
247 unsigned_long, unsigned_long, unsigned_long),
248 (Value, Value, Value, Value,
249 Reference, Value, Value,
251 Value, Value, Value));
253 pragma Import_Valued_Procedure
255 (Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long,
256 Address, AST_Handler, Address,
257 unsigned_long, unsigned_long, unsigned_long,
258 unsigned_long, unsigned_long, unsigned_long),
259 (Value, Value, Value, Value,
262 Value, Value, Value));
270 -- Status = Returned status of call
271 -- EFN = event flag to be set when timer expires
272 -- Tim = expiration time
273 -- AST = system trap to be generated when timer expires
274 -- Redidt = returned ID of timer (e.g. to cancel timer)
278 (Status : out Cond_Value_Type;
283 Flags : unsigned_long);
284 pragma Interface (External, Sys_Setimr);
285 pragma Import_Valued_Procedure
286 (Sys_Setimr, "SYS$SETIMR",
287 (Cond_Value_Type, unsigned_long, Long_Integer,
288 AST_Handler, Address, unsigned_long),
289 (Value, Value, Reference,
290 Value, Value, Value));
292 Interrupt_ID_0 : constant := 0;
293 Interrupt_ID_1 : constant := 1;
294 Interrupt_ID_2 : constant := 2;
295 Interrupt_ID_3 : constant := 3;
296 Interrupt_ID_4 : constant := 4;
297 Interrupt_ID_5 : constant := 5;
298 Interrupt_ID_6 : constant := 6;
299 Interrupt_ID_7 : constant := 7;
300 Interrupt_ID_8 : constant := 8;
301 Interrupt_ID_9 : constant := 9;
302 Interrupt_ID_10 : constant := 10;
303 Interrupt_ID_11 : constant := 11;
304 Interrupt_ID_12 : constant := 12;
305 Interrupt_ID_13 : constant := 13;
306 Interrupt_ID_14 : constant := 14;
307 Interrupt_ID_15 : constant := 15;
308 Interrupt_ID_16 : constant := 16;
309 Interrupt_ID_17 : constant := 17;
310 Interrupt_ID_18 : constant := 18;
311 Interrupt_ID_19 : constant := 19;
312 Interrupt_ID_20 : constant := 20;
313 Interrupt_ID_21 : constant := 21;
314 Interrupt_ID_22 : constant := 22;
315 Interrupt_ID_23 : constant := 23;
316 Interrupt_ID_24 : constant := 24;
317 Interrupt_ID_25 : constant := 25;
318 Interrupt_ID_26 : constant := 26;
319 Interrupt_ID_27 : constant := 27;
320 Interrupt_ID_28 : constant := 28;
321 Interrupt_ID_29 : constant := 29;
322 Interrupt_ID_30 : constant := 30;
323 Interrupt_ID_31 : constant := 31;
329 function errno return int;
330 pragma Import (C, errno, "__get_errno");
332 EINTR : constant := 4; -- Interrupted system call
333 EAGAIN : constant := 11; -- No more processes
334 ENOMEM : constant := 12; -- Not enough core
336 -------------------------
337 -- Priority Scheduling --
338 -------------------------
340 SCHED_FIFO : constant := 1;
341 SCHED_RR : constant := 2;
342 SCHED_OTHER : constant := 3;
343 SCHED_BG : constant := 4;
344 SCHED_LFI : constant := 5;
345 SCHED_LRR : constant := 6;
351 type pid_t is private;
353 function kill (pid : pid_t; sig : Signal) return int;
354 pragma Import (C, kill);
356 function getpid return pid_t;
357 pragma Import (C, getpid);
363 type Thread_Body is access
364 function (arg : System.Address) return System.Address;
365 pragma Convention (C, Thread_Body);
367 function Thread_Body_Access is new
368 Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, Thread_Body);
370 type pthread_t is private;
371 subtype Thread_Id is pthread_t;
373 type pthread_mutex_t is limited private;
374 type pthread_cond_t is limited private;
375 type pthread_attr_t is limited private;
376 type pthread_mutexattr_t is limited private;
377 type pthread_condattr_t is limited private;
378 type pthread_key_t is private;
380 PTHREAD_CREATE_JOINABLE : constant := 0;
381 PTHREAD_CREATE_DETACHED : constant := 1;
383 PTHREAD_CANCEL_DISABLE : constant := 0;
384 PTHREAD_CANCEL_ENABLE : constant := 1;
386 PTHREAD_CANCEL_DEFERRED : constant := 0;
387 PTHREAD_CANCEL_ASYNCHRONOUS : constant := 1;
389 -- Don't use ERRORCHECK mutexes, they don't work when a thread is not
390 -- the owner. AST's, at least, unlock others threads mutexes. Even
391 -- if the error is ignored, they don't work.
392 PTHREAD_MUTEX_NORMAL_NP : constant := 0;
393 PTHREAD_MUTEX_RECURSIVE_NP : constant := 1;
394 PTHREAD_MUTEX_ERRORCHECK_NP : constant := 2;
396 PTHREAD_INHERIT_SCHED : constant := 0;
397 PTHREAD_EXPLICIT_SCHED : constant := 1;
399 function pthread_cancel (thread : pthread_t) return int;
400 pragma Import (C, pthread_cancel, "PTHREAD_CANCEL");
402 procedure pthread_testcancel;
403 pragma Import (C, pthread_testcancel, "PTHREAD_TESTCANCEL");
405 function pthread_setcancelstate
406 (newstate : int; oldstate : access int) return int;
407 pragma Import (C, pthread_setcancelstate, "PTHREAD_SETCANCELSTATE");
409 function pthread_setcanceltype
410 (newtype : int; oldtype : access int) return int;
411 pragma Import (C, pthread_setcanceltype, "PTHREAD_SETCANCELTYPE");
413 -------------------------
414 -- POSIX.1c Section 3 --
415 -------------------------
417 function pthread_lock_global_np return int;
418 pragma Import (C, pthread_lock_global_np, "PTHREAD_LOCK_GLOBAL_NP");
420 function pthread_unlock_global_np return int;
421 pragma Import (C, pthread_unlock_global_np, "PTHREAD_UNLOCK_GLOBAL_NP");
423 --------------------------
424 -- POSIX.1c Section 11 --
425 --------------------------
427 function pthread_mutexattr_init
428 (attr : access pthread_mutexattr_t) return int;
429 pragma Import (C, pthread_mutexattr_init, "PTHREAD_MUTEXATTR_INIT");
431 function pthread_mutexattr_destroy
432 (attr : access pthread_mutexattr_t) return int;
433 pragma Import (C, pthread_mutexattr_destroy, "PTHREAD_MUTEXATTR_DESTROY");
435 function pthread_mutexattr_settype_np
436 (attr : access pthread_mutexattr_t;
437 mutextype : int) return int;
438 pragma Import (C, pthread_mutexattr_settype_np,
439 "PTHREAD_MUTEXATTR_SETTYPE_NP");
441 function pthread_mutex_init
442 (mutex : access pthread_mutex_t;
443 attr : access pthread_mutexattr_t) return int;
444 pragma Import (C, pthread_mutex_init, "PTHREAD_MUTEX_INIT");
446 function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
447 pragma Import (C, pthread_mutex_destroy, "PTHREAD_MUTEX_DESTROY");
449 function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
450 pragma Import (C, pthread_mutex_lock, "PTHREAD_MUTEX_LOCK");
452 function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
453 pragma Import (C, pthread_mutex_unlock, "PTHREAD_MUTEX_UNLOCK");
455 function pthread_condattr_init
456 (attr : access pthread_condattr_t) return int;
457 pragma Import (C, pthread_condattr_init, "PTHREAD_CONDATTR_INIT");
459 function pthread_condattr_destroy
460 (attr : access pthread_condattr_t) return int;
461 pragma Import (C, pthread_condattr_destroy, "PTHREAD_CONDATTR_DESTROY");
463 function pthread_cond_init
464 (cond : access pthread_cond_t;
465 attr : access pthread_condattr_t) return int;
466 pragma Import (C, pthread_cond_init, "PTHREAD_COND_INIT");
468 function pthread_cond_destroy (cond : access pthread_cond_t) return int;
469 pragma Import (C, pthread_cond_destroy, "PTHREAD_COND_DESTROY");
471 function pthread_cond_signal (cond : access pthread_cond_t) return int;
472 pragma Import (C, pthread_cond_signal, "PTHREAD_COND_SIGNAL");
474 function pthread_cond_signal_int_np
475 (cond : access pthread_cond_t) return int;
476 pragma Import (C, pthread_cond_signal_int_np,
477 "PTHREAD_COND_SIGNAL_INT_NP");
479 function pthread_cond_wait
480 (cond : access pthread_cond_t;
481 mutex : access pthread_mutex_t) return int;
482 pragma Import (C, pthread_cond_wait, "PTHREAD_COND_WAIT");
484 --------------------------
485 -- POSIX.1c Section 13 --
486 --------------------------
488 function pthread_mutexattr_setprotocol
489 (attr : access pthread_mutexattr_t; protocol : int) return int;
490 pragma Import (C, pthread_mutexattr_setprotocol,
491 "PTHREAD_MUTEXATTR_SETPROTOCOL");
493 type struct_sched_param is record
494 sched_priority : int; -- scheduling priority
496 for struct_sched_param'Size use 8*4;
497 pragma Convention (C, struct_sched_param);
499 function pthread_setschedparam
502 param : access struct_sched_param) return int;
503 pragma Import (C, pthread_setschedparam, "PTHREAD_SETSCHEDPARAM");
505 function pthread_attr_setscope
506 (attr : access pthread_attr_t;
507 contentionscope : int) return int;
508 pragma Import (C, pthread_attr_setscope, "PTHREAD_ATTR_SETSCOPE");
510 function pthread_attr_setinheritsched
511 (attr : access pthread_attr_t;
512 inheritsched : int) return int;
513 pragma Import (C, pthread_attr_setinheritsched,
514 "PTHREAD_ATTR_SETINHERITSCHED");
516 function pthread_attr_setschedpolicy
517 (attr : access pthread_attr_t; policy : int) return int;
518 pragma Import (C, pthread_attr_setschedpolicy,
519 "PTHREAD_ATTR_SETSCHEDPOLICY");
521 function pthread_attr_setschedparam
522 (attr : access pthread_attr_t;
523 sched_param : int) return int;
524 pragma Import (C, pthread_attr_setschedparam, "PTHREAD_ATTR_SETSCHEDPARAM");
526 function sched_yield return int;
528 --------------------------
529 -- P1003.1c Section 16 --
530 --------------------------
532 function pthread_attr_init (attributes : access pthread_attr_t) return int;
533 pragma Import (C, pthread_attr_init, "PTHREAD_ATTR_INIT");
535 function pthread_attr_destroy
536 (attributes : access pthread_attr_t) return int;
537 pragma Import (C, pthread_attr_destroy, "PTHREAD_ATTR_DESTROY");
539 function pthread_attr_setdetachstate
540 (attr : access pthread_attr_t;
541 detachstate : int) return int;
542 pragma Import (C, pthread_attr_setdetachstate,
543 "PTHREAD_ATTR_SETDETACHSTATE");
545 function pthread_attr_setstacksize
546 (attr : access pthread_attr_t;
547 stacksize : size_t) return int;
548 pragma Import (C, pthread_attr_setstacksize, "PTHREAD_ATTR_SETSTACKSIZE");
550 function pthread_create
551 (thread : access pthread_t;
552 attributes : access pthread_attr_t;
553 start_routine : Thread_Body;
554 arg : System.Address) return int;
555 pragma Import (C, pthread_create, "PTHREAD_CREATE");
557 procedure pthread_exit (status : System.Address);
558 pragma Import (C, pthread_exit, "PTHREAD_EXIT");
560 function pthread_self return pthread_t;
562 --------------------------
563 -- POSIX.1c Section 17 --
564 --------------------------
566 function pthread_setspecific
567 (key : pthread_key_t;
568 value : System.Address) return int;
569 pragma Import (C, pthread_setspecific, "PTHREAD_SETSPECIFIC");
571 function pthread_getspecific (key : pthread_key_t) return System.Address;
572 pragma Import (C, pthread_getspecific, "PTHREAD_GETSPECIFIC");
574 type destructor_pointer is access procedure (arg : System.Address);
575 pragma Convention (C, destructor_pointer);
577 function pthread_key_create
578 (key : access pthread_key_t;
579 destructor : destructor_pointer) return int;
580 pragma Import (C, pthread_key_create, "PTHREAD_KEY_CREATE");
584 type pid_t is new int;
586 type pthreadLongAddr_p is mod 2 ** Long_Integer'Size;
588 type pthreadLongAddr_t is mod 2 ** Long_Integer'Size;
589 type pthreadLongAddr_t_ptr is mod 2 ** Long_Integer'Size;
591 type pthreadLongString_t is mod 2 ** Long_Integer'Size;
593 type pthreadLongUint_t is mod 2 ** Long_Integer'Size;
594 type pthreadLongUint_array is array (Natural range <>)
595 of pthreadLongUint_t;
597 type pthread_t is mod 2 ** Long_Integer'Size;
599 type pthread_cond_t is record
602 name : pthreadLongString_t;
605 block : pthreadLongAddr_t_ptr;
607 for pthread_cond_t'Size use 8*32;
608 pragma Convention (C, pthread_cond_t);
610 type pthread_attr_t is record
612 name : pthreadLongString_t;
613 arg : pthreadLongUint_t;
614 reserved : pthreadLongUint_array (0 .. 18);
616 for pthread_attr_t'Size use 8*176;
617 pragma Convention (C, pthread_attr_t);
619 type pthread_mutex_t is record
622 name : pthreadLongString_t;
625 block : pthreadLongAddr_p;
629 for pthread_mutex_t'Size use 8*40;
630 pragma Convention (C, pthread_mutex_t);
632 type pthread_mutexattr_t is record
634 reserved : pthreadLongUint_array (0 .. 14);
636 for pthread_mutexattr_t'Size use 8*128;
637 pragma Convention (C, pthread_mutexattr_t);
639 type pthread_condattr_t is record
641 reserved : pthreadLongUint_array (0 .. 12);
643 for pthread_condattr_t'Size use 8*112;
644 pragma Convention (C, pthread_condattr_t);
646 type pthread_key_t is new unsigned;
648 pragma Inline (pthread_self);
650 end System.OS_Interface;