1 ------------------------------------------------------------------------------
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC --
10 -- Copyright (C) 2000-2001 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, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, 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 package is for OpenVMS/Alpha
37 with System
.OS_Interface
;
39 with Unchecked_Conversion
;
41 package body System
.Task_Primitives
.Operations
.DEC
is
43 use System
.OS_Interface
;
46 use type Interfaces
.C
.int
;
48 -- The FAB_RAB_Type specifies where the context field (the calling
49 -- task) is stored. Other fields defined for FAB_RAB aren't need and
52 type FAB_RAB_Type
is record
53 CTX
: Unsigned_Longword
;
56 for FAB_RAB_Type
use record
57 CTX
at 24 range 0 .. 31;
60 for FAB_RAB_Type
'Size use 224;
62 type FAB_RAB_Access_Type
is access all FAB_RAB_Type
;
64 -----------------------
65 -- Local Subprograms --
66 -----------------------
68 function To_Unsigned_Longword
is new
69 Unchecked_Conversion
(Task_ID
, Unsigned_Longword
);
71 function To_Task_Id
is new
72 Unchecked_Conversion
(Unsigned_Longword
, Task_ID
);
74 function To_FAB_RAB
is new
75 Unchecked_Conversion
(Address
, FAB_RAB_Access_Type
);
77 ---------------------------
78 -- Interrupt_AST_Handler --
79 ---------------------------
81 procedure Interrupt_AST_Handler
(ID
: Address
) is
82 Result
: Interfaces
.C
.int
;
83 AST_Self_ID
: Task_ID
:= To_Task_Id
(ID
);
86 Result
:= pthread_cond_signal_int_np
(AST_Self_ID
.Common
.LL
.CV
'Access);
87 pragma Assert
(Result
= 0);
88 end Interrupt_AST_Handler
;
94 procedure RMS_AST_Handler
(ID
: Address
) is
95 AST_Self_ID
: Task_ID
:= To_Task_Id
(To_FAB_RAB
(ID
).CTX
);
96 Result
: Interfaces
.C
.int
;
99 AST_Self_ID
.Common
.LL
.AST_Pending
:= False;
100 Result
:= pthread_cond_signal_int_np
(AST_Self_ID
.Common
.LL
.CV
'Access);
101 pragma Assert
(Result
= 0);
108 function Self
return Unsigned_Longword
is
109 Self_ID
: Task_ID
:= Self
;
112 Self_ID
.Common
.LL
.AST_Pending
:= True;
113 return To_Unsigned_Longword
(Self
);
116 -------------------------
117 -- Starlet_AST_Handler --
118 -------------------------
120 procedure Starlet_AST_Handler
(ID
: Address
) is
121 Result
: Interfaces
.C
.int
;
122 AST_Self_ID
: Task_ID
:= To_Task_Id
(ID
);
125 AST_Self_ID
.Common
.LL
.AST_Pending
:= False;
126 Result
:= pthread_cond_signal_int_np
(AST_Self_ID
.Common
.LL
.CV
'Access);
127 pragma Assert
(Result
= 0);
128 end Starlet_AST_Handler
;
134 procedure Task_Synch
is
135 Synch_Self_ID
: Task_ID
:= Self
;
138 Write_Lock
(Synch_Self_ID
);
139 Synch_Self_ID
.Common
.State
:= AST_Server_Sleep
;
141 while Synch_Self_ID
.Common
.LL
.AST_Pending
loop
142 Sleep
(Synch_Self_ID
, AST_Server_Sleep
);
145 Synch_Self_ID
.Common
.State
:= Runnable
;
146 Unlock
(Synch_Self_ID
);
149 end System
.Task_Primitives
.Operations
.DEC
;