https://gcc.gnu.org/g:820cd5266e714750888dd2cdf4793cde8741c1db
commit r15-4220-g820cd5266e714750888dd2cdf4793cde8741c1db
Author: Eric Botcazou <ebotca...@adacore.com>
Date: Wed Oct 9 21:21:36 2024 +0200
Remove support for HP-UX 10
gcc/ada
* Makefile.rtl: Remove HP-UX 10 section.
* libgnarl/s-osinte__hpux-dce.ads: Delete.
* libgnarl/s-osinte__hpux-dce.adb: Likewise.
* libgnarl/s-taprop__hpux-dce.adb: Likewise.
* libgnarl/s-taspri__hpux-dce.ads: Likewise.
* libgnat/s-oslock__hpux-dce.ads: Likewise.
Diff:
---
gcc/ada/Makefile.rtl | 26 -
gcc/ada/libgnarl/s-osinte__hpux-dce.adb | 494 -------------
gcc/ada/libgnarl/s-osinte__hpux-dce.ads | 487 -------------
gcc/ada/libgnarl/s-taprop__hpux-dce.adb | 1210 -------------------------------
gcc/ada/libgnarl/s-taspri__hpux-dce.ads | 106 ---
gcc/ada/libgnat/s-oslock__hpux-dce.ads | 61 --
6 files changed, 2384 deletions(-)
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
index 246c0059fb7f..a36f60170b5e 100644
--- a/gcc/ada/Makefile.rtl
+++ b/gcc/ada/Makefile.rtl
@@ -1972,32 +1972,6 @@ ifeq ($(strip $(filter-out s390% linux%,$(target_cpu)
$(target_os))),)
endif
endif
-# HP/PA HP-UX 10
-ifeq ($(SELECTED_PAIRS),PAIRS_NONE)
-ifeq ($(strip $(filter-out hppa% hp hpux10%,$(target_cpu) $(target_vendor)
$(target_os))),)
-
- SELECTED_PAIRS=hppa-hpux10
-
- LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<libgnarl/a-intnam__hpux.ads \
- s-inmaop.adb<libgnarl/s-inmaop__posix.adb \
- s-interr.adb<libgnarl/s-interr__sigaction.adb \
- s-intman.adb<libgnarl/s-intman__posix.adb \
- a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \
- s-osinte.adb<libgnarl/s-osinte__hpux-dce.adb \
- s-osinte.ads<libgnarl/s-osinte__hpux-dce.ads \
- s-parame.ads<libgnat/s-parame__hpux.ads \
- s-oslock.ads<libgnat/s-oslock__posix.ads \
- s-osprim.adb<libgnat/s-osprim__posix.adb \
- s-taprop.adb<libgnarl/s-taprop__hpux-dce.adb \
- s-taspri.ads<libgnarl/s-taspri__hpux-dce.ads \
- s-tpopsp.adb<libgnarl/s-tpopsp__posix.adb \
- system.ads<libgnat/system-hpux.ads
-
- EH_MECHANISM=-gcc
-endif
-endif
-
# HP/PA HP-UX 11
ifeq ($(SELECTED_PAIRS),PAIRS_NONE)
ifeq ($(strip $(filter-out hppa% hp hpux11%,$(target_cpu) $(target_vendor)
$(target_os))),)
diff --git a/gcc/ada/libgnarl/s-osinte__hpux-dce.adb
b/gcc/ada/libgnarl/s-osinte__hpux-dce.adb
deleted file mode 100644
index ff1e0d4c17e1..000000000000
--- a/gcc/ada/libgnarl/s-osinte__hpux-dce.adb
+++ /dev/null
@@ -1,494 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2024, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a DCE version of this package.
--- Currently HP-UX and SNI use this file
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
-with Interfaces.C; use Interfaces.C;
-
-package body System.OS_Interface is
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal) return int
- is
- Result : int;
-
- begin
- Result := sigwait (set);
-
- if Result = -1 then
- sig.all := 0;
- return errno;
- end if;
-
- sig.all := Signal (Result);
- return 0;
- end sigwait;
-
- -- DCE_THREADS does not have pthread_kill. Instead, we just ignore it
-
- function pthread_kill (thread : pthread_t; sig : Signal) return int is
- pragma Unreferenced (thread, sig);
- begin
- return 0;
- end pthread_kill;
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- -- For all following functions, DCE Threads has a non standard behavior.
- -- It sets errno but the standard Posix requires it to be returned.
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int
- is
- function pthread_mutexattr_create
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create");
-
- begin
- if pthread_mutexattr_create (attr) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_mutexattr_init;
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int
- is
- function pthread_mutexattr_delete
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_delete, "pthread_mutexattr_delete");
-
- begin
- if pthread_mutexattr_delete (attr) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_mutexattr_destroy;
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int
- is
- function pthread_mutex_init_base
- (mutex : access pthread_mutex_t;
- attr : pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init_base, "pthread_mutex_init");
-
- begin
- if pthread_mutex_init_base (mutex, attr.all) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_mutex_init;
-
- function pthread_mutex_destroy
- (mutex : access pthread_mutex_t) return int
- is
- function pthread_mutex_destroy_base
- (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy_base, "pthread_mutex_destroy");
-
- begin
- if pthread_mutex_destroy_base (mutex) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_mutex_destroy;
-
- function pthread_mutex_lock
- (mutex : access pthread_mutex_t) return int
- is
- function pthread_mutex_lock_base
- (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock_base, "pthread_mutex_lock");
-
- begin
- if pthread_mutex_lock_base (mutex) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_mutex_lock;
-
- function pthread_mutex_unlock
- (mutex : access pthread_mutex_t) return int
- is
- function pthread_mutex_unlock_base
- (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock_base, "pthread_mutex_unlock");
-
- begin
- if pthread_mutex_unlock_base (mutex) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_mutex_unlock;
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int
- is
- function pthread_condattr_create
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_create, "pthread_condattr_create");
-
- begin
- if pthread_condattr_create (attr) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_condattr_init;
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int
- is
- function pthread_condattr_delete
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_delete, "pthread_condattr_delete");
-
- begin
- if pthread_condattr_delete (attr) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_condattr_destroy;
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int
- is
- function pthread_cond_init_base
- (cond : access pthread_cond_t;
- attr : pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init_base, "pthread_cond_init");
-
- begin
- if pthread_cond_init_base (cond, attr.all) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_cond_init;
-
- function pthread_cond_destroy
- (cond : access pthread_cond_t) return int
- is
- function pthread_cond_destroy_base
- (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy_base, "pthread_cond_destroy");
-
- begin
- if pthread_cond_destroy_base (cond) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_cond_destroy;
-
- function pthread_cond_signal
- (cond : access pthread_cond_t) return int
- is
- function pthread_cond_signal_base
- (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal_base, "pthread_cond_signal");
-
- begin
- if pthread_cond_signal_base (cond) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_cond_signal;
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int
- is
- function pthread_cond_wait_base
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait_base, "pthread_cond_wait");
-
- begin
- if pthread_cond_wait_base (cond, mutex) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_cond_wait;
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int
- is
- function pthread_cond_timedwait_base
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait");
-
- begin
- if pthread_cond_timedwait_base (cond, mutex, abstime) /= 0 then
- return (if errno = EAGAIN then ETIMEDOUT else errno);
- else
- return 0;
- end if;
- end pthread_cond_timedwait;
-
- ----------------------------
- -- POSIX.1c Section 13 --
- ----------------------------
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int
- is
- function pthread_setscheduler
- (thread : pthread_t;
- policy : int;
- priority : int) return int;
- pragma Import (C, pthread_setscheduler, "pthread_setscheduler");
-
- begin
- if pthread_setscheduler (thread, policy, param.sched_priority) = -1 then
- return errno;
- else
- return 0;
- end if;
- end pthread_setschedparam;
-
- function sched_yield return int is
- procedure pthread_yield;
- pragma Import (C, pthread_yield, "pthread_yield");
- begin
- pthread_yield;
- return 0;
- end sched_yield;
-
- -----------------------------
- -- P1003.1c - Section 16 --
- -----------------------------
-
- function pthread_attr_init
- (attributes : access pthread_attr_t) return int
- is
- function pthread_attr_create
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_create, "pthread_attr_create");
-
- begin
- if pthread_attr_create (attributes) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_attr_init;
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int
- is
- function pthread_attr_delete
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_delete, "pthread_attr_delete");
-
- begin
- if pthread_attr_delete (attributes) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_attr_destroy;
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int
- is
- function pthread_attr_setstacksize_base
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize_base,
- "pthread_attr_setstacksize");
-
- begin
- if pthread_attr_setstacksize_base (attr, stacksize) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_attr_setstacksize;
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int
- is
- function pthread_create_base
- (thread : access pthread_t;
- attributes : pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create_base, "pthread_create");
-
- begin
- if pthread_create_base
- (thread, attributes.all, start_routine, arg) /= 0
- then
- return errno;
- else
- return 0;
- end if;
- end pthread_create;
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int
- is
- function pthread_setspecific_base
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific_base, "pthread_setspecific");
-
- begin
- if pthread_setspecific_base (key, value) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_setspecific;
-
- function pthread_getspecific (key : pthread_key_t) return System.Address is
- function pthread_getspecific_base
- (key : pthread_key_t;
- value : access System.Address) return int;
- pragma Import (C, pthread_getspecific_base, "pthread_getspecific");
- Addr : aliased System.Address;
-
- begin
- if pthread_getspecific_base (key, Addr'Access) /= 0 then
- return System.Null_Address;
- else
- return Addr;
- end if;
- end pthread_getspecific;
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int
- is
- function pthread_keycreate
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_keycreate, "pthread_keycreate");
-
- begin
- if pthread_keycreate (key, destructor) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_key_create;
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Warnings (Off, thread);
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
- function intr_attach (sig : int; handler : isr_address) return long is
- function c_signal (sig : int; handler : isr_address) return long;
- pragma Import (C, c_signal, "signal");
- begin
- return c_signal (sig, handler);
- end intr_attach;
-
-end System.OS_Interface;
diff --git a/gcc/ada/libgnarl/s-osinte__hpux-dce.ads
b/gcc/ada/libgnarl/s-osinte__hpux-dce.ads
deleted file mode 100644
index 364a5ecbd524..000000000000
--- a/gcc/ada/libgnarl/s-osinte__hpux-dce.ads
+++ /dev/null
@@ -1,487 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2024, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the HP-UX version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by the tasking run-time (libgnarl).
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-
-with System.OS_Locks;
-with System.Parameters;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-lcma");
-
- subtype int is Interfaces.C.int;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := 11;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- ETIME : constant := 52;
- ETIMEDOUT : constant := 238;
-
- FUNC_ERR : constant := -1;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 44;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 16; -- user defined signal 1
- SIGUSR2 : constant := 17; -- user defined signal 2
- SIGCLD : constant := 18; -- alias for SIGCHLD
- SIGCHLD : constant := 18; -- child status change
- SIGPWR : constant := 19; -- power-fail restart
- SIGVTALRM : constant := 20; -- virtual timer alarm
- SIGPROF : constant := 21; -- profiling timer alarm
- SIGIO : constant := 22; -- asynchronous I/O
- SIGPOLL : constant := 22; -- pollable event occurred
- SIGWINCH : constant := 23; -- window size change
- SIGSTOP : constant := 24; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 25; -- user stop requested from tty
- SIGCONT : constant := 26; -- stopped process has been continued
- SIGTTIN : constant := 27; -- background tty read attempted
- SIGTTOU : constant := 28; -- background tty write attempted
- SIGURG : constant := 29; -- urgent condition on IO channel
- SIGLOST : constant := 30; -- remote lock lost (NFS)
- SIGDIL : constant := 32; -- DIL signal
- SIGXCPU : constant := 33; -- CPU time limit exceeded (setrlimit)
- SIGXFSZ : constant := 34; -- file size limit exceeded (setrlimit)
-
- SIGADAABORT : constant := SIGABRT;
- -- Note: on other targets, we usually use SIGABRT, but on HP/UX, it
- -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set :=
- (SIGBUS, SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP);
-
- Reserved : constant Signal_Set := (SIGKILL, SIGSTOP);
-
- type sigset_t is private;
-
- type isr_address is access procedure (sig : int);
- pragma Convention (C, isr_address);
-
- function intr_attach (sig : int; handler : isr_address) return long;
-
- Intr_Attach_Reset : constant Boolean := True;
- -- True if intr_attach is reset after an interrupt handler is called
-
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- type Signal_Handler is access procedure (signo : Signal);
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SA_RESTART : constant := 16#40#;
- SA_SIGINFO : constant := 16#10#;
- SA_ONSTACK : constant := 16#01#;
-
- SIG_BLOCK : constant := 0;
- SIG_UNBLOCK : constant := 1;
- SIG_SETMASK : constant := 2;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
- SIG_ERR : constant := -1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- type timespec is private;
-
- function nanosleep (rqtp, rmtp : access timespec) return int;
- pragma Import (C, nanosleep);
-
- type clockid_t is new int;
-
- function Clock_Gettime
- (Clock_Id : clockid_t; Tp : access timespec) return int;
- pragma Import (C, Clock_Gettime);
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_FIFO : constant := 0;
- SCHED_RR : constant := 1;
- SCHED_OTHER : constant := 2;
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- function Thread_Body_Access is new
- Ada.Unchecked_Conversion (System.Address, Thread_Body);
-
- type pthread_t is private;
- subtype Thread_Id is pthread_t;
-
- subtype pthread_mutex_t is System.OS_Locks.pthread_mutex_t;
- type pthread_cond_t is limited private;
- type pthread_attr_t is limited private;
- type pthread_mutexattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- -- Read/Write lock not supported on HPUX. To add support both types
- -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
- -- with the associated routines pthread_rwlock_[init/destroy] and
- -- pthread_rwlock_[rdlock/wrlock/unlock].
-
- subtype pthread_rwlock_t is pthread_mutex_t;
- subtype pthread_rwlockattr_t is pthread_mutexattr_t;
-
- -----------
- -- Stack --
- -----------
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- This is a dummy procedure to share some GNULLI files
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- procedure pthread_init;
- pragma Inline (pthread_init);
- -- This is a dummy procedure to share some GNULLI files
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait (set : access sigset_t) return int;
- pragma Import (C, sigwait, "cma_sigwait");
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal) return int;
- pragma Inline (sigwait);
- -- DCE_THREADS has a nonstandard sigwait
-
- function pthread_kill
- (thread : pthread_t;
- sig : Signal) return int;
- pragma Inline (pthread_kill);
- -- DCE_THREADS doesn't have pthread_kill
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- -- DCE THREADS does not have pthread_sigmask. Instead, it uses sigprocmask
- -- to do the signal handling when the thread library is sucked in.
- pragma Import (C, pthread_sigmask, "sigprocmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- -- DCE_THREADS has a nonstandard pthread_mutexattr_init
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- -- DCE_THREADS has a nonstandard pthread_mutexattr_destroy
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- -- DCE_THREADS has a nonstandard pthread_mutex_init
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- -- DCE_THREADS has a nonstandard pthread_mutex_destroy
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Inline (pthread_mutex_lock);
- -- DCE_THREADS has nonstandard pthread_mutex_lock
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Inline (pthread_mutex_unlock);
- -- DCE_THREADS has nonstandard pthread_mutex_lock
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- -- DCE_THREADS has nonstandard pthread_condattr_init
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- -- DCE_THREADS has nonstandard pthread_condattr_destroy
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- -- DCE_THREADS has nonstandard pthread_cond_init
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- -- DCE_THREADS has nonstandard pthread_cond_destroy
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Inline (pthread_cond_signal);
- -- DCE_THREADS has nonstandard pthread_cond_signal
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Inline (pthread_cond_wait);
- -- DCE_THREADS has a nonstandard pthread_cond_wait
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Inline (pthread_cond_timedwait);
- -- DCE_THREADS has a nonstandard pthread_cond_timedwait
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- type struct_sched_param is record
- sched_priority : int; -- scheduling priority
- end record;
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int;
- pragma Inline (pthread_setschedparam);
- -- DCE_THREADS has a nonstandard pthread_setschedparam
-
- function sched_yield return int;
- pragma Inline (sched_yield);
- -- DCE_THREADS has a nonstandard sched_yield
-
- ---------------------------
- -- P1003.1c - Section 16 --
- ---------------------------
-
- function pthread_attr_init (attributes : access pthread_attr_t) return int;
- pragma Inline (pthread_attr_init);
- -- DCE_THREADS has a nonstandard pthread_attr_init
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Inline (pthread_attr_destroy);
- -- DCE_THREADS has a nonstandard pthread_attr_destroy
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Inline (pthread_attr_setstacksize);
- -- DCE_THREADS has a nonstandard pthread_attr_setstacksize
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Inline (pthread_create);
- -- DCE_THREADS has a nonstandard pthread_create
-
- procedure pthread_detach (thread : access pthread_t);
- pragma Import (C, pthread_detach);
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Inline (pthread_setspecific);
- -- DCE_THREADS has a nonstandard pthread_setspecific
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Inline (pthread_getspecific);
- -- DCE_THREADS has a nonstandard pthread_getspecific
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Inline (pthread_key_create);
- -- DCE_THREADS has a nonstandard pthread_key_create
-
-private
-
- type array_type_1 is array (Integer range 0 .. 7) of unsigned_long;
- type sigset_t is record
- X_X_sigbits : array_type_1;
- end record;
- pragma Convention (C, sigset_t);
-
- type pid_t is new int;
-
- type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
- .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- CLOCK_REALTIME : constant clockid_t := 1;
-
- type cma_t_address is new System.Address;
-
- type cma_t_handle is record
- field1 : cma_t_address;
- field2 : Short_Integer;
- field3 : Short_Integer;
- end record;
- for cma_t_handle'Size use 64;
-
- type pthread_attr_t is new cma_t_handle;
- pragma Convention (C_Pass_By_Copy, pthread_attr_t);
-
- type pthread_condattr_t is new cma_t_handle;
- pragma Convention (C_Pass_By_Copy, pthread_condattr_t);
-
- type pthread_mutexattr_t is new cma_t_handle;
- pragma Convention (C_Pass_By_Copy, pthread_mutexattr_t);
-
- type pthread_t is new cma_t_handle;
- pragma Convention (C_Pass_By_Copy, pthread_t);
-
- type pthread_cond_t is new cma_t_handle;
- pragma Convention (C_Pass_By_Copy, pthread_cond_t);
-
- type pthread_key_t is new int;
-
-end System.OS_Interface;
diff --git a/gcc/ada/libgnarl/s-taprop__hpux-dce.adb
b/gcc/ada/libgnarl/s-taprop__hpux-dce.adb
deleted file mode 100644
index 7f4e707645d1..000000000000
--- a/gcc/ada/libgnarl/s-taprop__hpux-dce.adb
+++ /dev/null
@@ -1,1210 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2024, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a HP-UX DCE threads (HPUX 10) version of this package
-
--- This package contains all the GNULL primitives that interface directly with
--- the underlying OS.
-
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-
-with System.Interrupt_Management;
-with System.OS_Constants;
-with System.OS_Primitives;
-with System.Task_Primitives.Interrupt_Operations;
-with System.Tasking.Debug;
-
-pragma Warnings (Off);
-with System.Interrupt_Management.Operations;
-pragma Elaborate_All (System.Interrupt_Management.Operations);
-pragma Warnings (On);
-
-with System.Soft_Links;
--- We use System.Soft_Links instead of System.Tasking.Initialization
--- because the later is a higher level package that we shouldn't depend on.
--- For example when using the restricted run time, it is replaced by
--- System.Tasking.Restricted.Stages.
-
-package body System.Task_Primitives.Operations is
-
- package OSC renames System.OS_Constants;
- package SSL renames System.Soft_Links;
-
- use Interfaces.C;
-
- use System.OS_Interface;
- use System.OS_Locks;
- use System.OS_Primitives;
- use System.Parameters;
- use System.Tasking;
- use System.Tasking.Debug;
-
- package PIO renames System.Task_Primitives.Interrupt_Operations;
-
- ----------------
- -- Local Data --
- ----------------
-
- -- The followings are logically constants, but need to be initialized
- -- at run time.
-
- Single_RTS_Lock : aliased RTS_Lock;
- -- This is a lock to allow only one thread of control in the RTS at
- -- a time; it is used to execute in mutual exclusion from all other tasks.
- -- Used to protect All_Tasks_List
-
- Environment_Task_Id : Task_Id;
- -- A variable to hold Task_Id for the environment task
-
- Unblocked_Signal_Mask : aliased sigset_t;
- -- The set of signals that should unblocked in all tasks
-
- Time_Slice_Val : constant Integer;
- pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
-
- Dispatching_Policy : constant Character;
- pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
-
- -- Note: the reason that Locking_Policy is not needed is that this
- -- is not implemented for DCE threads. The HPUX 10 port is at this
- -- stage considered dead, and no further work is planned on it.
-
- Foreign_Task_Elaborated : aliased Boolean := True;
- -- Used to identified fake tasks (i.e., non-Ada Threads)
-
- --------------------
- -- Local Packages --
- --------------------
-
- package Specific is
-
- procedure Initialize (Environment_Task : Task_Id);
- pragma Inline (Initialize);
- -- Initialize various data needed by this package
-
- function Is_Valid_Task return Boolean;
- pragma Inline (Is_Valid_Task);
- -- Does the executing thread have a TCB?
-
- procedure Set (Self_Id : Task_Id);
- pragma Inline (Set);
- -- Set the self id for the current task
-
- function Self return Task_Id;
- pragma Inline (Self);
- -- Return a pointer to the Ada Task Control Block of the calling task
-
- end Specific;
-
- package body Specific is separate;
- -- The body of this package is target specific
-
- ----------------------------------
- -- ATCB allocation/deallocation --
- ----------------------------------
-
- package body ATCB_Allocation is separate;
- -- The body of this package is shared across several targets
-
- ---------------------------------
- -- Support for foreign threads --
- ---------------------------------
-
- function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
- -- Allocate and Initialize a new ATCB for the current Thread
-
- function Register_Foreign_Thread
- (Thread : Thread_Id) return Task_Id is separate;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Abort_Handler (Sig : Signal);
-
- function To_Address is
- new Ada.Unchecked_Conversion (Task_Id, System.Address);
-
- -------------------
- -- Abort_Handler --
- -------------------
-
- procedure Abort_Handler (Sig : Signal) is
- pragma Unreferenced (Sig);
-
- Self_Id : constant Task_Id := Self;
- Result : Interfaces.C.int;
- Old_Set : aliased sigset_t;
-
- begin
- if Self_Id.Deferral_Level = 0
- and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
- and then not Self_Id.Aborting
- then
- Self_Id.Aborting := True;
-
- -- Make sure signals used for RTS internal purpose are unmasked
-
- Result :=
- pthread_sigmask
- (SIG_UNBLOCK,
- Unblocked_Signal_Mask'Access,
- Old_Set'Access);
- pragma Assert (Result = 0);
-
- raise Standard'Abort_Signal;
- end if;
- end Abort_Handler;
-
- -----------------
- -- Stack_Guard --
- -----------------
-
- -- The underlying thread system sets a guard page at the bottom of a thread
- -- stack, so nothing is needed.
- -- ??? Check the comment above
-
- procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
- pragma Unreferenced (T, On);
- begin
- null;
- end Stack_Guard;
-
- -------------------
- -- Get_Thread_Id --
- -------------------
-
- function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
- begin
- return T.Common.LL.Thread;
- end Get_Thread_Id;
-
- ----------
- -- Self --
- ----------
-
- function Self return Task_Id renames Specific.Self;
-
- ---------------------
- -- Initialize_Lock --
- ---------------------
-
- -- Note: mutexes and cond_variables needed per-task basis are initialized
- -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
- -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
- -- status change of RTS. Therefore raising Storage_Error in the following
- -- routines should be able to be handled safely.
-
- procedure Initialize_Lock
- (Prio : System.Any_Priority;
- L : not null access Lock)
- is
- Attributes : aliased pthread_mutexattr_t;
- Result : Interfaces.C.int;
-
- begin
- Result := pthread_mutexattr_init (Attributes'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- L.Priority := Prio;
-
- Result := pthread_mutex_init (L.L'Access, Attributes'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- Result := pthread_mutexattr_destroy (Attributes'Access);
- pragma Assert (Result = 0);
- end Initialize_Lock;
-
- procedure Initialize_Lock
- (L : not null access RTS_Lock;
- Level : Lock_Level)
- is
- pragma Unreferenced (Level);
-
- Attributes : aliased pthread_mutexattr_t;
- Result : Interfaces.C.int;
-
- begin
- Result := pthread_mutexattr_init (Attributes'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- Result := pthread_mutex_init (L, Attributes'Access);
-
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- Result := pthread_mutexattr_destroy (Attributes'Access);
- pragma Assert (Result = 0);
- end Initialize_Lock;
-
- -------------------
- -- Finalize_Lock --
- -------------------
-
- procedure Finalize_Lock (L : not null access Lock) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_mutex_destroy (L.L'Access);
- pragma Assert (Result = 0);
- end Finalize_Lock;
-
- procedure Finalize_Lock (L : not null access RTS_Lock) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_mutex_destroy (L);
- pragma Assert (Result = 0);
- end Finalize_Lock;
-
- ----------------
- -- Write_Lock --
- ----------------
-
- procedure Write_Lock
- (L : not null access Lock;
- Ceiling_Violation : out Boolean)
- is
- Result : Interfaces.C.int;
-
- begin
- L.Owner_Priority := Get_Priority (Self);
-
- if L.Priority < L.Owner_Priority then
- Ceiling_Violation := True;
- return;
- end if;
-
- Result := pthread_mutex_lock (L.L'Access);
- pragma Assert (Result = 0);
- Ceiling_Violation := False;
- end Write_Lock;
-
- procedure Write_Lock (L : not null access RTS_Lock) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_mutex_lock (L);
- pragma Assert (Result = 0);
- end Write_Lock;
-
- procedure Write_Lock (T : Task_Id) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_mutex_lock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end Write_Lock;
-
- ---------------
- -- Read_Lock --
- ---------------
-
- procedure Read_Lock
- (L : not null access Lock;
- Ceiling_Violation : out Boolean)
- is
- begin
- Write_Lock (L, Ceiling_Violation);
- end Read_Lock;
-
- ------------
- -- Unlock --
- ------------
-
- procedure Unlock (L : not null access Lock) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_mutex_unlock (L.L'Access);
- pragma Assert (Result = 0);
- end Unlock;
-
- procedure Unlock (L : not null access RTS_Lock) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_mutex_unlock (L);
- pragma Assert (Result = 0);
- end Unlock;
-
- procedure Unlock (T : Task_Id) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_mutex_unlock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end Unlock;
-
- -----------------
- -- Set_Ceiling --
- -----------------
-
- -- Dynamic priority ceilings are not supported by the underlying system
-
- procedure Set_Ceiling
- (L : not null access Lock;
- Prio : System.Any_Priority)
- is
- pragma Unreferenced (L, Prio);
- begin
- null;
- end Set_Ceiling;
-
- -----------
- -- Sleep --
- -----------
-
- procedure Sleep
- (Self_ID : Task_Id;
- Reason : System.Tasking.Task_States)
- is
- pragma Unreferenced (Reason);
-
- Result : Interfaces.C.int;
-
- begin
- Result :=
- pthread_cond_wait
- (cond => Self_ID.Common.LL.CV'Access,
- mutex => Self_ID.Common.LL.L'Access);
-
- -- EINTR is not considered a failure
-
- pragma Assert (Result = 0 or else Result = EINTR);
- end Sleep;
-
- -----------------
- -- Timed_Sleep --
- -----------------
-
- procedure Timed_Sleep
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes;
- Reason : System.Tasking.Task_States;
- Timedout : out Boolean;
- Yielded : out Boolean)
- is
- pragma Unreferenced (Reason);
-
- Check_Time : constant Duration := Monotonic_Clock;
- Abs_Time : Duration;
- Request : aliased timespec;
- Result : Interfaces.C.int;
-
- begin
- Timedout := True;
- Yielded := False;
-
- Abs_Time :=
- (if Mode = Relative
- then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
- else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
-
- if Abs_Time > Check_Time then
- Request := To_Timespec (Abs_Time);
-
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- Result :=
- pthread_cond_timedwait
- (cond => Self_ID.Common.LL.CV'Access,
- mutex => Self_ID.Common.LL.L'Access,
- abstime => Request'Access);
-
- exit when Abs_Time <= Monotonic_Clock;
-
- if Result = 0 or Result = EINTR then
-
- -- Somebody may have called Wakeup for us
-
- Timedout := False;
- exit;
- end if;
-
- pragma Assert (Result = ETIMEDOUT);
- end loop;
- end if;
- end Timed_Sleep;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- procedure Timed_Delay
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes)
- is
- Check_Time : constant Duration := Monotonic_Clock;
- Abs_Time : Duration;
- Request : aliased timespec;
-
- Result : Interfaces.C.int;
- pragma Warnings (Off, Result);
-
- begin
- Write_Lock (Self_ID);
-
- Abs_Time :=
- (if Mode = Relative
- then Time + Check_Time
- else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
-
- if Abs_Time > Check_Time then
- Request := To_Timespec (Abs_Time);
- Self_ID.Common.State := Delay_Sleep;
-
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- Result :=
- pthread_cond_timedwait
- (cond => Self_ID.Common.LL.CV'Access,
- mutex => Self_ID.Common.LL.L'Access,
- abstime => Request'Access);
-
- exit when Abs_Time <= Monotonic_Clock;
-
- pragma Assert (Result = 0 or else
- Result = ETIMEDOUT or else
- Result = EINTR);
- end loop;
-
- Self_ID.Common.State := Runnable;
- end if;
-
- Unlock (Self_ID);
- Result := sched_yield;
- end Timed_Delay;
-
- ---------------------
- -- Monotonic_Clock --
- ---------------------
-
- function Monotonic_Clock return Duration is
- TS : aliased timespec;
- Result : Interfaces.C.int;
- begin
- Result := Clock_Gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
- pragma Assert (Result = 0);
- return To_Duration (TS);
- end Monotonic_Clock;
-
- -------------------
- -- RT_Resolution --
- -------------------
-
- function RT_Resolution return Duration is
- begin
- return 10#1.0#E-6;
- end RT_Resolution;
-
- ------------
- -- Wakeup --
- ------------
-
- procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
- pragma Unreferenced (Reason);
- Result : Interfaces.C.int;
- begin
- Result := pthread_cond_signal (T.Common.LL.CV'Access);
- pragma Assert (Result = 0);
- end Wakeup;
-
- -----------
- -- Yield --
- -----------
-
- procedure Yield (Do_Yield : Boolean := True) is
- Result : Interfaces.C.int;
- pragma Unreferenced (Result);
- begin
- if Do_Yield then
- Result := sched_yield;
- end if;
- end Yield;
-
- ------------------
- -- Set_Priority --
- ------------------
-
- type Prio_Array_Type is array (System.Any_Priority) of Integer;
- pragma Atomic_Components (Prio_Array_Type);
-
- Prio_Array : Prio_Array_Type;
- -- Global array containing the id of the currently running task for
- -- each priority.
- --
- -- Note: assume we are on single processor with run-til-blocked scheduling
-
- procedure Set_Priority
- (T : Task_Id;
- Prio : System.Any_Priority;
- Loss_Of_Inheritance : Boolean := False)
- is
- Result : Interfaces.C.int;
- Array_Item : Integer;
- Param : aliased struct_sched_param;
-
- function Get_Policy (Prio : System.Any_Priority) return Character;
- pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
- -- Get priority specific dispatching policy
-
- Priority_Specific_Policy : constant Character := Get_Policy (Prio);
- -- Upper case first character of the policy name corresponding to the
- -- task as set by a Priority_Specific_Dispatching pragma.
-
- begin
- Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
-
- if Dispatching_Policy = 'R'
- or else Priority_Specific_Policy = 'R'
- or else Time_Slice_Val > 0
- then
- Result :=
- pthread_setschedparam
- (T.Common.LL.Thread, SCHED_RR, Param'Access);
-
- elsif Dispatching_Policy = 'F'
- or else Priority_Specific_Policy = 'F'
- or else Time_Slice_Val = 0
- then
- Result :=
- pthread_setschedparam
- (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
-
- else
- Result :=
- pthread_setschedparam
- (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
- end if;
-
- pragma Assert (Result = 0);
-
- if Dispatching_Policy = 'F' or else Priority_Specific_Policy = 'F' then
-
- -- Annex D requirement [RM D.2.2 par. 9]:
- -- If the task drops its priority due to the loss of inherited
- -- priority, it is added at the head of the ready queue for its
- -- new active priority.
-
- if Loss_Of_Inheritance
- and then Prio < T.Common.Current_Priority
- then
- Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
- Prio_Array (T.Common.Base_Priority) := Array_Item;
-
- loop
- -- Let some processes a chance to arrive
-
- Yield;
-
- -- Then wait for our turn to proceed
-
- exit when Array_Item = Prio_Array (T.Common.Base_Priority)
- or else Prio_Array (T.Common.Base_Priority) = 1;
- end loop;
-
- Prio_Array (T.Common.Base_Priority) :=
- Prio_Array (T.Common.Base_Priority) - 1;
- end if;
- end if;
-
- T.Common.Current_Priority := Prio;
- end Set_Priority;
-
- ------------------
- -- Get_Priority --
- ------------------
-
- function Get_Priority (T : Task_Id) return System.Any_Priority is
- begin
- return T.Common.Current_Priority;
- end Get_Priority;
-
- ----------------
- -- Enter_Task --
- ----------------
-
- procedure Enter_Task (Self_ID : Task_Id) is
- begin
- Self_ID.Common.LL.Thread := pthread_self;
- Specific.Set (Self_ID);
- end Enter_Task;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
-
- -----------------------------
- -- Register_Foreign_Thread --
- -----------------------------
-
- function Register_Foreign_Thread return Task_Id is
- begin
- if Is_Valid_Task then
- return Self;
- else
- return Register_Foreign_Thread (pthread_self);
- end if;
- end Register_Foreign_Thread;
-
- --------------------
- -- Initialize_TCB --
- --------------------
-
- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
- Mutex_Attr : aliased pthread_mutexattr_t;
- Result : Interfaces.C.int;
- Cond_Attr : aliased pthread_condattr_t;
-
- begin
- Result := pthread_mutexattr_init (Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = 0 then
- Result :=
- pthread_mutex_init
- (Self_ID.Common.LL.L'Access, Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
- end if;
-
- if Result /= 0 then
- Succeeded := False;
- return;
- end if;
-
- Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
- pragma Assert (Result = 0);
-
- Result := pthread_condattr_init (Cond_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = 0 then
- Result :=
- pthread_cond_init
- (Self_ID.Common.LL.CV'Access,
- Cond_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
- end if;
-
- if Result = 0 then
- Succeeded := True;
- else
- Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
- pragma Assert (Result = 0);
-
- Succeeded := False;
- end if;
-
- Result := pthread_condattr_destroy (Cond_Attr'Access);
- pragma Assert (Result = 0);
- end Initialize_TCB;
-
- -----------------
- -- Create_Task --
- -----------------
-
- procedure Create_Task
- (T : Task_Id;
- Wrapper : System.Address;
- Stack_Size : System.Parameters.Size_Type;
- Priority : System.Any_Priority;
- Succeeded : out Boolean)
- is
- Attributes : aliased pthread_attr_t;
- Result : Interfaces.C.int;
-
- function Thread_Body_Access is new
- Ada.Unchecked_Conversion (System.Address, Thread_Body);
-
- begin
- Result := pthread_attr_init (Attributes'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result /= 0 then
- Succeeded := False;
- return;
- end if;
-
- Result := pthread_attr_setstacksize
- (Attributes'Access, Interfaces.C.size_t (Stack_Size));
- pragma Assert (Result = 0);
-
- -- Since the initial signal mask of a thread is inherited from the
- -- creator, and the Environment task has all its signals masked, we
- -- do not need to manipulate caller's signal mask at this point.
- -- All tasks in RTS will have All_Tasks_Mask initially.
-
- Result := pthread_create
- (T.Common.LL.Thread'Access,
- Attributes'Access,
- Thread_Body_Access (Wrapper),
- To_Address (T));
- pragma Assert (Result = 0 or else Result = EAGAIN);
-
- Succeeded := Result = 0;
-
- pthread_detach (T.Common.LL.Thread'Access);
- -- Detach the thread using pthread_detach, since DCE threads do not have
- -- pthread_attr_set_detachstate.
-
- Result := pthread_attr_destroy (Attributes'Access);
- pragma Assert (Result = 0);
-
- Set_Priority (T, Priority);
- end Create_Task;
-
- ------------------
- -- Finalize_TCB --
- ------------------
-
- procedure Finalize_TCB (T : Task_Id) is
- Result : Interfaces.C.int;
-
- begin
- Result := pthread_mutex_destroy (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
-
- Result := pthread_cond_destroy (T.Common.LL.CV'Access);
- pragma Assert (Result = 0);
-
- if T.Known_Tasks_Index /= -1 then
- Known_Tasks (T.Known_Tasks_Index) := null;
- end if;
-
- ATCB_Allocation.Free_ATCB (T);
- end Finalize_TCB;
-
- ---------------
- -- Exit_Task --
- ---------------
-
- procedure Exit_Task is
- begin
- Specific.Set (null);
- end Exit_Task;
-
- ----------------
- -- Abort_Task --
- ----------------
-
- procedure Abort_Task (T : Task_Id) is
- begin
- -- Interrupt Server_Tasks may be waiting on an "event" flag (signal)
-
- if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then
- System.Interrupt_Management.Operations.Interrupt_Self_Process
- (PIO.Get_Interrupt_ID (T));
- end if;
- end Abort_Task;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (S : in out Suspension_Object) is
- Mutex_Attr : aliased pthread_mutexattr_t;
- Cond_Attr : aliased pthread_condattr_t;
- Result : Interfaces.C.int;
- begin
- -- Initialize internal state (always to False (ARM D.10(6)))
-
- S.State := False;
- S.Waiting := False;
-
- -- Initialize internal mutex
-
- Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- -- Initialize internal condition variable
-
- Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result /= 0 then
- Result := pthread_mutex_destroy (S.L'Access);
- pragma Assert (Result = 0);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
- end if;
- end Initialize;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- -- Destroy internal mutex
-
- Result := pthread_mutex_destroy (S.L'Access);
- pragma Assert (Result = 0);
-
- -- Destroy internal condition variable
-
- Result := pthread_cond_destroy (S.CV'Access);
- pragma Assert (Result = 0);
- end Finalize;
-
- -------------------
- -- Current_State --
- -------------------
-
- function Current_State (S : Suspension_Object) return Boolean is
- begin
- -- We do not want to use lock on this read operation. State is marked
- -- as Atomic so that we ensure that the value retrieved is correct.
-
- return S.State;
- end Current_State;
-
- ---------------
- -- Set_False --
- ---------------
-
- procedure Set_False (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := pthread_mutex_lock (S.L'Access);
- pragma Assert (Result = 0);
-
- S.State := False;
-
- Result := pthread_mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
- end Set_False;
-
- --------------
- -- Set_True --
- --------------
-
- procedure Set_True (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := pthread_mutex_lock (S.L'Access);
- pragma Assert (Result = 0);
-
- -- If there is already a task waiting on this suspension object then
- -- we resume it, leaving the state of the suspension object to False,
- -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
- -- the state to True.
-
- if S.Waiting then
- S.Waiting := False;
- S.State := False;
-
- Result := pthread_cond_signal (S.CV'Access);
- pragma Assert (Result = 0);
-
- else
- S.State := True;
- end if;
-
- Result := pthread_mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
- end Set_True;
-
- ------------------------
- -- Suspend_Until_True --
- ------------------------
-
- procedure Suspend_Until_True (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := pthread_mutex_lock (S.L'Access);
- pragma Assert (Result = 0);
-
- if S.Waiting then
- -- Program_Error must be raised upon calling Suspend_Until_True
- -- if another task is already waiting on that suspension object
- -- (ARM D.10 par. 10).
-
- Result := pthread_mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
-
- raise Program_Error;
- else
- -- Suspend the task if the state is False. Otherwise, the task
- -- continues its execution, and the state of the suspension object
- -- is set to False (ARM D.10 par. 9).
-
- if S.State then
- S.State := False;
- else
- S.Waiting := True;
-
- loop
- -- Loop in case pthread_cond_wait returns earlier than expected
- -- (e.g. in case of EINTR caused by a signal).
-
- Result := pthread_cond_wait (S.CV'Access, S.L'Access);
- pragma Assert (Result = 0 or else Result = EINTR);
-
- exit when not S.Waiting;
- end loop;
- end if;
-
- Result := pthread_mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
- end if;
- end Suspend_Until_True;
-
- ----------------
- -- Check_Exit --
- ----------------
-
- -- Dummy version
-
- function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
- pragma Unreferenced (Self_ID);
- begin
- return True;
- end Check_Exit;
-
- --------------------
- -- Check_No_Locks --
- --------------------
-
- function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
- pragma Unreferenced (Self_ID);
- begin
- return True;
- end Check_No_Locks;
-
- ----------------------
- -- Environment_Task --
- ----------------------
-
- function Environment_Task return Task_Id is
- begin
- return Environment_Task_Id;
- end Environment_Task;
-
- --------------
- -- Lock_RTS --
- --------------
-
- procedure Lock_RTS is
- begin
- Write_Lock (Single_RTS_Lock'Access);
- end Lock_RTS;
-
- ----------------
- -- Unlock_RTS --
- ----------------
-
- procedure Unlock_RTS is
- begin
- Unlock (Single_RTS_Lock'Access);
- end Unlock_RTS;
-
- ------------------
- -- Suspend_Task --
- ------------------
-
- function Suspend_Task
- (T : ST.Task_Id;
- Thread_Self : Thread_Id) return Boolean
- is
- pragma Unreferenced (T);
- pragma Unreferenced (Thread_Self);
- begin
- return False;
- end Suspend_Task;
-
- -----------------
- -- Resume_Task --
- -----------------
-
- function Resume_Task
- (T : ST.Task_Id;
- Thread_Self : Thread_Id) return Boolean
- is
- pragma Unreferenced (T);
- pragma Unreferenced (Thread_Self);
- begin
- return False;
- end Resume_Task;
-
- --------------------
- -- Stop_All_Tasks --
- --------------------
-
- procedure Stop_All_Tasks is
- begin
- null;
- end Stop_All_Tasks;
-
- ---------------
- -- Stop_Task --
- ---------------
-
- function Stop_Task (T : ST.Task_Id) return Boolean is
- pragma Unreferenced (T);
- begin
- return False;
- end Stop_Task;
-
- -------------------
- -- Continue_Task --
- -------------------
-
- function Continue_Task (T : ST.Task_Id) return Boolean is
- pragma Unreferenced (T);
- begin
- return False;
- end Continue_Task;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- act : aliased struct_sigaction;
- old_act : aliased struct_sigaction;
- Tmp_Set : aliased sigset_t;
- Result : Interfaces.C.int;
-
- function State
- (Int : System.Interrupt_Management.Interrupt_ID) return Character;
- pragma Import (C, State, "__gnat_get_interrupt_state");
- -- Get interrupt state. Defined in a-init.c. The input argument is
- -- the interrupt number, and the result is one of the following:
-
- Default : constant Character := 's';
- -- 'n' this interrupt not set by any Interrupt_State pragma
- -- 'u' Interrupt_State pragma set state to User
- -- 'r' Interrupt_State pragma set state to Runtime
- -- 's' Interrupt_State pragma set state to System (use "default"
- -- system handler)
-
- begin
- Environment_Task_Id := Environment_Task;
-
- Interrupt_Management.Initialize;
-
- -- Initialize the lock used to synchronize chain of all ATCBs
-
- Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-
- Specific.Initialize (Environment_Task);
-
- -- Make environment task known here because it doesn't go through
- -- Activate_Tasks, which does it for all other tasks.
-
- Known_Tasks (Known_Tasks'First) := Environment_Task;
- Environment_Task.Known_Tasks_Index := Known_Tasks'First;
-
- Enter_Task (Environment_Task);
-
- -- Install the abort-signal handler
-
- if State (System.Interrupt_Management.Abort_Task_Interrupt)
- /= Default
- then
- act.sa_flags := 0;
- act.sa_handler := Abort_Handler'Address;
-
- Result := sigemptyset (Tmp_Set'Access);
- pragma Assert (Result = 0);
- act.sa_mask := Tmp_Set;
-
- Result :=
- sigaction (
- Signal (System.Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
- end if;
- end Initialize;
-
- -- NOTE: Unlike other pthread implementations, we do *not* mask all
- -- signals here since we handle signals using the process-wide primitive
- -- signal, rather than using sigthreadmask and sigwait. The reason of
- -- this difference is that sigwait doesn't work when some critical
- -- signals (SIGABRT, SIGPIPE) are masked.
-
- -----------------------
- -- Set_Task_Affinity --
- -----------------------
-
- procedure Set_Task_Affinity (T : ST.Task_Id) is
- pragma Unreferenced (T);
-
- begin
- -- Setting task affinity is not supported by the underlying system
-
- null;
- end Set_Task_Affinity;
-
-end System.Task_Primitives.Operations;
diff --git a/gcc/ada/libgnarl/s-taspri__hpux-dce.ads
b/gcc/ada/libgnarl/s-taspri__hpux-dce.ads
deleted file mode 100644
index 9ec5dcbfd985..000000000000
--- a/gcc/ada/libgnarl/s-taspri__hpux-dce.ads
+++ /dev/null
@@ -1,106 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-2024, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a HP-UX version of this package
-
--- This package provides low-level support for most tasking features
-
-with System.OS_Interface;
-with System.OS_Locks;
-
-package System.Task_Primitives is
- pragma Preelaborate;
-
- type Lock is limited private;
- -- Should be used for implementation of protected objects
-
- type Suspension_Object is limited private;
- -- Should be used for the implementation of Ada.Synchronous_Task_Control
-
- type Task_Body_Access is access procedure;
- -- Pointer to the task body's entry point (or possibly a wrapper
- -- declared local to the GNARL).
-
- type Private_Data is limited private;
- -- Any information that the GNULLI needs maintained on a per-task basis.
- -- A component of this type is guaranteed to be included in the
- -- Ada_Task_Control_Block.
-
- subtype Task_Address is System.Address;
- Task_Address_Size : constant := Standard'Address_Size;
- -- Type used for task addresses and its size
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
-private
- type Lock is record
- L : aliased System.OS_Locks.RTS_Lock;
- Priority : Integer;
- Owner_Priority : Integer;
- end record;
-
- type Suspension_Object is record
- State : Boolean;
- pragma Atomic (State);
- -- Boolean that indicates whether the object is open. This field is
- -- marked Atomic to ensure that we can read its value without locking
- -- the access to the Suspension_Object.
-
- Waiting : Boolean;
- -- Flag showing if there is a task already suspended on this object
-
- L : aliased System.OS_Locks.RTS_Lock;
- -- Protection for ensuring mutual exclusion on the Suspension_Object
-
- CV : aliased System.OS_Interface.pthread_cond_t;
- -- Condition variable used to queue threads until condition is signaled
- end record;
-
- type Private_Data is record
- Thread : aliased System.OS_Interface.pthread_t;
- -- pragma Atomic (Thread);
- -- Unfortunately, the above fails because Thread is 64 bits.
-
- -- Thread field may be updated by two different threads of control.
- -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the
- -- same value (thr_self value). We do not want to use lock on those
- -- operations and the only thing we have to make sure is that they
- -- are updated in atomic fashion.
-
- CV : aliased System.OS_Interface.pthread_cond_t;
- -- Condition variable used to queue threads until condition is signaled
-
- L : aliased System.OS_Locks.RTS_Lock;
- -- Protection for all components is lock L
- end record;
-
-end System.Task_Primitives;
diff --git a/gcc/ada/libgnat/s-oslock__hpux-dce.ads
b/gcc/ada/libgnat/s-oslock__hpux-dce.ads
deleted file mode 100644
index 824c39511eab..000000000000
--- a/gcc/ada/libgnat/s-oslock__hpux-dce.ads
+++ /dev/null
@@ -1,61 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ L O C K S --
--- --
--- S p e c --
--- --
--- Copyright (C) 2024, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the HP-UX version of this package
-
-with Interfaces.C;
-with System.OS_Constants;
-
-package System.OS_Locks is
- pragma Preelaborate;
-
- type pthread_mutex_t is limited private;
-
- subtype RTS_Lock is pthread_mutex_t;
- -- Should be used inside the runtime system. The difference between Lock
- -- and the RTS_Lock is that the latter serves only as a semaphore so that
- -- we do not check for ceiling violations.
-
-private
-
- type cma_t_address is new System.Address;
-
- type cma_t_handle is record
- field1 : cma_t_address;
- field2 : Short_Integer;
- field3 : Short_Integer;
- end record;
- for cma_t_handle'Size use 64;
-
- type pthread_mutex_t is new cma_t_handle;
- pragma Convention (C_Pass_By_Copy, pthread_mutex_t);
-
-end System.OS_Locks;
