+2014-01-26 Arnaud Charlet <charlet@adacore.com>
+
+ * a-intnam-lynxos.ads, mlib-tgt-specific-lynxos.adb,
+ s-osinte-lynxos-3.adb, s-osinte-lynxos-3.ads, s-osinte-lynxos.adb,
+ s-osinte-lynxos.ads, s-taprop-lynxos.adb, s-tpopsp-lynxos.adb,
+ system-lynxos-ppc.ads, system-lynxos-x86.ads: Removed, no longer
+ maintained.
+
2014-01-25 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/Makefile.in: Fix oversight.
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- A D A . I N T E R R U P T S . N A M E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-2011, 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 LynxOS version of this package
-
--- The following signals are reserved by the run time:
-
--- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
--- SIGWAITING, SIGLWP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGSTOP, SIGKILL
-
--- The pragma Unreserve_All_Interrupts affects the following signal(s):
-
--- SIGINT: made available for Ada handler
-
-with System.OS_Interface;
-
-package Ada.Interrupts.Names is
-
- -- All identifiers in this unit are implementation defined
-
- pragma Implementation_Defined;
-
- -- Beware that the mapping of names to signals may be many-to-one. There
- -- may be aliases.
-
- SIGHUP : constant Interrupt_ID :=
- System.OS_Interface.SIGHUP; -- hangup
-
- SIGINT : constant Interrupt_ID :=
- System.OS_Interface.SIGINT; -- interrupt (rubout)
-
- SIGQUIT : constant Interrupt_ID :=
- System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
-
- SIGILL : constant Interrupt_ID :=
- System.OS_Interface.SIGILL; -- illegal instruction (not reset)
-
- SIGTRAP : constant Interrupt_ID :=
- System.OS_Interface.SIGTRAP; -- trace trap (not reset)
-
- SIGBRK : constant Interrupt_ID :=
- System.OS_Interface.SIGBRK; -- break
-
- SIGIOT : constant Interrupt_ID :=
- System.OS_Interface.SIGIOT; -- IOT instruction
-
- SIGABRT : constant Interrupt_ID := -- used by abort,
- System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
-
- SIGCORE : constant Interrupt_ID :=
- System.OS_Interface.SIGCORE; -- kill with core dump
-
- SIGEMT : constant Interrupt_ID :=
- System.OS_Interface.SIGEMT; -- EMT instruction
-
- SIGFPE : constant Interrupt_ID :=
- System.OS_Interface.SIGFPE; -- floating point exception
-
- SIGKILL : constant Interrupt_ID :=
- System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
-
- SIGBUS : constant Interrupt_ID :=
- System.OS_Interface.SIGBUS; -- bus error
-
- SIGSEGV : constant Interrupt_ID :=
- System.OS_Interface.SIGSEGV; -- segmentation violation
-
- SIGSYS : constant Interrupt_ID :=
- System.OS_Interface.SIGSYS; -- bad argument to system call
-
- SIGPIPE : constant Interrupt_ID := -- write on a pipe with
- System.OS_Interface.SIGPIPE; -- no one to read it
-
- SIGALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGALRM; -- alarm clock
-
- SIGTERM : constant Interrupt_ID :=
- System.OS_Interface.SIGTERM; -- software termination signal from kill
-
- SIGURG : constant Interrupt_ID :=
- System.OS_Interface.SIGURG; -- urgent condition on IO channel
-
- SIGSTOP : constant Interrupt_ID :=
- System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored)
-
- SIGTSTP : constant Interrupt_ID :=
- System.OS_Interface.SIGTSTP; -- user stop requested from tty
-
- SIGCONT : constant Interrupt_ID :=
- System.OS_Interface.SIGCONT; -- stopped process has been continued
-
- SIGCLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCLD; -- child status change
-
- SIGCHLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
-
- SIGTTIN : constant Interrupt_ID :=
- System.OS_Interface.SIGTTIN; -- background tty read attempted
-
- SIGTTOU : constant Interrupt_ID :=
- System.OS_Interface.SIGTTOU; -- background tty write attempted
-
- SIGPOLL : constant Interrupt_ID :=
- System.OS_Interface.SIGPOLL; -- pollable event occurred
-
- SIGIO : constant Interrupt_ID := -- input/output possible,
- System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
-
- SIGXCPU : constant Interrupt_ID :=
- System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
-
- SIGXFSZ : constant Interrupt_ID :=
- System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
-
- SIGVTALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGVTALRM; -- virtual timer expired
-
- SIGPROF : constant Interrupt_ID :=
- System.OS_Interface.SIGPROF; -- profiling timer expired
-
- SIGWINCH : constant Interrupt_ID :=
- System.OS_Interface.SIGWINCH; -- window size change
-
- SIGLOST : constant Interrupt_ID :=
- System.OS_Interface.SIGLOST; -- SUN 4.1 compatibility
-
- SIGUSR1 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR1; -- user defined signal 1
-
- SIGUSR2 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR2; -- user defined signal 2
-
- SIGPRIO : constant Interrupt_ID :=
- System.OS_Interface.SIGPRIO;
- -- sent to a process with its priority
- -- or group is changed
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . T G T . S P E C I F I C --
--- (LynxOS Version) --
--- --
--- B o d y --
--- --
--- Copyright (C) 2003-2008, 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. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the LynxOS version of the body
-
-package body MLib.Tgt.Specific is
-
- -- Non default subprograms
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False);
-
- function DLL_Ext return String;
-
- function Dynamic_Option return String;
-
- function PIC_Option return String;
-
- function Library_Major_Minor_Id_Supported return Boolean;
-
- function Standalone_Library_Auto_Init_Is_Supported return Boolean;
-
- function Support_For_Libraries return Library_Support;
-
- ---------------------------
- -- Build_Dynamic_Library --
- ---------------------------
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False)
- is
- pragma Unreferenced (Ofiles);
- pragma Unreferenced (Options);
- pragma Unreferenced (Interfaces);
- pragma Unreferenced (Lib_Filename);
- pragma Unreferenced (Lib_Dir);
- pragma Unreferenced (Symbol_Data);
- pragma Unreferenced (Driver_Name);
- pragma Unreferenced (Lib_Version);
- pragma Unreferenced (Auto_Init);
-
- begin
- null;
- end Build_Dynamic_Library;
-
- -------------
- -- DLL_Ext --
- -------------
-
- function DLL_Ext return String is
- begin
- return "";
- end DLL_Ext;
-
- --------------------
- -- Dynamic_Option --
- --------------------
-
- function Dynamic_Option return String is
- begin
- return "";
- end Dynamic_Option;
-
- --------------------------------------
- -- Library_Major_Minor_Id_Supported --
- --------------------------------------
-
- function Library_Major_Minor_Id_Supported return Boolean is
- begin
- return False;
- end Library_Major_Minor_Id_Supported;
-
- ----------------
- -- PIC_Option --
- ----------------
-
- function PIC_Option return String is
- begin
- return "";
- end PIC_Option;
-
- -----------------------------------------------
- -- Standalone_Library_Auto_Init_Is_Supported --
- -----------------------------------------------
-
- function Standalone_Library_Auto_Init_Is_Supported return Boolean is
- begin
- return False;
- end Standalone_Library_Auto_Init_Is_Supported;
-
- ---------------------------
- -- Support_For_Libraries --
- ---------------------------
-
- function Support_For_Libraries return Library_Support is
- begin
- return Static_Only;
- end Support_For_Libraries;
-
-begin
- Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access;
- DLL_Ext_Ptr := DLL_Ext'Access;
- Dynamic_Option_Ptr := Dynamic_Option'Access;
- Library_Major_Minor_Id_Supported_Ptr :=
- Library_Major_Minor_Id_Supported'Access;
- PIC_Option_Ptr := PIC_Option'Access;
- Standalone_Library_Auto_Init_Is_Supported_Ptr :=
- Standalone_Library_Auto_Init_Is_Supported'Access;
- Support_For_Libraries_Ptr := Support_For_Libraries'Access;
-end MLib.Tgt.Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 1999-2009, 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 LynxOS (Native) version of this package
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
-
-package body System.OS_Interface is
-
- use Interfaces.C;
-
- -------------------
- -- clock_gettime --
- -------------------
-
- function clock_gettime
- (clock_id : clockid_t;
- tp : access timespec)
- return int
- is
- function clock_gettime_base
- (clock_id : clockid_t;
- tp : access timespec)
- return int;
- pragma Import (C, clock_gettime_base, "clock_gettime");
-
- begin
- if clock_gettime_base (clock_id, tp) /= 0 then
- return errno;
- end if;
-
- return 0;
- end clock_gettime;
-
- -----------------
- -- 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_Target_Priority --
- ------------------------
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int
- is
- begin
- return Interfaces.C.int (Prio);
- end To_Target_Priority;
-
- -----------------
- -- 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
- function sigwait_base
- (set : access sigset_t;
- value : System.Address)
- return Signal;
- pragma Import (C, sigwait_base, "sigwait");
-
- begin
- sig.all := sigwait_base (set, Null_Address);
-
- if sig.all = -1 then
- return errno;
- end if;
-
- return 0;
- end sigwait;
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- -- For all the following functions, LynxOS threads has the POSIX Draft 4
- -- 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;
- end if;
-
- return 0;
- 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;
- end if;
-
- return 0;
- 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;
- end if;
-
- return 0;
- 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;
- end if;
-
- return 0;
- 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;
- end if;
-
- return 0;
- 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;
- end if;
-
- return 0;
- 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;
- end if;
-
- return 0;
- 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;
- end if;
-
- return 0;
- 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;
- end if;
-
- return 0;
- 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;
- end if;
-
- return 0;
- 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;
- end if;
-
- return 0;
- 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;
- end if;
-
- return 0;
- end pthread_cond_wait;
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- reltime : access timespec) return int
- is
- function pthread_cond_timedwait_base
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- reltime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait");
-
- begin
- if pthread_cond_timedwait_base (cond, mutex, reltime) /= 0 then
- if errno = EAGAIN then
- return ETIMEDOUT;
- end if;
-
- return errno;
- end if;
-
- return 0;
- 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;
- prio : int)
- return int;
- pragma Import (C, pthread_setscheduler, "pthread_setscheduler");
-
- begin
- if pthread_setscheduler (thread, policy, param.sched_priority) = -1 then
- return errno;
- end if;
-
- return 0;
- end pthread_setschedparam;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int)
- return int
- is
- pragma Unreferenced (attr, protocol);
- begin
- return 0;
- end pthread_mutexattr_setprotocol;
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int)
- return int
- is
- pragma Unreferenced (attr, prioceiling);
- begin
- return 0;
- end pthread_mutexattr_setprioceiling;
-
- function pthread_attr_setscope
- (attr : access pthread_attr_t;
- contentionscope : int)
- return int
- is
- pragma Unreferenced (attr, contentionscope);
- begin
- return 0;
- end pthread_attr_setscope;
-
- 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_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int)
- return int
- is
- pragma Unreferenced (attr, detachstate);
- begin
- return 0;
- end pthread_attr_setdetachstate;
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address)
- return int
- is
- -- The LynxOS pthread_create doesn't seems to work.
- -- Workaround : We're using st_new instead.
- --
- -- 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");
-
- St : aliased st_t := attributes.st;
-
- function st_new
- (start_routine : Thread_Body;
- arg : System.Address;
- attributes : access st_t;
- thread : access pthread_t)
- return int;
- pragma Import (C, st_new, "st_new");
-
- begin
- -- Following code would be used if above commented function worked
-
- -- if pthread_create_base
- -- (thread, attributes.all, start_routine, arg) /= 0 then
-
- if st_new (start_routine, arg, St'Access, thread) /= 0 then
- return errno;
- end if;
-
- return 0;
- end pthread_create;
-
- function pthread_detach (thread : pthread_t) return int is
- aliased_thread : aliased pthread_t := thread;
-
- function pthread_detach_base (thread : access pthread_t) return int;
- pragma Import (C, pthread_detach_base, "pthread_detach");
-
- begin
- if pthread_detach_base (aliased_thread'Access) /= 0 then
- return errno;
- end if;
-
- return 0;
- end pthread_detach;
-
- --------------------------
- -- 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;
- end if;
-
- return 0;
- end pthread_setspecific;
-
- function pthread_getspecific (key : pthread_key_t) return System.Address is
- procedure pthread_getspecific_base
- (key : pthread_key_t;
- value : access System.Address);
- pragma Import (C, pthread_getspecific_base, "pthread_getspecific");
-
- value : aliased System.Address := System.Null_Address;
-
- begin
- pthread_getspecific_base (key, value'Unchecked_Access);
- return value;
- end pthread_getspecific;
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Warnings (Off, thread);
-
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- 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;
- end if;
-
- return 0;
- end pthread_key_create;
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME 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-2011, 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/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a LynxOS (Native) 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;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-mthreads");
-
- subtype int is Interfaces.C.int;
- subtype char is Interfaces.C.char;
- 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;
- ETIMEDOUT : constant := 60;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 63;
- 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)
- SIGBRK : constant := 6; -- break
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGCORE : constant := 7; -- kill with core dump
- 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
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGCHLD : constant := 20; -- child status change
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
- SIGPOLL : constant := 23; -- pollable event occurred
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGWINCH : constant := 28; -- window size change
- SIGLOST : constant := 29; -- SUN 4.1 compatibility
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
- SIGPRIO : constant := 32; -- sent to a process with its priority or
- -- group is changed
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set :=
- (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF);
- Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP, SIGPRIO);
-
- type sigset_t is private;
-
- 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 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_SIGINFO : constant := 16#80#;
-
- SIG_BLOCK : constant := 0;
- SIG_UNBLOCK : constant := 1;
- SIG_SETMASK : constant := 2;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- Time_Slice_Supported : constant Boolean := True;
- -- Indicates whether time slicing is supported
-
- type timespec is private;
-
- type clockid_t is new int;
-
- function clock_gettime
- (clock_id : clockid_t;
- tp : access timespec) return int;
- pragma Inline (clock_gettime);
- -- LynxOS has non standard clock_gettime
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- type struct_timezone is record
- tz_minuteswest : int;
- tz_dsttime : int;
- end record;
- pragma Convention (C, struct_timezone);
- type struct_timezone_ptr is access all struct_timezone;
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_FIFO : constant := 16#00200000#;
- SCHED_RR : constant := 16#00100000#;
- SCHED_OTHER : constant := 16#00400000#;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority
-
- -------------
- -- 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");
-
- ---------
- -- LWP --
- ---------
-
- function lwp_self return System.Address;
- -- lwp_self does not exist on this thread library, revert to pthread_self
- -- which is the closest approximation (with getpid). This function is
- -- needed to share 7staprop.adb across POSIX-like targets.
- pragma Import (C, lwp_self, "pthread_self");
-
- -------------
- -- 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;
-
- type pthread_mutex_t is limited private;
- type pthread_cond_t is limited private;
- type st_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;
-
- PTHREAD_CREATE_DETACHED : constant := 0;
-
- PTHREAD_SCOPE_PROCESS : constant := 0;
- PTHREAD_SCOPE_SYSTEM : constant := 1;
-
- -----------
- -- Stack --
- -----------
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread.
- -- Only call this function when Stack_Base_Available is True.
-
- function Get_Page_Size return size_t;
- function Get_Page_Size return Address;
- pragma Import (C, Get_Page_Size, "getpagesize");
- -- returns the size of a page, or 0 if this is not relevant on this
- -- target
-
- PROT_NONE : constant := 0;
- PROT_READ : constant := 1;
- PROT_WRITE : constant := 2;
- PROT_EXEC : constant := 4;
- PROT_USER : constant := 8;
- PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC + PROT_USER;
-
- PROT_ON : constant := PROT_READ;
- PROT_OFF : constant := PROT_ALL;
-
- function mprotect (addr : Address; len : size_t; prot : int) return int;
- pragma Import (C, mprotect);
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal) return int;
- pragma Inline (sigwait);
- -- LynxOS has non standard sigwait
-
- function pthread_kill (thread : pthread_t; sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "sigprocmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Inline (pthread_mutexattr_init);
- -- LynxOS has a nonstandard pthread_mutexattr_init
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Inline (pthread_mutexattr_destroy);
- -- Lynxos has a nonstandard pthread_mutexattr_destroy
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Inline (pthread_mutex_init);
- -- LynxOS has a nonstandard pthread_mutex_init
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Inline (pthread_mutex_destroy);
- -- LynxOS has a nonstandard pthread_mutex_destroy
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Inline (pthread_mutex_lock);
- -- LynxOS has a nonstandard pthread_mutex_lock
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Inline (pthread_mutex_unlock);
- -- LynxOS has a nonstandard pthread_mutex_unlock
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Inline (pthread_condattr_init);
- -- LynxOS has a nonstandard pthread_condattr_init
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Inline (pthread_condattr_destroy);
- -- LynxOS has a nonstandard pthread_condattr_destroy
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Inline (pthread_cond_init);
- -- LynxOS has a non standard pthread_cond_init
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Inline (pthread_cond_destroy);
- -- LynxOS has a nonstandard pthread_cond_destroy
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Inline (pthread_cond_signal);
- -- LynxOS has a 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);
- -- LynxOS has a nonstandard pthread_cond_wait
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- reltime : access timespec) return int;
- pragma Inline (pthread_cond_timedwait);
- -- LynxOS has a nonstandard pthread_cond_timedwait
-
- Relative_Timed_Wait : constant Boolean := True;
- -- pthread_cond_timedwait requires a relative delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_INHERIT : constant := 0;
- PTHREAD_PRIO_PROTECT : constant := 0;
-
- 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);
- -- LynxOS doesn't have pthread_setschedparam.
- -- Instead, use pthread_setscheduler
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Inline (pthread_mutexattr_setprotocol);
- -- LynxOS doesn't have pthread_mutexattr_setprotocol
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Inline (pthread_mutexattr_setprioceiling);
- -- LynxOS doesn't have pthread_mutexattr_setprioceiling
-
- function pthread_attr_setscope
- (attr : access pthread_attr_t;
- contentionscope : int) return int;
- -- LynxOS doesn't have pthread_attr_setscope: all threads have system scope
- pragma Inline (pthread_attr_setscope);
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched");
-
- function sched_yield return int;
- -- pragma Import (C, sched_yield, "sched_yield");
- pragma Inline (sched_yield);
-
- ---------------------------
- -- P1003.1c - Section 16 --
- ---------------------------
-
- function pthread_attr_init (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init, "pthread_attr_create");
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy, "pthread_attr_delete");
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- pragma Inline (pthread_attr_setdetachstate);
- -- LynxOS doesn't have pthread_attr_setdetachstate
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize, "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);
- -- LynxOS has a non standard pthread_create
-
- function pthread_detach (thread : pthread_t) return int;
- pragma Inline (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);
- -- LynxOS has a non standard pthread_setspecific
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Inline (pthread_getspecific);
- -- LynxOS has a non standard 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);
- -- LynxOS has a non standard pthread_keycreate
-
- procedure pthread_init;
- -- This is a dummy procedure to share some GNULLI files
-
-private
-
- type sigbit_array is array (1 .. 2) of long;
- type sigset_t is record
- sa_sigbits : sigbit_array;
- end record;
- pragma Convention (C_Pass_By_Copy, sigset_t);
-
- type pid_t is new long;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type st_t is record
- stksize : int;
- prio : int;
- inheritsched : int;
- state : int;
- sched : int;
- end record;
- pragma Convention (C, st_t);
-
- type pthread_attr_t is record
- st : st_t;
- pthread_attr_scope : int; -- ignored
- end record;
- pragma Convention (C, pthread_attr_t);
-
- type pthread_condattr_t is new int;
-
- type pthread_mutexattr_t is new int;
-
- type tid_t is new short;
- type pthread_t is new tid_t;
-
- type synch_ptr is access all pthread_mutex_t;
- type pthread_mutex_t is record
- w_count : int;
- mut_owner : int;
- id : unsigned;
- next : synch_ptr;
- end record;
- pragma Convention (C, pthread_mutex_t);
-
- type pthread_cond_t is new pthread_mutex_t;
-
- type pthread_key_t is new int;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 2001-2010, 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 LynxOS (POSIX Threads) version of this package
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
-
-package body System.OS_Interface is
-
- use Interfaces.C;
-
- -----------------
- -- 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;
-
- -------------
- -- sigwait --
- -------------
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal)
- return int
- is
- function sigwaitinfo
- (set : access sigset_t;
- info : System.Address) return Signal;
- pragma Import (C, sigwaitinfo, "sigwaitinfo");
-
- begin
- sig.all := sigwaitinfo (set, Null_Address);
-
- if sig.all = -1 then
- return errno;
- end if;
-
- return 0;
- end sigwait;
-
- --------------------
- -- Get_Stack_Base --
- --------------------
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Warnings (Off, thread);
-
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- ------------------
- -- pthread_init --
- ------------------
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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-2011, 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 a LynxOS (POSIX Threads) 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;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-mthreads");
- -- Selects the POSIX 1.c runtime, rather than the non-threading runtime
- -- or the deprecated legacy threads library. The -mthreads flag is
- -- defined in patch.LynxOS and matches the definition for Lynx's gcc.
-
- 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;
- ETIMEDOUT : constant := 60;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 63;
-
- -- Max_Interrupt is the number of OS signals, as defined in:
- --
- -- /usr/include/sys/signal.h
- --
- --
- -- The lowest numbered signal is 1, but 0 is a valid argument to some
- -- library functions, e.g. kill(2). However, 0 is not just another
- -- signal: For instance 'I in Signal' and similar should be used with
- -- caution.
-
- 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)
- SIGBRK : constant := 6; -- break
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in future
- SIGCORE : constant := 7; -- kill with core dump
- 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
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGCHLD : constant := 20; -- child status change
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
- SIGPOLL : constant := 23; -- pollable event occurred
- SIGTHREADKILL : constant := 24; -- Reserved by LynxOS runtime
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGWINCH : constant := 28; -- window size change
- SIGLOST : constant := 29; -- SUN 4.1 compatibility
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
-
- SIGPRIO : constant := 32;
- -- sent to a process with its priority or group is changed
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set :=
- (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGTHREADKILL);
- Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP, SIGPRIO);
-
- type sigset_t is private;
-
- 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 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_SIGINFO : constant := 16#80#;
-
- SA_ONSTACK : constant := 16#00#;
- -- SA_ONSTACK is not defined on LynxOS, but it is referred to in the POSIX
- -- implementation of System.Interrupt_Management. Therefore we define a
- -- dummy value of zero here so that setting this flag is a nop.
-
- SIG_BLOCK : constant := 0;
- SIG_UNBLOCK : constant := 1;
- SIG_SETMASK : constant := 2;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- Time_Slice_Supported : constant Boolean := True;
- -- Indicates whether time slicing is supported
-
- type timespec is private;
-
- type clockid_t is new int;
-
- function clock_gettime
- (clock_id : clockid_t;
- tp : access timespec) return int;
- pragma Import (C, clock_gettime, "clock_gettime");
-
- function clock_getres
- (clock_id : clockid_t;
- res : access timespec) return int;
- pragma Import (C, clock_getres, "clock_getres");
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- type struct_timezone is record
- tz_minuteswest : int;
- tz_dsttime : int;
- end record;
- pragma Convention (C, struct_timezone);
- type struct_timezone_ptr is access all struct_timezone;
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_FIFO : constant := 16#200000#;
- SCHED_RR : constant := 16#100000#;
- SCHED_OTHER : constant := 16#400000#;
-
- -------------
- -- 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");
-
- ---------
- -- LWP --
- ---------
-
- function lwp_self return System.Address;
- pragma Import (C, lwp_self, "pthread_self");
-
- -------------
- -- 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;
-
- type pthread_mutex_t is limited private;
- 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;
-
- PTHREAD_CREATE_DETACHED : constant := 1;
- PTHREAD_CREATE_JOINABLE : constant := 0;
-
- -----------
- -- Stack --
- -----------
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- Returns the stack base of the specified thread.
- -- Only call this function when Stack_Base_Available is True.
-
- function Get_Page_Size return size_t;
- function Get_Page_Size return Address;
- pragma Import (C, Get_Page_Size, "getpagesize");
- -- Returns the size of a page, or 0 if this is not relevant on this
- -- target
-
- PROT_NONE : constant := 1;
- PROT_READ : constant := 2;
- PROT_WRITE : constant := 4;
- PROT_EXEC : constant := 8;
- PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
-
- PROT_ON : constant := PROT_READ;
- PROT_OFF : constant := PROT_ALL;
-
- function mprotect (addr : Address; len : size_t; prot : int) return int;
- pragma Import (C, mprotect);
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- procedure pthread_init;
- -- This is a dummy procedure to share some GNULLI files
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal) return int;
- pragma Inline (sigwait);
- -- LynxOS has non standard sigwait
-
- function pthread_kill
- (thread : pthread_t;
- sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
- -- The behavior of pthread_sigmask on LynxOS requires
- -- further investigation.
-
- ----------------------------
- -- POSIX.1c Section 11 --
- ----------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- Relative_Timed_Wait : constant Boolean := False;
- -- pthread_cond_timedwait requires an absolute delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_INHERIT : constant := 1;
- PTHREAD_PRIO_PROTECT : constant := 2;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import (C, pthread_mutexattr_setprotocol);
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import (C, pthread_mutexattr_setprioceiling);
-
- type struct_sched_param is record
- sched_priority : int;
- end record;
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int;
- pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
-
- function pthread_attr_setscope
- (attr : access pthread_attr_t;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import (C, pthread_attr_setinheritsched);
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, pthread_attr_setschedpolicy);
-
- function sched_yield return int;
- pragma Import (C, sched_yield, "sched_yield");
-
- --------------------------
- -- P1003.1c Section 16 --
- --------------------------
-
- function pthread_attr_init (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init, "pthread_attr_init");
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- pragma Import (C, pthread_attr_setdetachstate);
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, 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 Import (C, pthread_create, "pthread_create");
-
- 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 st_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, st_setspecific, "st_setspecific");
-
- function st_getspecific
- (key : pthread_key_t;
- retval : System.Address) return int;
- pragma Import (C, st_getspecific, "st_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function st_keycreate
- (destructor : destructor_pointer;
- key : access pthread_key_t) return int;
- pragma Import (C, st_keycreate, "st_keycreate");
-
-private
-
- type sigset_t is record
- X1, X2 : long;
- end record;
- pragma Convention (C, sigset_t);
-
- type pid_t is new long;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type st_attr_t is record
- stksize : int;
- prio : int;
- inheritsched : int;
- state : int;
- sched : int;
- detachstate : int;
- guardsize : int;
- end record;
- pragma Convention (C, st_attr_t);
-
- type pthread_attr_t is record
- pthread_attr_magic : unsigned;
- st : st_attr_t;
- pthread_attr_scope : int;
- end record;
- pragma Convention (C, pthread_attr_t);
-
- type pthread_condattr_t is record
- cv_magic : unsigned;
- cv_pshared : unsigned;
- end record;
- pragma Convention (C, pthread_condattr_t);
-
- type pthread_mutexattr_t is record
- m_flags : unsigned;
- m_prio_c : int;
- m_pshared : int;
- end record;
- pragma Convention (C, pthread_mutexattr_t);
-
- type tid_t is new short;
- type pthread_t is new tid_t;
-
- type block_obj_t is new System.Address;
- -- typedef struct _block_obj_s {
- -- struct st_entry *b_head;
- -- } block_obj_t;
-
- type pthread_mutex_t is record
- m_flags : unsigned;
- m_owner : tid_t;
- m_wait : block_obj_t;
- m_prio_c : int;
- m_oldprio : int;
- m_count : int;
- m_referenced : int;
- end record;
- pragma Convention (C, pthread_mutex_t);
- type pthread_mutex_t_ptr is access all pthread_mutex_t;
-
- type pthread_cond_t is record
- cv_magic : unsigned;
- cv_wait : block_obj_t;
- cv_mutex : pthread_mutex_t_ptr;
- cv_refcnt : int;
- end record;
- pragma Convention (C, pthread_cond_t);
-
- type pthread_key_t is new int;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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-2009, 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 LynxOS version of this file, adapted to make SCHED_FIFO and
--- ceiling locking (Annex D compliance) work properly.
-
--- This package contains all the GNULL primitives that interface directly with
--- the underlying OS.
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with Ada.Unchecked_Deallocation;
-
-with Interfaces.C;
-
-with System.Tasking.Debug;
-with System.Interrupt_Management;
-with System.OS_Primitives;
-with System.Task_Info;
-
-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 SSL renames System.Soft_Links;
-
- use System.Tasking.Debug;
- use System.Tasking;
- use Interfaces.C;
- use System.OS_Interface;
- use System.Parameters;
- use System.OS_Primitives;
-
- ----------------
- -- 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 mainly in Single_Lock mode, but also to protect All_Tasks_List
-
- ATCB_Key : aliased pthread_key_t;
- -- Key used to find the Ada Task_Id associated with a thread
-
- Environment_Task_Id : Task_Id;
- -- A variable to hold Task_Id for the environment task
-
- Locking_Policy : Character;
- pragma Import (C, Locking_Policy, "__gl_locking_policy");
- -- Value of the pragma Locking_Policy:
- -- 'C' for Ceiling_Locking
- -- 'I' for Inherit_Locking
- -- ' ' for none.
-
- Unblocked_Signal_Mask : aliased sigset_t;
- -- The set of signals that should unblocked in all tasks
-
- -- The followings are internal configuration constants needed
-
- Next_Serial_Number : Task_Serial_Number := 100;
- -- We start at 100, to reserve some special values for
- -- using in error checking.
-
- Time_Slice_Val : Integer;
- pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
-
- Dispatching_Policy : Character;
- pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
-
- 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 current thread have an ATCB?
-
- 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
-
- ---------------------------------
- -- 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);
- -- Signal handler used to implement asynchronous abort
-
- procedure Set_OS_Priority (T : Task_Id; Prio : System.Any_Priority);
- -- This procedure calls the scheduler of the OS to set thread's priority
-
- -------------------
- -- Abort_Handler --
- -------------------
-
- procedure Abort_Handler (Sig : Signal) is
- pragma Unreferenced (Sig);
-
- T : constant Task_Id := Self;
- Result : Interfaces.C.int;
- Old_Set : aliased sigset_t;
-
- begin
- -- It is not safe to raise an exception when using ZCX and the GCC
- -- exception handling mechanism.
-
- if ZCX_By_Default and then GCC_ZCX_Support then
- return;
- end if;
-
- if T.Deferral_Level = 0
- and then T.Pending_ATC_Level < T.ATC_Nesting_Level
- and then not T.Aborting
- then
- T.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 --
- -----------------
-
- procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
- Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread);
- Guard_Page_Address : Address;
-
- Res : Interfaces.C.int;
-
- begin
- if Stack_Base_Available then
-
- -- Compute the guard page address
-
- Guard_Page_Address :=
- Stack_Base - (Stack_Base mod Get_Page_Size) + Get_Page_Size;
-
- if On then
- Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_ON);
- else
- Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_OFF);
- end if;
-
- pragma Assert (Res = 0);
- end if;
- 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 --
- ---------------------
-
- 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;
-
- if Locking_Policy = 'C' then
- L.Ceiling := Prio;
- end if;
-
- Result := pthread_mutex_init (L.Mutex'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
- Result := pthread_mutexattr_destroy (Attributes'Access);
- 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.Mutex'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;
- T : constant Task_Id := Self;
-
- begin
- if Locking_Policy = 'C' then
- if T.Common.Current_Priority > L.Ceiling then
- Ceiling_Violation := True;
- return;
- end if;
-
- L.Saved_Priority := T.Common.Current_Priority;
-
- if T.Common.Current_Priority < L.Ceiling then
- Set_OS_Priority (T, L.Ceiling);
- end if;
- end if;
-
- Result := pthread_mutex_lock (L.Mutex'Access);
-
- -- Assume that the cause of EINVAL is a priority ceiling violation
-
- Ceiling_Violation := (Result = EINVAL);
- pragma Assert (Result = 0 or else Result = EINVAL);
- end Write_Lock;
-
- -- No tricks on RTS_Locks
-
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- Result : Interfaces.C.int;
- begin
- if not Single_Lock or else Global_Lock then
- Result := pthread_mutex_lock (L);
- pragma Assert (Result = 0);
- end if;
- end Write_Lock;
-
- procedure Write_Lock (T : Task_Id) is
- Result : Interfaces.C.int;
- begin
- if not Single_Lock then
- Result := pthread_mutex_lock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
- 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;
- T : constant Task_Id := Self;
-
- begin
- Result := pthread_mutex_unlock (L.Mutex'Access);
- pragma Assert (Result = 0);
-
- if Locking_Policy = 'C' then
- if T.Common.Current_Priority > L.Saved_Priority then
- Set_OS_Priority (T, L.Saved_Priority);
- end if;
- end if;
- end Unlock;
-
- procedure Unlock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- Result : Interfaces.C.int;
- begin
- if not Single_Lock or else Global_Lock then
- Result := pthread_mutex_unlock (L);
- pragma Assert (Result = 0);
- end if;
- end Unlock;
-
- procedure Unlock (T : Task_Id) is
- Result : Interfaces.C.int;
- begin
- if not Single_Lock then
- Result := pthread_mutex_unlock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
- 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
- if Single_Lock then
- Result :=
- pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
- else
- Result :=
- pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
- end if;
-
- -- EINTR is not considered a failure
-
- pragma Assert (Result = 0 or else Result = EINTR);
- end Sleep;
-
- -----------------
- -- Timed_Sleep --
- -----------------
-
- -- This is for use within the run-time system, so abort is
- -- assumed to be already deferred, and the caller should be
- -- holding its own ATCB lock.
-
- procedure Timed_Sleep
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes;
- Reason : Task_States;
- Timedout : out Boolean;
- Yielded : out Boolean)
- is
- pragma Unreferenced (Reason);
-
- Base_Time : constant Duration := Monotonic_Clock;
- Check_Time : Duration := Base_Time;
- Rel_Time : Duration;
- Abs_Time : Duration;
- Request : aliased timespec;
- Result : Interfaces.C.int;
-
- begin
- Timedout := True;
- Yielded := False;
-
- if Mode = Relative then
- Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
-
- if Relative_Timed_Wait then
- Rel_Time := Duration'Min (Max_Sensible_Delay, Time);
- end if;
-
- else
- Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
-
- if Relative_Timed_Wait then
- Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time);
- end if;
- end if;
-
- if Abs_Time > Check_Time then
- if Relative_Timed_Wait then
- Request := To_Timespec (Rel_Time);
- else
- Request := To_Timespec (Abs_Time);
- end if;
-
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- if Single_Lock then
- Result :=
- pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
- Request'Access);
-
- else
- Result :=
- pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
- Request'Access);
- end if;
-
- Check_Time := Monotonic_Clock;
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- 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 --
- -----------------
-
- -- This is for use in implementing delay statements, so we assume
- -- the caller is abort-deferred but is holding no locks.
-
- procedure Timed_Delay
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes)
- is
- Base_Time : constant Duration := Monotonic_Clock;
- Check_Time : Duration := Base_Time;
- Abs_Time : Duration;
- Rel_Time : Duration;
- Request : aliased timespec;
-
- Result : Interfaces.C.int;
- pragma Warnings (Off, Result);
-
- begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
- -- Comments needed in code below ???
-
- Write_Lock (Self_ID);
-
- if Mode = Relative then
- Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
-
- if Relative_Timed_Wait then
- Rel_Time := Duration'Min (Max_Sensible_Delay, Time);
- end if;
-
- else
- Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
-
- if Relative_Timed_Wait then
- Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time);
- end if;
- end if;
-
- if Abs_Time > Check_Time then
- if Relative_Timed_Wait then
- Request := To_Timespec (Rel_Time);
- else
- Request := To_Timespec (Abs_Time);
- end if;
-
- Self_ID.Common.State := Delay_Sleep;
-
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- if Single_Lock then
- Result :=
- pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock'Access,
- Request'Access);
- else
- Result :=
- pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access,
- Request'Access);
- end if;
-
- Check_Time := Monotonic_Clock;
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- pragma Assert (Result = 0 or else
- Result = ETIMEDOUT or else
- Result = EINTR);
- end loop;
-
- Self_ID.Common.State := Runnable;
- end if;
-
- Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
- 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
- (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access);
- pragma Assert (Result = 0);
- return To_Duration (TS);
- end Monotonic_Clock;
-
- -------------------
- -- RT_Resolution --
- -------------------
-
- function RT_Resolution return Duration is
- Res : aliased timespec;
- Result : Interfaces.C.int;
- begin
- Result :=
- clock_getres
- (clock_id => CLOCK_REALTIME, res => Res'Unchecked_Access);
- pragma Assert (Result = 0);
- return To_Duration (Res);
- 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 --
- ------------------
-
- procedure Set_OS_Priority (T : Task_Id; Prio : System.Any_Priority) is
- Result : Interfaces.C.int;
- 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 (Prio);
-
- if Time_Slice_Supported
- and then (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);
- end Set_OS_Priority;
-
- type Prio_Array_Type is array (System.Any_Priority) of Integer;
- pragma Atomic_Components (Prio_Array_Type);
- Prio_Array : Prio_Array_Type;
- -- Comments needed for these declarations ???
-
- procedure Set_Priority
- (T : Task_Id;
- Prio : System.Any_Priority;
- Loss_Of_Inheritance : Boolean := False)
- is
- Array_Item : Integer;
-
- begin
- Set_OS_Priority (T, Prio);
-
- if Locking_Policy = 'C' then
-
- -- Annex D requirements: loss of inheritance puts task at the start
- -- of the queue for that prio; copied from 5ztaprop (VxWorks).
-
- 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
- Yield;
- 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;
- Self_ID.Common.LL.LWP := lwp_self;
-
- Specific.Set (Self_ID);
-
- Lock_RTS;
-
- for J in Known_Tasks'Range loop
- if Known_Tasks (J) = null then
- Known_Tasks (J) := Self_ID;
- Self_ID.Known_Tasks_Index := J;
- exit;
- end if;
- end loop;
-
- Unlock_RTS;
- end Enter_Task;
-
- --------------
- -- New_ATCB --
- --------------
-
- function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
- begin
- return new Ada_Task_Control_Block (Entry_Num);
- end New_ATCB;
-
- -------------------
- -- 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
- -- Give the task a unique serial number
-
- Self_ID.Serial_Number := Next_Serial_Number;
- Next_Serial_Number := Next_Serial_Number + 1;
- pragma Assert (Next_Serial_Number /= 0);
-
- if not Single_Lock then
- 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);
- end if;
-
- 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
- if not Single_Lock then
- Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
-
- 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;
- Adjusted_Stack_Size : Interfaces.C.size_t;
- Result : Interfaces.C.int;
-
- use System.Task_Info;
-
- begin
- Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
-
- if Stack_Base_Available then
-
- -- If Stack Checking is supported then allocate 2 additional pages:
-
- -- In the worst case, stack is allocated at something like
- -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages
- -- to be sure the effective stack size is greater than what
- -- has been asked.
-
- Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Get_Page_Size;
- end if;
-
- 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_setdetachstate
- (Attributes'Access, PTHREAD_CREATE_DETACHED);
- pragma Assert (Result = 0);
-
- Result :=
- pthread_attr_setstacksize
- (Attributes'Access, Adjusted_Stack_Size);
- pragma Assert (Result = 0);
-
- if T.Common.Task_Info /= Default_Scope then
-
- -- We are assuming that Scope_Type has the same values than the
- -- corresponding C macros
-
- Result :=
- pthread_attr_setscope
- (Attributes'Access, Task_Info_Type'Pos (T.Common.Task_Info));
- pragma Assert (Result = 0);
- end if;
-
- -- 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;
-
- Result := pthread_attr_destroy (Attributes'Access);
- pragma Assert (Result = 0);
-
- if Succeeded then
- Set_Priority (T, Priority);
- end if;
- end Create_Task;
-
- ------------------
- -- Finalize_TCB --
- ------------------
-
- procedure Finalize_TCB (T : Task_Id) is
- Result : Interfaces.C.int;
- Tmp : Task_Id := T;
- Is_Self : constant Boolean := T = Self;
-
- procedure Free is new
- Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
-
- begin
- if not Single_Lock then
- Result := pthread_mutex_destroy (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
-
- 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;
-
- Free (Tmp);
-
- if Is_Self then
- Result := st_setspecific (ATCB_Key, System.Null_Address);
- pragma Assert (Result = 0);
- end if;
- 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
- Result : Interfaces.C.int;
- begin
- Result :=
- pthread_kill
- (T.Common.LL.Thread,
- Signal (System.Interrupt_Management.Abort_Task_Interrupt));
- pragma Assert (Result = 0);
- 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 (RM D.10(6)))
-
- S.State := False;
- S.Waiting := False;
-
- -- Initialize internal mutex
-
- Result := pthread_mutexattr_init (Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
- pragma Assert (Result = 0);
-
- raise Storage_Error;
- end if;
-
- Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
- pragma Assert (Result = 0);
-
- -- Initialize internal condition variable
-
- Result := pthread_condattr_init (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;
-
- 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
- Result := pthread_condattr_destroy (Cond_Attr'Access);
- pragma Assert (Result = 0);
-
- raise Storage_Error;
- end if;
- end if;
-
- Result := pthread_condattr_destroy (Cond_Attr'Access);
- pragma Assert (Result = 0);
- 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 specified in (RM D.10(9)). Otherwise, just leave state set 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
- -- (RM D.10 (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 (RM D.10(9)).
-
- if S.State then
- S.State := False;
- else
- S.Waiting := True;
- Result := pthread_cond_wait (S.CV'Access, S.L'Access);
- 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, Global_Lock => True);
- end Lock_RTS;
-
- ----------------
- -- Unlock_RTS --
- ----------------
-
- procedure Unlock_RTS is
- begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
- 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;
-
- -- Prepare the set of signals that should unblocked in all tasks
-
- Result := sigemptyset (Unblocked_Signal_Mask'Access);
- pragma Assert (Result = 0);
-
- for J in Interrupt_Management.Interrupt_ID loop
- if System.Interrupt_Management.Keep_Unmasked (J) then
- Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
- pragma Assert (Result = 0);
- end if;
- end loop;
-
- -- Initialize the lock used to synchronize chain of all ATCBs
-
- Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-
- Specific.Initialize (Environment_Task);
-
- 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;
-
-end System.Task_Primitives.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2009, 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 LynxOS version of this package.
-
-separate (System.Task_Primitives.Operations)
-package body Specific is
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- pragma Warnings (Off, Environment_Task);
- Result : Interfaces.C.int;
-
- begin
- Result := st_keycreate (null, ATCB_Key'Access);
- pragma Assert (Result = 0);
- end Initialize;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean is
- Result : Interfaces.C.int;
- Value : aliased System.Address;
- begin
- Result := st_getspecific (ATCB_Key, Value'Address);
- pragma Assert (Result = 0);
- return (Value /= System.Null_Address);
- end Is_Valid_Task;
-
- ---------
- -- Set --
- ---------
-
- procedure Set (Self_Id : Task_Id) is
- Result : Interfaces.C.int;
-
- begin
- Result := st_setspecific (ATCB_Key, To_Address (Self_Id));
- pragma Assert (Result = 0);
- end Set;
-
- ----------
- -- Self --
- ----------
-
- -- To make Ada tasks and C threads interoperate better, we have added some
- -- functionality to Self. Suppose a C main program (with threads) calls an
- -- Ada procedure and the Ada procedure calls the tasking runtime system.
- -- Eventually, a call will be made to self. Since the call is not coming
- -- from an Ada task, there will be no corresponding ATCB.
-
- -- What we do in Self is to catch references that do not come from
- -- recognized Ada tasks, and create an ATCB for the calling thread.
-
- -- The new ATCB will be "detached" from the normal Ada task master
- -- hierarchy, much like the existing implicitly created signal-server
- -- tasks.
-
- function Self return Task_Id is
- Value : aliased System.Address;
-
- Result : Interfaces.C.int;
- pragma Unreferenced (Result);
-
- begin
- Result := st_getspecific (ATCB_Key, Value'Address);
- -- Is it OK not to check this result???
-
- -- If the key value is Null, then it is a non-Ada task.
-
- if Value /= System.Null_Address then
- return To_Task_Id (Value);
- else
- return Register_Foreign_Thread;
- end if;
- end Self;
-
-end Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M --
--- --
--- S p e c --
--- (LynxOS PPC Version) --
--- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- 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/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package System is
- pragma Pure;
- -- Note that we take advantage of the implementation permission to make
- -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
- -- 2005, this is Pure in any case (AI-362).
-
- type Name is (SYSTEM_NAME_GNAT);
- System_Name : constant Name := SYSTEM_NAME_GNAT;
-
- -- System-Dependent Named Numbers
-
- Min_Int : constant := Long_Long_Integer'First;
- Max_Int : constant := Long_Long_Integer'Last;
-
- Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
- Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1;
-
- Max_Base_Digits : constant := Long_Long_Float'Digits;
- Max_Digits : constant := Long_Long_Float'Digits;
-
- Max_Mantissa : constant := 63;
- Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
-
- Tick : constant := 0.01;
-
- -- Storage-related Declarations
-
- type Address is private;
- pragma Preelaborable_Initialization (Address);
- Null_Address : constant Address;
-
- Storage_Unit : constant := 8;
- Word_Size : constant := 32;
- Memory_Size : constant := 2 ** 32;
-
- -- Address comparison
-
- function "<" (Left, Right : Address) return Boolean;
- function "<=" (Left, Right : Address) return Boolean;
- function ">" (Left, Right : Address) return Boolean;
- function ">=" (Left, Right : Address) return Boolean;
- function "=" (Left, Right : Address) return Boolean;
-
- pragma Import (Intrinsic, "<");
- pragma Import (Intrinsic, "<=");
- pragma Import (Intrinsic, ">");
- pragma Import (Intrinsic, ">=");
- pragma Import (Intrinsic, "=");
-
- -- Other System-Dependent Declarations
-
- type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := High_Order_First;
- pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-
- -- Priority-related Declarations (RM D.1)
-
- -- 17 is the system determined default priority for user applications
- -- running on LynxOS.
-
- -- The standard (Rm 13.7) requires that Default_Priority has the value:
-
- -- (Priority'First + Priority'Last) / 2
-
- -- To allow an appropriate value for Default_Priority and expose a useful
- -- range of priorities to the user, we use a range of 0 .. 34 for subtype
- -- Priority.
-
- -- The rest of the range allowed by the system from 35 to 255 is made
- -- available here in Interrupt_Priority.
-
- Max_Priority : constant Positive := 34;
- Max_Interrupt_Priority : constant Positive := 255;
-
- subtype Any_Priority is Integer range 0 .. 255;
- subtype Priority is Any_Priority range 0 .. 34;
- subtype Interrupt_Priority is Any_Priority range 35 .. 255;
-
- Default_Priority : constant Priority := 17;
-
-private
-
- type Address is mod Memory_Size;
- Null_Address : constant Address := 0;
-
- --------------------------------------
- -- System Implementation Parameters --
- --------------------------------------
-
- -- These parameters provide information about the target that is used
- -- by the compiler. They are in the private part of System, where they
- -- can be accessed using the special circuitry in the Targparm unit
- -- whose source should be consulted for more detailed descriptions
- -- of the individual switch values.
-
- Backend_Divide_Checks : constant Boolean := False;
- Backend_Overflow_Checks : constant Boolean := False;
- Command_Line_Args : constant Boolean := True;
- Configurable_Run_Time : constant Boolean := False;
- Denorm : constant Boolean := True;
- Duration_32_Bits : constant Boolean := False;
- Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
- Machine_Overflows : constant Boolean := False;
- Machine_Rounds : constant Boolean := True;
- Preallocated_Stacks : constant Boolean := False;
- Signed_Zeros : constant Boolean := True;
- Stack_Check_Default : constant Boolean := False;
- Stack_Check_Probes : constant Boolean := True;
- Stack_Check_Limits : constant Boolean := False;
- Support_Aggregates : constant Boolean := True;
- Support_Composite_Assign : constant Boolean := True;
- Support_Composite_Compare : constant Boolean := True;
- Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := False;
- Suppress_Standard_Library : constant Boolean := False;
- Use_Ada_Main_Program_Name : constant Boolean := False;
- ZCX_By_Default : constant Boolean := False;
-
-end System;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M --
--- --
--- S p e c --
--- (LynxOS x86 Version) --
--- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- 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/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package System is
- pragma Pure;
- -- Note that we take advantage of the implementation permission to make
- -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
- -- 2005, this is Pure in any case (AI-362).
-
- type Name is (SYSTEM_NAME_GNAT);
- System_Name : constant Name := SYSTEM_NAME_GNAT;
-
- -- System-Dependent Named Numbers
-
- Min_Int : constant := Long_Long_Integer'First;
- Max_Int : constant := Long_Long_Integer'Last;
-
- Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
- Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1;
-
- Max_Base_Digits : constant := Long_Long_Float'Digits;
- Max_Digits : constant := Long_Long_Float'Digits;
-
- Max_Mantissa : constant := 63;
- Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
-
- Tick : constant := 0.01;
-
- -- Storage-related Declarations
-
- type Address is private;
- pragma Preelaborable_Initialization (Address);
- Null_Address : constant Address;
-
- Storage_Unit : constant := 8;
- Word_Size : constant := 32;
- Memory_Size : constant := 2 ** 32;
-
- -- Address comparison
-
- function "<" (Left, Right : Address) return Boolean;
- function "<=" (Left, Right : Address) return Boolean;
- function ">" (Left, Right : Address) return Boolean;
- function ">=" (Left, Right : Address) return Boolean;
- function "=" (Left, Right : Address) return Boolean;
-
- pragma Import (Intrinsic, "<");
- pragma Import (Intrinsic, "<=");
- pragma Import (Intrinsic, ">");
- pragma Import (Intrinsic, ">=");
- pragma Import (Intrinsic, "=");
-
- -- Other System-Dependent Declarations
-
- type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := Low_Order_First;
- pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-
- -- Priority-related Declarations (RM D.1)
-
- -- 17 is the system determined default priority for user applications
- -- running on LynxOS.
-
- -- The standard (Rm 13.7) requires that Default_Priority has the value:
-
- -- (Priority'First + Priority'Last) / 2
-
- -- To allow an appropriate value for Default_Priority and expose a useful
- -- range of priorities to the user, we use a range of 0 .. 34 for subtype
- -- Priority.
-
- -- The rest of the range allowed by the system from 35 to 255 is made
- -- available here in Interrupt_Priority.
-
- Max_Priority : constant Positive := 34;
- Max_Interrupt_Priority : constant Positive := 255;
-
- subtype Any_Priority is Integer range 0 .. 255;
- subtype Priority is Any_Priority range 0 .. 34;
- subtype Interrupt_Priority is Any_Priority range 35 .. 255;
-
- Default_Priority : constant Priority := 17;
-
-private
-
- type Address is mod Memory_Size;
- Null_Address : constant Address := 0;
-
- --------------------------------------
- -- System Implementation Parameters --
- --------------------------------------
-
- -- These parameters provide information about the target that is used
- -- by the compiler. They are in the private part of System, where they
- -- can be accessed using the special circuitry in the Targparm unit
- -- whose source should be consulted for more detailed descriptions
- -- of the individual switch values.
-
- Backend_Divide_Checks : constant Boolean := False;
- Backend_Overflow_Checks : constant Boolean := False;
- Command_Line_Args : constant Boolean := True;
- Configurable_Run_Time : constant Boolean := False;
- Denorm : constant Boolean := True;
- Duration_32_Bits : constant Boolean := False;
- Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
- Machine_Overflows : constant Boolean := False;
- Machine_Rounds : constant Boolean := True;
- Preallocated_Stacks : constant Boolean := False;
- Signed_Zeros : constant Boolean := True;
- Stack_Check_Default : constant Boolean := False;
- Stack_Check_Probes : constant Boolean := True;
- Stack_Check_Limits : constant Boolean := False;
- Support_Aggregates : constant Boolean := True;
- Support_Atomic_Primitives : constant Boolean := True;
- Support_Composite_Assign : constant Boolean := True;
- Support_Composite_Compare : constant Boolean := True;
- Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := False;
- Suppress_Standard_Library : constant Boolean := False;
- Use_Ada_Main_Program_Name : constant Boolean := False;
- ZCX_By_Default : constant Boolean := False;
-
-end System;
projects / platform / upstream / gcc.git / commitdiff