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-1994, Florida State University -- 10-- Copyright (C) 1995-2003, Ada Core Technologies -- 11-- -- 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. -- 22-- -- 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. -- 29-- -- 30-- GNARL was developed by the GNARL team at Florida State University. -- 31-- Extensive contributions were provided by Ada Core Technologies, Inc. -- 32-- -- 33------------------------------------------------------------------------------ 34 35-- This is a DCE version of this package. 36-- Currently HP-UX and SNI use this file 37 38pragma Polling (Off); 39-- Turn off polling, we do not want ATC polling to take place during 40-- tasking operations. It causes infinite loops and other problems. 41 42-- This package encapsulates all direct interfaces to OS services 43-- that are needed by children of System. 44 45with Interfaces.C; use Interfaces.C; 46 47package body System.OS_Interface is 48 49 ----------------- 50 -- To_Duration -- 51 ----------------- 52 53 function To_Duration (TS : timespec) return Duration is 54 begin 55 return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; 56 end To_Duration; 57 58 ----------------- 59 -- To_Timespec -- 60 ----------------- 61 62 function To_Timespec (D : Duration) return timespec is 63 S : time_t; 64 F : Duration; 65 66 begin 67 S := time_t (Long_Long_Integer (D)); 68 F := D - Duration (S); 69 70 -- If F has negative value due to a round-up, adjust for positive F 71 -- value. 72 if F < 0.0 then 73 S := S - 1; 74 F := F + 1.0; 75 end if; 76 77 return timespec'(tv_sec => S, 78 tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); 79 end To_Timespec; 80 81 function To_Duration (TV : struct_timeval) return Duration is 82 begin 83 return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; 84 end To_Duration; 85 86 function To_Timeval (D : Duration) return struct_timeval is 87 S : time_t; 88 F : Duration; 89 begin 90 S := time_t (Long_Long_Integer (D)); 91 F := D - Duration (S); 92 93 -- If F has negative value due to a round-up, adjust for positive F 94 -- value. 95 96 if F < 0.0 then 97 S := S - 1; 98 F := F + 1.0; 99 end if; 100 101 return 102 struct_timeval' 103 (tv_sec => S, 104 tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); 105 end To_Timeval; 106 107 --------------------------- 108 -- POSIX.1c Section 3 -- 109 --------------------------- 110 111 function sigwait 112 (set : access sigset_t; 113 sig : access Signal) 114 return int 115 is 116 Result : int; 117 118 begin 119 Result := sigwait (set); 120 121 if Result = -1 then 122 sig.all := 0; 123 return errno; 124 end if; 125 126 sig.all := Signal (Result); 127 return 0; 128 end sigwait; 129 130 -- DCE_THREADS does not have pthread_kill. Instead, we just ignore it. 131 132 function pthread_kill (thread : pthread_t; sig : Signal) return int is 133 pragma Unreferenced (thread, sig); 134 begin 135 return 0; 136 end pthread_kill; 137 138 ---------------------------- 139 -- POSIX.1c Section 11 -- 140 ---------------------------- 141 142 -- For all the following functions, DCE Threads has a non standard 143 -- behavior: it sets errno but the standard Posix requires it to be 144 -- returned. 145 146 function pthread_mutexattr_init 147 (attr : access pthread_mutexattr_t) 148 return int 149 is 150 function pthread_mutexattr_create 151 (attr : access pthread_mutexattr_t) 152 return int; 153 pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create"); 154 155 begin 156 if pthread_mutexattr_create (attr) /= 0 then 157 return errno; 158 else 159 return 0; 160 end if; 161 end pthread_mutexattr_init; 162 163 function pthread_mutexattr_destroy 164 (attr : access pthread_mutexattr_t) 165 return int 166 is 167 function pthread_mutexattr_delete 168 (attr : access pthread_mutexattr_t) 169 return int; 170 pragma Import (C, pthread_mutexattr_delete, "pthread_mutexattr_delete"); 171 172 begin 173 if pthread_mutexattr_delete (attr) /= 0 then 174 return errno; 175 else 176 return 0; 177 end if; 178 end pthread_mutexattr_destroy; 179 180 function pthread_mutex_init 181 (mutex : access pthread_mutex_t; 182 attr : access pthread_mutexattr_t) 183 return int 184 is 185 function pthread_mutex_init_base 186 (mutex : access pthread_mutex_t; 187 attr : pthread_mutexattr_t) 188 return int; 189 pragma Import (C, pthread_mutex_init_base, "pthread_mutex_init"); 190 191 begin 192 if pthread_mutex_init_base (mutex, attr.all) /= 0 then 193 return errno; 194 else 195 return 0; 196 end if; 197 end pthread_mutex_init; 198 199 function pthread_mutex_destroy 200 (mutex : access pthread_mutex_t) 201 return int 202 is 203 function pthread_mutex_destroy_base 204 (mutex : access pthread_mutex_t) 205 return int; 206 pragma Import (C, pthread_mutex_destroy_base, "pthread_mutex_destroy"); 207 208 begin 209 if pthread_mutex_destroy_base (mutex) /= 0 then 210 return errno; 211 else 212 return 0; 213 end if; 214 end pthread_mutex_destroy; 215 216 function pthread_mutex_lock 217 (mutex : access pthread_mutex_t) 218 return int 219 is 220 function pthread_mutex_lock_base 221 (mutex : access pthread_mutex_t) 222 return int; 223 pragma Import (C, pthread_mutex_lock_base, "pthread_mutex_lock"); 224 225 begin 226 if pthread_mutex_lock_base (mutex) /= 0 then 227 return errno; 228 else 229 return 0; 230 end if; 231 end pthread_mutex_lock; 232 233 function pthread_mutex_unlock 234 (mutex : access pthread_mutex_t) 235 return int 236 is 237 function pthread_mutex_unlock_base 238 (mutex : access pthread_mutex_t) 239 return int; 240 pragma Import (C, pthread_mutex_unlock_base, "pthread_mutex_unlock"); 241 242 begin 243 if pthread_mutex_unlock_base (mutex) /= 0 then 244 return errno; 245 else 246 return 0; 247 end if; 248 end pthread_mutex_unlock; 249 250 function pthread_condattr_init 251 (attr : access pthread_condattr_t) 252 return int 253 is 254 function pthread_condattr_create 255 (attr : access pthread_condattr_t) 256 return int; 257 pragma Import (C, pthread_condattr_create, "pthread_condattr_create"); 258 259 begin 260 if pthread_condattr_create (attr) /= 0 then 261 return errno; 262 else 263 return 0; 264 end if; 265 end pthread_condattr_init; 266 267 function pthread_condattr_destroy 268 (attr : access pthread_condattr_t) 269 return int 270 is 271 function pthread_condattr_delete 272 (attr : access pthread_condattr_t) 273 return int; 274 pragma Import (C, pthread_condattr_delete, "pthread_condattr_delete"); 275 276 begin 277 if pthread_condattr_delete (attr) /= 0 then 278 return errno; 279 else 280 return 0; 281 end if; 282 end pthread_condattr_destroy; 283 284 function pthread_cond_init 285 (cond : access pthread_cond_t; 286 attr : access pthread_condattr_t) 287 return int 288 is 289 function pthread_cond_init_base 290 (cond : access pthread_cond_t; 291 attr : pthread_condattr_t) 292 return int; 293 pragma Import (C, pthread_cond_init_base, "pthread_cond_init"); 294 295 begin 296 if pthread_cond_init_base (cond, attr.all) /= 0 then 297 return errno; 298 else 299 return 0; 300 end if; 301 end pthread_cond_init; 302 303 function pthread_cond_destroy 304 (cond : access pthread_cond_t) 305 return int 306 is 307 function pthread_cond_destroy_base 308 (cond : access pthread_cond_t) 309 return int; 310 pragma Import (C, pthread_cond_destroy_base, "pthread_cond_destroy"); 311 312 begin 313 if pthread_cond_destroy_base (cond) /= 0 then 314 return errno; 315 else 316 return 0; 317 end if; 318 end pthread_cond_destroy; 319 320 function pthread_cond_signal 321 (cond : access pthread_cond_t) 322 return int 323 is 324 function pthread_cond_signal_base 325 (cond : access pthread_cond_t) 326 return int; 327 pragma Import (C, pthread_cond_signal_base, "pthread_cond_signal"); 328 329 begin 330 if pthread_cond_signal_base (cond) /= 0 then 331 return errno; 332 else 333 return 0; 334 end if; 335 end pthread_cond_signal; 336 337 function pthread_cond_wait 338 (cond : access pthread_cond_t; 339 mutex : access pthread_mutex_t) 340 return int 341 is 342 function pthread_cond_wait_base 343 (cond : access pthread_cond_t; 344 mutex : access pthread_mutex_t) 345 return int; 346 pragma Import (C, pthread_cond_wait_base, "pthread_cond_wait"); 347 348 begin 349 if pthread_cond_wait_base (cond, mutex) /= 0 then 350 return errno; 351 else 352 return 0; 353 end if; 354 end pthread_cond_wait; 355 356 function pthread_cond_timedwait 357 (cond : access pthread_cond_t; 358 mutex : access pthread_mutex_t; 359 abstime : access timespec) 360 return int 361 is 362 function pthread_cond_timedwait_base 363 (cond : access pthread_cond_t; 364 mutex : access pthread_mutex_t; 365 abstime : access timespec) 366 return int; 367 pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait"); 368 369 begin 370 if pthread_cond_timedwait_base (cond, mutex, abstime) /= 0 then 371 if errno = EAGAIN then 372 return ETIMEDOUT; 373 else 374 return errno; 375 end if; 376 else 377 return 0; 378 end if; 379 end pthread_cond_timedwait; 380 381 ---------------------------- 382 -- POSIX.1c Section 13 -- 383 ---------------------------- 384 385 function pthread_setschedparam 386 (thread : pthread_t; 387 policy : int; 388 param : access struct_sched_param) return int 389 is 390 function pthread_setscheduler 391 (thread : pthread_t; 392 policy : int; 393 priority : int) 394 return int; 395 pragma Import (C, pthread_setscheduler, "pthread_setscheduler"); 396 397 begin 398 if pthread_setscheduler (thread, policy, param.sched_priority) = -1 then 399 return errno; 400 else 401 return 0; 402 end if; 403 end pthread_setschedparam; 404 405 function sched_yield return int is 406 procedure pthread_yield; 407 pragma Import (C, pthread_yield, "pthread_yield"); 408 begin 409 pthread_yield; 410 return 0; 411 end sched_yield; 412 413 ----------------------------- 414 -- P1003.1c - Section 16 -- 415 ----------------------------- 416 417 function pthread_attr_init (attributes : access pthread_attr_t) return int 418 is 419 function pthread_attr_create 420 (attributes : access pthread_attr_t) 421 return int; 422 pragma Import (C, pthread_attr_create, "pthread_attr_create"); 423 424 begin 425 if pthread_attr_create (attributes) /= 0 then 426 return errno; 427 else 428 return 0; 429 end if; 430 end pthread_attr_init; 431 432 function pthread_attr_destroy 433 (attributes : access pthread_attr_t) return int 434 is 435 function pthread_attr_delete 436 (attributes : access pthread_attr_t) 437 return int; 438 pragma Import (C, pthread_attr_delete, "pthread_attr_delete"); 439 440 begin 441 if pthread_attr_delete (attributes) /= 0 then 442 return errno; 443 else 444 return 0; 445 end if; 446 end pthread_attr_destroy; 447 448 function pthread_attr_setstacksize 449 (attr : access pthread_attr_t; 450 stacksize : size_t) return int 451 is 452 function pthread_attr_setstacksize_base 453 (attr : access pthread_attr_t; 454 stacksize : size_t) 455 return int; 456 pragma Import (C, pthread_attr_setstacksize_base, 457 "pthread_attr_setstacksize"); 458 459 begin 460 if pthread_attr_setstacksize_base (attr, stacksize) /= 0 then 461 return errno; 462 else 463 return 0; 464 end if; 465 end pthread_attr_setstacksize; 466 467 function pthread_create 468 (thread : access pthread_t; 469 attributes : access pthread_attr_t; 470 start_routine : Thread_Body; 471 arg : System.Address) return int 472 is 473 function pthread_create_base 474 (thread : access pthread_t; 475 attributes : pthread_attr_t; 476 start_routine : Thread_Body; 477 arg : System.Address) 478 return int; 479 pragma Import (C, pthread_create_base, "pthread_create"); 480 481 begin 482 if pthread_create_base 483 (thread, attributes.all, start_routine, arg) /= 0 484 then 485 return errno; 486 else 487 return 0; 488 end if; 489 end pthread_create; 490 491 ---------------------------- 492 -- POSIX.1c Section 17 -- 493 ---------------------------- 494 495 function pthread_setspecific 496 (key : pthread_key_t; 497 value : System.Address) return int 498 is 499 function pthread_setspecific_base 500 (key : pthread_key_t; 501 value : System.Address) return int; 502 pragma Import (C, pthread_setspecific_base, "pthread_setspecific"); 503 504 begin 505 if pthread_setspecific_base (key, value) /= 0 then 506 return errno; 507 else 508 return 0; 509 end if; 510 end pthread_setspecific; 511 512 function pthread_getspecific (key : pthread_key_t) return System.Address is 513 function pthread_getspecific_base 514 (key : pthread_key_t; 515 value : access System.Address) return int; 516 pragma Import (C, pthread_getspecific_base, "pthread_getspecific"); 517 Addr : aliased System.Address; 518 519 begin 520 if pthread_getspecific_base (key, Addr'Access) /= 0 then 521 return System.Null_Address; 522 else 523 return Addr; 524 end if; 525 end pthread_getspecific; 526 527 function pthread_key_create 528 (key : access pthread_key_t; 529 destructor : destructor_pointer) return int 530 is 531 function pthread_keycreate 532 (key : access pthread_key_t; 533 destructor : destructor_pointer) return int; 534 pragma Import (C, pthread_keycreate, "pthread_keycreate"); 535 536 begin 537 if pthread_keycreate (key, destructor) /= 0 then 538 return errno; 539 else 540 return 0; 541 end if; 542 end pthread_key_create; 543 544 function Get_Stack_Base (thread : pthread_t) return Address is 545 pragma Warnings (Off, thread); 546 547 begin 548 return Null_Address; 549 end Get_Stack_Base; 550 551 procedure pthread_init is 552 begin 553 null; 554 end pthread_init; 555 556 function intr_attach (sig : int; handler : isr_address) return long is 557 function c_signal (sig : int; handler : isr_address) return long; 558 pragma Import (C, c_signal, "signal"); 559 560 begin 561 return c_signal (sig, handler); 562 end intr_attach; 563 564end System.OS_Interface; 565