gcc/ada/libgnarl/s-osinte__rtems.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
   4 --                                                                          --
   5 --                   S Y S T E M . O S _ I N T E R F A C E                  --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --            Copyright (C) 1991-2017, Florida State University             --
  10 --          Copyright (C) 1995-2023, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT 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 3,  or (at your option) any later ver- --
  15 -- sion.  GNAT 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.                                     --
  18 --                                                                          --
  19 -- As a special exception under Section 7 of GPL version 3, you are granted --
  20 -- additional permissions described in the GCC Runtime Library Exception,   --
  21 -- version 3.1, as published by the Free Software Foundation.               --
  22 --                                                                          --
  23 -- You should have received a copy of the GNU General Public License and    --
  24 -- a copy of the GCC Runtime Library Exception along with this program;     --
  25 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  26 -- <http://www.gnu.org/licenses/>.                                          --
  27 --                                                                          --
  28 -- GNARL was developed by the GNARL team at Florida State University. It is --
  29 -- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
  30 -- State University (http://www.gnat.com).                                  --
  31 --                                                                          --
  32 -- The GNARL files that were developed for RTEMS are maintained by  On-Line --
  33 -- Applications Research Corporation (http://www.oarcorp.com)  in  coopera- --
  34 -- tion with Ada Core Technologies Inc. and Florida State University.       --
  35 --                                                                          --
  36 ------------------------------------------------------------------------------
  37
  38 --  This is the RTEMS version of this package
  39
  40 --  This package encapsulates all direct interfaces to OS services
  41 --  that are needed by children of System.
  42
  43 with Interfaces.C; use Interfaces.C;
  44
  45 package body System.OS_Interface is
  46
  47    ---------------
  48    -- RTEMS API --
  49    ---------------
  50
  51    type RTEMS_Attributes is new unsigned;
  52
  53    RTEMS_SIMPLE_BINARY_SEMAPHORE : constant := 16#00000020#;
  54    RTEMS_FIFO                    : constant := 16#00000000#;
  55
  56    type RTEMS_Interval is new unsigned;
  57
  58    RTEMS_NO_TIMEOUT : constant := 0;
  59
  60    type RTEMS_Options is new unsigned;
  61
  62    RTEMS_WAIT             : constant := 16#00000000#;
  63    RTEMS_INTERRUPT_UNIQUE : constant := 16#00000001#;
  64
  65    type RTEMS_Name is new unsigned;
  66
  67    function RTEMS_Build_Name (C1, C2, C3, C4 : Character) return RTEMS_Name
  68      with Import, External_Name => "rtems_build_name", Convention => C;
  69
  70    function RTEMS_Semaphore_Create
  71      (Name             : RTEMS_Name;
  72       Count            : unsigned;
  73       Attributes       : RTEMS_Attributes;
  74       Priority_Ceiling : unsigned;
  75       Semaphore        : out Binary_Semaphore_Id) return int
  76      with Import, External_Name => "rtems_semaphore_create", Convention => C;
  77
  78    function RTEMS_Semaphore_Delete (Semaphore : Binary_Semaphore_Id) return int
  79      with Import, External_Name => "rtems_semaphore_delete", Convention => C;
  80
  81    function RTEMS_Semaphore_Flush (Semaphore : Binary_Semaphore_Id)
  82      return int
  83      with Import, External_Name => "rtems_semaphore_flush", Convention => C;
  84
  85    function RTEMS_Semaphore_Obtain
  86      (Semaphore : Binary_Semaphore_Id;
  87       Options   : RTEMS_Options;
  88       Timeout   : RTEMS_Interval) return int
  89      with Import, External_Name => "rtems_semaphore_obtain", Convention => C;
  90
  91    function RTEMS_Semaphore_Release (Semaphore : Binary_Semaphore_Id)
  92      return int
  93      with Import, External_Name => "rtems_semaphore_release", Convention => C;
  94
  95    -----------------
  96    -- To_Duration --
  97    -----------------
  98
  99    function To_Duration (TS : timespec) return Duration is
 100    begin
 101       return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
 102    end To_Duration;
 103
 104    ------------------------
 105    -- To_Target_Priority --
 106    ------------------------
 107
 108    function To_Target_Priority
 109      (Prio : System.Any_Priority) return Interfaces.C.int
 110    is
 111    begin
 112       return Interfaces.C.int (Prio);
 113    end To_Target_Priority;
 114
 115    -----------------
 116    -- To_Timespec --
 117    -----------------
 118
 119    function To_Timespec (D : Duration) return timespec is
 120       S : time_t;
 121       F : Duration;
 122    begin
 123       S := time_t (Long_Long_Integer (D));
 124       F := D - Duration (S);
 125
 126       --  If F has negative value due to round-up, adjust for positive F value
 127
 128       if F < 0.0 then
 129          S := S - 1;
 130          F := F + 1.0;
 131       end if;
 132       return timespec'(tv_sec => S,
 133                        tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
 134    end To_Timespec;
 135
 136    -----------------------------
 137    -- Binary_Semaphore_Create --
 138    -----------------------------
 139
 140    function Binary_Semaphore_Create return Binary_Semaphore_Id is
 141       Semaphore : Binary_Semaphore_Id;
 142       Status    : int;
 143    begin
 144       Status :=
 145         RTEMS_Semaphore_Create
 146           (Name             => RTEMS_Build_Name ('G', 'N', 'A', 'T'),
 147            Count            => 0,
 148            Attributes       => RTEMS_SIMPLE_BINARY_SEMAPHORE or RTEMS_FIFO,
 149            Priority_Ceiling => 0,
 150            Semaphore        => Semaphore);
 151
 152       pragma Assert (Status = 0);
 153
 154       return Semaphore;
 155    end Binary_Semaphore_Create;
 156
 157    -----------------------------
 158    -- Binary_Semaphore_Delete --
 159    -----------------------------
 160
 161    function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id)
 162      return int is
 163    begin
 164       return RTEMS_Semaphore_Delete (ID);
 165    end Binary_Semaphore_Delete;
 166
 167    -----------------------------
 168    -- Binary_Semaphore_Obtain --
 169    -----------------------------
 170
 171    function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id)
 172      return int is
 173    begin
 174       return RTEMS_Semaphore_Obtain (ID, RTEMS_WAIT, RTEMS_NO_TIMEOUT);
 175    end Binary_Semaphore_Obtain;
 176
 177    ------------------------------
 178    -- Binary_Semaphore_Release --
 179    ------------------------------
 180
 181    function Binary_Semaphore_Release (ID : Binary_Semaphore_Id)
 182      return int is
 183    begin
 184       return RTEMS_Semaphore_Release (ID);
 185    end Binary_Semaphore_Release;
 186
 187    ----------------------------
 188    -- Binary_Semaphore_Flush --
 189    ----------------------------
 190
 191    function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int is
 192    begin
 193       return RTEMS_Semaphore_Flush (ID);
 194    end Binary_Semaphore_Flush;
 195
 196    -----------------------
 197    -- Interrupt_Connect --
 198    -----------------------
 199
 200    function Interrupt_Connect
 201      (Vector    : Interrupt_Vector;
 202       Handler   : Interrupt_Handler;
 203       Parameter : System.Address := System.Null_Address) return int
 204    is
 205       function RTEMS_Interrupt_Handler_Install
 206          (Vector    : Interrupt_Vector;
 207           Info      : char_array;
 208           Options   : RTEMS_Options;
 209           Handler   : Interrupt_Handler;
 210           Parameter : System.Address) return int
 211         with Import,
 212              External_Name => "rtems_interrupt_handler_install",
 213              Convention => C;
 214
 215       Info_String : constant char_array := To_C ("GNAT Interrupt Handler");
 216       --  Handler name that is registered with RTEMS
 217    begin
 218       return
 219         RTEMS_Interrupt_Handler_Install
 220           (Vector    => Vector,
 221            Info      => Info_String,
 222            Options   => RTEMS_INTERRUPT_UNIQUE,
 223            Handler   => Handler,
 224            Parameter => Parameter);
 225    end Interrupt_Connect;
 226
 227    --------------------------------
 228    -- Interrupt_Number_To_Vector --
 229    --------------------------------
 230
 231    function Interrupt_Number_To_Vector (intNum : int)
 232      return Interrupt_Vector
 233    is
 234    begin
 235       return Interrupt_Vector (intNum);
 236    end Interrupt_Number_To_Vector;
 237
 238    ------------------
 239    -- pthread_init --
 240    ------------------
 241
 242    procedure pthread_init is
 243    begin
 244       null;
 245    end pthread_init;
 246
 247    --------------------
 248    -- Get_Stack_Base --
 249    --------------------
 250
 251    function Get_Stack_Base (thread : pthread_t) return Address is
 252       pragma Warnings (Off, thread);
 253
 254    begin
 255       return Null_Address;
 256    end Get_Stack_Base;
 257
 258    -----------------
 259    -- sigaltstack --
 260    -----------------
 261
 262    function sigaltstack
 263      (ss  : not null access stack_t;
 264       oss : access stack_t) return int is
 265       pragma Unreferenced (ss);
 266       pragma Unreferenced (oss);
 267    begin
 268       return 0;
 269    end sigaltstack;
 270
 271    -----------------------------------
 272    -- pthread_rwlockattr_setkind_np --
 273    -----------------------------------
 274
 275    function pthread_rwlockattr_setkind_np
 276      (attr : access pthread_rwlockattr_t;
 277       pref : int) return int is
 278       pragma Unreferenced (attr);
 279       pragma Unreferenced (pref);
 280    begin
 281       return 0;
 282    end pthread_rwlockattr_setkind_np;
 283
 284 end System.OS_Interface;