projects / thirdparty / gcc.git / blame
| Commit | Line | Data |
|---|---|---|
| d23b8f57 RK |
1 | ------------------------------------------------------------------------------ |
| 2 | -- -- | |
| 3084fecd | 3 | -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- |
| d23b8f57 RK |
4 | -- -- |
| 5 | -- A D A . R E A L _ T I M E . D E L A Y S -- | |
| 6 | -- -- | |
| 7 | -- B o d y -- | |
| 8 | -- -- | |
| 4b490c1e | 9 | -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- |
| d23b8f57 RK |
10 | -- -- |
| 11 | -- GNARL 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- -- | |
| 748086b7 JJ |
13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| 14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- | |
| d23b8f57 | 15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| 748086b7 JJ |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
| 17 | -- -- | |
| 18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- | |
| 19 | -- additional permissions described in the GCC Runtime Library Exception, -- | |
| 20 | -- version 3.1, as published by the Free Software Foundation. -- | |
| 21 | -- -- | |
| 22 | -- You should have received a copy of the GNU General Public License and -- | |
| 23 | -- a copy of the GCC Runtime Library Exception along with this program; -- | |
| 24 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- | |
| 25 | -- <http://www.gnu.org/licenses/>. -- | |
| d23b8f57 | 26 | -- -- |
| c6362f4f NN |
27 | -- GNARL was developed by the GNARL team at Florida State University. -- |
| 28 | -- Extensive contributions were provided by Ada Core Technologies, Inc. -- | |
| d23b8f57 RK |
29 | -- -- |
| 30 | ------------------------------------------------------------------------------ | |
| 31 | ||
| c885d7a1 | 32 | with Ada.Exceptions; |
| c885d7a1 AC |
33 | |
| 34 | with System.Tasking; | |
| d23b8f57 | 35 | with System.Task_Primitives.Operations; |
| d23b8f57 | 36 | |
| d23b8f57 RK |
37 | package body Ada.Real_Time.Delays is |
| 38 | ||
| 39 | package STPO renames System.Task_Primitives.Operations; | |
| 07fc65c4 | 40 | |
| c885d7a1 AC |
41 | ---------------- |
| 42 | -- Local Data -- | |
| 43 | ---------------- | |
| 44 | ||
| 07fc65c4 | 45 | Absolute_RT : constant := 2; |
| d23b8f57 RK |
46 | |
| 47 | ----------------- | |
| 48 | -- Delay_Until -- | |
| 49 | ----------------- | |
| 50 | ||
| 51 | procedure Delay_Until (T : Time) is | |
| c885d7a1 AC |
52 | Self_Id : constant System.Tasking.Task_Id := STPO.Self; |
| 53 | ||
| d23b8f57 | 54 | begin |
| c885d7a1 AC |
55 | -- If pragma Detect_Blocking is active, Program_Error must be |
| 56 | -- raised if this potentially blocking operation is called from a | |
| 57 | -- protected action. | |
| 58 | ||
| 59 | if System.Tasking.Detect_Blocking | |
| 60 | and then Self_Id.Common.Protected_Action_Nesting > 0 | |
| 61 | then | |
| 62 | Ada.Exceptions.Raise_Exception | |
| 63 | (Program_Error'Identity, "potentially blocking operation"); | |
| 64 | else | |
| 65 | STPO.Timed_Delay (Self_Id, To_Duration (T), Absolute_RT); | |
| 66 | end if; | |
| d23b8f57 RK |
67 | end Delay_Until; |
| 68 | ||
| 69 | ----------------- | |
| 70 | -- To_Duration -- | |
| 71 | ----------------- | |
| 72 | ||
| 73 | function To_Duration (T : Time) return Duration is | |
| 74 | begin | |
| 75 | return To_Duration (Time_Span (T)); | |
| 76 | end To_Duration; | |
| 77 | ||
| 78 | end Ada.Real_Time.Delays; |