1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . S O F T _ L I N K S . T A S K I N G --
9 -- Copyright (C) 2004, Free Software Foundation, Inc. --
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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 -- This package contains the tasking versions soft links.
36 pragma Style_Checks (All_Checks);
37 -- Turn off subprogram alpha ordering check, since we group soft link
38 -- bodies and dummy soft link bodies together separately in this unit.
41 -- Turn polling off for this package. We don't need polling during any
42 -- of the routines in this package, and more to the point, if we try
43 -- to poll it can cause infinite loops.
45 with System.Task_Primitives.Operations;
49 package body System.Soft_Links.Tasking is
51 package STPO renames System.Task_Primitives.Operations;
52 package SSL renames System.Soft_Links;
58 Initialized : Boolean := False;
59 -- Boolean flag that indicates whether the tasking soft links have
62 ----------------------------------------------------------------------
63 -- Tasking versions of some services needed by non-tasking programs --
64 ----------------------------------------------------------------------
66 function Get_Jmpbuf_Address return Address;
67 procedure Set_Jmpbuf_Address (Addr : Address);
68 -- Get/Set Jmpbuf_Address for current task
70 function Get_Sec_Stack_Addr return Address;
71 procedure Set_Sec_Stack_Addr (Addr : Address);
72 -- Get/Set location of current task's secondary stack
74 function Get_Machine_State_Addr return Address;
75 procedure Set_Machine_State_Addr (Addr : Address);
76 -- Get/Set the address for storing the current task's machine state
78 function Get_Current_Excep return SSL.EOA;
79 -- Task-safe version of SSL.Get_Current_Excep
81 procedure Timed_Delay_T (Time : Duration; Mode : Integer);
82 -- Task-safe version of SSL.Timed_Delay
84 ----------------------
85 -- Soft-Link Bodies --
86 ----------------------
88 function Get_Current_Excep return SSL.EOA is
90 return STPO.Self.Common.Compiler_Data.Current_Excep'Access;
91 end Get_Current_Excep;
93 function Get_Jmpbuf_Address return Address is
95 return STPO.Self.Common.Compiler_Data.Jmpbuf_Address;
96 end Get_Jmpbuf_Address;
98 function Get_Machine_State_Addr return Address is
100 return STPO.Self.Common.Compiler_Data.Machine_State_Addr;
101 end Get_Machine_State_Addr;
103 function Get_Sec_Stack_Addr return Address is
105 return STPO.Self.Common.Compiler_Data.Sec_Stack_Addr;
106 end Get_Sec_Stack_Addr;
108 procedure Set_Jmpbuf_Address (Addr : Address) is
110 STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr;
111 end Set_Jmpbuf_Address;
113 procedure Set_Machine_State_Addr (Addr : Address) is
115 STPO.Self.Common.Compiler_Data.Machine_State_Addr := Addr;
116 end Set_Machine_State_Addr;
118 procedure Set_Sec_Stack_Addr (Addr : Address) is
120 STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr;
121 end Set_Sec_Stack_Addr;
123 procedure Timed_Delay_T (Time : Duration; Mode : Integer) is
125 STPO.Timed_Delay (STPO.Self, Time, Mode);
128 -----------------------------
129 -- Init_Tasking_Soft_Links --
130 -----------------------------
132 procedure Init_Tasking_Soft_Links is
134 -- If the tasking soft links have already been initialized do not
137 if not Initialized then
138 -- Mark tasking soft links as initialized
142 -- The application being executed uses tasking so that the tasking
143 -- version of the following soft links need to be used.
145 SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access;
146 SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access;
147 SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
148 SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
149 SSL.Get_Machine_State_Addr := Get_Machine_State_Addr'Access;
150 SSL.Set_Machine_State_Addr := Set_Machine_State_Addr'Access;
151 SSL.Get_Current_Excep := Get_Current_Excep'Access;
152 SSL.Timed_Delay := Timed_Delay_T'Access;
154 -- No need to create a new Secondary Stack, since we will use the
155 -- default one created in s-secsta.adb
157 SSL.Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT);
158 SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT);
159 SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT);
162 end Init_Tasking_Soft_Links;
164 end System.Soft_Links.Tasking;