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-2005, 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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 pragma Style_Checks (All_Checks);
35 -- Turn off subprogram alpha ordering check, since we group soft link
36 -- bodies and dummy soft link bodies together separately in this unit.
39 -- Turn polling off for this package. We don't need polling during any
40 -- of the routines in this package, and more to the point, if we try
41 -- to poll it can cause infinite loops.
43 with System.Task_Primitives.Operations;
50 package body System.Soft_Links.Tasking is
52 package STPO renames System.Task_Primitives.Operations;
53 package SSL renames System.Soft_Links;
59 Initialized : Boolean := False;
60 -- Boolean flag that indicates whether the tasking soft links have
63 -----------------------------------------------------------------
64 -- Tasking Versions of Services Needed by Non-Tasking Programs --
65 -----------------------------------------------------------------
67 function Get_Jmpbuf_Address return Address;
68 procedure Set_Jmpbuf_Address (Addr : Address);
69 -- Get/Set Jmpbuf_Address for current task
71 function Get_Sec_Stack_Addr return Address;
72 procedure Set_Sec_Stack_Addr (Addr : Address);
73 -- Get/Set location of current task's secondary stack
75 function Get_Current_Excep return SSL.EOA;
76 -- Task-safe version of SSL.Get_Current_Excep
78 procedure Timed_Delay_T (Time : Duration; Mode : Integer);
79 -- Task-safe version of SSL.Timed_Delay
81 --------------------------
82 -- Soft-Link Get Bodies --
83 --------------------------
85 function Get_Current_Excep return SSL.EOA is
87 return STPO.Self.Common.Compiler_Data.Current_Excep'Access;
88 end Get_Current_Excep;
90 function Get_Jmpbuf_Address return Address is
92 return STPO.Self.Common.Compiler_Data.Jmpbuf_Address;
93 end Get_Jmpbuf_Address;
95 function Get_Sec_Stack_Addr return Address is
97 return STPO.Self.Common.Compiler_Data.Sec_Stack_Addr;
98 end Get_Sec_Stack_Addr;
100 --------------------------
101 -- Soft-Link Set Bodies --
102 --------------------------
104 procedure Set_Jmpbuf_Address (Addr : Address) is
106 STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr;
107 end Set_Jmpbuf_Address;
109 procedure Set_Sec_Stack_Addr (Addr : Address) is
111 STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr;
112 end Set_Sec_Stack_Addr;
118 procedure Timed_Delay_T (Time : Duration; Mode : Integer) is
119 Self_Id : constant System.Tasking.Task_Id := STPO.Self;
122 -- In case pragma Detect_Blocking is active then Program_Error
123 -- must be raised if this potentially blocking operation
124 -- is called from a protected operation.
126 if System.Tasking.Detect_Blocking
127 and then Self_Id.Common.Protected_Action_Nesting > 0
129 raise Program_Error with "potentially blocking operation";
132 STPO.Timed_Delay (Self_Id, Time, Mode);
137 -----------------------------
138 -- Init_Tasking_Soft_Links --
139 -----------------------------
141 procedure Init_Tasking_Soft_Links is
143 -- Set links only if not set already
145 if not Initialized then
147 -- Mark tasking soft links as initialized
151 -- The application being executed uses tasking so that the tasking
152 -- version of the following soft links need to be used.
154 SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access;
155 SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access;
156 SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
157 SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
158 SSL.Get_Current_Excep := Get_Current_Excep'Access;
159 SSL.Timed_Delay := Timed_Delay_T'Access;
161 -- No need to create a new Secondary Stack, since we will use the
162 -- default one created in s-secsta.adb
164 SSL.Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT);
165 SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT);
167 end Init_Tasking_Soft_Links;
169 end System.Soft_Links.Tasking;