--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1999-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a UnixWare (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.
+
+with Interfaces.C;
+
+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;
+
+ function To_Duration (TV : struct_timeval) return Duration is
+ begin
+ return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
+ 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;
+
+ ----------------
+ -- To_Timeval --
+ ----------------
+
+ function To_Timeval (D : Duration) return struct_timeval is
+ S : long;
+ F : Duration;
+
+ begin
+ S := long (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 struct_timeval' (tv_sec => S,
+ tv_usec => long (Long_Long_Integer (F * 10#1#E6)));
+ end To_Timeval;
+
+ -------------------
+ -- clock_gettime --
+ -------------------
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int
+ is
+ Result : int;
+ tv : aliased struct_timeval;
+
+ function gettimeofday
+ (tv : access struct_timeval;
+ tz : System.Address := System.Null_Address) return int;
+ pragma Import (C, gettimeofday, "gettimeofday");
+
+ begin
+ Result := gettimeofday (tv'Unchecked_Access);
+ tp.all := To_Timespec (To_Duration (tv));
+ return Result;
+ end clock_gettime;
+
+ ---------------------------
+ -- POSIX.1c Section 3 --
+ ---------------------------
+
+ function sigwait (set : access sigset_t; sig : access Signal) return int is
+ Result : int;
+
+ function sigwait (set : access sigset_t) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ begin
+ Result := sigwait (set);
+
+ if Result < 0 then
+ sig.all := 0;
+ return errno;
+ end if;
+
+ sig.all := Signal (Result);
+ return 0;
+ end sigwait;
+
+ function pthread_kill (thread : pthread_t; sig : Signal) return int is
+ function pthread_kill_base
+ (thread : access pthread_t; sig : access Signal) return int;
+ pragma Import (C, pthread_kill_base, "pthread_kill");
+
+ thr : aliased pthread_t := thread;
+ signo : aliased Signal := sig;
+
+ begin
+ return pthread_kill_base (thr'Unchecked_Access, signo'Unchecked_Access);
+ end pthread_kill;
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.10 $
+-- --
+-- Copyright (C) 1999-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a UnixWare (Native THREADS) version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lthread");
+
+ 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 := 145;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 34;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ SIGWINCH : constant := 20; -- window size change
+ SIGURG : constant := 21; -- urgent condition on IO channel
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias)
+ SIGSTOP : constant := 23; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 24; -- user stop requested from tty
+ SIGCONT : constant := 25; -- stopped process has been continued
+ SIGTTIN : constant := 26; -- background tty read attempted
+ SIGTTOU : constant := 27; -- background tty write attempted
+ SIGVTALRM : constant := 28; -- virtual timer expired
+ SIGPROF : constant := 29; -- profiling timer expired
+ SIGXCPU : constant := 30; -- CPU time limit exceeded
+ SIGXFSZ : constant := 31; -- filesize limit exceeded
+ SIGWAITING : constant := 32; -- all LWPs blocked interruptibly notific.
+ SIGLWP : constant := 33; -- signal reserved for thread lib impl.
+ SIGAIO : constant := 34; -- Asynchronous I/O signal
+
+ 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, SIGLWP, SIGWAITING, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF);
+ Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP);
+
+ 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_flags : int;
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_resv1 : int;
+ sa_resv2 : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+ -- SIG_ERR : constant := -1;
+ -- not used
+
+ 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 := False;
+ -- Indicates wether time slicing is supported
+
+ type timespec is private;
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int;
+ -- UnixWare threads don't have clock_gettime
+ -- We instead use gettimeofday()
+
+ 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;
+
+ type struct_timeval is private;
+ -- This is needed on systems that do not have clock_gettime()
+ -- but do have gettimeofday().
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 2;
+ SCHED_RR : constant := 3;
+ SCHED_OTHER : constant := 1;
+
+ -------------
+ -- 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, "_lwp_self");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ 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 := 0;
+
+ -----------
+ -- Stack --
+ -----------
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates wether 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);
+ -- UnixWare provides a non standard sigwait
+
+ function pthread_kill (thread : pthread_t; sig : Signal) return int;
+ pragma Inline (pthread_kill);
+ -- UnixWare provides a non standard pthread_kill
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- 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 := 1;
+ PTHREAD_PRIO_INHERIT : constant := 2;
+ PTHREAD_PRIO_PROTECT : constant := 3;
+
+ 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 sched_union is record
+ sched_fifo : int;
+ sched_fcfs : int;
+ sched_other : int;
+ sched_ts : int;
+ policy_params : long;
+ end record;
+
+ type struct_sched_param is record
+ sched_priority : int;
+ sched_other_stuff : sched_union;
+ 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 pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+ procedure pthread_init;
+ -- This is a dummy procedure to share some GNULLI files
+
+private
+
+ type sigbit_array is array (1 .. 4) of unsigned;
+ type sigset_t is record
+ sa_sigbits : sigbit_array;
+ end record;
+ pragma Convention (C_Pass_By_Copy, sigset_t);
+
+ type pid_t is new unsigned;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 0;
+
+ type struct_timeval is record
+ tv_sec : long;
+ tv_usec : long;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type pthread_attr_t is record
+ pt_attr_status : int;
+ pt_attr_stacksize : size_t;
+ pt_attr_stackaddr : System.Address;
+ pt_attr_detachstate : int;
+ pt_attr_contentionscope : int;
+ pt_attr_inheritsched : int;
+ pt_attr_schedpolicy : int;
+ pt_attr_sched_param : struct_sched_param;
+ pt_attr_tlflags : int;
+ end record;
+ pragma Convention (C, pthread_attr_t);
+
+ type pthread_condattr_t is record
+ pt_condattr_status : int;
+ pt_condattr_pshared : int;
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_mutexattr_t is record
+ pt_mutexattr_status : int;
+ pt_mutexattr_pshared : int;
+ pt_mutexattr_type : int;
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type thread_t is new long;
+ type pthread_t is new thread_t;
+
+ type thrq_elt_t;
+ type thrq_elt_t_ptr is access all thrq_elt_t;
+
+ type thrq_elt_t is record
+ thrq_next : thrq_elt_t_ptr;
+ thrq_prev : thrq_elt_t_ptr;
+ end record;
+ pragma Convention (C, thrq_elt_t);
+
+ type lwp_mutex_t is record
+ wanted : char;
+ lock : unsigned_char;
+ end record;
+ pragma Convention (C, lwp_mutex_t);
+ pragma Volatile (lwp_mutex_t);
+
+ type mutex_t is record
+ m_lmutex : lwp_mutex_t;
+ m_sync_lock : lwp_mutex_t;
+ m_type : int;
+ m_sleepq : thrq_elt_t;
+ filler1 : int;
+ filler2 : int;
+ end record;
+ pragma Convention (C, mutex_t);
+ pragma Volatile (mutex_t);
+
+ type pthread_mutex_t is record
+ pt_mutex_mutex : mutex_t;
+ pt_mutex_pid : pid_t;
+ pt_mutex_owner : thread_t;
+ pt_mutex_depth : int;
+ pt_mutex_attr : pthread_mutexattr_t;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+ type lwp_cond_t is record
+ wanted : char;
+ end record;
+ pragma Convention (C, lwp_cond_t);
+ pragma Volatile (lwp_cond_t);
+
+ type cond_t is record
+ c_lcond : lwp_cond_t;
+ c_sync_lock : lwp_mutex_t;
+ c_type : int;
+ c_syncq : thrq_elt_t;
+ end record;
+ pragma Convention (C, cond_t);
+ pragma Volatile (cond_t);
+
+ type pthread_cond_t is record
+ pt_cond_cond : cond_t;
+ pt_cond_attr : pthread_condattr_t;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new unsigned;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.8 $
+-- --
+-- Copyright (C) 1999-2000 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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.
+
+with Interfaces.C;
+
+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;
+
+ function To_Duration (TV : struct_timeval) return Duration is
+ begin
+ return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
+ 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;
+
+ ----------------
+ -- To_Timeval --
+ ----------------
+
+ function To_Timeval (D : Duration) return struct_timeval 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 struct_timeval' (tv_sec => S,
+ tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
+ end To_Timeval;
+
+ -------------------------
+ -- 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
+ -- begavior; 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
+ begin
+ return 0;
+ end pthread_mutexattr_setprotocol;
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int)
+ return int
+ is
+ begin
+ return 0;
+ end pthread_mutexattr_setprioceiling;
+
+ function pthread_attr_setscope
+ (attr : access pthread_attr_t;
+ contentionscope : int)
+ return int
+ is
+ 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
+ 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
+ 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
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.14 $
+-- --
+-- Copyright (C) 1999-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a LynxOS (Native) version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+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;
+
+ 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 wether time slicing is supported
+
+ type timespec is private;
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+
+ 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;
+
+ type struct_timeval is private;
+ -- This is needed on systems that do not have clock_gettime()
+ -- but do have gettimeofday().
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 16#00200000#;
+ SCHED_RR : constant := 16#00100000#;
+ SCHED_OTHER : constant := 16#00400000#;
+
+ -------------
+ -- 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;
+ 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;
+
+ -----------
+ -- Stack --
+ -----------
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates wether 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");
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) 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 pthrad_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
+
+ 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);
+
+ 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 clockid_t is new unsigned_char;
+ CLOCK_REALTIME : constant clockid_t := 0;
+
+ type struct_timeval is record
+ tv_sec : time_t;
+ tv_usec : time_t;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ 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 COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (LynxOS PPC/x86 Version)
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ 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 := Integer'Last;
+
+ 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 := Standard'Tick;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := Standard'Storage_Unit;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Standard'Address_Size;
+
+ -- 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 :=
+ Bit_Order'Val (Standard'Default_Bit_Order);
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer
+ range 0 .. Standard'Max_Interrupt_Priority;
+
+ subtype Priority is Any_Priority
+ range 0 .. Standard'Max_Priority;
+
+ -- Functional notation is needed in the following to avoid visibility
+ -- problems when this package is compiled through rtsfind in the middle
+ -- of another compilation.
+
+ subtype Interrupt_Priority is Any_Priority
+ range
+ Standard."+" (Standard'Max_Priority, 1) ..
+ Standard'Max_Interrupt_Priority;
+
+ Default_Priority : constant Priority :=
+ Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
+
+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.
+
+ AAMP : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Denorm : constant Boolean := True;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+ High_Integrity_Mode : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+end System;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.10 $
+-- --
+-- Copyright (C) 1999-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a HPUX 11.0 (Native THREADS) version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lpthread");
+
+ 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 := 238;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 44;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ SIGVTALRM : constant := 20; -- virtual timer alarm
+ SIGPROF : constant := 21; -- profiling timer alarm
+ SIGIO : constant := 22; -- asynchronous I/O
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGWINCH : constant := 23; -- window size change
+ SIGSTOP : constant := 24; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 25; -- user stop requested from tty
+ SIGCONT : constant := 26; -- stopped process has been continued
+ SIGTTIN : constant := 27; -- background tty read attempted
+ SIGTTOU : constant := 28; -- background tty write attempted
+ SIGURG : constant := 29; -- urgent condition on IO channel
+ SIGLOST : constant := 30; -- remote lock lost (NFS)
+ SIGDIL : constant := 32; -- DIL signal
+ SIGXCPU : constant := 33; -- CPU time limit exceeded (setrlimit)
+ SIGXFSZ : constant := 34; -- file size limit exceeded (setrlimit)
+ SIGCANCEL : constant := 35; -- used for pthread cancellation.
+ SIGGFAULT : constant := 36; -- Graphics framebuffer fault
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Note: on other targets, we usually use SIGABRT, but on HPUX, it
+ -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set :=
+ (SIGABRT, SIGPIPE, SIGBUS, SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF,
+ SIGALRM, SIGVTALRM, SIGIO, SIGCHLD);
+
+ Reserved : constant Signal_Set := (SIGKILL, SIGSTOP);
+
+ 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;
+
+ 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 wether time slicing is supported
+
+ type timespec is private;
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "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;
+
+ type struct_timeval is private;
+ -- This is needed on systems that do not have clock_gettime()
+ -- but do have gettimeofday().
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 0;
+ SCHED_RR : constant := 1;
+ SCHED_OTHER : constant := 2;
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- LWP --
+ ---------
+
+ function lwp_self return System.Address;
+ pragma Import (C, lwp_self, "_lwp_self");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ 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 := 16#de#;
+
+ -----------
+ -- Stack --
+ -----------
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates wether 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_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;
+ pragma Inline (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 Import (C, sigwait, "sigwait");
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- 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 := 16#100#;
+ PTHREAD_PRIO_PROTECT : constant := 16#200#;
+ PTHREAD_PRIO_INHERIT : constant := 16#400#;
+
+ 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 Array_7_Int is array (0 .. 6) of int;
+ type struct_sched_param is record
+ sched_priority : int;
+ sched_reserved : Array_7_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_system");
+
+ 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, "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_system");
+
+ 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 Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+
+ type unsigned_int_array_8 is array (0 .. 7) of unsigned;
+ type sigset_t is record
+ sigset : unsigned_int_array_8;
+ end record;
+ pragma Convention (C_Pass_By_Copy, sigset_t);
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 1;
+
+ type struct_timeval is record
+ tv_sec : time_t;
+ tv_usec : time_t;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type pthread_attr_t is new int;
+ type pthread_condattr_t is new int;
+ type pthread_mutexattr_t is new int;
+ type pthread_t is new int;
+
+ type short_array is array (Natural range <>) of short;
+ type int_array is array (Natural range <>) of int;
+
+ type pthread_mutex_t is record
+ m_short : short_array (0 .. 1);
+ m_int : int;
+ m_int1 : int_array (0 .. 3);
+ m_pad : int; -- needed for 32 bit ABI, but *not* for 64 bit
+ m_ptr : System.Address;
+ m_int2 : int_array (0 .. 1);
+ m_int3 : int_array (0 .. 3);
+ m_short2 : short_array (0 .. 1);
+ m_int4 : int_array (0 .. 4);
+ m_int5 : int_array (0 .. 1);
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_cond_t is record
+ c_short : short_array (0 .. 1);
+ c_int : int;
+ c_int1 : int_array (0 .. 3);
+ m_pad : int; -- needed for 32 bit ABI, but *not* for 64 bit
+ m_ptr : System.Address;
+ c_int2 : int_array (0 .. 1);
+ c_int3 : int_array (0 .. 1);
+ c_int4 : int_array (0 .. 1);
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.6 $
+-- --
+-- Copyright (C) 2000-2001 Ada Core Technologies, 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Solaris (POSIX Threads) version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lposix4");
+ pragma Linker_Options ("-lpthread");
+
+ 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 := 145;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 45;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ SIGWINCH : constant := 20; -- window size change
+ SIGURG : constant := 21; -- urgent condition on IO channel
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias)
+ SIGSTOP : constant := 23; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 24; -- user stop requested from tty
+ SIGCONT : constant := 25; -- stopped process has been continued
+ SIGTTIN : constant := 26; -- background tty read attempted
+ SIGTTOU : constant := 27; -- background tty write attempted
+ SIGVTALRM : constant := 28; -- virtual timer expired
+ SIGPROF : constant := 29; -- profiling timer expired
+ SIGXCPU : constant := 30; -- CPU time limit exceeded
+ SIGXFSZ : constant := 31; -- filesize limit exceeded
+ SIGWAITING : constant := 32; -- process's lwps blocked (Solaris)
+ SIGLWP : constant := 33; -- used by thread library (Solaris)
+ SIGFREEZE : constant := 34; -- used by CPR (Solaris)
+ SIGTHAW : constant := 35; -- used by CPR (Solaris)
+ SIGCANCEL : constant := 36; -- thread cancellation signal (libthread)
+
+ SIGADAABORT : constant := SIGABRT;
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set := (SIGTRAP, SIGLWP, SIGPROF);
+
+ -- Following signals should not be disturbed.
+ -- See c-posix-signals.c in FLORIST
+
+ Reserved : constant Signal_Set :=
+ (SIGKILL, SIGSTOP, SIGWAITING, SIGCANCEL);
+
+ 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_flags : int;
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_resv1 : int;
+ sa_resv2 : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ 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 wether time slicing is supported
+
+ type timespec is private;
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "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_timeval is private;
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 1;
+ SCHED_RR : constant := 2;
+ SCHED_OTHER : constant := 0;
+
+ -------------
+ -- 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, "_lwp_self");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ 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 := 16#40#;
+
+ -----------
+ -- Stack --
+ -----------
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates wether 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_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 Import (C, sigwait, "sigwait");
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- 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 := 16#10#;
+ PTHREAD_PRIO_PROTECT : constant := 16#20#;
+
+ 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 Array_8_Int is array (0 .. 7) of int;
+ type struct_sched_param is record
+ sched_priority : int;
+ sched_pad : Array_8_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 pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+
+ type array_type_1 is array (Integer range 0 .. 3) of unsigned_long;
+ type sigset_t is record
+ X_X_sigbits : array_type_1;
+ end record;
+ pragma Convention (C, sigset_t);
+
+ type pid_t is new 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 clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 0;
+
+ type struct_timeval is record
+ tv_sec : time_t;
+ tv_usec : time_t;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type pthread_attr_t is record
+ pthread_attrp : System.Address;
+ end record;
+ pragma Convention (C, pthread_attr_t);
+
+ type pthread_condattr_t is record
+ pthread_condattrp : System.Address;
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_mutexattr_t is record
+ pthread_mutexattrp : System.Address;
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type pthread_t is new unsigned;
+
+ type uint64_t is mod 2 ** 64;
+
+ type pthread_mutex_t is record
+ pthread_mutex_flags : uint64_t;
+ pthread_mutex_owner64 : uint64_t;
+ pthread_mutex_data : uint64_t;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+ type pthread_mutex_t_ptr is access pthread_mutex_t;
+
+ type pthread_cond_t is record
+ pthread_cond_flags : uint64_t;
+ pthread_cond_data : uint64_t;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new unsigned;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- SYSTEM.MACHINE_STATE_OPERATIONS --
+-- --
+-- B o d y --
+-- (Version for Alpha/Dec Unix) --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1999-2001 Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This version of System.Machine_State_Operations is for use on
+-- Alpha systems running DEC Unix.
+
+with System.Memory;
+
+package body System.Machine_State_Operations is
+
+ use System.Exceptions;
+
+ pragma Linker_Options ("-lexc");
+ -- Needed for definitions of exc_capture_context and exc_virtual_unwind
+
+ ----------------------------
+ -- Allocate_Machine_State --
+ ----------------------------
+
+ function Allocate_Machine_State return Machine_State is
+ use System.Storage_Elements;
+
+ function c_machine_state_length return Storage_Offset;
+ pragma Import (C, c_machine_state_length, "__gnat_machine_state_length");
+
+ begin
+ return Machine_State
+ (Memory.Alloc (Memory.size_t (c_machine_state_length)));
+ end Allocate_Machine_State;
+
+ -------------------
+ -- Enter_Handler --
+ -------------------
+
+ procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
+ procedure c_enter_handler (M : Machine_State; Handler : Handler_Loc);
+ pragma Import (C, c_enter_handler, "__gnat_enter_handler");
+
+ begin
+ c_enter_handler (M, Handler);
+ end Enter_Handler;
+
+ ----------------
+ -- Fetch_Code --
+ ----------------
+
+ function Fetch_Code (Loc : Code_Loc) return Code_Loc is
+ begin
+ return Loc;
+ end Fetch_Code;
+
+ ------------------------
+ -- Free_Machine_State --
+ ------------------------
+
+ procedure Free_Machine_State (M : in out Machine_State) is
+ procedure Gnat_Free (M : in Machine_State);
+ pragma Import (C, Gnat_Free, "__gnat_free");
+
+ begin
+ Gnat_Free (M);
+ M := Machine_State (Null_Address);
+ end Free_Machine_State;
+
+ ------------------
+ -- Get_Code_Loc --
+ ------------------
+
+ function Get_Code_Loc (M : Machine_State) return Code_Loc is
+ Asm_Call_Size : constant := 4;
+
+ function c_get_code_loc (M : Machine_State) return Code_Loc;
+ pragma Import (C, c_get_code_loc, "__gnat_get_code_loc");
+
+ -- Code_Loc returned by c_get_code_loc is the return point but here we
+ -- want Get_Code_Loc to return the call point. Under DEC Unix a call
+ -- asm instruction takes 4 bytes. So we must remove this value from
+ -- c_get_code_loc to have the call point.
+
+ begin
+ return c_get_code_loc (M) - Asm_Call_Size;
+ end Get_Code_Loc;
+
+ --------------------------
+ -- Machine_State_Length --
+ --------------------------
+
+ function Machine_State_Length
+ return System.Storage_Elements.Storage_Offset
+ is
+ use System.Storage_Elements;
+
+ function c_machine_state_length return Storage_Offset;
+ pragma Import (C, c_machine_state_length, "__gnat_machine_state_length");
+
+ begin
+ return c_machine_state_length;
+ end Machine_State_Length;
+
+ ---------------
+ -- Pop_Frame --
+ ---------------
+
+ procedure Pop_Frame
+ (M : Machine_State;
+ Info : Subprogram_Info_Type)
+ is
+ procedure exc_virtual_unwind
+ (Fcn : System.Address;
+ M : Machine_State);
+ pragma Import (C, exc_virtual_unwind, "exc_virtual_unwind");
+
+ begin
+ exc_virtual_unwind (System.Null_Address, M);
+ end Pop_Frame;
+
+ -----------------------
+ -- Set_Machine_State --
+ -----------------------
+
+ procedure Set_Machine_State (M : Machine_State) is
+ procedure c_capture_context (M : Machine_State);
+ pragma Import (C, c_capture_context, "exc_capture_context");
+
+ begin
+ c_capture_context (M);
+ Pop_Frame (M, System.Null_Address);
+ end Set_Machine_State;
+
+ ------------------------------
+ -- Set_Signal_Machine_State --
+ ------------------------------
+
+ procedure Set_Signal_Machine_State
+ (M : Machine_State;
+ Context : System.Address) is
+ begin
+ null;
+ end Set_Signal_Machine_State;
+
+end System.Machine_State_Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.15 $
+-- --
+-- Copyright (C) 1991-2001 Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the DEC Unix and IRIX version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+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 Interfaces.C; use Interfaces.C;
+package body System.OS_Interface is
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ -----------------
+ -- 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;
+
+ function To_Duration (TV : struct_timeval) return Duration is
+ begin
+ return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
+ 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;
+
+ function To_Timeval (D : Duration) return struct_timeval 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 struct_timeval' (tv_sec => S,
+ tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
+ end To_Timeval;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.23 $
+-- --
+-- Copyright (C) 1998-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the DEC Unix 4.0/5.1 version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lpthread");
+ pragma Linker_Options ("-lmach");
+ pragma Linker_Options ("-lexc");
+ pragma Linker_Options ("-lrt");
+
+ 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;
+ subtype char_array is Interfaces.C.char_array;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "_Geterrno");
+
+ EAGAIN : constant := 35;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ ETIMEDOUT : constant := 60;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 48;
+ 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)
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGIOT : constant := 6; -- abort (terminate) process
+ SIGLOST : constant := 6; -- old BSD signal ??
+ 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
+ SIGIOINT : constant := 16; -- printer to backend error signal
+ 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
+ SIGCHLD : constant := 20; -- child status change
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGPOLL : constant := 23; -- I/O possible, or completed
+ SIGIO : constant := 23; -- STREAMS version of SIGPOLL
+ SIGAIO : constant := 23; -- base lan i/o
+ SIGPTY : constant := 23; -- pty i/o
+ 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
+ SIGINFO : constant := 29; -- information request
+ SIGPWR : constant := 29; -- Power Fail/Restart -- SVID3/SVR4
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+ SIGRESV : constant := 32; -- reserved by Digital for future use
+
+ SIGADAABORT : constant := SIGABRT;
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set := (0 .. 0 => SIGTRAP);
+ Reserved : constant Signal_Set := (SIGALRM, SIGABRT, SIGKILL, SIGSTOP);
+
+ type sigset_t is private;
+
+ function sigaddset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigaddset);
+
+ function sigdelset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigdelset);
+
+ function sigfillset (set : access sigset_t) return int;
+ pragma Import (C, sigfillset);
+
+ function sigismember (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigismember);
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset);
+
+ type union_type_3 is new String (1 .. 116);
+ type siginfo_t is record
+ si_signo : int;
+ si_errno : int;
+ si_code : int;
+ X_data : union_type_3;
+ end record;
+ for siginfo_t'Size use 8 * 128;
+ pragma Convention (C, siginfo_t);
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ sa_signo : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ SA_NODEFER : constant := 8;
+ SA_SIGINFO : constant := 16#40#;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction);
+
+ ----------
+ -- Time --
+ ----------
+
+ type timespec is private;
+
+ function nanosleep (rqtp, rmtp : access timespec) return int;
+ pragma Import (C, nanosleep);
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int;
+ pragma Import (C, clock_gettime);
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ type struct_timezone is record
+ tz_minuteswest : int;
+ tz_dsttime : int;
+ end record;
+ pragma Convention (C, struct_timezone);
+ type struct_timeval is private;
+ -- This is needed on systems that do not have clock_gettime()
+ -- but do have gettimeofday().
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 1;
+ SCHED_RR : constant := 2;
+ SCHED_OTHER : constant := 3;
+ SCHED_LFI : constant := 5;
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill);
+
+ function getpid return pid_t;
+ pragma Import (C, getpid);
+
+ BIND_NO_INHERIT : constant := 1;
+
+ function bind_to_cpu
+ (pid : pid_t;
+ cpu_mask : unsigned_long;
+ flag : unsigned_long := BIND_NO_INHERIT) return int;
+ pragma Import (C, bind_to_cpu);
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ 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_SCOPE_PROCESS : constant := 0;
+ PTHREAD_SCOPE_SYSTEM : constant := 1;
+
+ PTHREAD_EXPLICIT_SCHED : constant := 1;
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ procedure pthread_init;
+ pragma Inline (pthread_init);
+ -- This is a dummy procedure to share some GNULLI files
+
+ ---------------------------
+ -- POSIX.1c Section 3 --
+ ---------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ pragma Import (C, sigwait, "__sigwaitd10");
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill);
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask);
+
+ ----------------------------
+ -- POSIX.1c Section 11 --
+ ----------------------------
+
+ function pthread_mutexattr_init (attr : access pthread_mutexattr_t)
+ return int;
+ pragma Import (C, pthread_mutexattr_init);
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, 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);
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, 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");
+
+ ----------------------------
+ -- POSIX.1c Section 13 --
+ ----------------------------
+
+ 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; -- scheduling priority
+ end record;
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int;
+ pragma Import (C, pthread_setschedparam);
+
+ function pthread_attr_setscope
+ (attr : access pthread_attr_t;
+ contentionscope : int) return int;
+ pragma Import (C, pthread_attr_setscope);
+
+ function pthread_attr_setinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : int) return int;
+ pragma Import (C, pthread_attr_setinheritsched,
+ "__pthread_attr_setinheritsched");
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t; policy : int) return int;
+ pragma Import (C, pthread_attr_setschedpolicy);
+
+ function pthread_attr_setschedparam
+ (attr : access pthread_attr_t;
+ sched_param : access struct_sched_param) return int;
+ pragma Import (C, pthread_attr_setschedparam);
+
+ function sched_yield return int;
+ pragma Import (C, sched_yield);
+
+ ---------------------------
+ -- P1003.1c - Section 16 --
+ ---------------------------
+
+ function pthread_attr_init (attributes : access pthread_attr_t)
+ return int;
+ pragma Import (C, pthread_attr_init);
+
+ function pthread_attr_destroy (attributes : access pthread_attr_t)
+ return int;
+ pragma Import (C, 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, "__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 pthread_setspecific
+ (key : pthread_key_t; value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "__pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "__pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create);
+
+private
+
+ type sigset_t is new unsigned_long;
+
+ type pid_t is new int;
+
+ type time_t is new int;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 1;
+
+ type struct_timeval is record
+ tv_sec : time_t;
+ tv_usec : time_t;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type unsigned_long_array is array (Natural range <>) of unsigned_long;
+
+ type pthread_t is new System.Address;
+
+ type pthread_cond_t is record
+ state : unsigned;
+ valid : unsigned;
+ name : System.Address;
+ arg : unsigned;
+ reserved1 : unsigned;
+ sequence : unsigned_long;
+ block : System.Address;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_attr_t is record
+ valid : long;
+ name : System.Address;
+ arg : unsigned_long;
+ reserved : unsigned_long_array (0 .. 18);
+ end record;
+ pragma Convention (C, pthread_attr_t);
+
+ type pthread_mutex_t is record
+ lock : unsigned;
+ valid : unsigned;
+ name : System.Address;
+ arg : unsigned;
+ depth : unsigned;
+ sequence : unsigned_long;
+ owner : unsigned_long;
+ block : System.Address;
+ end record;
+ for pthread_mutex_t'Size use 8 * 48;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_mutexattr_t is record
+ valid : long;
+ reserved : unsigned_long_array (0 .. 14);
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type pthread_condattr_t is record
+ valid : long;
+ reserved : unsigned_long_array (0 .. 12);
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_key_t is new unsigned;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (DEC Unix Version) --
+-- --
+-- $Revision: 1.20 $
+-- --
+-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ 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 := Integer'Last;
+
+ 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 := Standard'Tick;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := Standard'Storage_Unit;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Standard'Address_Size;
+
+ -- 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;
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer
+ range 0 .. Standard'Max_Interrupt_Priority;
+
+ subtype Priority is Any_Priority
+ range 0 .. Standard'Max_Priority;
+
+ -- Functional notation is needed in the following to avoid visibility
+ -- problems when this package is compiled through rtsfind in the middle
+ -- of another compilation.
+
+ subtype Interrupt_Priority is Any_Priority
+ range
+ Standard."+" (Standard'Max_Priority, 1) ..
+ Standard'Max_Interrupt_Priority;
+
+ Default_Priority : constant Priority :=
+ Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
+
+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.
+
+ AAMP : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Denorm : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := True;
+ Long_Shifts_Inlined : constant Boolean := True;
+ High_Integrity_Mode : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := True;
+ Stack_Check_Probes : constant Boolean := True;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := True;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := True;
+
+ -- Note: Denorm is False because denormals are only handled properly
+ -- if the -mieee switch is set, and we do not require this usage.
+
+ ---------------------------
+ -- Underlying Priorities --
+ ---------------------------
+
+ -- Important note: this section of the file must come AFTER the
+ -- definition of the system implementation parameters to ensure
+ -- that the value of these parameters is available for analysis
+ -- of the declarations here (using Rtsfind at compile time).
+
+ -- The underlying priorities table provides a generalized mechanism
+ -- for mapping from Ada priorities to system priorities. In some
+ -- cases a 1-1 mapping is not the convenient or optimal choice.
+
+ -- For Dec Unix 4.0d, we use a default 1-to-1 mapping that provides
+ -- the full range of 64 priorities available from the operating system.
+
+ -- On DU prior to 4.0d, less than 64 priorities are available so there
+ -- are two possibilities:
+
+ -- Limit your range of priorities to the range provided by the
+ -- OS (e.g 16 .. 32 on 4.0b)
+
+ -- Replace the standard table as described below
+
+ -- To replace the default values of the Underlying_Priorities mapping,
+ -- copy this source file into your build directory, edit the file to
+ -- reflect your desired behavior, and recompile with the command:
+
+ -- $ gcc -c -O3 -gnatpgn system.ads
+
+ -- then recompile the run-time parts that depend on this package:
+
+ -- $ gnatmake -a -gnatn -O3 <your application>
+
+ -- then force rebuilding your application if you need different options:
+
+ -- $ gnatmake -f <your options> <your application>
+
+ type Priorities_Mapping is array (Any_Priority) of Integer;
+ pragma Suppress_Initialization (Priorities_Mapping);
+ -- Suppress initialization in case gnat.adc specifies Normalize_Scalars
+
+ Underlying_Priorities : constant Priorities_Mapping :=
+ (Priority'First => 16,
+ 1 => 17,
+ 2 => 18,
+ 3 => 18,
+ 4 => 18,
+ 5 => 18,
+ 6 => 19,
+ 7 => 19,
+ 8 => 19,
+ 9 => 20,
+ 10 => 20,
+ 11 => 21,
+ 12 => 21,
+ 13 => 22,
+ 14 => 23,
+ Default_Priority => 24,
+ 16 => 25,
+ 17 => 25,
+ 18 => 25,
+ 19 => 26,
+ 20 => 26,
+ 21 => 26,
+ 22 => 27,
+ 23 => 27,
+ 24 => 27,
+ 25 => 28,
+ 26 => 28,
+ 27 => 29,
+ 28 => 29,
+ 29 => 30,
+ Priority'Last => 30,
+ Interrupt_Priority => 31);
+
+end System;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.60 $
+-- --
+-- Copyright (C) 1991-2001, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a DEC Unix 4.0d version of this package
+
+-- 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 System.Tasking.Debug;
+-- used for Known_Tasks
+
+with System.Task_Info;
+-- used for Task_Info_Type
+
+with Interfaces;
+-- used for Shift_Left
+
+with Interfaces.C;
+-- used for int
+-- size_t
+
+with System.Interrupt_Management;
+-- used for Keep_Unmasked
+-- Abort_Task_Interrupt
+-- Interrupt_ID
+
+with System.Interrupt_Management.Operations;
+-- used for Set_Interrupt_Mask
+-- All_Tasks_Mask
+pragma Elaborate_All (System.Interrupt_Management.Operations);
+
+with System.Parameters;
+-- used for Size_Type
+
+with System.Tasking;
+-- used for Ada_Task_Control_Block
+-- Task_ID
+-- ATCB components and types
+
+with System.Soft_Links;
+-- used for Defer/Undefer_Abort
+
+-- Note that we do not use System.Tasking.Initialization directly since
+-- this 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.Initialization
+
+with System.OS_Primitives;
+-- used for Delay_Modes
+
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+package body System.Task_Primitives.Operations is
+
+ use System.Tasking.Debug;
+ use System.Tasking;
+ use Interfaces.C;
+ use System.OS_Interface;
+ use System.Parameters;
+ use System.OS_Primitives;
+
+ package SSL renames System.Soft_Links;
+
+ -----------------
+ -- Local Data --
+ -----------------
+
+ -- The followings are logically constants, but need to be initialized
+ -- at run time.
+
+ All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
+ -- See comments on locking rules in System.Tasking (spec).
+
+ Environment_Task_ID : Task_ID;
+ -- A variable to hold Task_ID for the environment task.
+
+ Unblocked_Signal_Mask : aliased sigset_t;
+ -- The set of signals that should unblocked in all tasks
+
+ Time_Slice_Val : Integer;
+ pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
+
+ Locking_Policy : Character;
+ pragma Import (C, Locking_Policy, "__gl_locking_policy");
+
+ Dispatching_Policy : Character;
+ pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
+
+ FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
+ -- Indicates whether FIFO_Within_Priorities is set.
+
+ Curpid : pid_t;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Abort_Handler (Sig : Signal);
+
+ function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
+
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+
+ --------------------
+ -- Local Packages --
+ --------------------
+
+ package Specific is
+
+ procedure Initialize (Environment_Task : Task_ID);
+ pragma Inline (Initialize);
+ -- Initialize various data needed by this package.
+
+ 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.
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ procedure Abort_Handler (Sig : Signal) is
+ T : constant Task_ID := Self;
+ Result : Interfaces.C.int;
+ Old_Set : aliased sigset_t;
+
+ begin
+ 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'Unchecked_Access, Old_Set'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ raise Standard'Abort_Signal;
+ end if;
+ end Abort_Handler;
+
+ ------------------
+ -- Stack_Guard --
+ ------------------
+
+ -- The underlying thread system sets a guard page at the
+ -- bottom of a thread stack, so nothing is needed.
+
+ procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ begin
+ null;
+ end Stack_Guard;
+
+ --------------------
+ -- Get_Thread_Id --
+ --------------------
+
+ function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
+ begin
+ return T.Common.LL.Thread;
+ end Get_Thread_Id;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_ID renames Specific.Self;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ -- Note: mutexes and cond_variables needed per-task basis are
+ -- initialized in Intialize_TCB and the Storage_Error is
+ -- handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...)
+ -- used in RTS is initialized before any status change of RTS.
+ -- Therefore rasing Storage_Error in the following routines
+ -- should be able to be handled safely.
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : 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 := Interfaces.C.int (Prio);
+ end if;
+
+ Result := pthread_mutex_init (L.L'Access, 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;
+
+ procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) 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;
+
+ 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 : access Lock) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_destroy (L.L'Access);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : 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 : access Lock; Ceiling_Violation : out Boolean) is
+ Result : Interfaces.C.int;
+ Self_ID : Task_ID;
+ All_Tasks_Link : Task_ID;
+ Current_Prio : System.Any_Priority;
+
+ begin
+ -- Perform ceiling checks only when this is the locking policy in use.
+
+ if Locking_Policy = 'C' then
+ Self_ID := Self;
+ All_Tasks_Link := Self_ID.Common.All_Tasks_Link;
+ Current_Prio := Get_Priority (Self_ID);
+
+ -- if there is no other task, no need to check priorities
+ if All_Tasks_Link /= Null_Task and then
+ L.Ceiling < Interfaces.C.int (Current_Prio) then
+ Ceiling_Violation := True;
+ return;
+ end if;
+ end if;
+
+ Result := pthread_mutex_lock (L.L'Access);
+
+ pragma Assert (Result = 0);
+
+ Ceiling_Violation := False;
+ end Write_Lock;
+
+ procedure Write_Lock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_ID) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ Write_Lock (L, Ceiling_Violation);
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : access Lock) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_unlock (L.L'Access);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock (T : Task_ID) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ -----------
+ -- Sleep --
+ -----------
+
+ procedure Sleep
+ (Self_ID : Task_ID;
+ Reason : System.Tasking.Task_States)
+ is
+ Result : Interfaces.C.int;
+ begin
+ pragma Assert (Self_ID = Self);
+ Result := pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+
+ -- 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 : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ Check_Time : constant Duration := Monotonic_Clock;
+ 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;
+ else
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+ end if;
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ or else Self_ID.Pending_Priority_Change;
+
+ Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access, Request'Access);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ if Result = 0 or Result = EINTR then
+ -- somebody may have called Wakeup for us
+ Timedout := False;
+ exit;
+ end if;
+
+ pragma Assert (Result = ETIMEDOUT);
+ end loop;
+ end if;
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ -- 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
+ Check_Time : constant Duration := Monotonic_Clock;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ -- Only the little window between deferring abort and
+ -- locking Self_ID is the reason we need to
+ -- check for pending abort and priority change below! :(
+
+ SSL.Abort_Defer.all;
+ Write_Lock (Self_ID);
+
+ if Mode = Relative then
+ Abs_Time := Time + Check_Time;
+ else
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+ end if;
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+ Self_ID.Common.State := Delay_Sleep;
+
+ loop
+ if Self_ID.Pending_Priority_Change then
+ Self_ID.Pending_Priority_Change := False;
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
+ end if;
+
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access, Request'Access);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ pragma Assert (Result = 0 or else
+ Result = ETIMEDOUT or else
+ Result = EINTR);
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+ Yield;
+ SSL.Abort_Undefer.all;
+ end Timed_Delay;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ TS : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+ return To_Duration (TS);
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ begin
+ return 1.0 / 1024.0; -- Clock on DEC Alpha ticks at 1024 Hz
+ end RT_Resolution;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
+ 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;
+ begin
+ if Do_Yield then
+ Result := sched_yield;
+ end if;
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_Priority
+ (T : Task_ID;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ Result : Interfaces.C.int;
+ Param : aliased struct_sched_param;
+
+ begin
+ T.Common.Current_Priority := Prio;
+ Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
+
+ if Time_Slice_Val > 0 then
+ Result := pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_RR, Param'Access);
+
+ elsif FIFO_Within_Priorities 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_Priority;
+
+ ------------------
+ -- Get_Priority --
+ ------------------
+
+ function Get_Priority (T : Task_ID) return System.Any_Priority is
+ begin
+ return T.Common.Current_Priority;
+ end Get_Priority;
+
+ ----------------
+ -- Enter_Task --
+ ----------------
+
+ procedure Enter_Task (Self_ID : Task_ID) is
+ begin
+ Self_ID.Common.LL.Thread := pthread_self;
+ Specific.Set (Self_ID);
+
+ Lock_All_Tasks_List;
+
+ 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_All_Tasks_List;
+ 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;
+
+ --------------------
+ -- Initialize_TCB --
+ --------------------
+
+ procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
+ Mutex_Attr : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+ Cond_Attr : aliased pthread_condattr_t;
+
+ begin
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
+ Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
+ Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = 0 then
+ Succeeded := True;
+ else
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Succeeded := False;
+ end if;
+
+ Result := pthread_condattr_destroy (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+ end Initialize_TCB;
+
+ -----------------
+ -- Create_Task --
+ -----------------
+
+ procedure Create_Task
+ (T : Task_ID;
+ Wrapper : System.Address;
+ Stack_Size : System.Parameters.Size_Type;
+ Priority : System.Any_Priority;
+ Succeeded : out Boolean)
+ is
+ Attributes : aliased pthread_attr_t;
+ Adjusted_Stack_Size : Interfaces.C.size_t;
+ Result : Interfaces.C.int;
+ Param : aliased System.OS_Interface.struct_sched_param;
+
+ function Thread_Body_Access is new
+ Unchecked_Conversion (System.Address, Thread_Body);
+
+ use System.Task_Info;
+
+ begin
+ if Stack_Size = Unspecified_Size then
+ Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size);
+
+ elsif Stack_Size < Minimum_Stack_Size then
+ Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
+
+ else
+ Adjusted_Stack_Size := Interfaces.C.size_t (Stack_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);
+
+ -- Set the scheduling parameters explicitely, since this is the only
+ -- way to force the OS to take the scope attribute into account
+
+ Result := pthread_attr_setinheritsched
+ (Attributes'Access, PTHREAD_EXPLICIT_SCHED);
+ pragma Assert (Result = 0);
+
+ Param.sched_priority :=
+ Interfaces.C.int (Underlying_Priorities (Priority));
+ Result := pthread_attr_setschedparam
+ (Attributes'Access, Param'Access);
+ pragma Assert (Result = 0);
+
+ if Time_Slice_Val > 0 then
+ Result := pthread_attr_setschedpolicy
+ (Attributes'Access, System.OS_Interface.SCHED_RR);
+
+ elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
+ Result := pthread_attr_setschedpolicy
+ (Attributes'Access, System.OS_Interface.SCHED_FIFO);
+
+ else
+ Result := pthread_attr_setschedpolicy
+ (Attributes'Access, System.OS_Interface.SCHED_OTHER);
+ end if;
+
+ pragma Assert (Result = 0);
+
+ T.Common.Current_Priority := Priority;
+
+ if T.Common.Task_Info /= null then
+ case T.Common.Task_Info.Contention_Scope is
+ when System.Task_Info.Process_Scope =>
+ Result := pthread_attr_setscope
+ (Attributes'Access, PTHREAD_SCOPE_PROCESS);
+
+ when System.Task_Info.System_Scope =>
+ Result := pthread_attr_setscope
+ (Attributes'Access, PTHREAD_SCOPE_SYSTEM);
+
+ when System.Task_Info.Default_Scope =>
+ Result := 0;
+ end case;
+
+ 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 T.Common.Task_Info /= null then
+ if T.Common.Task_Info.Bind_To_Cpu_Number = 0 then
+ Result := bind_to_cpu (Curpid, 0);
+ elsif T.Common.Task_Info.Bind_To_Cpu_Number > 0 then
+ Result := bind_to_cpu
+ (Curpid,
+ Interfaces.C.unsigned_long (
+ Interfaces.Shift_Left
+ (Interfaces.Unsigned_64'(1),
+ T.Common.Task_Info.Bind_To_Cpu_Number - 1)));
+ pragma Assert (Result = 0);
+ end if;
+ end if;
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_ID) is
+ Result : Interfaces.C.int;
+ Tmp : Task_ID := T;
+
+ procedure Free is new
+ Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
+
+ begin
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Result := pthread_cond_destroy (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+ if T.Known_Tasks_Index /= -1 then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ end if;
+ Free (Tmp);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ pthread_exit (System.Null_Address);
+ 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;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy versions. The only currently working versions is for solaris
+ -- (native).
+
+ function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ 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_All_Tasks_List --
+ -------------------------
+
+ procedure Lock_All_Tasks_List is
+ begin
+ Write_Lock (All_Tasks_L'Access);
+ end Lock_All_Tasks_List;
+
+ ---------------------------
+ -- Unlock_All_Tasks_List --
+ ---------------------------
+
+ procedure Unlock_All_Tasks_List is
+ begin
+ Unlock (All_Tasks_L'Access);
+ end Unlock_All_Tasks_List;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ return False;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ return False;
+ end Resume_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;
+
+ begin
+ Environment_Task_ID := Environment_Task;
+
+ Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
+ -- Initialize the lock used to synchronize chain of all ATCBs.
+
+ Specific.Initialize (Environment_Task);
+
+ Enter_Task (Environment_Task);
+
+ -- Install the abort-signal handler
+
+ 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 Initialize;
+
+begin
+ declare
+ Result : Interfaces.C.int;
+
+ begin
+ -- Mask Environment task for all signals. The original mask of the
+ -- Environment task will be recovered by Interrupt_Server task
+ -- during the elaboration of s-interr.adb.
+
+ System.Interrupt_Management.Operations.Set_Interrupt_Mask
+ (System.Interrupt_Management.Operations.All_Tasks_Mask'Access);
+
+ -- 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;
+ end;
+
+ Curpid := getpid;
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- S p e c --
+-- (Compiler Interface) --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1998-2000 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a DEC Unix 4.0d version of this package.
+
+-- This package contains the definitions and routines associated with the
+-- implementation of the Task_Info pragma.
+
+-- Note: the compiler generates direct calls to this interface, via Rtsfind.
+-- Any changes to this interface may require corresponding compiler changes.
+
+with Unchecked_Deallocation;
+package System.Task_Info is
+pragma Elaborate_Body;
+-- To ensure that a body is allowed
+
+ -----------------------------------------
+ -- Implementation of Task_Info Feature --
+ -----------------------------------------
+
+ -- The Task_Info pragma:
+
+ -- pragma Task_Info (EXPRESSION);
+
+ -- allows the specification on a task by task basis of a value of type
+ -- System.Task_Info.Task_Info_Type to be passed to a task when it is
+ -- created. The specification of this type, and the effect on the task
+ -- that is created is target dependent.
+
+ -- The Task_Info pragma appears within a task definition (compare the
+ -- definition and implementation of pragma Priority). If no such pragma
+ -- appears, then the value Task_Info_Unspecified is passed. If a pragma
+ -- is present, then it supplies an alternative value. If the argument of
+ -- the pragma is a discriminant reference, then the value can be set on
+ -- a task by task basis by supplying the appropriate discriminant value.
+
+ -- Note that this means that the type used for Task_Info_Type must be
+ -- suitable for use as a discriminant (i.e. a scalar or access type).
+
+ ------------------
+ -- Declarations --
+ ------------------
+
+ type Scope_Type is
+ (Process_Scope,
+ -- Contend only with threads in same process
+
+ System_Scope,
+ -- Contend with all threads on same CPU
+
+ Default_Scope);
+
+ type Thread_Attributes is record
+ Bind_To_Cpu_Number : Integer;
+ -- -1: Do nothing
+ -- 0: Unbind
+ -- 1-N: Bind all unbound threads to this CPU
+
+ Contention_Scope : Scope_Type;
+ end record;
+
+ type Task_Info_Type is access all Thread_Attributes;
+ -- Type used for passing information to task create call, using the
+ -- Task_Info pragma. This type may be specialized for individual
+ -- implementations, but it must be a type that can be used as a
+ -- discriminant (i.e. a scalar or access type).
+
+ type Task_Image_Type is access String;
+ -- Used to generate a meaningful identifier for tasks that are variables
+ -- and components of variables.
+
+ procedure Free_Task_Image is new
+ Unchecked_Deallocation (String, Task_Image_Type);
+
+ Unspecified_Thread_Attribute : aliased Thread_Attributes :=
+ Thread_Attributes'(-1, Default_Scope);
+
+ Unspecified_Task_Info : constant Task_Info_Type :=
+ Unspecified_Thread_Attribute'Access;
+ -- Value passed to task in the absence of a Task_Info pragma
+ -- Don't call new here because the tasking run time has not been
+ -- elaborated yet, so calling Task_Lock is unsafe.
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.8 $
+-- --
+-- Copyright (C) 1991-2000 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the DEC Unix 4.0 version of this package.
+
+-- This package provides low-level support for most tasking features.
+
+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 Interfaces.C;
+-- used for int
+-- size_t
+
+with System.OS_Interface;
+-- used for pthread_mutex_t
+-- pthread_cond_t
+-- pthread_t
+
+package System.Task_Primitives is
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects.
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system.
+ -- The difference between Lock and the RTS_Lock is that the later
+ -- one serves only as a semaphore so that do not check for
+ -- ceiling violations.
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper
+ -- declared local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task
+ -- basis. A component of this type is guaranteed to be included
+ -- in the Ada_Task_Control_Block.
+
+private
+
+ type Lock is record
+ L : aliased System.OS_Interface.pthread_mutex_t;
+ Ceiling : Interfaces.C.int;
+ end record;
+
+ type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
+ type Private_Data is record
+ Thread : aliased System.OS_Interface.pthread_t;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb).
+ -- They put the same value (thr_self value). We do not want to
+ -- use lock on those operations and the only thing we have to
+ -- make sure is that they are updated in atomic fashion.
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+ L : aliased RTS_Lock;
+ -- protection for all components is lock L
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 . --
+-- S P E C I F I C --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.13 $
+-- --
+-- Copyright (C) 1991-2001, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a POSIX version of this package where foreign threads are
+-- recognized.
+-- Currently, DEC Unix, SCO UnixWare, Solaris pthread, HPUX pthread and RTEMS
+-- use this version.
+
+with System.Soft_Links;
+-- used to initialize TSD for a C thread, in function Self
+
+separate (System.Task_Primitives.Operations)
+package body Specific is
+
+ ------------------
+ -- Local Data --
+ ------------------
+
+ -- The followings are logically constants, but need to be initialized
+ -- at run time.
+
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_ID associated with a thread
+
+ -- The following are used to allow the Self function to
+ -- automatically generate ATCB's for C threads that happen to call
+ -- Ada procedure, which in turn happen to call the Ada runtime system.
+
+ type Fake_ATCB;
+ type Fake_ATCB_Ptr is access Fake_ATCB;
+ type Fake_ATCB is record
+ Stack_Base : Interfaces.C.unsigned := 0;
+ -- A value of zero indicates the node is not in use.
+ Next : Fake_ATCB_Ptr;
+ Real_ATCB : aliased Ada_Task_Control_Block (0);
+ end record;
+
+ Fake_ATCB_List : Fake_ATCB_Ptr;
+ -- A linear linked list.
+ -- The list is protected by All_Tasks_L;
+ -- Nodes are added to this list from the front.
+ -- Once a node is added to this list, it is never removed.
+
+ Fake_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads).
+
+ Next_Fake_ATCB : Fake_ATCB_Ptr;
+ -- Used to allocate one Fake_ATCB in advance. See comment in New_Fake_ATCB
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ ---------------------------------
+ -- Support for New_Fake_ATCB --
+ ---------------------------------
+
+ function New_Fake_ATCB return Task_ID;
+ -- Allocate and Initialize a new ATCB. This code can safely be called from
+ -- a foreign thread, as it doesn't access implicitely or explicitely
+ -- "self" before having initialized the new ATCB.
+
+ -------------------
+ -- New_Fake_ATCB --
+ -------------------
+
+ function New_Fake_ATCB return Task_ID is
+ Self_ID : Task_ID;
+ P, Q : Fake_ATCB_Ptr;
+ Succeeded : Boolean;
+ Result : Interfaces.C.int;
+
+ begin
+ -- This section is ticklish.
+ -- We dare not call anything that might require an ATCB, until
+ -- we have the new ATCB in place.
+
+ Write_Lock (All_Tasks_L'Access);
+ Q := null;
+ P := Fake_ATCB_List;
+
+ while P /= null loop
+ if P.Stack_Base = 0 then
+ Q := P;
+ end if;
+
+ P := P.Next;
+ end loop;
+
+ if Q = null then
+
+ -- Create a new ATCB with zero entries.
+
+ Self_ID := Next_Fake_ATCB.Real_ATCB'Access;
+ Next_Fake_ATCB.Stack_Base := 1;
+ Next_Fake_ATCB.Next := Fake_ATCB_List;
+ Fake_ATCB_List := Next_Fake_ATCB;
+ Next_Fake_ATCB := null;
+
+ else
+ -- Reuse an existing fake ATCB.
+
+ Self_ID := Q.Real_ATCB'Access;
+ Q.Stack_Base := 1;
+ end if;
+
+ -- Record this as the Task_ID for the current thread.
+
+ Self_ID.Common.LL.Thread := pthread_self;
+ Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID));
+ pragma Assert (Result = 0);
+
+ -- Do the standard initializations
+
+ System.Tasking.Initialize_ATCB
+ (Self_ID, null, Null_Address, Null_Task, Fake_Task_Elaborated'Access,
+ System.Priority'First, Task_Info.Unspecified_Task_Info, 0, Self_ID,
+ Succeeded);
+ pragma Assert (Succeeded);
+
+ -- Finally, it is safe to use an allocator in this thread.
+
+ if Next_Fake_ATCB = null then
+ Next_Fake_ATCB := new Fake_ATCB;
+ end if;
+
+ Self_ID.Master_of_Task := 0;
+ Self_ID.Master_Within := Self_ID.Master_of_Task + 1;
+
+ for L in Self_ID.Entry_Calls'Range loop
+ Self_ID.Entry_Calls (L).Self := Self_ID;
+ Self_ID.Entry_Calls (L).Level := L;
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ Self_ID.Awake_Count := 1;
+
+ -- Since this is not an ordinary Ada task, we will start out undeferred
+
+ Self_ID.Deferral_Level := 0;
+
+ System.Soft_Links.Create_TSD (Self_ID.Common.Compiler_Data);
+
+ -- ????
+ -- The following call is commented out to avoid dependence on
+ -- the System.Tasking.Initialization package.
+ -- It seems that if we want Ada.Task_Attributes to work correctly
+ -- for C threads we will need to raise the visibility of this soft
+ -- link to System.Soft_Links.
+ -- We are putting that off until this new functionality is otherwise
+ -- stable.
+ -- System.Tasking.Initialization.Initialize_Attributes_Link.all (T);
+
+ 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;
+
+ -- Must not unlock until Next_ATCB is again allocated.
+
+ Unlock (All_Tasks_L'Access);
+ return Self_ID;
+ end New_Fake_ATCB;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_key_create (ATCB_Key'Access, null);
+ pragma Assert (Result = 0);
+ Result := pthread_setspecific (ATCB_Key, To_Address (Environment_Task));
+ pragma Assert (Result = 0);
+
+ -- Create a free ATCB for use on the Fake_ATCB_List.
+
+ Next_Fake_ATCB := new Fake_ATCB;
+ end Initialize;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_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.
+
+ -- (The entire Ada run-time system may not have been elaborated,
+ -- either, but that is a different problem, that we will need to
+ -- solve another way.)
+
+ -- 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.
+
+ -- We will also use such points to poll for disappearance of the
+ -- threads associated with any implicit ATCBs that we created
+ -- earlier, and take the opportunity to recover them.
+
+ -- A nasty problem here is the limitations of the compilation
+ -- order dependency, and in particular the GNARL/GNULLI layering.
+ -- To initialize an ATCB we need to assume System.Tasking has
+ -- been elaborated.
+
+ function Self return Task_ID is
+ Result : System.Address;
+
+ begin
+ Result := pthread_getspecific (ATCB_Key);
+
+ -- If the key value is Null, then it is a non-Ada task.
+
+ if Result = System.Null_Address then
+ return New_Fake_ATCB;
+ end if;
+
+ return To_Task_ID (Result);
+ end Self;
+
+end Specific;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1998-2001 Free Software Foundation --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Alpha VxWorks version of this package.
+
+with Interfaces.C;
+
+package System.VxWorks is
+ pragma Preelaborate (System.VxWorks);
+
+ package IC renames Interfaces.C;
+
+ -- Define enough of a Wind Task Control Block in order to
+ -- obtain the inherited priority. When porting this to
+ -- different versions of VxWorks (this is based on 5.3[.1]),
+ -- be sure to look at the definition for WIND_TCB located
+ -- in $WIND_BASE/target/h/taskLib.h
+
+ type Wind_Fill_1 is array (0 .. 16#77#) of IC.unsigned_char;
+ type Wind_Fill_2 is array (16#80# .. 16#1c7#) of IC.unsigned_char;
+ type Wind_Fill_3 is array (16#1d8# .. 16#777#) of IC.unsigned_char;
+
+ type Wind_TCB is record
+ Fill_1 : Wind_Fill_1; -- 0x00 - 0x77
+ Priority : IC.int; -- 0x78 - 0x7b, current (inherited) priority
+ Normal_Priority : IC.int; -- 0x7c - 0x7f, base priority
+ Fill_2 : Wind_Fill_2; -- 0x80 - 0x1c7
+ spare1 : Address; -- 0x1c8 - 0x1cb
+ spare2 : Address; -- 0x1cc - 0x1cf
+ spare3 : Address; -- 0x1d0 - 0x1d3
+ spare4 : Address; -- 0x1d4 - 0x1d7
+
+ -- Fill_3 is much smaller on the board runtime, but the larger size
+ -- below keeps this record compatible with vxsim.
+
+ Fill_3 : Wind_Fill_3; -- 0x1d8 - 0x777
+ end record;
+ type Wind_TCB_Ptr is access Wind_TCB;
+
+
+ -- Floating point context record. Alpha version
+
+ FP_NUM_DREGS : constant := 32;
+ type Fpx_Array is array (1 .. FP_NUM_DREGS) of IC.double;
+
+ type FP_CONTEXT is record
+ fpx : Fpx_Array;
+ fpcsr : IC.long;
+ end record;
+ pragma Convention (C, FP_CONTEXT);
+
+ -- Number of entries in hardware interrupt vector table. Value of
+ -- 0 disables hardware interrupt handling until it can be tested
+ Num_HW_Interrupts : constant := 0;
+
+ -- VxWorks 5.3 and 5.4 version
+ type TASK_DESC is record
+ td_id : IC.int; -- task id
+ td_name : Address; -- name of task
+ td_priority : IC.int; -- task priority
+ td_status : IC.int; -- task status
+ td_options : IC.int; -- task option bits (see below)
+ td_entry : Address; -- original entry point of task
+ td_sp : Address; -- saved stack pointer
+ td_pStackBase : Address; -- the bottom of the stack
+ td_pStackLimit : Address; -- the effective end of the stack
+ td_pStackEnd : Address; -- the actual end of the stack
+ td_stackSize : IC.int; -- size of stack in bytes
+ td_stackCurrent : IC.int; -- current stack usage in bytes
+ td_stackHigh : IC.int; -- maximum stack usage in bytes
+ td_stackMargin : IC.int; -- current stack margin in bytes
+ td_errorStatus : IC.int; -- most recent task error status
+ td_delay : IC.int; -- delay/timeout ticks
+ end record;
+ pragma Convention (C, TASK_DESC);
+
+end System.VxWorks;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.8 $
+-- --
+-- Copyright (C) 1997-2001, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a AIX (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.
+
+with Interfaces.C;
+
+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;
+
+ function To_Duration (TV : struct_timeval) return Duration is
+ begin
+ return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
+ 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;
+
+ ----------------
+ -- To_Timeval --
+ ----------------
+
+ function To_Timeval (D : Duration) return struct_timeval is
+ S : long;
+ F : Duration;
+
+ begin
+ S := long (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 struct_timeval' (tv_sec => S,
+ tv_usec => long (Long_Long_Integer (F * 10#1#E6)));
+ end To_Timeval;
+
+ -------------------
+ -- clock_gettime --
+ -------------------
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec)
+ return int
+ is
+ Result : int;
+ tv : aliased struct_timeval;
+
+ function gettimeofday
+ (tv : access struct_timeval;
+ tz : System.Address := System.Null_Address) return int;
+ pragma Import (C, gettimeofday, "gettimeofday");
+
+ begin
+ Result := gettimeofday (tv'Unchecked_Access);
+ tp.all := To_Timespec (To_Duration (tv));
+ return Result;
+ end clock_gettime;
+
+ -----------------
+ -- sched_yield --
+ -----------------
+
+ -- AIX Thread does not have sched_yield;
+
+ function sched_yield return int is
+
+ procedure pthread_yield;
+ pragma Import (C, pthread_yield, "pthread_yield");
+
+ begin
+ pthread_yield;
+ return 0;
+ end sched_yield;
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.26 $
+-- --
+-- Copyright (C) 1997-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a AIX (Native THREADS) version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lpthreads");
+ pragma Linker_Options ("-lc_r");
+
+ 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 := 78;
+
+ -------------
+ -- 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)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGPWR : constant := 29; -- power-fail restart
+ SIGWINCH : constant := 28; -- window size change
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGPOLL : constant := 23; -- pollable event occurred
+ SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
+ 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
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGVTALRM : constant := 34; -- virtual timer expired
+ SIGPROF : constant := 32; -- profiling timer expired
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGWAITING : constant := 39; -- m:n scheduling
+
+ -- the following signals are AIX specific
+ SIGMSG : constant := 27; -- input data is in the ring buffer
+ SIGDANGER : constant := 33; -- system crash imminent
+ SIGMIGRATE : constant := 35; -- migrate process
+ SIGPRE : constant := 36; -- programming exception
+ SIGVIRT : constant := 37; -- AIX virtual time alarm
+ SIGALRM1 : constant := 38; -- m:n condition variables
+ SIGKAP : constant := 60; -- keep alive poll from native keyboard
+ SIGGRANT : constant := SIGKAP; -- monitor mode granted
+ SIGRETRACT : constant := 61; -- monitor mode should be relinguished
+ SIGSOUND : constant := 62; -- sound control has completed
+ SIGSAK : constant := 63; -- secure attention key
+
+ SIGADAABORT : constant := SIGTERM;
+ -- Note: on other targets, we usually use SIGABRT, but on AiX, it
+ -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set :=
+ (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF);
+ Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP);
+
+ 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;
+
+
+ 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 := False;
+ -- Indicates wether time slicing is supported
+
+ type timespec is private;
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int;
+ -- AiX threads don't have clock_gettime
+ -- We instead use gettimeofday()
+
+ 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;
+
+ type struct_timeval is private;
+ -- This is needed on systems that do not have clock_gettime()
+ -- but do have gettimeofday().
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 1;
+ SCHED_RR : constant := 2;
+ SCHED_OTHER : constant := 0;
+
+ -------------
+ -- 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, "thread_self");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ 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;
+
+ -----------
+ -- Stack --
+ -----------
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates wether 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_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 --
+ ---------------------------------------
+
+ -- Though not documented, pthread_init *must* be called before any other
+ -- pthread call
+
+ procedure pthread_init;
+ pragma Import (C, pthread_init, "pthread_init");
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "sigthreadmask");
+
+ --------------------------
+ -- 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_PROTECT : constant := 0;
+ PTHREAD_PRIO_INHERIT : constant := 0;
+
+ 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 Array_5_Int is array (0 .. 5) of int;
+ type struct_sched_param is record
+ sched_priority : int;
+ sched_policy : int;
+ sched_reserved : Array_5_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 pthread_attr_setschedparam
+ (attr : access pthread_attr_t;
+ sched_param : int) return int;
+ pragma Import (C, pthread_attr_setschedparam);
+
+ function sched_yield return int;
+ -- AiX have a nonstandard 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 pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access
+ procedure (arg : System.Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+
+ type sigset_t is record
+ losigs : unsigned_long;
+ hisigs : unsigned_long;
+ end record;
+ pragma Convention (C_Pass_By_Copy, sigset_t);
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 0;
+
+ type struct_timeval is record
+ tv_sec : long;
+ tv_usec : long;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type pthread_attr_t is new System.Address;
+ pragma Convention (C, pthread_attr_t);
+ -- typedef struct __pt_attr *pthread_attr_t;
+
+ type pthread_condattr_t is new System.Address;
+ pragma Convention (C, pthread_condattr_t);
+ -- typedef struct __pt_attr *pthread_condattr_t;
+
+ type pthread_mutexattr_t is new System.Address;
+ pragma Convention (C, pthread_mutexattr_t);
+ -- typedef struct __pt_attr *pthread_mutexattr_t;
+
+ type pthread_t is new System.Address;
+ pragma Convention (C, pthread_t);
+ -- typedef void *pthread_t;
+
+ type ptq_queue;
+ type ptq_queue_ptr is access all ptq_queue;
+
+ type ptq_queue is record
+ ptq_next : ptq_queue_ptr;
+ ptq_prev : ptq_queue_ptr;
+ end record;
+
+ type Array_3_Int is array (0 .. 3) of int;
+ type pthread_mutex_t is record
+ link : ptq_queue;
+ ptmtx_lock : int;
+ ptmtx_flags : long;
+ protocol : int;
+ prioceiling : int;
+ ptmtx_owner : pthread_t;
+ mtx_id : int;
+ attr : pthread_attr_t;
+ mtx_kind : int;
+ lock_cpt : int;
+ reserved : Array_3_Int;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+ type pthread_mutex_t_ptr is access pthread_mutex_t;
+
+ type pthread_cond_t is record
+ link : ptq_queue;
+ ptcv_lock : int;
+ ptcv_flags : long;
+ ptcv_waiters : ptq_queue;
+ cv_id : int;
+ attr : pthread_attr_t;
+ mutex : pthread_mutex_t_ptr;
+ cptwait : int;
+ reserved : int;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new unsigned;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (AIX/PPC Version)
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ 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 := Integer'Last;
+
+ 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 := Standard'Tick;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := Standard'Storage_Unit;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Standard'Address_Size;
+
+ -- 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 :=
+ Bit_Order'Val (Standard'Default_Bit_Order);
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer
+ range 0 .. Standard'Max_Interrupt_Priority;
+
+ subtype Priority is Any_Priority
+ range 0 .. Standard'Max_Priority;
+
+ -- Functional notation is needed in the following to avoid visibility
+ -- problems when this package is compiled through rtsfind in the middle
+ -- of another compilation.
+
+ subtype Interrupt_Priority is Any_Priority
+ range
+ Standard."+" (Standard'Max_Priority, 1) ..
+ Standard'Max_Interrupt_Priority;
+
+ Default_Priority : constant Priority :=
+ Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
+
+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.
+
+ AAMP : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Denorm : constant Boolean := True;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+ High_Integrity_Mode : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+end System;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.18 $
+-- --
+-- Copyright (C) 1998-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a AIX (FSU THREADS) version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+ -- pragma Elaborate_Body;
+
+ pragma Linker_Options ("-lgthreads");
+ pragma Linker_Options ("-lmalloc");
+
+ 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 := 78;
+
+ -------------
+ -- 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)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGPWR : constant := 29; -- power-fail restart
+ SIGWINCH : constant := 28; -- window size change
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGPOLL : constant := 23; -- pollable event occurred
+ SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
+ 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
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGVTALRM : constant := 34; -- virtual timer expired
+ SIGPROF : constant := 32; -- profiling timer expired
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGWAITING : constant := 39; -- m:n scheduling
+
+ -- the following signals are AIX specific
+ SIGMSG : constant := 27; -- input data is in the ring buffer
+ SIGDANGER : constant := 33; -- system crash imminent
+ SIGMIGRATE : constant := 35; -- migrate process
+ SIGPRE : constant := 36; -- programming exception
+ SIGVIRT : constant := 37; -- AIX virtual time alarm
+ SIGALRM1 : constant := 38; -- m:n condition variables
+ SIGKAP : constant := 60; -- keep alive poll from native keyboard
+ SIGGRANT : constant := SIGKAP; -- monitor mode granted
+ SIGRETRACT : constant := 61; -- monitor mode should be relinguished
+ SIGSOUND : constant := 62; -- sound control has completed
+ SIGSAK : constant := 63; -- secure attention key
+
+ SIGADAABORT : constant := SIGABRT;
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set :=
+ (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF);
+ Reserved : constant Signal_Set :=
+ (SIGKILL, SIGSTOP, SIGALRM, SIGWAITING);
+
+ 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;
+
+ 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, "_internal_sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ Time_Slice_Supported : constant Boolean := True;
+ -- Indicates wether time slicing is supported (i.e FSU threads have been
+ -- compiled with DEF_RR)
+
+ type timespec is private;
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "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_timeval is private;
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 0;
+ SCHED_RR : constant := 1;
+ SCHED_OTHER : constant := 2;
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- 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;
+ 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;
+
+ -----------
+ -- Stack --
+ -----------
+
+ Stack_Base_Available : constant Boolean := True;
+ -- Indicates wether the stack base is available on this target.
+ -- This allows us to share s-osinte.adb between all the FSU run time.
+ -- Note that this value can only be true if pthread_t has a complete
+ -- definition that corresponds exactly to the C header files.
+
+ 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_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;
+ -- FSU_THREADS requires pthread_init, which is nonstandard
+ -- and this should be invoked during the elaboration of s-taprop.adb
+ pragma Import (C, pthread_init, "pthread_init");
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ -- FSU_THREADS has a nonstandard sigwait
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ -- FSU threads does not have pthread_sigmask. Instead, it redefines
+ -- sigprocmask and then uses a special syscall API to call the system
+ -- version. Doing syscalls on AiX is very difficult, so we rename the
+ -- pthread version instead.
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "_internal_sigprocmask");
+
+ --------------------------
+ -- 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;
+ -- FSU_THREADS has nonstandard pthread_mutex_lock
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ -- FSU_THREADS has nonstandard pthread_mutex_lock
+
+ 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;
+ -- FSU_THREADS has a nonstandard pthread_cond_wait
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ -- FSU_THREADS has a nonstandard 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_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ 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,
+ "pthread_mutexattr_setprio_ceiling");
+
+ 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;
+ -- FSU_THREADS does not have 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, "pthread_attr_setsched");
+
+ function sched_yield return int;
+ -- FSU_THREADS does not have 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;
+ -- FSU_THREADS has a nonstandard 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 pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ -- FSU_THREADS has a nonstandard pthread_getspecific
+
+ type destructor_pointer is access procedure (arg : System.Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+
+ type sigset_t is record
+ losigs : unsigned_long;
+ hisigs : unsigned_long;
+ end record;
+ pragma Convention (C_Pass_By_Copy, sigset_t);
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 0;
+
+ type struct_timeval is record
+ tv_sec : long;
+ tv_usec : long;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type pthread_attr_t is record
+ flags : int;
+ stacksize : int;
+ contentionscope : int;
+ inheritsched : int;
+ detachstate : int;
+ sched : int;
+ prio : int;
+ starttime : timespec;
+ deadline : timespec;
+ period : timespec;
+ end record;
+ pragma Convention (C_Pass_By_Copy, pthread_attr_t);
+
+ type pthread_condattr_t is record
+ flags : int;
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_mutexattr_t is record
+ flags : int;
+ prio_ceiling : int;
+ protocol : int;
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type sigjmp_buf is array (Integer range 0 .. 63) of int;
+
+ type pthread_t_struct is record
+ context : sigjmp_buf;
+ pbody : sigjmp_buf;
+ errno : int;
+ ret : int;
+ stack_base : System.Address;
+ end record;
+ pragma Convention (C, pthread_t_struct);
+
+ type pthread_t is access all pthread_t_struct;
+
+ type queue_t is record
+ head : System.Address;
+ tail : System.Address;
+ end record;
+ pragma Convention (C, queue_t);
+
+ type pthread_mutex_t is record
+ queue : queue_t;
+ lock : plain_char;
+ owner : System.Address;
+ flags : int;
+ prio_ceiling : int;
+ protocol : int;
+ prev_max_ceiling_prio : int;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_cond_t is record
+ queue : queue_t;
+ flags : int;
+ waiters : int;
+ mutex : System.Address;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.18 $
+-- --
+-- Copyright (C) 1992-2001, 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a DOS/DJGPPv2 (FSU THREAD) version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ --
+ -- A short name for libgthreads.a to keep Mike Feldman happy.
+ --
+ pragma Linker_Options ("-lgthre");
+
+ 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 := 5;
+ EINTR : constant := 13;
+ EINVAL : constant := 14;
+ ENOMEM : constant := 25;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 319;
+ type Signal is new int range 0 .. Max_Interrupt;
+
+ SIGHUP : constant := 294; -- hangup
+ SIGINT : constant := 295; -- interrupt (rubout)
+ SIGQUIT : constant := 298; -- quit (ASCD FS)
+ SIGILL : constant := 290; -- illegal instruction (not reset)
+ SIGABRT : constant := 288; -- used by abort
+ SIGFPE : constant := 289; -- floating point exception
+ SIGKILL : constant := 296; -- kill (cannot be caught or ignored)
+ SIGSEGV : constant := 291; -- segmentation violation
+ SIGPIPE : constant := 297; -- write on a pipe with no one to read it
+ SIGALRM : constant := 293; -- alarm clock
+ SIGTERM : constant := 292; -- software termination signal from kill
+ SIGUSR1 : constant := 299; -- user defined signal 1
+ SIGUSR2 : constant := 300; -- user defined signal 2
+ SIGBUS : constant := 0;
+
+ SIGADAABORT : constant := SIGABRT;
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set := (SIGTRAP, SIGALRM);
+ Reserved : constant Signal_Set := (0 .. 0 => SIGSTOP);
+
+ 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_flags : int;
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 3;
+ 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 := False;
+ -- Indicates wether time slicing is supported (i.e FSU threads have been
+ -- compiled with DEF_RR)
+
+ type timespec is private;
+
+ function nanosleep (rqtp, rmtp : access timespec) return int;
+ -- FSU_THREADS has nonstandard nanosleep
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "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_timeval is private;
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 0;
+ SCHED_RR : constant := 1;
+ SCHED_OTHER : constant := 2;
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- 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;
+
+ 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;
+
+ -----------
+ -- Stack --
+ -----------
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates wether the stack base is available on this target.
+ -- This allows us to share s-osinte.adb between all the FSU run time.
+ -- Note that this value can only be true if pthread_t has a complete
+ -- definition that corresponds exactly to the C header files.
+
+ 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_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
+
+ PROT_ON : constant := PROT_NONE;
+ 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;
+ -- FSU_THREADS requires pthread_init, which is nonstandard
+ -- and this should be invoked during the elaboration of s-taprop.adb
+ pragma Import (C, pthread_init, "pthread_init");
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait (set : access sigset_t; sig : access Signal) return int;
+ -- FSU_THREADS has a nonstandard sigwait
+
+ function pthread_kill (thread : pthread_t; sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "sigprocmask");
+
+ --------------------------
+ -- 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;
+ -- FSU_THREADS has nonstandard pthread_mutex_lock
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ -- FSU_THREADS has nonstandard pthread_mutex_lock
+
+ 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;
+ -- FSU_THREADS has a nonstandard pthread_cond_wait
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ -- FSU_THREADS has a nonstandard 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_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ 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; -- scheduling priority
+ end record;
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int;
+ -- FSU_THREADS does not have 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, "pthread_attr_setsched");
+
+ function sched_yield return int;
+ -- FSU_THREADS does not have sched_yield;
+
+ ---------------------------
+ -- P1003.1c - Section 16 --
+ ---------------------------
+
+ function pthread_attr_init (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_init);
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_destroy);
+
+ function pthread_attr_setdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : int) return int;
+ -- FSU_THREADS has a nonstandard 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);
+
+ 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 Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ -- FSU_THREADS has a nonstandard pthread_getspecific
+
+ type destructor_pointer is access procedure (arg : System.Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+
+ type bits_arr_t is array (Integer range 1 .. 10) of long;
+ type sigset_t is record
+ bits : bits_arr_t;
+ end record;
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 0;
+
+ type struct_timeval is record
+ tv_sec : long;
+ tv_usec : long;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type pthread_attr_t is record
+ flags : int;
+ stacksize : int;
+ contentionscope : int;
+ inheritsched : int;
+ detachstate : int;
+ sched : int;
+ prio : int;
+ starttime : timespec;
+ deadline : timespec;
+ period : timespec;
+ end record;
+ pragma Convention (C, pthread_attr_t);
+
+ type pthread_condattr_t is record
+ flags : int;
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_mutexattr_t is record
+ flags : int;
+ prio_ceiling : int;
+ protocol : int;
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type sigjmp_buf is array (Integer range 0 .. 43) of int;
+
+ type pthread_t_struct is record
+ context : sigjmp_buf;
+ pbody : sigjmp_buf;
+ errno : int;
+ ret : int;
+ stack_base : System.Address;
+ end record;
+ pragma Convention (C, pthread_t_struct);
+
+ type pthread_t is access all pthread_t_struct;
+
+ type queue_t is record
+ head : System.Address;
+ tail : System.Address;
+ end record;
+ pragma Convention (C, queue_t);
+
+ type pthread_mutex_t is record
+ queue : queue_t;
+ lock : plain_char;
+ owner : System.Address;
+ flags : int;
+ prio_ceiling : int;
+ protocol : int;
+ prev_max_ceiling_prio : int;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_cond_t is record
+ queue : queue_t;
+ flags : int;
+ waiters : int;
+ mutex : System.Address;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (X86 Solaris Version) --
+-- --
+-- $Revision: 1.10 $
+-- --
+-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ 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 := Integer'Last;
+
+ 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 := Standard'Tick;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := Standard'Storage_Unit;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Standard'Address_Size;
+
+ -- 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;
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer
+ range 0 .. Standard'Max_Interrupt_Priority;
+
+ subtype Priority is Any_Priority
+ range 0 .. Standard'Max_Priority;
+
+ -- Functional notation is needed in the following to avoid visibility
+ -- problems when this package is compiled through rtsfind in the middle
+ -- of another compilation.
+
+ subtype Interrupt_Priority is Any_Priority
+ range
+ Standard."+" (Standard'Max_Priority, 1) ..
+ Standard'Max_Interrupt_Priority;
+
+ Default_Priority : constant Priority :=
+ Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
+
+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.
+
+ AAMP : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Denorm : constant Boolean := True;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+ High_Integrity_Mode : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := True;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+end System;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SELF --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 1991-1998, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Solaris/X86 (native) version of this package.
+
+separate (System.Task_Primitives.Operations)
+
+----------
+-- Self --
+----------
+
+function Self return Task_ID is
+ Temp : aliased System.Address;
+ Result : Interfaces.C.int;
+
+begin
+ Result := thr_getspecific (ATCB_Key, Temp'Unchecked_Access);
+ pragma Assert (Result = 0);
+ return To_Task_ID (Temp);
+end Self;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1991-2001, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a SGI Pthread version of this package.
+
+-- PLEASE DO NOT add any dependences on other packages.
+-- This package is designed to work with or without tasking support.
+
+-- Make a careful study of all signals available under the OS,
+-- to see which need to be reserved, kept always unmasked,
+-- or kept always unmasked.
+-- Be on the lookout for special signals that
+-- may be used by the thread library.
+
+with Interfaces.C;
+-- used for int
+
+with System.OS_Interface;
+-- used for various Constants, Signal and types
+
+package body System.Interrupt_Management is
+
+ use System.OS_Interface;
+
+ type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
+ Exception_Interrupts : constant Interrupt_List :=
+ (SIGTSTP, SIGILL, SIGTRAP, SIGEMT, SIGFPE, SIGBUS, SIGSTOP, SIGKILL,
+ SIGSEGV, SIGSYS, SIGXCPU, SIGXFSZ, SIGPROF, SIGPTINTR, SIGPTRESCHED,
+ SIGABRT, SIGPIPE);
+
+ ---------------------------
+ -- Initialize_Interrupts --
+ ---------------------------
+
+ -- Nothing needs to be done on this platform.
+
+ procedure Initialize_Interrupts is
+ begin
+ null;
+ end Initialize_Interrupts;
+
+ Unreserve_All_Interrupts : Interfaces.C.int;
+ pragma Import
+ (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
+
+ use type Interfaces.C.int;
+
+begin
+ Abort_Task_Interrupt := SIGABRT;
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ for I in Exception_Interrupts'Range loop
+ Keep_Unmasked (Exception_Interrupts (I)) := True;
+ end loop;
+
+ -- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but in the
+ -- same time, disable the ability of handling this signal via
+ -- Ada.Interrupts.
+ -- The pragma Unreserve_All_Interrupts let the user the ability to
+ -- change this behavior.
+
+ if Unreserve_All_Interrupts = 0 then
+ Keep_Unmasked (SIGINT) := True;
+ end if;
+
+ Keep_Unmasked (Abort_Task_Interrupt) := True;
+
+ Reserve := Keep_Unmasked or Keep_Masked;
+ Reserve (0) := True;
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.13 $
+-- --
+-- Copyright (C) 1998-2001, 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the SGI Pthreads version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lpthread");
+
+ 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");
+
+ EINTR : constant := 4; -- interrupted system call
+ EAGAIN : constant := 11; -- No more processes
+ ENOMEM : constant := 12; -- Not enough core
+ EINVAL : constant := 22; -- Invalid argument
+ ETIMEDOUT : constant := 145; -- Connection timed out
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 64;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the
+ -- future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ SIGWINCH : constant := 20; -- window size change
+ SIGURG : constant := 21; -- urgent condition on IO channel
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias)
+ SIGSTOP : constant := 23; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 24; -- user stop requested from tty
+ SIGCONT : constant := 25; -- stopped process has been continued
+ SIGTTIN : constant := 26; -- background tty read attempted
+ SIGTTOU : constant := 27; -- background tty write attempted
+ SIGVTALRM : constant := 28; -- virtual timer expired
+ SIGPROF : constant := 29; -- profiling timer expired
+ SIGXCPU : constant := 30; -- CPU time limit exceeded
+ SIGXFSZ : constant := 31; -- filesize limit exceeded
+ SIGK32 : constant := 32; -- reserved for kernel (IRIX)
+ SIGCKPT : constant := 33; -- Checkpoint warning
+ SIGRESTART : constant := 34; -- Restart warning
+ SIGUME : constant := 35; -- Uncorrectable memory error
+ -- Signals defined for Posix 1003.1c.
+ SIGPTINTR : constant := 47;
+ SIGPTRESCHED : constant := 48;
+ -- Posix 1003.1b signals
+ SIGRTMIN : constant := 49; -- Posix 1003.1b signals
+ SIGRTMAX : constant := 64; -- Posix 1003.1b signals
+
+ type sigset_t is private;
+ type sigset_t_ptr is access all sigset_t;
+
+ 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 array_type_2 is array (Integer range 0 .. 1) of int;
+ type struct_sigaction is record
+ sa_flags : int;
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_resv : array_type_2;
+ end record;
+ pragma Convention (C, struct_sigaction);
+
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr := null) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ type timespec is private;
+ type timespec_ptr is access all timespec;
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+ CLOCK_SGI_FAST : constant clockid_t;
+ CLOCK_SGI_CYCLE : constant clockid_t;
+
+ SGI_CYCLECNTR_SIZE : constant := 165;
+
+ function syssgi (request : Interfaces.C.int) return Interfaces.C.ptrdiff_t;
+ pragma Import (C, syssgi, "syssgi");
+
+ 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;
+ tp : 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_timeval is private;
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 1;
+ SCHED_RR : constant := 2;
+ SCHED_TS : constant := 3;
+ SCHED_OTHER : constant := 3;
+ SCHED_NP : constant := 4;
+
+ function sched_get_priority_min (Policy : int) return int;
+ pragma Import (C, sched_get_priority_min, "sched_get_priority_min");
+
+ function sched_get_priority_max (Policy : int) return int;
+ pragma Import (C, sched_get_priority_max, "sched_get_priority_max");
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ 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;
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ procedure pthread_init;
+ pragma Inline (pthread_init);
+ -- This is a dummy procedure to share some GNULLI files
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- 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");
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ PTHREAD_PRIO_NONE : constant := 0;
+ PTHREAD_PRIO_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ 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;
+ pragma Convention (C, struct_sched_param);
+
+ 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, "pthread_attr_setinheritsched");
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import (C, pthread_attr_setschedpolicy);
+
+ function pthread_attr_setschedparam
+ (attr : access pthread_attr_t;
+ sched_param : access struct_sched_param)
+ return int;
+ pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam");
+
+ 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, "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 pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+ ---------------------------------------------------------------
+ -- Non portable SGI 6.5 additions to the pthread interface --
+ -- must be executed from within the context of a system --
+ -- scope task --
+ ---------------------------------------------------------------
+
+ function pthread_setrunon_np (cpu : int) return int;
+ pragma Import (C, pthread_setrunon_np, "pthread_setrunon_np");
+
+private
+
+ type array_type_1 is array (Integer range 0 .. 3) of unsigned;
+ type sigset_t is record
+ X_X_sigbits : array_type_1;
+ 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 clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 1;
+ CLOCK_SGI_CYCLE : constant clockid_t := 2;
+ CLOCK_SGI_FAST : constant clockid_t := 3;
+
+ type struct_timeval is record
+ tv_sec : time_t;
+ tv_usec : time_t;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type array_type_9 is array (Integer range 0 .. 4) of long;
+ type pthread_attr_t is record
+ X_X_D : array_type_9;
+ end record;
+ pragma Convention (C, pthread_attr_t);
+
+ type array_type_8 is array (Integer range 0 .. 1) of long;
+ type pthread_condattr_t is record
+ X_X_D : array_type_8;
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type array_type_7 is array (Integer range 0 .. 1) of long;
+ type pthread_mutexattr_t is record
+ X_X_D : array_type_7;
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type pthread_t is new unsigned;
+
+ type array_type_10 is array (Integer range 0 .. 7) of long;
+ type pthread_mutex_t is record
+ X_X_D : array_type_10;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+ type array_type_11 is array (Integer range 0 .. 7) of long;
+ type pthread_cond_t is record
+ X_X_D : array_type_11;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (SGI Irix, o32 ABI) --
+-- --
+-- $Revision: 1.13 $
+-- --
+-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ 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 := Integer'Last;
+
+ 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 := Standard'Tick;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := Standard'Storage_Unit;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Standard'Address_Size;
+
+ -- 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;
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer
+ range 0 .. Standard'Max_Interrupt_Priority;
+
+ subtype Priority is Any_Priority
+ range 0 .. Standard'Max_Priority;
+
+ -- Functional notation is needed in the following to avoid visibility
+ -- problems when this package is compiled through rtsfind in the middle
+ -- of another compilation.
+
+ subtype Interrupt_Priority is Any_Priority
+ range
+ Standard."+" (Standard'Max_Priority, 1) ..
+ Standard'Max_Interrupt_Priority;
+
+ Default_Priority : constant Priority :=
+ Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
+
+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.
+
+ AAMP : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Denorm : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := True;
+ Long_Shifts_Inlined : constant Boolean := True;
+ High_Integrity_Mode : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := True;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := True;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := True;
+
+ -- Note: Denorm is False because denormals are not supported on the
+ -- R10000, and we want the code to be valid for this processor.
+
+end System;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.26 $
+-- --
+-- Copyright (C) 1991-2001, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a IRIX (pthread library) version of this package.
+
+-- 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 Interfaces.C;
+-- used for int
+-- size_t
+
+with System.Task_Info;
+
+with System.Tasking.Debug;
+-- used for Known_Tasks
+
+with System.IO;
+-- used for Put_Line
+
+with System.Interrupt_Management;
+-- used for Keep_Unmasked
+-- Abort_Task_Interrupt
+-- Interrupt_ID
+
+with System.Interrupt_Management.Operations;
+-- used for Set_Interrupt_Mask
+-- All_Tasks_Mask
+pragma Elaborate_All (System.Interrupt_Management.Operations);
+
+with System.Parameters;
+-- used for Size_Type
+
+with System.Tasking;
+-- used for Ada_Task_Control_Block
+-- Task_ID
+
+with System.Soft_Links;
+-- used for Defer/Undefer_Abort
+
+-- Note that we do not use System.Tasking.Initialization directly since
+-- this 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.Initialization
+
+with System.Program_Info;
+-- used for Default_Task_Stack
+-- Default_Time_Slice
+-- Stack_Guard_Pages
+-- Pthread_Sched_Signal
+-- Pthread_Arena_Size
+
+with System.OS_Interface;
+-- used for various type, constant, and operations
+
+with System.OS_Primitives;
+-- used for Delay_Modes
+
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+package body System.Task_Primitives.Operations is
+
+ use System.Tasking;
+ use System.Tasking.Debug;
+ use Interfaces.C;
+ use System.OS_Interface;
+ use System.OS_Primitives;
+ use System.Parameters;
+
+ package SSL renames System.Soft_Links;
+
+ ------------------
+ -- Local Data --
+ ------------------
+
+ -- The followings are logically constants, but need to be initialized
+ -- at run time.
+
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_ID associated with a thread
+
+ All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
+ -- See comments on locking rules in System.Locking_Rules (spec).
+
+ 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");
+
+ Real_Time_Clock_Id : constant clockid_t := CLOCK_REALTIME;
+
+ Unblocked_Signal_Mask : aliased sigset_t;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
+
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+
+ procedure Abort_Handler (Sig : Signal);
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ procedure Abort_Handler (Sig : Signal) is
+ T : Task_ID := Self;
+ Result : Interfaces.C.int;
+ Old_Set : aliased sigset_t;
+
+ begin
+ if T.Deferral_Level = 0
+ and then T.Pending_ATC_Level < T.ATC_Nesting_Level
+ then
+ -- Make sure signals used for RTS internal purpose are unmasked
+
+ Result := pthread_sigmask
+ (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Unchecked_Access,
+ Old_Set'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ raise Standard'Abort_Signal;
+ end if;
+ end Abort_Handler;
+
+ -----------------
+ -- Stack_Guard --
+ -----------------
+
+ -- The underlying thread system sets a guard page at the
+ -- bottom of a thread stack, so nothing is needed.
+
+ procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ begin
+ null;
+ end Stack_Guard;
+
+ -------------------
+ -- Get_Thread_Id --
+ -------------------
+
+ function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
+ begin
+ return T.Common.LL.Thread;
+ end Get_Thread_Id;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_ID is
+ Result : System.Address;
+
+ begin
+ Result := pthread_getspecific (ATCB_Key);
+ pragma Assert (Result /= System.Null_Address);
+
+ return To_Task_ID (Result);
+ end Self;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ -- Note: mutexes and cond_variables needed per-task basis are
+ -- initialized in Intialize_TCB and the Storage_Error is
+ -- handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...)
+ -- used in RTS is initialized before any status change of RTS.
+ -- Therefore rasing Storage_Error in the following routines
+ -- should be able to be handled safely.
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : 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
+ Result := pthread_mutexattr_setprotocol
+ (Attributes'Access, PTHREAD_PRIO_PROTECT);
+ pragma Assert (Result = 0);
+
+ Result := pthread_mutexattr_setprioceiling
+ (Attributes'Access, Interfaces.C.int (Prio));
+ pragma Assert (Result = 0);
+ 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;
+
+ procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) 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
+ Result := pthread_mutexattr_setprotocol
+ (Attributes'Access, PTHREAD_PRIO_PROTECT);
+ pragma Assert (Result = 0);
+
+ Result := pthread_mutexattr_setprioceiling
+ (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
+ pragma Assert (Result = 0);
+ 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);
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_destroy (L);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : 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 : access Lock; Ceiling_Violation : out Boolean) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (L);
+ Ceiling_Violation := Result = EINVAL;
+
+ -- assumes the cause of EINVAL is a priority ceiling violation
+
+ pragma Assert (Result = 0 or else Result = EINVAL);
+ end Write_Lock;
+
+ procedure Write_Lock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ Write_Lock (L, Ceiling_Violation);
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ -----------
+ -- Sleep --
+ -----------
+
+ procedure Sleep
+ (Self_ID : ST.Task_ID;
+ Reason : System.Tasking.Task_States)
+ is
+ Result : Interfaces.C.int;
+ begin
+ pragma Assert (Self_ID = Self);
+ Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access);
+
+ -- EINTR is not considered a failure.
+
+ pragma Assert (Result = 0 or else Result = EINTR);
+ end Sleep;
+
+ -----------------
+ -- Timed_Sleep --
+ -----------------
+
+ procedure Timed_Sleep
+ (Self_ID : Task_ID;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ Check_Time : constant Duration := Monotonic_Clock;
+ 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;
+ else
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+ end if;
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ or else Self_ID.Pending_Priority_Change;
+
+ Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access, Request'Access);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ if Result = 0 or else errno = EINTR then
+ Timedout := False;
+ exit;
+ end if;
+ 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
+ Check_Time : constant Duration := Monotonic_Clock;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ -- Only the little window between deferring abort and
+ -- locking Self_ID is the reason we need to
+ -- check for pending abort and priority change below! :(
+
+ SSL.Abort_Defer.all;
+ Write_Lock (Self_ID);
+
+ if Mode = Relative then
+ Abs_Time := Time + Check_Time;
+ else
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+ end if;
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+ Self_ID.Common.State := Delay_Sleep;
+
+ loop
+ if Self_ID.Pending_Priority_Change then
+ Self_ID.Pending_Priority_Change := False;
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
+ end if;
+
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access, Request'Access);
+ exit when Abs_Time <= Monotonic_Clock;
+
+ pragma Assert (Result = 0
+ or else Result = ETIMEDOUT
+ or else Result = EINTR);
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+ Yield;
+ SSL.Abort_Undefer.all;
+ end Timed_Delay;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ TS : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := clock_gettime (Real_Time_Clock_Id, TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+ return To_Duration (TS);
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ begin
+ -- The clock_getres (Real_Time_Clock_Id) function appears to return
+ -- the interrupt resolution of the realtime clock and not the actual
+ -- resolution of reading the clock. Even though this last value is
+ -- only guaranteed to be 100 Hz, at least the Origin 200 appears to
+ -- have a microsecond resolution or better.
+ -- ??? We should figure out a method to return the right value on
+ -- all SGI hardware.
+
+ return 0.000_001; -- Assume microsecond resolution of clock
+ end RT_Resolution;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : ST.Task_ID; Reason : System.Tasking.Task_States) is
+ 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;
+ begin
+ if Do_Yield then
+ Result := sched_yield;
+ end if;
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_Priority
+ (T : Task_ID;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ Result : Interfaces.C.int;
+ Param : aliased struct_sched_param;
+ Sched_Policy : Interfaces.C.int;
+
+ use type System.Task_Info.Task_Info_Type;
+
+ function To_Int is new Unchecked_Conversion
+ (System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int);
+
+ begin
+ T.Common.Current_Priority := Prio;
+ Param.sched_priority := Interfaces.C.int (Prio);
+
+ if T.Common.Task_Info /= null then
+ Sched_Policy := To_Int (T.Common.Task_Info.Policy);
+ else
+ Sched_Policy := SCHED_FIFO;
+ end if;
+
+ Result := pthread_setschedparam (T.Common.LL.Thread, Sched_Policy,
+ Param'Access);
+ pragma Assert (Result = 0);
+ 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
+ Result : Interfaces.C.int;
+
+ function To_Int is new Unchecked_Conversion
+ (System.Task_Info.CPU_Number, Interfaces.C.int);
+
+ use System.Task_Info;
+
+ begin
+ Self_ID.Common.LL.Thread := pthread_self;
+ Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID));
+ pragma Assert (Result = 0);
+
+ if Self_ID.Common.Task_Info /= null
+ and then Self_ID.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM
+ and then Self_ID.Common.Task_Info.Runon_CPU /= ANY_CPU
+ then
+ Result := pthread_setrunon_np
+ (To_Int (Self_ID.Common.Task_Info.Runon_CPU));
+ pragma Assert (Result = 0);
+ end if;
+
+ Lock_All_Tasks_List;
+
+ 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_All_Tasks_List;
+ 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;
+
+ --------------------
+ -- Initialize_TCB --
+ --------------------
+
+ procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
+ Result : Interfaces.C.int;
+ Cond_Attr : aliased pthread_condattr_t;
+
+ begin
+ Initialize_Lock (Self_ID.Common.LL.L'Access, All_Tasks_Level);
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
+ Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = 0 then
+ Succeeded := True;
+ else
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Succeeded := False;
+ end if;
+
+ Result := pthread_condattr_destroy (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+ end Initialize_TCB;
+
+ -----------------
+ -- Create_Task --
+ -----------------
+
+ procedure Create_Task
+ (T : Task_ID;
+ Wrapper : System.Address;
+ Stack_Size : System.Parameters.Size_Type;
+ Priority : System.Any_Priority;
+ Succeeded : out Boolean)
+ is
+ use System.Task_Info;
+
+ Attributes : aliased pthread_attr_t;
+ Sched_Param : aliased struct_sched_param;
+ Adjusted_Stack_Size : Interfaces.C.size_t;
+ Result : Interfaces.C.int;
+
+ function Thread_Body_Access is new
+ Unchecked_Conversion (System.Address, Thread_Body);
+
+ function To_Int is new Unchecked_Conversion
+ (System.Task_Info.Thread_Scheduling_Scope, Interfaces.C.int);
+ function To_Int is new Unchecked_Conversion
+ (System.Task_Info.Thread_Scheduling_Inheritance, Interfaces.C.int);
+ function To_Int is new Unchecked_Conversion
+ (System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int);
+
+ begin
+ if Stack_Size = System.Parameters.Unspecified_Size then
+ Adjusted_Stack_Size :=
+ Interfaces.C.size_t (System.Program_Info.Default_Task_Stack);
+
+ elsif Stack_Size < Size_Type (Minimum_Stack_Size) then
+ Adjusted_Stack_Size :=
+ Interfaces.C.size_t (Minimum_Stack_Size);
+
+ else
+ Adjusted_Stack_Size := Interfaces.C.size_t (Stack_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, Interfaces.C.size_t (Adjusted_Stack_Size));
+ pragma Assert (Result = 0);
+
+ if T.Common.Task_Info /= null then
+ Result := pthread_attr_setscope
+ (Attributes'Access, To_Int (T.Common.Task_Info.Scope));
+ pragma Assert (Result = 0);
+
+ Result := pthread_attr_setinheritsched
+ (Attributes'Access, To_Int (T.Common.Task_Info.Inheritance));
+ pragma Assert (Result = 0);
+
+ Result := pthread_attr_setschedpolicy
+ (Attributes'Access, To_Int (T.Common.Task_Info.Policy));
+ pragma Assert (Result = 0);
+
+ Sched_Param.sched_priority :=
+ Interfaces.C.int (T.Common.Task_Info.Priority);
+
+ Result := pthread_attr_setschedparam
+ (Attributes'Access, Sched_Param'Access);
+ 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));
+
+ if Result /= 0
+ and then T.Common.Task_Info /= null
+ and then T.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM
+ then
+ -- The pthread_create call may have failed because we
+ -- asked for a system scope pthread and none were
+ -- available (probably because the program was not executed
+ -- by the superuser). Let's try for a process scope pthread
+ -- instead of raising Tasking_Error.
+
+ System.IO.Put_Line
+ ("Request for PTHREAD_SCOPE_SYSTEM in Task_Info pragma for task");
+ System.IO.Put ("""");
+ System.IO.Put (T.Common.Task_Image.all);
+ System.IO.Put_Line (""" could not be honored. ");
+ System.IO.Put_Line ("Scope changed to PTHREAD_SCOPE_PROCESS");
+
+ T.Common.Task_Info.Scope := PTHREAD_SCOPE_PROCESS;
+ Result := pthread_attr_setscope
+ (Attributes'Access, To_Int (T.Common.Task_Info.Scope));
+ pragma Assert (Result = 0);
+
+ Result := pthread_create
+ (T.Common.LL.Thread'Access,
+ Attributes'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
+ end if;
+
+ pragma Assert (Result = 0 or else Result = EAGAIN);
+
+ Succeeded := Result = 0;
+
+ Set_Priority (T, Priority);
+
+ Result := pthread_attr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_ID) is
+ Result : Interfaces.C.int;
+ Tmp : Task_ID := T;
+
+ procedure Free is new
+ Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
+
+ begin
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+
+ Result := pthread_cond_destroy (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+
+ if T.Known_Tasks_Index /= -1 then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ end if;
+
+ Free (Tmp);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ pthread_exit (System.Null_Address);
+ 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;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy versions. The only currently working versions is for solaris
+ -- (native).
+
+ function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ 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_All_Tasks_List --
+ -------------------------
+
+ procedure Lock_All_Tasks_List is
+ begin
+ Write_Lock (All_Tasks_L'Access);
+ end Lock_All_Tasks_List;
+
+ ---------------------------
+ -- Unlock_All_Tasks_List --
+ ---------------------------
+
+ procedure Unlock_All_Tasks_List is
+ begin
+ Unlock (All_Tasks_L'Access);
+ end Unlock_All_Tasks_List;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ return False;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ return False;
+ end Resume_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;
+
+ begin
+ Environment_Task_ID := Environment_Task;
+
+ -- Initialize the lock used to synchronize chain of all ATCBs.
+ Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
+
+ Enter_Task (Environment_Task);
+
+ -- Install the abort-signal handler
+
+ 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 Initialize;
+
+begin
+ declare
+ Result : Interfaces.C.int;
+ begin
+ -- Mask Environment task for all signals. The original mask of the
+ -- Environment task will be recovered by Interrupt_Server task
+ -- during the elaboration of s-interr.adb.
+
+ System.Interrupt_Management.Operations.Set_Interrupt_Mask
+ (System.Interrupt_Management.Operations.All_Tasks_Mask'Access);
+
+ -- 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;
+
+ Result := pthread_key_create (ATCB_Key'Access, null);
+ pragma Assert (Result = 0);
+
+ -- Pick the highest resolution Clock for Clock_Realtime
+ -- ??? This code currently doesn't work (see c94007[ab] for example)
+ --
+ -- if syssgi (SGI_CYCLECNTR_SIZE) = 64 then
+ -- Real_Time_Clock_Id := CLOCK_SGI_CYCLE;
+ -- else
+ -- Real_Time_Clock_Id := CLOCK_REALTIME;
+ -- end if;
+ end;
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- S p e c --
+-- (Compiler Interface) --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the definitions and routines associated with the
+-- implementation of the Task_Info pragma. It is specialized appropriately
+-- for targets that make use of this pragma.
+
+-- Note: the compiler generates direct calls to this interface, via Rtsfind.
+-- Any changes to this interface may require corresponding compiler changes.
+
+with Interfaces.C;
+with System.OS_Interface;
+with Unchecked_Deallocation;
+
+package System.Task_Info is
+pragma Elaborate_Body;
+-- To ensure that a body is allowed
+
+ package OSI renames System.OS_Interface;
+
+ -----------------------------------------
+ -- Implementation of Task_Info Feature --
+ -----------------------------------------
+
+ -- Pragma Task_Info allows an application to set the underlying
+ -- pthread scheduling attributes for a specific task.
+
+ ------------------
+ -- Declarations --
+ ------------------
+
+ type Thread_Scheduling_Scope is
+ (PTHREAD_SCOPE_PROCESS, PTHREAD_SCOPE_SYSTEM);
+
+ for Thread_Scheduling_Scope'Size use Interfaces.C.int'Size;
+
+ type Thread_Scheduling_Inheritance is
+ (PTHREAD_EXPLICIT_SCHED, PTHREAD_INHERIT_SCHED);
+
+ for Thread_Scheduling_Inheritance'Size use Interfaces.C.int'Size;
+
+ type Thread_Scheduling_Policy is
+ (SCHED_FIFO, -- The first-in-first-out real-time policy
+ SCHED_RR, -- The round-robin real-time scheduling policy
+ SCHED_TS); -- The timeshare earnings based scheduling policy
+
+ for Thread_Scheduling_Policy'Size use Interfaces.C.int'Size;
+ for Thread_Scheduling_Policy use
+ (SCHED_FIFO => 1,
+ SCHED_RR => 2,
+ SCHED_TS => 3);
+
+ function SCHED_OTHER return Thread_Scheduling_Policy renames SCHED_TS;
+
+ No_Specified_Priority : constant := -1;
+
+ subtype Thread_Scheduling_Priority is Integer range
+ No_Specified_Priority .. 255;
+
+ function Min (Policy : Interfaces.C.int) return Interfaces.C.int
+ renames OSI.sched_get_priority_min;
+
+ function Max (Policy : Interfaces.C.int) return Interfaces.C.int
+ renames OSI.sched_get_priority_max;
+
+ subtype FIFO_Priority is Thread_Scheduling_Priority range
+ Thread_Scheduling_Priority (Min (OSI.SCHED_FIFO)) ..
+ Thread_Scheduling_Priority (Max (OSI.SCHED_FIFO));
+
+ subtype RR_Priority is Thread_Scheduling_Priority range
+ Thread_Scheduling_Priority (Min (OSI.SCHED_RR)) ..
+ Thread_Scheduling_Priority (Max (OSI.SCHED_RR));
+
+ subtype TS_Priority is Thread_Scheduling_Priority range
+ Thread_Scheduling_Priority (Min (OSI.SCHED_TS)) ..
+ Thread_Scheduling_Priority (Max (OSI.SCHED_TS));
+
+ subtype OTHER_Priority is Thread_Scheduling_Priority range
+ Thread_Scheduling_Priority (Min (OSI.SCHED_OTHER)) ..
+ Thread_Scheduling_Priority (Max (OSI.SCHED_OTHER));
+
+ subtype CPU_Number is Integer range -1 .. Integer'Last;
+ ANY_CPU : constant CPU_Number := CPU_Number'First;
+
+ type Thread_Attributes is record
+ Scope : Thread_Scheduling_Scope := PTHREAD_SCOPE_PROCESS;
+ Inheritance : Thread_Scheduling_Inheritance := PTHREAD_EXPLICIT_SCHED;
+ Policy : Thread_Scheduling_Policy := SCHED_RR;
+ Priority : Thread_Scheduling_Priority := No_Specified_Priority;
+ Runon_CPU : CPU_Number := ANY_CPU;
+ end record;
+
+ Default_Thread_Attributes : constant Thread_Attributes :=
+ (PTHREAD_SCOPE_PROCESS, PTHREAD_EXPLICIT_SCHED, SCHED_RR,
+ No_Specified_Priority, ANY_CPU);
+
+ type Task_Info_Type is access all Thread_Attributes;
+
+ type Task_Image_Type is access String;
+ -- Used to generate a meaningful identifier for tasks that are variables
+ -- and components of variables.
+
+ procedure Free_Task_Image is new
+ Unchecked_Deallocation (String, Task_Image_Type);
+
+ Unspecified_Task_Info : constant Task_Info_Type := null;
+ -- Value passed to task in the absence of a Task_Info pragma
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.13 $
+-- --
+-- Copyright (C) 1998-1999 Free Software Fundation --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the IRIX & NT version of this package.
+
+with Ada.Task_Identification;
+-- used for Task_Id
+
+with Ada.Exceptions;
+-- used for Raise_Exception
+
+with System.OS_Interface;
+-- used for intr_attach
+
+with System.Storage_Elements;
+-- used for To_Address
+-- To_Integer
+
+with System.Task_Primitives.Operations;
+-- used for Self
+-- Sleep
+-- Wakeup
+-- Write_Lock
+-- Unlock
+
+with System.Tasking.Utilities;
+-- used for Make_Independent
+
+with System.Tasking.Rendezvous;
+-- used for Call_Simple
+
+with System.Tasking.Initialization;
+-- used for Defer_Abort
+-- Undefer_Abort
+
+with System.Interrupt_Management;
+
+with Interfaces.C;
+-- used for int
+
+with Unchecked_Conversion;
+
+package body System.Interrupts is
+
+ use Tasking;
+ use Ada.Exceptions;
+ use System.OS_Interface;
+ use Interfaces.C;
+
+ package STPO renames System.Task_Primitives.Operations;
+ package IMNG renames System.Interrupt_Management;
+
+ subtype int is Interfaces.C.int;
+
+ function To_System is new Unchecked_Conversion
+ (Ada.Task_Identification.Task_Id, Task_ID);
+
+ type Handler_Kind is (Unknown, Task_Entry, Protected_Procedure);
+
+ type Handler_Desc is record
+ Kind : Handler_Kind := Unknown;
+ T : Task_ID;
+ E : Task_Entry_Index;
+ H : Parameterless_Handler;
+ Static : Boolean := False;
+ end record;
+
+ task type Server_Task (Interrupt : Interrupt_ID) is
+ pragma Interrupt_Priority (System.Interrupt_Priority'Last);
+ end Server_Task;
+
+ type Server_Task_Access is access Server_Task;
+
+ Attached_Interrupts : array (Interrupt_ID) of Boolean;
+ Handlers : array (Interrupt_ID) of Task_ID;
+ Descriptors : array (Interrupt_ID) of Handler_Desc;
+ Interrupt_Count : array (Interrupt_ID) of Integer := (others => 0);
+
+ pragma Volatile_Components (Interrupt_Count);
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean);
+ -- This internal procedure is needed to finalize protected objects
+ -- that contain interrupt handlers.
+
+ procedure Signal_Handler (Sig : Interrupt_ID);
+ -- This procedure is used to handle all the signals.
+
+ -- Type and Head, Tail of the list containing Registered Interrupt
+ -- Handlers. These definitions are used to register the handlers
+ -- specified by the pragma Interrupt_Handler.
+
+ --
+ -- Handler Registration:
+ --
+
+ type Registered_Handler;
+ type R_Link is access all Registered_Handler;
+
+ type Registered_Handler is record
+ H : System.Address := System.Null_Address;
+ Next : R_Link := null;
+ end record;
+
+ Registered_Handlers : R_Link := null;
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean;
+ -- See if the Handler has been "pragma"ed using Interrupt_Handler.
+ -- Always consider a null handler as registered.
+
+ type Handler_Ptr is access procedure (Sig : Interrupt_ID);
+
+ function TISR is new Unchecked_Conversion (Handler_Ptr, isr_address);
+
+ procedure Signal_Handler (Sig : Interrupt_ID) is
+ Handler : Task_ID renames Handlers (Sig);
+ begin
+ if Intr_Attach_Reset and then
+ intr_attach (int (Sig), TISR (Signal_Handler'Access)) = FUNC_ERR
+ then
+ raise Program_Error;
+ end if;
+
+ if Handler /= null then
+ Interrupt_Count (Sig) := Interrupt_Count (Sig) + 1;
+ STPO.Wakeup (Handler, Interrupt_Server_Idle_Sleep);
+ end if;
+ end Signal_Handler;
+
+ -----------------
+ -- Is_Reserved --
+ -----------------
+
+ function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt));
+ end Is_Reserved;
+
+ -----------------------
+ -- Is_Entry_Attached --
+ -----------------------
+
+ function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ return Descriptors (Interrupt).T /= Null_Task;
+ end Is_Entry_Attached;
+
+ -------------------------
+ -- Is_Handler_Attached --
+ -------------------------
+
+ function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ return Descriptors (Interrupt).Kind /= Unknown;
+ end Is_Handler_Attached;
+
+ ----------------
+ -- Is_Ignored --
+ ----------------
+
+ function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ raise Program_Error;
+ return False;
+ end Is_Ignored;
+
+ ------------------
+ -- Unblocked_By --
+ ------------------
+
+ function Unblocked_By (Interrupt : Interrupt_ID) return Task_ID is
+ begin
+ raise Program_Error;
+ return Null_Task;
+ end Unblocked_By;
+
+ ----------------------
+ -- Ignore_Interrupt --
+ ----------------------
+
+ procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ raise Program_Error;
+ end Ignore_Interrupt;
+
+ ------------------------
+ -- Unignore_Interrupt --
+ ------------------------
+
+ procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ raise Program_Error;
+ end Unignore_Interrupt;
+
+ -------------------------------------
+ -- Has_Interrupt_Or_Attach_Handler --
+ -------------------------------------
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Dynamic_Interrupt_Protection) return Boolean is
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ ----------------
+ -- Finalize --
+ ----------------
+
+ procedure Finalize (Object : in out Static_Interrupt_Protection) is
+ begin
+ -- ??? loop to be executed only when we're not doing library level
+ -- finalization, since in this case all interrupt tasks are gone.
+
+ for N in reverse Object.Previous_Handlers'Range loop
+ Attach_Handler
+ (New_Handler => Object.Previous_Handlers (N).Handler,
+ Interrupt => Object.Previous_Handlers (N).Interrupt,
+ Static => Object.Previous_Handlers (N).Static,
+ Restoration => True);
+ end loop;
+
+ Tasking.Protected_Objects.Entries.Finalize
+ (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
+ end Finalize;
+
+ -------------------------------------
+ -- Has_Interrupt_Or_Attach_Handler --
+ -------------------------------------
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Static_Interrupt_Protection)
+ return Boolean
+ is
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ ----------------------
+ -- Install_Handlers --
+ ----------------------
+
+ procedure Install_Handlers
+ (Object : access Static_Interrupt_Protection;
+ New_Handlers : in New_Handler_Array)
+ is
+ begin
+ for N in New_Handlers'Range loop
+
+ -- We need a lock around this ???
+
+ Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
+ Object.Previous_Handlers (N).Static := Descriptors
+ (New_Handlers (N).Interrupt).Static;
+
+ -- We call Exchange_Handler and not directly Interrupt_Manager.
+ -- Exchange_Handler so we get the Is_Reserved check.
+
+ Exchange_Handler
+ (Old_Handler => Object.Previous_Handlers (N).Handler,
+ New_Handler => New_Handlers (N).Handler,
+ Interrupt => New_Handlers (N).Interrupt,
+ Static => True);
+ end loop;
+ end Install_Handlers;
+
+ ---------------------
+ -- Current_Handler --
+ ---------------------
+
+ function Current_Handler (Interrupt : Interrupt_ID)
+ return Parameterless_Handler is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if Descriptors (Interrupt).Kind = Protected_Procedure then
+ return Descriptors (Interrupt).H;
+ else
+ return null;
+ end if;
+ end Current_Handler;
+
+ --------------------
+ -- Attach_Handler --
+ --------------------
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False) is
+ begin
+ Attach_Handler (New_Handler, Interrupt, Static, False);
+ end Attach_Handler;
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean)
+ is
+ New_Task : Server_Task_Access;
+
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if not Restoration and then not Static
+
+ -- Tries to overwrite a static Interrupt Handler with a
+ -- dynamic Handler
+
+ and then (Descriptors (Interrupt).Static
+
+ -- The new handler is not specified as an
+ -- Interrupt Handler by a pragma.
+
+ or else not Is_Registered (New_Handler))
+ then
+ Raise_Exception (Program_Error'Identity,
+ "Trying to overwrite a static Interrupt Handler with a " &
+ "dynamic Handler");
+ end if;
+
+ if Handlers (Interrupt) = null then
+ New_Task := new Server_Task (Interrupt);
+ Handlers (Interrupt) := To_System (New_Task.all'Identity);
+ end if;
+
+ if intr_attach (int (Interrupt),
+ TISR (Signal_Handler'Access)) = FUNC_ERR
+ then
+ raise Program_Error;
+ end if;
+
+ if New_Handler = null then
+
+ -- The null handler means we are detaching the handler.
+
+ Attached_Interrupts (Interrupt) := False;
+ Descriptors (Interrupt) :=
+ (Kind => Unknown, T => null, E => 0, H => null, Static => False);
+
+ else
+ Descriptors (Interrupt).Kind := Protected_Procedure;
+ Descriptors (Interrupt).H := New_Handler;
+ Descriptors (Interrupt).Static := Static;
+ Attached_Interrupts (Interrupt) := True;
+ end if;
+ end Attach_Handler;
+
+ ----------------------
+ -- Exchange_Handler --
+ ----------------------
+
+ procedure Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False) is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if Descriptors (Interrupt).Kind = Task_Entry then
+
+ -- In case we have an Interrupt Entry already installed.
+ -- raise a program error. (propagate it to the caller).
+
+ Raise_Exception (Program_Error'Identity,
+ "An interrupt is already installed");
+ end if;
+
+ Old_Handler := Current_Handler (Interrupt);
+ Attach_Handler (New_Handler, Interrupt, Static);
+ end Exchange_Handler;
+
+ --------------------
+ -- Detach_Handler --
+ --------------------
+
+ procedure Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean := False) is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if Descriptors (Interrupt).Kind = Task_Entry then
+ Raise_Exception (Program_Error'Identity,
+ "Trying to detach an Interrupt Entry");
+ end if;
+
+ if not Static and then Descriptors (Interrupt).Static then
+ Raise_Exception (Program_Error'Identity,
+ "Trying to detach a static Interrupt Handler");
+ end if;
+
+ Attached_Interrupts (Interrupt) := False;
+ Descriptors (Interrupt) :=
+ (Kind => Unknown, T => null, E => 0, H => null, Static => False);
+
+ if intr_attach (int (Interrupt), null) = FUNC_ERR then
+ raise Program_Error;
+ end if;
+ end Detach_Handler;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference (Interrupt : Interrupt_ID) return System.Address is
+ Signal : System.Address :=
+ System.Storage_Elements.To_Address
+ (System.Storage_Elements.Integer_Address (Interrupt));
+
+ begin
+ if Is_Reserved (Interrupt) then
+ -- Only usable Interrupts can be used for binding it to an Entry.
+ raise Program_Error;
+ end if;
+
+ return Signal;
+ end Reference;
+
+ --------------------------------
+ -- Register_Interrupt_Handler --
+ --------------------------------
+
+ procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
+ begin
+ Registered_Handlers :=
+ new Registered_Handler'(H => Handler_Addr, Next => Registered_Handlers);
+ end Register_Interrupt_Handler;
+
+ -------------------
+ -- Is_Registered --
+ -------------------
+
+ -- See if the Handler has been "pragma"ed using Interrupt_Handler.
+ -- Always consider a null handler as registered.
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean is
+ Ptr : R_Link := Registered_Handlers;
+
+ type Fat_Ptr is record
+ Object_Addr : System.Address;
+ Handler_Addr : System.Address;
+ end record;
+
+ function To_Fat_Ptr is new Unchecked_Conversion
+ (Parameterless_Handler, Fat_Ptr);
+
+ Fat : Fat_Ptr;
+
+ begin
+ if Handler = null then
+ return True;
+ end if;
+
+ Fat := To_Fat_Ptr (Handler);
+
+ while Ptr /= null loop
+
+ if Ptr.H = Fat.Handler_Addr then
+ return True;
+ end if;
+
+ Ptr := Ptr.Next;
+ end loop;
+
+ return False;
+ end Is_Registered;
+
+ -----------------------------
+ -- Bind_Interrupt_To_Entry --
+ -----------------------------
+
+ procedure Bind_Interrupt_To_Entry
+ (T : Task_ID;
+ E : Task_Entry_Index;
+ Int_Ref : System.Address)
+ is
+ Interrupt : constant Interrupt_ID :=
+ Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
+
+ New_Task : Server_Task_Access;
+
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if Descriptors (Interrupt).Kind /= Unknown then
+ Raise_Exception (Program_Error'Identity,
+ "A binding for this interrupt is already present");
+ end if;
+
+ if Handlers (Interrupt) = null then
+ New_Task := new Server_Task (Interrupt);
+ Handlers (Interrupt) := To_System (New_Task.all'Identity);
+ end if;
+
+ if intr_attach (int (Interrupt),
+ TISR (Signal_Handler'Access)) = FUNC_ERR
+ then
+ raise Program_Error;
+ end if;
+
+ Descriptors (Interrupt).Kind := Task_Entry;
+ Descriptors (Interrupt).T := T;
+ Descriptors (Interrupt).E := E;
+
+ -- Indicate the attachment of Interrupt Entry in ATCB.
+ -- This is need so that when an Interrupt Entry task terminates
+ -- the binding can be cleaned. The call to unbinding must be
+ -- make by the task before it terminates.
+
+ T.Interrupt_Entry := True;
+
+ Attached_Interrupts (Interrupt) := True;
+ end Bind_Interrupt_To_Entry;
+
+ ------------------------------
+ -- Detach_Interrupt_Entries --
+ ------------------------------
+
+ procedure Detach_Interrupt_Entries (T : Task_ID) is
+ begin
+ for I in Interrupt_ID loop
+ if not Is_Reserved (I) then
+ if Descriptors (I).Kind = Task_Entry and then
+ Descriptors (I).T = T then
+ Attached_Interrupts (I) := False;
+ Descriptors (I).Kind := Unknown;
+
+ if intr_attach (int (I), null) = FUNC_ERR then
+ raise Program_Error;
+ end if;
+ end if;
+ end if;
+ end loop;
+
+ -- Indicate in ATCB that no Interrupt Entries are attached.
+
+ T.Interrupt_Entry := True;
+ end Detach_Interrupt_Entries;
+
+ ---------------------
+ -- Block_Interrupt --
+ ---------------------
+
+ procedure Block_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ raise Program_Error;
+ end Block_Interrupt;
+
+ -----------------------
+ -- Unblock_Interrupt --
+ -----------------------
+
+ procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ raise Program_Error;
+ end Unblock_Interrupt;
+
+ ----------------
+ -- Is_Blocked --
+ ----------------
+
+ function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ raise Program_Error;
+ return False;
+ end Is_Blocked;
+
+ task body Server_Task is
+ Desc : Handler_Desc renames Descriptors (Interrupt);
+ Self_Id : Task_ID := STPO.Self;
+ Temp : Parameterless_Handler;
+
+ begin
+ Utilities.Make_Independent;
+
+ loop
+ while Interrupt_Count (Interrupt) > 0 loop
+ Interrupt_Count (Interrupt) := Interrupt_Count (Interrupt) - 1;
+ begin
+ case Desc.Kind is
+ when Unknown =>
+ null;
+ when Task_Entry =>
+ Rendezvous.Call_Simple (Desc.T, Desc.E, Null_Address);
+ when Protected_Procedure =>
+ Temp := Desc.H;
+ Temp.all;
+ end case;
+ exception
+ when others => null;
+ end;
+ end loop;
+
+ Initialization.Defer_Abort (Self_Id);
+ STPO.Write_Lock (Self_Id);
+ Self_Id.Common.State := Interrupt_Server_Idle_Sleep;
+ STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep);
+ Self_Id.Common.State := Runnable;
+ STPO.Unlock (Self_Id);
+ Initialization.Undefer_Abort (Self_Id);
+
+ -- Undefer abort here to allow a window for this task
+ -- to be aborted at the time of system shutdown.
+
+ end loop;
+ end Server_Task;
+
+end System.Interrupts;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.6 $ --
+-- --
+-- Copyright (C) 1997-1998, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is an Irix (old pthread library) version of this package.
+
+-- PLEASE DO NOT add any dependences on other packages.
+-- This package is designed to work with or without tasking support.
+
+-- Make a careful study of all signals available under the OS,
+-- to see which need to be reserved, kept always unmasked,
+-- or kept always unmasked.
+-- Be on the lookout for special signals that
+-- may be used by the thread library.
+
+with System.OS_Interface;
+-- used for various Constants, Signal and types
+
+package body System.Interrupt_Management is
+
+ use System.OS_Interface;
+
+ type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
+
+ Exception_Interrupts : constant Interrupt_List :=
+ (SIGILL,
+ SIGABRT,
+ SIGFPE,
+ SIGSEGV,
+ SIGBUS);
+
+ Reserved_Interrupts : constant Interrupt_List :=
+ (0,
+ SIGTRAP,
+ SIGKILL,
+ SIGSYS,
+ SIGALRM,
+ SIGSTOP,
+ SIGPTINTR,
+ SIGPTRESCHED);
+
+ Abort_Signal : constant := 48;
+ --
+ -- Serious MOJO: The SGI pthreads library only supports the
+ -- unnamed signal number 48 for pthread_kill!
+ --
+
+ ----------------------
+ -- Notify_Exception --
+ ----------------------
+
+ -- This function identifies the Ada exception to be raised using the
+ -- information when the system received a synchronous signal.
+ -- Since this function is machine and OS dependent, different code has to
+ -- be provided for different target.
+ -- On SGI, the signal handling is done is a-init.c, even when tasking is
+ -- involved.
+
+ ---------------------------
+ -- Initialize_Interrupts --
+ ---------------------------
+
+ -- Nothing needs to be done on this platform.
+
+ procedure Initialize_Interrupts is
+ begin
+ null;
+ end Initialize_Interrupts;
+
+begin
+ Abort_Task_Interrupt := Abort_Signal;
+
+ for I in Reserved_Interrupts'Range loop
+ Keep_Unmasked (Reserved_Interrupts (I)) := True;
+ Reserve (Reserved_Interrupts (I)) := True;
+ end loop;
+
+ for I in Exception_Interrupts'Range loop
+ Keep_Unmasked (Exception_Interrupts (I)) := True;
+ Reserve (Reserved_Interrupts (I)) := True;
+ end loop;
+
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- SYSTEM.MACHINE_STATE_OPERATIONS --
+-- --
+-- B o d y --
+-- (Version for IRIX/MIPS) --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- Copyright (C) 1999-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This version of Ada.Exceptions.Machine_State_Operations is for use on
+-- SGI Irix systems. By means of compile time conditional calculations, it
+-- can handle both n32/n64 and o32 modes.
+
+with System.Machine_Code; use System.Machine_Code;
+with System.Memory;
+with System.Soft_Links; use System.Soft_Links;
+with Unchecked_Conversion;
+
+package body System.Machine_State_Operations is
+
+ use System.Storage_Elements;
+ use System.Exceptions;
+
+ -- The exc_unwind function in libexc operats on a Sigcontext
+
+ -- Type sigcontext_t is defined in /usr/include/sys/signal.h.
+ -- We define an equivalent Ada type here. From the comments in
+ -- signal.h:
+
+ -- sigcontext is not part of the ABI - so this version is used to
+ -- handle 32 and 64 bit applications - it is a constant size regardless
+ -- of compilation mode, and always returns 64 bit register values
+
+ type Uns32 is mod 2 ** 32;
+ type Uns64 is mod 2 ** 64;
+
+ type Uns32_Ptr is access all Uns32;
+ type Uns64_Array is array (Integer range <>) of Uns64;
+
+ type Reg_Array is array (0 .. 31) of Uns64;
+
+ type Sigcontext is
+ record
+ SC_Regmask : Uns32; -- 0
+ SC_Status : Uns32; -- 4
+ SC_PC : Uns64; -- 8
+ SC_Regs : Reg_Array; -- 16
+ SC_Fpregs : Reg_Array; -- 272
+ SC_Ownedfp : Uns32; -- 528
+ SC_Fpc_Csr : Uns32; -- 532
+ SC_Fpc_Eir : Uns32; -- 536
+ SC_Ssflags : Uns32; -- 540
+ SC_Mdhi : Uns64; -- 544
+ SC_Mdlo : Uns64; -- 552
+ SC_Cause : Uns64; -- 560
+ SC_Badvaddr : Uns64; -- 568
+ SC_Triggersave : Uns64; -- 576
+ SC_Sigset : Uns64; -- 584
+ SC_Fp_Rounded_Result : Uns64; -- 592
+ SC_Pancake : Uns64_Array (0 .. 5);
+ SC_Pad : Uns64_Array (0 .. 26);
+ end record;
+
+ type Sigcontext_Ptr is access all Sigcontext;
+
+ SC_Regs_Pos : constant String := "16";
+ SC_Fpregs_Pos : constant String := "272";
+ -- Byte offset of the Integer and Floating Point register save areas
+ -- within the Sigcontext.
+
+ function To_Sigcontext_Ptr is
+ new Unchecked_Conversion (Machine_State, Sigcontext_Ptr);
+
+ type Addr_Int is mod 2 ** Long_Integer'Size;
+ -- An unsigned integer type whose size is the same as System.Address.
+ -- We rely on the fact that Long_Integer'Size = System.Address'Size in
+ -- all ABIs. Type Addr_Int can be converted to Uns64.
+
+ function To_Code_Loc is new Unchecked_Conversion (Addr_Int, Code_Loc);
+ function To_Addr_Int is new Unchecked_Conversion (System.Address, Addr_Int);
+ function To_Uns32_Ptr is new Unchecked_Conversion (Addr_Int, Uns32_Ptr);
+
+ --------------------------------
+ -- ABI-Dependant Declarations --
+ --------------------------------
+
+ o32 : constant Natural := Boolean'Pos (System.Word_Size = 32);
+ n32 : constant Natural := Boolean'Pos (System.Word_Size = 64);
+ -- Flags to indicate which ABI is in effect for this compilation. For the
+ -- purposes of this unit, the n32 and n64 ABI's are identical.
+
+ LSC : constant Character := Character'Val (o32 * Character'Pos ('w') +
+ n32 * Character'Pos ('d'));
+ -- This is 'w' for o32, and 'd' for n32/n64, used for constructing the
+ -- load/store instructions used to save/restore machine instructions.
+
+ Roff : constant Character := Character'Val (o32 * Character'Pos ('4') +
+ n32 * Character'Pos (' '));
+ -- Offset from first byte of a __uint64 register save location where
+ -- the register value is stored. For n32/64 we store the entire 64
+ -- bit register into the uint64. For o32, only 32 bits are stored
+ -- at an offset of 4 bytes.
+
+ procedure Update_GP (Scp : Sigcontext_Ptr);
+
+ ---------------
+ -- Update_GP --
+ ---------------
+
+ procedure Update_GP (Scp : Sigcontext_Ptr) is
+
+ type F_op is mod 2 ** 6;
+ type F_reg is mod 2 ** 5;
+ type F_imm is new Short_Integer;
+
+ type I_Type is record
+ op : F_op;
+ rs : F_reg;
+ rt : F_reg;
+ imm : F_imm;
+ end record;
+
+ pragma Pack (I_Type);
+ for I_Type'Size use 32;
+
+ type I_Type_Ptr is access all I_Type;
+
+ LW : constant F_op := 2#100011#;
+ Reg_GP : constant := 28;
+
+ type Address_Int is mod 2 ** Standard'Address_Size;
+ function To_I_Type_Ptr is new
+ Unchecked_Conversion (Address_Int, I_Type_Ptr);
+
+ Ret_Ins : I_Type_Ptr := To_I_Type_Ptr (Address_Int (Scp.SC_PC));
+ GP_Ptr : Uns32_Ptr;
+
+ begin
+ if Ret_Ins.op = LW and then Ret_Ins.rt = Reg_GP then
+ GP_Ptr := To_Uns32_Ptr
+ (Addr_Int (Scp.SC_Regs (Integer (Ret_Ins.rs)))
+ + Addr_Int (Ret_Ins.imm));
+ Scp.SC_Regs (Reg_GP) := Uns64 (GP_Ptr.all);
+ end if;
+ end Update_GP;
+
+ ----------------------------
+ -- Allocate_Machine_State --
+ ----------------------------
+
+ function Allocate_Machine_State return Machine_State is
+ begin
+ return Machine_State
+ (Memory.Alloc (Sigcontext'Max_Size_In_Storage_Elements));
+ end Allocate_Machine_State;
+
+ -------------------
+ -- Enter_Handler --
+ -------------------
+
+ procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
+
+ LOADI : constant String (1 .. 2) := 'l' & LSC;
+ -- This is "lw" in o32 mode, and "ld" in n32/n64 mode
+
+ LOADF : constant String (1 .. 4) := 'l' & LSC & "c1";
+ -- This is "lwc1" in o32 mode and "ldc1" in n32/n64 mode
+
+ begin
+ -- Restore integer registers from machine state. Note that we know
+ -- that $4 points to M, and $5 points to Handler, since this is
+ -- the standard calling sequence
+
+ Asm (LOADI & " $16, 16*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (LOADI & " $17, 17*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (LOADI & " $18, 18*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (LOADI & " $19, 19*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (LOADI & " $20, 20*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (LOADI & " $21, 21*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (LOADI & " $22, 22*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (LOADI & " $23, 23*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (LOADI & " $24, 24*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (LOADI & " $25, 25*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (LOADI & " $26, 26*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (LOADI & " $27, 27*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (LOADI & " $28, 28*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (LOADI & " $29, 29*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (LOADI & " $30, 30*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (LOADI & " $31, 31*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+
+ -- Restore floating-point registers from machine state
+
+ Asm (LOADF & " $f16, 16*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (LOADF & " $f17, 17*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (LOADF & " $f18, 18*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (LOADF & " $f19, 19*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (LOADF & " $f20, 20*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (LOADF & " $f21, 21*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (LOADF & " $f22, 22*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (LOADF & " $f23, 23*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (LOADF & " $f24, 24*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (LOADF & " $f25, 25*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (LOADF & " $f26, 26*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (LOADF & " $f27, 27*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (LOADF & " $f28, 28*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (LOADF & " $f29, 29*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (LOADF & " $f30, 30*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (LOADF & " $f31, 31*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+
+ -- Jump directly to the handler
+
+ Asm ("jr $5");
+ end Enter_Handler;
+
+ ----------------
+ -- Fetch_Code --
+ ----------------
+
+ function Fetch_Code (Loc : Code_Loc) return Code_Loc is
+ begin
+ return Loc;
+ end Fetch_Code;
+
+ ------------------------
+ -- Free_Machine_State --
+ ------------------------
+
+ procedure Free_Machine_State (M : in out Machine_State) is
+ procedure Gnat_Free (M : in Machine_State);
+ pragma Import (C, Gnat_Free, "__gnat_free");
+
+ begin
+ Gnat_Free (M);
+ M := Machine_State (Null_Address);
+ end Free_Machine_State;
+
+ ------------------
+ -- Get_Code_Loc --
+ ------------------
+
+ function Get_Code_Loc (M : Machine_State) return Code_Loc is
+ SC : constant Sigcontext_Ptr := To_Sigcontext_Ptr (M);
+ begin
+ return To_Code_Loc (Addr_Int (SC.SC_PC));
+ end Get_Code_Loc;
+
+ --------------------------
+ -- Machine_State_Length --
+ --------------------------
+
+ function Machine_State_Length return Storage_Offset is
+ begin
+ return Sigcontext'Max_Size_In_Storage_Elements;
+ end Machine_State_Length;
+
+ ---------------
+ -- Pop_Frame --
+ ---------------
+
+ procedure Pop_Frame
+ (M : Machine_State;
+ Info : Subprogram_Info_Type)
+ is
+ Scp : Sigcontext_Ptr := To_Sigcontext_Ptr (M);
+
+ procedure Exc_Unwind (Scp : Sigcontext_Ptr; Fde : Long_Integer := 0);
+ pragma Import (C, Exc_Unwind, "exc_unwind");
+ pragma Linker_Options ("-lexc");
+
+ begin
+ -- exc_unwind is apparently not thread-safe under IRIX, so protect it
+ -- against race conditions within the GNAT run time.
+ -- ??? Note that we might want to use a fine grained lock here since
+ -- Lock_Task is used in many other places.
+
+ Lock_Task.all;
+ Exc_Unwind (Scp);
+ Unlock_Task.all;
+
+ if Scp.SC_PC = 0 or else Scp.SC_PC = 1 then
+
+ -- A return value of 0 or 1 means exc_unwind couldn't find a parent
+ -- frame. Propagate_Exception expects a zero return address to
+ -- indicate TOS.
+
+ Scp.SC_PC := 0;
+
+ else
+
+ -- Set the GP to restore to the caller value (not callee value)
+ -- This is done only in o32 mode. In n32/n64 mode, GP is a normal
+ -- callee save register
+
+ if o32 = 1 then
+ Update_GP (Scp);
+ end if;
+
+ -- Adjust the return address to the call site, not the
+ -- instruction following the branch delay slot. This may
+ -- be necessary if the last instruction of a pragma No_Return
+ -- subprogram is a call. The first instruction following the
+ -- delay slot may be the start of another subprogram. We back
+ -- off the address by 8, which points safely into the middle
+ -- of the generated subprogram code, avoiding end effects.
+
+ Scp.SC_PC := Scp.SC_PC - 8;
+ end if;
+ end Pop_Frame;
+
+ -----------------------
+ -- Set_Machine_State --
+ -----------------------
+
+ procedure Set_Machine_State (M : Machine_State) is
+
+ STOREI : constant String (1 .. 2) := 's' & LSC;
+ -- This is "sw" in o32 mode, and "sd" in n32 mode
+
+ STOREF : constant String (1 .. 4) := 's' & LSC & "c1";
+ -- This is "swc1" in o32 mode and "sdc1" in n32 mode
+
+ Scp : Sigcontext_Ptr;
+
+ begin
+ -- Save the integer registers. Note that we know that $4 points
+ -- to M, since that is where the first parameter is passed.
+ -- Restore integer registers from machine state. Note that we know
+ -- that $4 points to M since this is the standard calling sequence
+
+ <<Past_Prolog>>
+
+ Asm (STOREI & " $16, 16*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (STOREI & " $17, 17*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (STOREI & " $18, 18*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (STOREI & " $19, 19*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (STOREI & " $20, 20*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (STOREI & " $21, 21*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (STOREI & " $22, 22*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (STOREI & " $23, 23*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (STOREI & " $24, 24*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (STOREI & " $25, 25*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (STOREI & " $26, 26*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (STOREI & " $27, 27*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (STOREI & " $28, 28*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (STOREI & " $29, 29*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (STOREI & " $30, 30*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+ Asm (STOREI & " $31, 31*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
+
+ -- Restore floating-point registers from machine state
+
+ Asm (STOREF & " $f16, 16*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (STOREF & " $f17, 17*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (STOREF & " $f18, 18*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (STOREF & " $f19, 19*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (STOREF & " $f20, 20*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (STOREF & " $f21, 21*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (STOREF & " $f22, 22*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (STOREF & " $f23, 23*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (STOREF & " $f24, 24*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (STOREF & " $f25, 25*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (STOREF & " $f26, 26*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (STOREF & " $f27, 27*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (STOREF & " $f28, 28*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (STOREF & " $f29, 29*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (STOREF & " $f30, 30*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+ Asm (STOREF & " $f31, 31*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
+
+ -- Set the PC value for the context to a location after the
+ -- prolog has been executed.
+
+ Scp := To_Sigcontext_Ptr (M);
+ Scp.SC_PC := Uns64 (To_Addr_Int (Past_Prolog'Address));
+
+ -- We saved the state *inside* this routine, but what we want is
+ -- the state at the call site. So we need to do one pop operation.
+ -- This pop operation will properly set the PC value in the machine
+ -- state, so there is no need to save PC in the above code.
+
+ Pop_Frame (M, Set_Machine_State'Address);
+ end Set_Machine_State;
+
+ ------------------------------
+ -- Set_Signal_Machine_State --
+ ------------------------------
+
+ procedure Set_Signal_Machine_State
+ (M : Machine_State;
+ Context : System.Address) is
+ begin
+ null;
+ end Set_Signal_Machine_State;
+
+end System.Machine_State_Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.20 $
+-- --
+-- Copyright (C) 1997-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is an Irix (old pthread library) version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces;
+with Interfaces.C;
+with Interfaces.C.Strings;
+
+package System.OS_Interface is
+
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lathread");
+
+ 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;
+ subtype chars_ptr is Interfaces.C.Strings.chars_ptr;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EINTR : constant := 4; -- interrupted system call
+ EAGAIN : constant := 11; -- No more processes
+ ENOMEM : constant := 12; -- Not enough core
+ EINVAL : constant := 22; -- Invalid argument
+ ETIMEDOUT : constant := 145; -- Connection timed out
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 64;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the
+ -- future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ SIGWINCH : constant := 20; -- window size change
+ SIGURG : constant := 21; -- urgent condition on IO channel
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias)
+ SIGSTOP : constant := 23; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 24; -- user stop requested from tty
+ SIGCONT : constant := 25; -- stopped process has been continued
+ SIGTTIN : constant := 26; -- background tty read attempted
+ SIGTTOU : constant := 27; -- background tty write attempted
+ SIGVTALRM : constant := 28; -- virtual timer expired
+ SIGPROF : constant := 29; -- profiling timer expired
+ SIGXCPU : constant := 30; -- CPU time limit exceeded
+ SIGXFSZ : constant := 31; -- filesize limit exceeded
+ SIGK32 : constant := 32; -- reserved for kernel (IRIX)
+ SIGCKPT : constant := 33; -- Checkpoint warning
+ SIGRESTART : constant := 34; -- Restart warning
+ SIGUME : constant := 35; -- Uncorrectable memory error
+ -- Signals defined for Posix 1003.1c.
+ SIGPTINTR : constant := 47;
+ SIGPTRESCHED : constant := 48;
+ -- Posix 1003.1b signals
+ SIGRTMIN : constant := 49; -- Posix 1003.1b signals
+ SIGRTMAX : constant := 64; -- Posix 1003.1b signals
+
+ type sigset_t is private;
+ type sigset_t_ptr is access all sigset_t;
+
+ 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 siginfo_t is record
+ si_signo : int;
+ si_code : int;
+ si_errno : int;
+ bit_field_substitute_1 : String (1 .. 116);
+ end record;
+ pragma Convention (C, siginfo_t);
+
+ type array_type_2 is array (Integer range 0 .. 1) of int;
+ type struct_sigaction is record
+ sa_flags : int;
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_resv : array_type_2;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr := null) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ type time_t is new int;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+ type timespec_ptr is access all timespec;
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ type timer_t is new Integer;
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+ CLOCK_SGI_FAST : constant clockid_t;
+ CLOCK_SGI_CYCLE : constant clockid_t;
+
+ SGI_CYCLECNTR_SIZE : constant := 165;
+ function syssgi (request : Interfaces.C.int) return Interfaces.C.ptrdiff_t;
+
+ pragma Import (C, syssgi, "syssgi");
+
+ 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; tp : access timespec) return int;
+ pragma Import (C, clock_getres, "clock_getres");
+
+ type struct_timeval is record
+ tv_sec : time_t;
+ tv_usec : time_t;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ function gettimeofday
+ (tv : access struct_timeval;
+ tz : System.Address := System.Null_Address) return int;
+ pragma Import (C, gettimeofday, "gettimeofday");
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 0;
+ SCHED_RR : constant := 0;
+ SCHED_OTHER : constant := 0;
+
+ -------------
+ -- 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");
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ procedure pthread_init;
+ pragma Inline (pthread_init);
+ -- This is a dummy procedure to share some GNULLI files
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+
+ type pthread_t is private; -- thread identifier
+ subtype Thread_Id is pthread_t;
+
+ type pthread_mutex_t is private; -- mutex identifier
+ type pthread_cond_t is private; -- cond identifier
+ type pthread_attr_t is private; -- pthread attributes
+ type pthread_mutexattr_t is private; -- mutex attributes
+ type pthread_condattr_t is private; -- mutex attributes
+ type sem_t is private; -- semaphore identifier
+ type pthread_key_t is private; -- per thread key
+
+ subtype pthread_once_t is int; -- dynamic package initialization
+ subtype resource_t is long; -- sproc. resource info.
+ type start_addr is access function (arg : Address) return Address;
+ type sproc_start_addr is access function (arg : Address) return int;
+ type callout_addr is
+ access function (arg : Address; arg1 : Address) return Address;
+
+ -- SGI specific types
+
+ subtype sproc_t is Address; -- sproc identifier
+ subtype sproc_attr_t is Address; -- sproc attributes
+
+ subtype spcb_p is Address;
+ subtype ptcb_p is Address;
+
+ -- Pthread Error Types
+
+ FUNC_OK : constant := 0;
+ FUNC_ERR : constant := -1;
+
+ -- pthread run-time initialization data structure
+
+ type pthread_init_struct is record
+ conf_initsize : int; -- shared area size
+ max_sproc_count : int; -- maximum number of sprocs
+ sproc_stack_size : size_t; -- sproc stack size
+ os_default_priority : int; -- default IRIX pri for main process
+ os_sched_signal : int; -- default OS scheduling signal
+ guard_pages : int; -- number of guard pages per stack
+ init_sproc_count : int; -- initial number of sprocs
+ end record;
+
+ --
+ -- Pthread Attribute Initialize / Destroy
+ --
+
+ function pthread_attr_init (attr : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_init, "pthread_attr_init");
+
+ function pthread_attr_destroy (attr : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
+
+ --
+ -- Thread Attributes
+ --
+
+ 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_attr_setdetachstate
+ (attr : access pthread_attr_t; detachstate : int) return int;
+ pragma Import (C, pthread_attr_setdetachstate);
+
+ function pthread_attr_setname
+ (attr : access pthread_attr_t; name : chars_ptr) return int;
+ pragma Import (C, pthread_attr_setname, "pthread_attr_setname");
+
+ --
+ -- Thread Scheduling Attributes
+ --
+
+ 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; inherit : int) return int;
+ pragma Import
+ (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched");
+
+ function pthread_attr_setsched
+ (attr : access pthread_attr_t; scheduler : int) return int;
+ pragma Import (C, pthread_attr_setsched, "pthread_attr_setsched");
+
+ function pthread_attr_setprio
+ (attr : access pthread_attr_t; priority : int) return int;
+ pragma Import (C, pthread_attr_setprio, "pthread_attr_setprio");
+
+ --
+ -- SGI Extensions to Thread Attributes
+ --
+
+ -- Bound to sproc attribute values
+
+ PTHREAD_BOUND : constant := 1;
+ PTHREAD_NOT_BOUND : constant := 0;
+
+ function pthread_attr_setresources
+ (attr : access pthread_attr_t; resources : resource_t) return int;
+ pragma Import (C, pthread_attr_setresources, "pthread_attr_setresources");
+
+ function pthread_attr_set_boundtosproc
+ (attr : access pthread_attr_t; bound_to_sproc : int) return int;
+ pragma Import
+ (C, pthread_attr_set_boundtosproc, "pthread_attr_set_boundtosproc");
+
+ function pthread_attr_set_bsproc
+ (attr : access pthread_attr_t; bsproc : spcb_p) return int;
+ pragma Import (C, pthread_attr_set_bsproc, "pthread_attr_set_bsproc");
+
+ function pthread_attr_set_tslice
+ (attr : access pthread_attr_t;
+ ts_interval : access struct_timeval) return int;
+ pragma Import (C, pthread_attr_set_tslice, "pthread_attr_set_tslice");
+
+ --
+ -- Thread Creation & Management
+ --
+
+ function pthread_create
+ (thread : access pthread_t;
+ attr : access pthread_attr_t;
+ start_routine : start_addr;
+ arg : Address) return int;
+ pragma Import (C, pthread_create, "pthread_create");
+
+ procedure pthread_exit (status : Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ procedure pthread_yield (arg : Address := System.Null_Address);
+ pragma Import (C, pthread_yield, "pthread_yield");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ function pthread_kill (thread : pthread_t; sig : int) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ --
+ -- SGI Extensions to POSIX thread operations
+ --
+
+ function pthread_setprio (thread : pthread_t; priority : int) return int;
+ pragma Import (C, pthread_setprio, "pthread_setprio");
+
+ function pthread_suspend (thread : pthread_t) return int;
+ pragma Import (C, pthread_suspend, "pthread_suspend");
+
+ function pthread_resume (thread : pthread_t) return int;
+ pragma Import (C, pthread_resume, "pthread_resume");
+
+ function pthread_get_current_ada_tcb return Address;
+ pragma Import (C, pthread_get_current_ada_tcb);
+
+ function pthread_set_ada_tcb
+ (thread : pthread_t; data : Address) return int;
+ pragma Import (C, pthread_set_ada_tcb, "pthread_set_ada_tcb");
+
+ -- Mutex Initialization / Destruction
+
+ 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_mutexattr_setqueueorder
+ (attr : access pthread_mutexattr_t; order : int) return int;
+ pragma Import (C, pthread_mutexattr_setqueueorder);
+
+ function pthread_mutexattr_setceilingprio
+ (attr : access pthread_mutexattr_t; priority : int) return int;
+ pragma Import (C, pthread_mutexattr_setceilingprio);
+
+ -- Mutex Attributes
+
+ -- Threads queueing order
+
+ MUTEX_PRIORITY : constant := 0; -- wait in priority order
+ MUTEX_FIFO : constant := 1; -- first-in-first-out
+ MUTEX_PRIORITY_INHERIT : constant := 2; -- priority inhertance mutex
+ MUTEX_PRIORITY_CEILING : constant := 3; -- priority ceiling mutex
+
+ -- Mutex debugging options
+
+ MUTEX_NO_DEBUG : constant := 0; -- no debugging on mutex
+ MUTEX_DEBUG : constant := 1; -- debugging is on
+
+ -- Mutex spin on lock operations
+
+ MUTEX_NO_SPIN : constant := 0; -- no spin, try once only
+ MUTEX_SPIN_ONLY : constant := -1; -- spin forever
+ -- cnt > 0, limited spin
+ -- Mutex sharing attributes
+
+ MUTEX_SHARED : constant := 0; -- shared between processes
+ MUTEX_NOTSHARED : constant := 1; -- not shared between processes
+
+ -- Mutex Operations
+
+ 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");
+
+ -- Condition Initialization / Destruction
+
+ 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");
+
+ -- Condition Attributes
+
+ COND_PRIORITY : constant := 0; -- wait in priority order
+ COND_FIFO : constant := 1; -- first-in-first-out
+
+ -- Condition debugging options
+
+ COND_NO_DEBUG : constant := 0; -- no debugging on mutex
+ COND_DEBUG : constant := 1; -- debugging is on
+
+ -- Condition sharing attributes
+
+ COND_SHARED : constant := 0; -- shared between processes
+ COND_NOTSHARED : constant := 1; -- not shared between processes
+
+ -- Condition Operations
+
+ 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 struct_timeval) return int;
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+
+ -- Thread-Specific Data
+
+ type foo_h_proc_1 is access procedure (value : Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t; destructor : foo_h_proc_1) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+ function pthread_setspecific
+ (key : pthread_key_t; value : Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific
+ (key : pthread_key_t; value : access Address) return int;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type foo_h_proc_2 is access procedure;
+
+ function pthread_exec_begin (init : access pthread_init_struct) return int;
+ pragma Import (C, pthread_exec_begin, "pthread_exec_begin");
+
+ function sproc_create
+ (sproc_id : access sproc_t;
+ attr : access sproc_attr_t;
+ start_routine : sproc_start_addr;
+ arg : Address) return int;
+ pragma Import (C, sproc_create, "sproc_create");
+
+ function sproc_self return sproc_t;
+ pragma Import (C, sproc_self, "sproc_self");
+
+ -- if equal fast TRUE is returned - common case
+ -- if not equal thread resource must NOT be null in order to compare bits
+
+ --
+ -- Sproc attribute initialize / destroy
+ --
+
+ function sproc_attr_init (attr : access sproc_attr_t) return int;
+ pragma Import (C, sproc_attr_init, "sproc_attr_init");
+
+ function sproc_attr_destroy (attr : access sproc_attr_t) return int;
+ pragma Import (C, sproc_attr_destroy, "sproc_attr_destroy");
+
+ function sproc_attr_setresources
+ (attr : access sproc_attr_t; resources : resource_t) return int;
+ pragma Import (C, sproc_attr_setresources, "sproc_attr_setresources");
+
+ function sproc_attr_getresources
+ (attr : access sproc_attr_t;
+ resources : access resource_t) return int;
+ pragma Import (C, sproc_attr_getresources, "sproc_attr_getresources");
+
+ function sproc_attr_setcpu
+ (attr : access sproc_attr_t; cpu_num : int) return int;
+ pragma Import (C, sproc_attr_setcpu, "sproc_attr_setcpu");
+
+ function sproc_attr_getcpu
+ (attr : access sproc_attr_t; cpu_num : access int) return int;
+ pragma Import (C, sproc_attr_getcpu, "sproc_attr_getcpu");
+
+ function sproc_attr_setresident
+ (attr : access sproc_attr_t; resident : int) return int;
+ pragma Import (C, sproc_attr_setresident, "sproc_attr_setresident");
+
+ function sproc_attr_getresident
+ (attr : access sproc_attr_t; resident : access int) return int;
+ pragma Import (C, sproc_attr_getresident, "sproc_attr_getresident");
+
+ function sproc_attr_setname
+ (attr : access sproc_attr_t; name : chars_ptr) return int;
+ pragma Import (C, sproc_attr_setname, "sproc_attr_setname");
+
+ function sproc_attr_getname
+ (attr : access sproc_attr_t; name : chars_ptr) return int;
+ pragma Import (C, sproc_attr_getname, "sproc_attr_getname");
+
+ function sproc_attr_setstacksize
+ (attr : access sproc_attr_t; stacksize : size_t) return int;
+ pragma Import (C, sproc_attr_setstacksize, "sproc_attr_setstacksize");
+
+ function sproc_attr_getstacksize
+ (attr : access sproc_attr_t; stacksize : access size_t) return int;
+ pragma Import (C, sproc_attr_getstacksize, "sproc_attr_getstacksize");
+
+ function sproc_attr_setprio
+ (attr : access sproc_attr_t; priority : int) return int;
+ pragma Import (C, sproc_attr_setprio, "sproc_attr_setprio");
+
+ function sproc_attr_getprio
+ (attr : access sproc_attr_t; priority : access int) return int;
+ pragma Import (C, sproc_attr_getprio, "sproc_attr_getprio");
+
+ function sproc_attr_setbthread
+ (attr : access sproc_attr_t; bthread : ptcb_p) return int;
+ pragma Import (C, sproc_attr_setbthread, "sproc_attr_setbthread");
+
+ function sproc_attr_getbthread
+ (attr : access sproc_attr_t; bthread : access ptcb_p) return int;
+ pragma Import (C, sproc_attr_getbthread, "sproc_attr_getbthread");
+
+ SPROC_NO_RESOURCES : constant := 0;
+ SPROC_ANY_CPU : constant := -1;
+ SPROC_MY_PRIORITY : constant := -1;
+ SPROC_SWAPPED : constant := 0;
+ SPROC_RESIDENT : constant := 1;
+
+ type isr_address is access procedure;
+
+ function intr_attach (sig : int; isr : isr_address) return int;
+ pragma Import (C, intr_attach, "intr_attach");
+
+ Intr_Attach_Reset : constant Boolean := False;
+ -- True if intr_attach is reset after an interrupt handler is called
+
+ function intr_exchange
+ (sig : int;
+ isr : isr_address;
+ oisr : access isr_address) return int;
+ pragma Import (C, intr_exchange, "intr_exchange");
+
+ function intr_current_isr
+ (sig : int;
+ oisr : access isr_address)
+ return int;
+ pragma Import (C, intr_current_isr, "intr_current_isr");
+
+private
+
+ type clockid_t is new int;
+
+ CLOCK_REALTIME : constant clockid_t := 1;
+ CLOCK_SGI_CYCLE : constant clockid_t := 2;
+ CLOCK_SGI_FAST : constant clockid_t := 3;
+
+ type pthread_t is new Address; -- thread identifier
+ type pthread_mutex_t is new Address; -- mutex identifier
+ type pthread_cond_t is new Address; -- cond identifier
+ type pthread_attr_t is new Address; -- pthread attributes
+ type pthread_mutexattr_t is new Address; -- mutex attributes
+ type pthread_condattr_t is new Address; -- mutex attributes
+ type sem_t is new Address; -- semaphore identifier
+ type pthread_key_t is new Address; -- per thread key
+
+ type sigbits_t is array (Integer range 0 .. 3) of unsigned;
+ type sigset_t is record
+ sigbits : sigbits_t;
+ end record;
+ pragma Convention (C, sigset_t);
+
+ type pid_t is new long;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P R O G R A M _ I N F O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- Copyright (C) 1997-1999 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is an Irix (old pthread library) version of this package.
+
+-- This package contains the parameters used by the run-time system at
+-- program startup. These parameters are isolated in this package body to
+-- facilitate replacement by the end user.
+--
+-- To replace the default values, copy this source file into your build
+-- directory, edit the file to reflect your desired behavior, and recompile
+-- with the command:
+--
+-- % gcc -c -O2 -gnatpg s-proinf.adb
+--
+-- then relink your application as usual.
+--
+
+with GNAT.OS_Lib;
+
+package body System.Program_Info is
+
+ Kbytes : constant := 1024;
+
+ Default_Initial_Sproc_Count : constant := 0;
+ Default_Max_Sproc_Count : constant := 128;
+ Default_Sproc_Stack_Size : constant := 16#4000#;
+ Default_Stack_Guard_Pages : constant := 1;
+ Default_Default_Time_Slice : constant := 0.0;
+ Default_Default_Task_Stack : constant := 12 * Kbytes;
+ Default_Pthread_Sched_Signal : constant := 35;
+ Default_Pthread_Arena_Size : constant := 16#40000#;
+ Default_Os_Default_Priority : constant := 0;
+
+ -------------------------
+ -- Initial_Sproc_Count --
+ -------------------------
+
+ function Initial_Sproc_Count return Integer is
+
+ function sysmp (P1 : Integer) return Integer;
+ pragma Import (C, sysmp, "sysmp", "sysmp");
+
+ MP_NPROCS : constant := 1; -- # processor in complex
+
+ Pthread_Sproc_Count : constant GNAT.OS_Lib.String_Access :=
+ GNAT.OS_Lib.Getenv ("PTHREAD_SPROC_COUNT");
+
+ begin
+ if Pthread_Sproc_Count.all'Length = 0 then
+ return Default_Initial_Sproc_Count;
+
+ elsif Pthread_Sproc_Count.all = "AUTO" then
+ return sysmp (MP_NPROCS);
+
+ else
+ return Integer'Value (Pthread_Sproc_Count.all);
+ end if;
+ exception
+ when others =>
+ return Default_Initial_Sproc_Count;
+ end Initial_Sproc_Count;
+
+ ---------------------
+ -- Max_Sproc_Count --
+ ---------------------
+
+ function Max_Sproc_Count return Integer is
+ Pthread_Max_Sproc_Count : constant GNAT.OS_Lib.String_Access :=
+ GNAT.OS_Lib.Getenv ("PTHREAD_MAX_SPROC_COUNT");
+
+ begin
+ if Pthread_Max_Sproc_Count.all'Length = 0 then
+ return Default_Max_Sproc_Count;
+ else
+ return Integer'Value (Pthread_Max_Sproc_Count.all);
+ end if;
+ exception
+ when others =>
+ return Default_Max_Sproc_Count;
+ end Max_Sproc_Count;
+
+ ----------------------
+ -- Sproc_Stack_Size --
+ ----------------------
+
+ function Sproc_Stack_Size return Integer is
+ begin
+ return Default_Sproc_Stack_Size;
+ end Sproc_Stack_Size;
+
+ ------------------------
+ -- Default_Time_Slice --
+ ------------------------
+
+ function Default_Time_Slice return Duration is
+ Pthread_Time_Slice_Sec : constant GNAT.OS_Lib.String_Access :=
+ GNAT.OS_Lib.Getenv ("PTHREAD_TIME_SLICE_SEC");
+ Pthread_Time_Slice_Usec : constant GNAT.OS_Lib.String_Access :=
+ GNAT.OS_Lib.Getenv ("PTHREAD_TIME_SLICE_USEC");
+
+ Val_Sec, Val_Usec : Integer := 0;
+
+ begin
+ if Pthread_Time_Slice_Sec.all'Length /= 0 or
+ Pthread_Time_Slice_Usec.all'Length /= 0
+ then
+ if Pthread_Time_Slice_Sec.all'Length /= 0 then
+ Val_Sec := Integer'Value (Pthread_Time_Slice_Sec.all);
+ end if;
+
+ if Pthread_Time_Slice_Usec.all'Length /= 0 then
+ Val_Usec := Integer'Value (Pthread_Time_Slice_Usec.all);
+ end if;
+
+ return Duration (Val_Sec) + Duration (Val_Usec) / 1000.0;
+ else
+ return Default_Default_Time_Slice;
+ end if;
+
+ exception
+ when others =>
+ return Default_Default_Time_Slice;
+ end Default_Time_Slice;
+
+ ------------------------
+ -- Default_Task_Stack --
+ ------------------------
+
+ function Default_Task_Stack return Integer is
+ begin
+ return Default_Default_Task_Stack;
+ end Default_Task_Stack;
+
+ -----------------------
+ -- Stack_Guard_Pages --
+ -----------------------
+
+ function Stack_Guard_Pages return Integer is
+ Pthread_Stack_Guard_Pages : constant GNAT.OS_Lib.String_Access :=
+ GNAT.OS_Lib.Getenv ("PTHREAD_STACK_GUARD_PAGES");
+
+ begin
+ if Pthread_Stack_Guard_Pages.all'Length /= 0 then
+ return Integer'Value (Pthread_Stack_Guard_Pages.all);
+ else
+ return Default_Stack_Guard_Pages;
+ end if;
+ exception
+ when others =>
+ return Default_Stack_Guard_Pages;
+ end Stack_Guard_Pages;
+
+ --------------------------
+ -- Pthread_Sched_Signal --
+ --------------------------
+
+ function Pthread_Sched_Signal return Integer is
+ begin
+ return Default_Pthread_Sched_Signal;
+ end Pthread_Sched_Signal;
+
+ ------------------------
+ -- Pthread_Arena_Size --
+ ------------------------
+
+ function Pthread_Arena_Size return Integer is
+ Pthread_Arena_Size : constant GNAT.OS_Lib.String_Access :=
+ GNAT.OS_Lib.Getenv ("PTHREAD_ARENA_SIZE");
+
+ begin
+ if Pthread_Arena_Size.all'Length = 0 then
+ return Default_Pthread_Arena_Size;
+ else
+ return Integer'Value (Pthread_Arena_Size.all);
+ end if;
+ exception
+ when others =>
+ return Default_Pthread_Arena_Size;
+ end Pthread_Arena_Size;
+
+ -------------------------
+ -- Os_Default_Priority --
+ -------------------------
+
+ function Os_Default_Priority return Integer is
+ begin
+ return Default_Os_Default_Priority;
+ end Os_Default_Priority;
+
+end System.Program_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P R O G R A M _ I N F O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 1997 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+-- This package contains the definitions and routines used as parameters
+-- to the run-time system at program startup for the SGI implementation.
+
+package System.Program_Info is
+
+ function Initial_Sproc_Count return Integer;
+ --
+ -- The number of sproc created at program startup for scheduling
+ -- threads.
+ --
+
+ function Max_Sproc_Count return Integer;
+ --
+ -- The maximum number of sprocs that can be created by the program
+ -- for servicing threads. This limit includes both the pre-created
+ -- sprocs and those explicitly created under program control.
+ --
+
+ function Sproc_Stack_Size return Integer;
+ --
+ -- The size, in bytes, of the sproc's initial stack.
+ --
+
+ function Default_Time_Slice return Duration;
+ --
+ -- The default time quanta for round-robin scheduling of threads of
+ -- equal priority. This default value can be overridden on a per-task
+ -- basis by specifying an alternate value via the implementation-defined
+ -- Task_Info pragma. See s-tasinf.ads for more information.
+ --
+
+ function Default_Task_Stack return Integer;
+ --
+ -- The default stack size for each created thread. This default value
+ -- can be overriden on a per-task basis by the language-defined
+ -- Storage_Size pragma.
+ --
+
+ function Stack_Guard_Pages return Integer;
+ --
+ -- The number of non-writable, guard pages to append to the bottom of
+ -- each thread's stack.
+ --
+
+ function Pthread_Sched_Signal return Integer;
+ --
+ -- The signal used by the Pthreads library to affect scheduling actions
+ -- in remote sprocs.
+ --
+
+ function Pthread_Arena_Size return Integer;
+ --
+ -- The size of the shared arena from which pthread locks are allocated.
+ -- See the usinit(3p) man page for more information on shared arenas.
+ --
+
+ function Os_Default_Priority return Integer;
+ --
+ -- The default Irix Non-Degrading priority for each sproc created to
+ -- service threads.
+ --
+
+end System.Program_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (SGI Irix, n32 ABI) --
+-- --
+-- $Revision: 1.19 $
+-- --
+-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ 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 := Integer'Last;
+
+ 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 := Standard'Tick;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := Standard'Storage_Unit;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Standard'Address_Size;
+
+ -- 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;
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer
+ range 0 .. Standard'Max_Interrupt_Priority;
+
+ subtype Priority is Any_Priority
+ range 0 .. Standard'Max_Priority;
+
+ -- Functional notation is needed in the following to avoid visibility
+ -- problems when this package is compiled through rtsfind in the middle
+ -- of another compilation.
+
+ subtype Interrupt_Priority is Any_Priority
+ range
+ Standard."+" (Standard'Max_Priority, 1) ..
+ Standard'Max_Interrupt_Priority;
+
+ Default_Priority : constant Priority :=
+ Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
+
+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.
+
+ AAMP : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Denorm : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := True;
+ Long_Shifts_Inlined : constant Boolean := True;
+ High_Integrity_Mode : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := True;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := True;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := True;
+
+ -- Note: Denorm is False because denormals are not supported on the
+ -- R10000, and we want the code to be valid for this processor.
+
+end System;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.37 $
+-- --
+-- Copyright (C) 1991-2001, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is an Irix (old athread library) version of this package
+
+-- 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 Interfaces.C;
+-- used for int
+-- size_t
+
+with System.Tasking.Debug;
+-- used for Known_Tasks
+
+with System.Task_Info;
+
+with System.Interrupt_Management;
+-- used for Keep_Unmasked
+-- Abort_Task_Interrupt
+-- Interrupt_ID
+
+with System.Parameters;
+-- used for Size_Type
+
+with System.Tasking;
+-- used for Ada_Task_Control_Block
+-- Task_ID
+
+with System.Program_Info;
+-- used for Default_Task_Stack
+-- Default_Time_Slice
+-- Stack_Guard_Pages
+-- Pthread_Sched_Signal
+-- Pthread_Arena_Size
+
+with System.Soft_Links;
+-- used for Defer/Undefer_Abort
+
+-- Note that we do not use System.Tasking.Initialization directly since
+-- this 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.Initialization
+
+with System.OS_Primitives;
+-- used for Delay_Modes
+
+with System.Storage_Elements;
+-- used for To_Address
+
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+package body System.Task_Primitives.Operations is
+
+ use System.Tasking.Debug;
+ use System.Tasking;
+ use Interfaces.C;
+ use System.OS_Interface;
+ use System.Parameters;
+ use System.OS_Primitives;
+
+ package SSL renames System.Soft_Links;
+
+ ------------------
+ -- Local Data --
+ ------------------
+
+ -- The followings are logically constants, but need to be initialized
+ -- at run time.
+
+ All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
+ -- See comments on locking rules in System.Tasking (spec).
+
+ 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",
+ "__gl_locking_policy");
+
+ Clock_Address : constant System.Address :=
+ System.Storage_Elements.To_Address (16#200F90#);
+
+ RT_Clock_Id : clockid_t;
+ for RT_Clock_Id'Address use Clock_Address;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Initialize_Athread_Library;
+
+ function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
+
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+
+ -------------------
+ -- Stack_Guard --
+ -------------------
+
+ -- The underlying thread system sets a guard page at the
+ -- bottom of a thread stack, so nothing is needed.
+ -- ??? Check the comment above
+
+ procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ begin
+ null;
+ end Stack_Guard;
+
+ --------------------
+ -- Get_Thread_Id --
+ --------------------
+
+ function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
+ begin
+ return T.Common.LL.Thread;
+ end Get_Thread_Id;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_ID is
+ begin
+ return To_Task_ID (pthread_get_current_ada_tcb);
+ end Self;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ -- Note: mutexes and cond_variables needed per-task basis are
+ -- initialized in Intialize_TCB and the Storage_Error is
+ -- handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...)
+ -- used in RTS is initialized before any status change of RTS.
+ -- Therefore rasing Storage_Error in the following routines
+ -- should be able to be handled safely.
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : access Lock)
+ is
+ Attributes : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutexattr_init (Attributes'Access);
+
+ if Result = FUNC_ERR then
+ raise Storage_Error;
+ end if;
+
+ if Locking_Policy = 'C' then
+
+ Result := pthread_mutexattr_setqueueorder
+ (Attributes'Access, MUTEX_PRIORITY_CEILING);
+
+ pragma Assert (Result /= FUNC_ERR);
+
+ Result := pthread_mutexattr_setceilingprio
+ (Attributes'Access, Interfaces.C.int (Prio));
+
+ pragma Assert (Result /= FUNC_ERR);
+ end if;
+
+ Result := pthread_mutex_init (L, Attributes'Access);
+
+ if Result = FUNC_ERR then
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ end Initialize_Lock;
+
+ procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
+ Attributes : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutexattr_init (Attributes'Access);
+
+ if Result = FUNC_ERR then
+ raise Storage_Error;
+ end if;
+
+ if Locking_Policy = 'C' then
+ Result := pthread_mutexattr_setqueueorder
+ (Attributes'Access, MUTEX_PRIORITY_CEILING);
+ pragma Assert (Result /= FUNC_ERR);
+
+ Result := pthread_mutexattr_setceilingprio
+ (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
+ pragma Assert (Result /= FUNC_ERR);
+ end if;
+
+ Result := pthread_mutex_init (L, Attributes'Access);
+
+ if Result = FUNC_ERR then
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_destroy (L);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : 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 : access Lock; Ceiling_Violation : out Boolean) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (L);
+
+ Ceiling_Violation := Result = FUNC_ERR and then errno = EINVAL;
+ pragma Assert (Result /= FUNC_ERR);
+ end Write_Lock;
+
+ procedure Write_Lock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ Write_Lock (L, Ceiling_Violation);
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ -------------
+ -- Sleep --
+ -------------
+
+ procedure Sleep
+ (Self_ID : ST.Task_ID;
+ Reason : System.Tasking.Task_States) is
+
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Self_ID = Self);
+ Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access);
+ -- EINTR is not considered a failure.
+ pragma Assert (Result = 0 or else Result = EINTR);
+ end Sleep;
+
+ -- Note that we are relying heaviliy here on the GNAT feature
+ -- that Calendar.Time, System.Real_Time.Time, Duration, and
+ -- System.Real_Time.Time_Span are all represented in the same
+ -- way, i.e., as a 64-bit count of nanoseconds.
+ -- This allows us to always pass the timeout value as a Duration.
+
+ -- ????? .........
+ -- We are taking liberties here with the semantics of the delays.
+ -- That is, we make no distinction between delays on the Calendar clock
+ -- and delays on the Real_Time clock. That is technically incorrect, if
+ -- the Calendar clock happens to be reset or adjusted.
+ -- To solve this defect will require modification to the compiler
+ -- interface, so that it can pass through more information, to tell
+ -- us here which clock to use!
+
+ -- cond_timedwait will return if any of the following happens:
+ -- 1) some other task did cond_signal on this condition variable
+ -- In this case, the return value is 0
+ -- 2) the call just returned, for no good reason
+ -- This is called a "spurious wakeup".
+ -- In this case, the return value may also be 0.
+ -- 3) the time delay expires
+ -- In this case, the return value is ETIME
+ -- 4) this task received a signal, which was handled by some
+ -- handler procedure, and now the thread is resuming execution
+ -- UNIX calls this an "interrupted" system call.
+ -- In this case, the return value is EINTR
+
+ -- If the cond_timedwait returns 0 or EINTR, it is still
+ -- possible that the time has actually expired, and by chance
+ -- a signal or cond_signal occurred at around the same time.
+
+ -- We have also observed that on some OS's the value ETIME
+ -- will be returned, but the clock will show that the full delay
+ -- has not yet expired.
+
+ -- For these reasons, we need to check the clock after return
+ -- from cond_timedwait. If the time has expired, we will set
+ -- Timedout = True.
+
+ -- This check might be omitted for systems on which the
+ -- cond_timedwait() never returns early or wakes up spuriously.
+
+ -- Annex D requires that completion of a delay cause the task
+ -- to go to the end of its priority queue, regardless of whether
+ -- the task actually was suspended by the delay. Since
+ -- cond_timedwait does not do this on Solaris, we add a call
+ -- to thr_yield at the end. We might do this at the beginning,
+ -- instead, but then the round-robin effect would not be the
+ -- same; the delayed task would be ahead of other tasks of the
+ -- same priority that awoke while it was sleeping.
+
+ -- For Timed_Sleep, we are expecting possible cond_signals
+ -- to indicate other events (e.g., completion of a RV or
+ -- completion of the abortable part of an async. select),
+ -- we want to always return if interrupted. The caller will
+ -- be responsible for checking the task state to see whether
+ -- the wakeup was spurious, and to go back to sleep again
+ -- in that case. We don't need to check for pending abort
+ -- or priority change on the way in our out; that is the
+ -- caller's responsibility.
+
+ -- For Timed_Delay, we are not expecting any cond_signals or
+ -- other interruptions, except for priority changes and aborts.
+ -- Therefore, we don't want to return unless the delay has
+ -- actually expired, or the call has been aborted. In this
+ -- case, since we want to implement the entire delay statement
+ -- semantics, we do need to check for pending abort and priority
+ -- changes. We can quietly handle priority changes inside the
+ -- procedure, since there is no entry-queue reordering involved.
+
+ -----------------
+ -- 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.
+ -- Yielded should be False unles we know for certain that the
+ -- operation resulted in the calling task going to the end of
+ -- the dispatching queue for its priority.
+ -- ?????
+ -- This version presumes the worst, so Yielded is always False.
+ -- On some targets, if cond_timedwait always yields, we could
+ -- set Yielded to True just before the cond_timedwait call.
+
+ procedure Timed_Sleep
+ (Self_ID : Task_ID;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ Check_Time : constant Duration := Monotonic_Clock;
+ Abs_Time : Duration;
+ Request : aliased struct_timeval;
+ Result : Interfaces.C.int;
+ begin
+ Timedout := True;
+ Yielded := False;
+
+ if Mode = Relative then
+ Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
+ else
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+ end if;
+
+ if Abs_Time > Check_Time then
+ Request := To_Timeval (Abs_Time);
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ or else Self_ID.Pending_Priority_Change;
+
+ Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access, Request'Access);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ if Result = 0 or Result = EINTR then
+ -- somebody may have called Wakeup for us
+ Timedout := False;
+ exit;
+ end if;
+
+ pragma Assert (Result = ETIMEDOUT
+ or else (Result = -1 and then errno = EAGAIN));
+ 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
+ Check_Time : constant Duration := Monotonic_Clock;
+ Abs_Time : Duration;
+ Request : aliased struct_timeval;
+ Result : Interfaces.C.int;
+ begin
+
+ -- Only the little window between deferring abort and
+ -- locking Self_ID is the reason we need to
+ -- check for pending abort and priority change below! :(
+
+ SSL.Abort_Defer.all;
+ Write_Lock (Self_ID);
+
+ if Mode = Relative then
+ Abs_Time := Time + Check_Time;
+ else
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+ end if;
+
+ if Abs_Time > Check_Time then
+ Request := To_Timeval (Abs_Time);
+ Self_ID.Common.State := Delay_Sleep;
+
+ loop
+ if Self_ID.Pending_Priority_Change then
+ Self_ID.Pending_Priority_Change := False;
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
+ end if;
+
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access, Request'Access);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ pragma Assert (Result = 0 or else
+ Result = ETIMEDOUT or else
+ (Result = -1 and then errno = EAGAIN) or else
+ Result = EINTR);
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+ pthread_yield;
+ SSL.Abort_Undefer.all;
+ end Timed_Delay;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ type timeval is record
+ tv_sec : Integer;
+ tv_usec : Integer;
+ end record;
+ pragma Convention (C, timeval);
+
+ tv : aliased timeval;
+
+ procedure gettimeofday (tp : access timeval);
+ pragma Import (C, gettimeofday, "gettimeofday", "gettimeofday");
+
+ begin
+ gettimeofday (tv'Access);
+ return Duration (tv.tv_sec) + Duration (tv.tv_usec) / 1_000_000.0;
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ begin
+ return 10#1.0#E-6;
+ end RT_Resolution;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup
+ (T : ST.Task_ID;
+ Reason : System.Tasking.Task_States) is
+
+ 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
+ begin
+ if Do_Yield then
+ pthread_yield;
+ end if;
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_Priority
+ (T : Task_ID;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ T.Common.Current_Priority := Prio;
+ Result := pthread_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio));
+ pragma Assert (Result /= FUNC_ERR);
+
+ 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
+ Result : Interfaces.C.int;
+
+ begin
+
+ Self_ID.Common.LL.Thread := pthread_self;
+ Self_ID.Common.LL.LWP := sproc_self;
+
+ Result :=
+ pthread_set_ada_tcb (Self_ID.Common.LL.Thread, To_Address (Self_ID));
+
+ pragma Assert (Result = 0);
+
+ Lock_All_Tasks_List;
+
+ for I in Known_Tasks'Range loop
+ if Known_Tasks (I) = null then
+ Known_Tasks (I) := Self_ID;
+ Self_ID.Known_Tasks_Index := I;
+ exit;
+ end if;
+ end loop;
+
+ Unlock_All_Tasks_List;
+ 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;
+
+ ----------------------
+ -- Initialize_TCB --
+ ----------------------
+
+ procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
+ Result : Interfaces.C.int;
+ Cond_Attr : aliased pthread_condattr_t;
+
+ begin
+ Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
+ Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = 0 then
+ Succeeded := True;
+ else
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Succeeded := False;
+ end if;
+
+ Result := pthread_condattr_destroy (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+ end Initialize_TCB;
+
+ -----------------
+ -- Create_Task --
+ -----------------
+
+ procedure Create_Task
+ (T : Task_ID;
+ Wrapper : System.Address;
+ Stack_Size : System.Parameters.Size_Type;
+ Priority : System.Any_Priority;
+ Succeeded : out Boolean)
+ is
+ Attributes : aliased pthread_attr_t;
+ Adjusted_Stack_Size : Interfaces.C.size_t;
+ Result : Interfaces.C.int;
+
+ function Thread_Body_Access is new
+ Unchecked_Conversion (System.Address, start_addr);
+
+ function To_Resource_T is new Unchecked_Conversion
+ (System.Task_Info.Resource_Vector_T, System.OS_Interface.resource_t);
+
+ use System.Task_Info;
+ begin
+ if Stack_Size = Unspecified_Size then
+ Adjusted_Stack_Size :=
+ Interfaces.C.size_t (System.Program_Info.Default_Task_Stack);
+
+ elsif Stack_Size < Minimum_Stack_Size then
+ Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
+
+ else
+ Adjusted_Stack_Size := Interfaces.C.size_t (Stack_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, 1);
+ pragma Assert (Result = 0);
+
+ Result := pthread_attr_setstacksize
+ (Attributes'Access, Adjusted_Stack_Size);
+ pragma Assert (Result = 0);
+
+ if T.Common.Task_Info /= null then
+ Result := pthread_attr_setresources
+ (Attributes'Access,
+ To_Resource_T (T.Common.Task_Info.Thread_Resources));
+ pragma Assert (Result /= FUNC_ERR);
+
+ if T.Common.Task_Info.Thread_Timeslice /= 0.0 then
+ declare
+ use System.OS_Interface;
+
+ Tv : aliased struct_timeval := To_Timeval
+ (T.Common.Task_Info.Thread_Timeslice);
+ begin
+ Result := pthread_attr_set_tslice
+ (Attributes'Access, Tv'Access);
+ end;
+ end if;
+
+ if T.Common.Task_Info.Bound_To_Sproc then
+ Result := pthread_attr_set_boundtosproc
+ (Attributes'Access, PTHREAD_BOUND);
+ Result := pthread_attr_set_bsproc
+ (Attributes'Access, T.Common.Task_Info.Sproc);
+ end if;
+
+ 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;
+
+ Set_Priority (T, Priority);
+
+ Result := pthread_attr_destroy (Attributes'Access);
+ pragma Assert (Result /= FUNC_ERR);
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_ID) is
+ procedure Free is new
+ Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
+
+ Result : Interfaces.C.int;
+ Tmp : Task_ID := T;
+
+ begin
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Result := pthread_cond_destroy (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+
+ if T.Known_Tasks_Index /= -1 then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ end if;
+
+ Free (Tmp);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ pthread_exit (System.Null_Address);
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_kill (T.Common.LL.Thread,
+ Interfaces.C.int (System.Interrupt_Management.Abort_Task_Interrupt));
+ pragma Assert (Result = 0);
+ end Abort_Task;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy versions. The only currently working versions is for solaris
+ -- (native).
+
+ function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ 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_All_Tasks_List --
+ -------------------------
+
+ procedure Lock_All_Tasks_List is
+ begin
+ Write_Lock (All_Tasks_L'Access);
+ end Lock_All_Tasks_List;
+
+ ---------------------------
+ -- Unlock_All_Tasks_List --
+ ---------------------------
+
+ procedure Unlock_All_Tasks_List is
+ begin
+ Unlock (All_Tasks_L'Access);
+ end Unlock_All_Tasks_List;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ if T.Common.LL.Thread /= Thread_Self then
+ return pthread_suspend (T.Common.LL.Thread) = 0;
+ else
+ return True;
+ end if;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ if T.Common.LL.Thread /= Thread_Self then
+ return pthread_resume (T.Common.LL.Thread) = 0;
+ else
+ return True;
+ end if;
+ end Resume_Task;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_ID) is
+ begin
+ Environment_Task_ID := Environment_Task;
+
+ Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
+ -- Initialize the lock used to synchronize chain of all ATCBs.
+
+ Enter_Task (Environment_Task);
+
+ Set_Priority (Environment_Task,
+ Environment_Task.Common.Current_Priority);
+ end Initialize;
+
+ procedure Initialize_Athread_Library is
+ Result : Interfaces.C.int;
+ Init : aliased pthread_init_struct;
+
+ package PINF renames System.Program_Info;
+ package C renames Interfaces.C;
+
+ begin
+ Init.conf_initsize := C.int (PINF.Pthread_Arena_Size);
+ Init.max_sproc_count := C.int (PINF.Max_Sproc_Count);
+ Init.sproc_stack_size := C.size_t (PINF.Sproc_Stack_Size);
+ Init.os_default_priority := C.int (PINF.Os_Default_Priority);
+ Init.os_sched_signal := C.int (PINF.Pthread_Sched_Signal);
+ Init.guard_pages := C.int (PINF.Stack_Guard_Pages);
+ Init.init_sproc_count := C.int (PINF.Initial_Sproc_Count);
+
+ Result := pthread_exec_begin (Init'Access);
+ pragma Assert (Result /= FUNC_ERR);
+
+ if Result = FUNC_ERR then
+ raise Storage_Error; -- Insufficient resources.
+ end if;
+
+ end Initialize_Athread_Library;
+
+begin
+ Initialize_Athread_Library;
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1998 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package body contains the routines associated with the implementation
+-- of the Task_Info pragma.
+
+-- This is the SGI specific version of this module.
+
+with Interfaces.C;
+with System.OS_Interface;
+with System;
+with Unchecked_Conversion;
+package body System.Task_Info is
+
+ use System.OS_Interface;
+ use type Interfaces.C.int;
+
+ function To_Resource_T is new
+ Unchecked_Conversion (Resource_Vector_T, resource_t);
+
+ MP_NPROCS : constant := 1;
+
+ function Sysmp (Cmd : Integer) return Integer;
+ pragma Import (C, Sysmp);
+
+ function Num_Processors (Cmd : Integer := MP_NPROCS) return Integer
+ renames Sysmp;
+
+ function Geteuid return Integer;
+ pragma Import (C, Geteuid);
+
+ Locking_Map : constant array (Page_Locking) of Interfaces.C.int :=
+ (NOLOCK => 0,
+ PROCLOCK => 1,
+ TXTLOCK => 2,
+ DATLOCK => 4);
+
+ package body Resource_Vector_Functions is
+
+ function "+" (R : Resource_T)
+ return Resource_Vector_T is
+ Result : Resource_Vector_T := NO_RESOURCES;
+ begin
+ Result (Resource_T'Pos (R)) := True;
+ return Result;
+ end "+";
+
+ function "+" (R1, R2 : Resource_T)
+ return Resource_Vector_T is
+ Result : Resource_Vector_T := NO_RESOURCES;
+ begin
+ Result (Resource_T'Pos (R1)) := True;
+ Result (Resource_T'Pos (R2)) := True;
+ return Result;
+ end "+";
+
+ function "+" (R : Resource_T; S : Resource_Vector_T)
+ return Resource_Vector_T is
+ Result : Resource_Vector_T := S;
+ begin
+ Result (Resource_T'Pos (R)) := True;
+ return Result;
+ end "+";
+
+ function "+" (S : Resource_Vector_T; R : Resource_T)
+ return Resource_Vector_T is
+ Result : Resource_Vector_T := S;
+ begin
+ Result (Resource_T'Pos (R)) := True;
+ return Result;
+ end "+";
+
+ function "+" (S1, S2 : Resource_Vector_T)
+ return Resource_Vector_T is
+ Result : Resource_Vector_T;
+ begin
+ Result := S1 or S2;
+ return Result;
+ end "+";
+
+ function "-" (S : Resource_Vector_T; R : Resource_T)
+ return Resource_Vector_T is
+ Result : Resource_Vector_T := S;
+ begin
+ Result (Resource_T'Pos (R)) := False;
+ return Result;
+ end "-";
+
+ end Resource_Vector_Functions;
+
+ function New_Sproc (Attr : Sproc_Attributes) return sproc_t is
+ Sproc_Attr : aliased sproc_attr_t;
+ Sproc : aliased sproc_t;
+ Status : int;
+ begin
+ Status := sproc_attr_init (Sproc_Attr'Unrestricted_Access);
+ if Status = 0 then
+
+ Status := sproc_attr_setresources
+ (Sproc_Attr'Unrestricted_Access,
+ To_Resource_T (Attr.Sproc_Resources));
+
+ if Attr.CPU /= ANY_CPU then
+ if Attr.CPU > Num_Processors then
+ raise Invalid_CPU_Number;
+ end if;
+ Status := sproc_attr_setcpu
+ (Sproc_Attr'Unrestricted_Access,
+ int (Attr.CPU));
+ end if;
+
+ if Attr.Resident /= NOLOCK then
+
+ if Geteuid /= 0 then
+ raise Permission_Error;
+ end if;
+
+ Status := sproc_attr_setresident
+ (Sproc_Attr'Unrestricted_Access,
+ Locking_Map (Attr.Resident));
+ end if;
+
+ if Attr.NDPRI /= NDP_NONE then
+-- if Geteuid /= 0 then
+-- raise Permission_Error;
+-- end if;
+
+ Status := sproc_attr_setprio
+ (Sproc_Attr'Unrestricted_Access,
+ int (Attr.NDPRI));
+ end if;
+
+ Status := sproc_create
+ (Sproc'Unrestricted_Access,
+ Sproc_Attr'Unrestricted_Access,
+ null,
+ System.Null_Address);
+
+ if Status /= 0 then
+ Status := sproc_attr_destroy (Sproc_Attr'Unrestricted_Access);
+ raise Sproc_Create_Error;
+ end if;
+
+ Status := sproc_attr_destroy (Sproc_Attr'Unrestricted_Access);
+
+ end if;
+
+ if Status /= 0 then
+ raise Sproc_Create_Error;
+ end if;
+
+ return Sproc;
+ end New_Sproc;
+
+ function New_Sproc
+ (Sproc_Resources : Resource_Vector_T := NO_RESOURCES;
+ CPU : CPU_Number := ANY_CPU;
+ Resident : Page_Locking := NOLOCK;
+ NDPRI : Non_Degrading_Priority := NDP_NONE)
+ return sproc_t is
+
+ Attr : Sproc_Attributes :=
+ (Sproc_Resources, CPU, Resident, NDPRI);
+
+ begin
+ return New_Sproc (Attr);
+ end New_Sproc;
+
+ function Unbound_Thread_Attributes
+ (Thread_Resources : Resource_Vector_T := NO_RESOURCES;
+ Thread_Timeslice : Duration := 0.0)
+ return Thread_Attributes is
+ begin
+ return (False, Thread_Resources, Thread_Timeslice);
+ end Unbound_Thread_Attributes;
+
+ function Bound_Thread_Attributes
+ (Thread_Resources : Resource_Vector_T := NO_RESOURCES;
+ Thread_Timeslice : Duration := 0.0;
+ Sproc : sproc_t)
+ return Thread_Attributes is
+ begin
+ return (True, Thread_Resources, Thread_Timeslice, Sproc);
+ end Bound_Thread_Attributes;
+
+ function Bound_Thread_Attributes
+ (Thread_Resources : Resource_Vector_T := NO_RESOURCES;
+ Thread_Timeslice : Duration := 0.0;
+ Sproc_Resources : Resource_Vector_T := NO_RESOURCES;
+ CPU : CPU_Number := ANY_CPU;
+ Resident : Page_Locking := NOLOCK;
+ NDPRI : Non_Degrading_Priority := NDP_NONE)
+ return Thread_Attributes is
+
+ Sproc : sproc_t := New_Sproc
+ (Sproc_Resources, CPU, Resident, NDPRI);
+
+ begin
+ return (True, Thread_Resources, Thread_Timeslice, Sproc);
+ end Bound_Thread_Attributes;
+
+ function New_Unbound_Thread_Attributes
+ (Thread_Resources : Resource_Vector_T := NO_RESOURCES;
+ Thread_Timeslice : Duration := 0.0)
+ return Task_Info_Type is
+ begin
+ return new Thread_Attributes'
+ (False, Thread_Resources, Thread_Timeslice);
+ end New_Unbound_Thread_Attributes;
+
+ function New_Bound_Thread_Attributes
+ (Thread_Resources : Resource_Vector_T := NO_RESOURCES;
+ Thread_Timeslice : Duration := 0.0;
+ Sproc : sproc_t)
+ return Task_Info_Type is
+ begin
+ return new Thread_Attributes'
+ (True, Thread_Resources, Thread_Timeslice, Sproc);
+ end New_Bound_Thread_Attributes;
+
+ function New_Bound_Thread_Attributes
+ (Thread_Resources : Resource_Vector_T := NO_RESOURCES;
+ Thread_Timeslice : Duration := 0.0;
+ Sproc_Resources : Resource_Vector_T := NO_RESOURCES;
+ CPU : CPU_Number := ANY_CPU;
+ Resident : Page_Locking := NOLOCK;
+ NDPRI : Non_Degrading_Priority := NDP_NONE)
+ return Task_Info_Type is
+
+ Sproc : sproc_t := New_Sproc
+ (Sproc_Resources, CPU, Resident, NDPRI);
+
+ begin
+ return new Thread_Attributes'
+ (True, Thread_Resources, Thread_Timeslice, Sproc);
+ end New_Bound_Thread_Attributes;
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the definitions and routines associated with the
+-- implementation of the Task_Info pragma.
+
+-- This is the SGI (libathread) specific version of this module.
+
+with System.OS_Interface;
+with Unchecked_Deallocation;
+package System.Task_Info is
+pragma Elaborate_Body;
+-- To ensure that a body is allowed
+
+ ---------------------------------------------------------
+ -- Binding of Tasks to sprocs and sprocs to processors --
+ ---------------------------------------------------------
+
+ -- The SGI implementation of the GNU Low-Level Interface (GNULLI)
+ -- implements each Ada task as a Posix thread (Pthread). The SGI
+ -- Pthread library distributes threads across one or more processes
+ -- that are members of a common share group. Irix distributes
+ -- processes across the available CPUs on a given machine. The
+ -- pragma Task_Info provides the mechanism to control the distribution
+ -- of tasks to sprocs, and sprocs to processors.
+
+ -- Each thread has a number of attributes that dictate it's scheduling.
+ -- These attributes are:
+ --
+ -- Bound_To_Sproc: whether the thread is bound to a specific sproc
+ -- for its entire lifetime.
+ --
+ -- Timeslice: Amount of time that a thread is allowed to execute
+ -- before the system yeilds control to another thread
+ -- of equal priority.
+ --
+ -- Resource_Vector: A bitmask used to control the binding of threads
+ -- to sprocs.
+ --
+
+ -- Each share group process (sproc)
+
+ -- The Task_Info pragma:
+
+ -- pragma Task_Info (EXPRESSION);
+
+ -- allows the specification on a task by task basis of a value of type
+ -- System.Task_Info.Task_Info_Type to be passed to a task when it is
+ -- created. The specification of this type, and the effect on the task
+ -- that is created is target dependent.
+
+ -- The Task_Info pragma appears within a task definition (compare the
+ -- definition and implementation of pragma Priority). If no such pragma
+ -- appears, then the value Task_Info_Unspecified is passed. If a pragma
+ -- is present, then it supplies an alternative value. If the argument of
+ -- the pragma is a discriminant reference, then the value can be set on
+ -- a task by task basis by supplying the appropriate discriminant value.
+
+ -- Note that this means that the type used for Task_Info_Type must be
+ -- suitable for use as a discriminant (i.e. a scalar or access type).
+
+ ----------------------
+ -- Resource Vectors --
+ ----------------------
+
+ -- <discussion>
+
+ type Resource_Vector_T is array (0 .. 31) of Boolean;
+ pragma Pack (Resource_Vector_T);
+
+ NO_RESOURCES : constant Resource_Vector_T := (others => False);
+
+ generic
+ type Resource_T is (<>); -- Discrete type up to 32 entries
+ package Resource_Vector_Functions is
+ function "+"(R : Resource_T)
+ return Resource_Vector_T;
+ function "+"(R1, R2 : Resource_T)
+ return Resource_Vector_T;
+ function "+"(R : Resource_T; S : Resource_Vector_T)
+ return Resource_Vector_T;
+ function "+"(S : Resource_Vector_T; R : Resource_T)
+ return Resource_Vector_T;
+ function "+"(S1, S2 : Resource_Vector_T)
+ return Resource_Vector_T;
+ function "-"(S : Resource_Vector_T; R : Resource_T)
+ return Resource_Vector_T;
+ end Resource_Vector_Functions;
+
+ ----------------------
+ -- Sproc Attributes --
+ ----------------------
+
+ subtype sproc_t is System.OS_Interface.sproc_t;
+
+ subtype CPU_Number is Integer range -1 .. Integer'Last;
+
+ ANY_CPU : constant CPU_Number := CPU_Number'First;
+
+ --
+ -- Specification of IRIX Non Degrading Priorities.
+ --
+ -- WARNING: IRIX priorities have the reverse meaning of Ada priorities.
+ -- The lower the priority value, the greater the greater the
+ -- scheduling preference.
+ --
+ -- See the schedctl(2) man page for a complete discussion of non-degrading
+ -- priorities.
+ --
+ type Non_Degrading_Priority is range 0 .. 255;
+
+ -- these priorities are higher than ALL normal user process priorities
+ NDPHIMAX : constant Non_Degrading_Priority := 30;
+ NDPHIMIN : constant Non_Degrading_Priority := 39;
+
+ subtype NDP_High is Non_Degrading_Priority range NDPHIMAX .. NDPHIMIN;
+
+ -- these priorities overlap normal user process priorities
+ NDPNORMMAX : constant Non_Degrading_Priority := 40;
+ NDPNORMMIN : constant Non_Degrading_Priority := 127;
+
+ subtype NDP_Norm is Non_Degrading_Priority range NDPNORMMAX .. NDPNORMMIN;
+
+ -- these priorities are below ALL normal user process priorities
+ NDPLOMAX : constant Non_Degrading_Priority := 128;
+ NDPLOMIN : constant Non_Degrading_Priority := 254;
+
+ NDP_NONE : constant Non_Degrading_Priority := 255;
+
+ subtype NDP_LOW is Non_Degrading_Priority range NDPLOMAX .. NDPLOMIN;
+
+ type Page_Locking is
+ (NOLOCK, -- Do not lock pages in memory
+ PROCLOCK, -- Lock text and data segments into memory (process lock)
+ TXTLOCK, -- Lock text segment into memory (text lock)
+ DATLOCK -- Lock data segment into memory (data lock)
+ );
+
+ type Sproc_Attributes is
+ record
+ Sproc_Resources : Resource_Vector_T := NO_RESOURCES;
+ CPU : CPU_Number := ANY_CPU;
+ Resident : Page_Locking := NOLOCK;
+ NDPRI : Non_Degrading_Priority := NDP_NONE;
+-- Sproc_Slice : Duration := 0.0;
+-- Deadline_Period : Duration := 0.0;
+-- Deadline_Alloc : Duration := 0.0;
+
+ end record;
+
+ Default_Sproc_Attributes : constant Sproc_Attributes :=
+ (NO_RESOURCES, ANY_CPU, NOLOCK, NDP_NONE);
+
+ function New_Sproc (Attr : Sproc_Attributes) return sproc_t;
+ function New_Sproc
+ (Sproc_Resources : Resource_Vector_T := NO_RESOURCES;
+ CPU : CPU_Number := ANY_CPU;
+ Resident : Page_Locking := NOLOCK;
+ NDPRI : Non_Degrading_Priority := NDP_NONE)
+ return sproc_t;
+ --
+ -- Allocates a sproc_t controll structure and creates the
+ -- corresponding sproc.
+ --
+
+ Invalid_CPU_Number : exception;
+ Permission_Error : exception;
+ Sproc_Create_Error : exception;
+
+ -----------------------
+ -- Thread Attributes --
+ -----------------------
+
+ type Thread_Attributes (Bound_To_Sproc : Boolean) is
+ record
+ Thread_Resources : Resource_Vector_T := NO_RESOURCES;
+ Thread_Timeslice : Duration := 0.0;
+ case Bound_To_Sproc is
+ when False =>
+ null;
+ when True =>
+ Sproc : sproc_t;
+ end case;
+ end record;
+
+ Default_Thread_Attributes : constant Thread_Attributes :=
+ (False, NO_RESOURCES, 0.0);
+
+ function Unbound_Thread_Attributes
+ (Thread_Resources : Resource_Vector_T := NO_RESOURCES;
+ Thread_Timeslice : Duration := 0.0)
+ return Thread_Attributes;
+
+ function Bound_Thread_Attributes
+ (Thread_Resources : Resource_Vector_T := NO_RESOURCES;
+ Thread_Timeslice : Duration := 0.0;
+ Sproc : sproc_t)
+ return Thread_Attributes;
+
+ function Bound_Thread_Attributes
+ (Thread_Resources : Resource_Vector_T := NO_RESOURCES;
+ Thread_Timeslice : Duration := 0.0;
+ Sproc_Resources : Resource_Vector_T := NO_RESOURCES;
+ CPU : CPU_Number := ANY_CPU;
+ Resident : Page_Locking := NOLOCK;
+ NDPRI : Non_Degrading_Priority := NDP_NONE)
+ return Thread_Attributes;
+
+ type Task_Info_Type is access all Thread_Attributes;
+
+ function New_Unbound_Thread_Attributes
+ (Thread_Resources : Resource_Vector_T := NO_RESOURCES;
+ Thread_Timeslice : Duration := 0.0)
+ return Task_Info_Type;
+
+ function New_Bound_Thread_Attributes
+ (Thread_Resources : Resource_Vector_T := NO_RESOURCES;
+ Thread_Timeslice : Duration := 0.0;
+ Sproc : sproc_t)
+ return Task_Info_Type;
+
+ function New_Bound_Thread_Attributes
+ (Thread_Resources : Resource_Vector_T := NO_RESOURCES;
+ Thread_Timeslice : Duration := 0.0;
+ Sproc_Resources : Resource_Vector_T := NO_RESOURCES;
+ CPU : CPU_Number := ANY_CPU;
+ Resident : Page_Locking := NOLOCK;
+ NDPRI : Non_Degrading_Priority := NDP_NONE)
+ return Task_Info_Type;
+
+ type Task_Image_Type is access String;
+ -- Used to generate a meaningful identifier for tasks that are variables
+ -- and components of variables.
+
+ procedure Free_Task_Image is new
+ Unchecked_Deallocation (String, Task_Image_Type);
+
+ Unspecified_Task_Info : constant Task_Info_Type := null;
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 . G E N _ T C B I N F --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1999-2000 Free Software Fundation --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is an SGI Irix version of this package
+
+-- This procedure creates the file "a-tcbinf.c"
+-- "A-tcbinf.c" is subsequently compiled and made part of the RTL
+-- to be referenced by the SGI Workshop debugger. The main procedure:
+-- "Gen_Tcbinf" imports this child procedure and runs as part of the
+-- RTL build process. Because of the complex process used to build
+-- the GNAT RTL for all the different systems and the frequent changes
+-- made to the internal data structures, its impractical to create
+-- "a-tcbinf.c" using a standalone process.
+with System.Tasking;
+with Ada.Text_IO;
+with Unchecked_Conversion;
+
+procedure System.Task_Primitives.Gen_Tcbinf is
+
+ use System.Tasking;
+
+ subtype Version_String is String (1 .. 4);
+
+ Version : constant Version_String := "3.11";
+
+ function To_Integer is new Unchecked_Conversion
+ (Version_String, Integer);
+
+ type Dummy_TCB_Ptr is access Ada_Task_Control_Block (Entry_Num => 0);
+ Dummy_TCB : constant Dummy_TCB_Ptr := new Ada_Task_Control_Block (0);
+
+ C_File : Ada.Text_IO.File_Type;
+
+ procedure Pl (S : String);
+ procedure Nl (C : Ada.Text_IO.Positive_Count := 1);
+ function State_Name (S : Task_States) return String;
+
+ procedure Pl (S : String) is
+ begin
+ Ada.Text_IO.Put_Line (C_File, S);
+ end Pl;
+
+ procedure Nl (C : Ada.Text_IO.Positive_Count := 1) is
+ begin
+ Ada.Text_IO.New_Line (C_File, C);
+ end Nl;
+
+ function State_Name (S : Task_States) return String is
+ begin
+ case S is
+ when Unactivated =>
+ return "Unactivated";
+ when Runnable =>
+ return "Runnable";
+ when Terminated =>
+ return "Terminated";
+ when Activator_Sleep =>
+ return "Child Activation Wait";
+ when Acceptor_Sleep =>
+ return "Accept/Select Wait";
+ when Entry_Caller_Sleep =>
+ return "Waiting on Entry Call";
+ when Async_Select_Sleep =>
+ return "Async_Select Wait";
+ when Delay_Sleep =>
+ return "Delay Sleep";
+ when Master_Completion_Sleep =>
+ return "Child Termination Wait";
+ when Master_Phase_2_Sleep =>
+ return "Wait Child in Term Alt";
+ when Interrupt_Server_Idle_Sleep =>
+ return "Int Server Idle Sleep";
+ when Interrupt_Server_Blocked_Interrupt_Sleep =>
+ return "Int Server Blk Int Sleep";
+ when Timer_Server_Sleep =>
+ return "Timer Server Sleep";
+ when AST_Server_Sleep =>
+ return "AST Server Sleep";
+ when Asynchronous_Hold =>
+ return "Asynchronous Hold";
+ when Interrupt_Server_Blocked_On_Event_Flag =>
+ return "Int Server Blk Evt Flag";
+ end case;
+ end State_Name;
+
+ All_Tasks_Link_Offset : constant Integer
+ := Dummy_TCB.Common'Position + Dummy_TCB.Common.All_Tasks_Link'Position;
+ Entry_Count_Offset : constant Integer
+ := Dummy_TCB.Entry_Num'Position;
+ Entry_Point_Offset : constant Integer
+ := Dummy_TCB.Common'Position + Dummy_TCB.Common.Task_Entry_Point'Position;
+ Parent_Offset : constant Integer
+ := Dummy_TCB.Common'Position + Dummy_TCB.Common.Parent'Position;
+ Base_Priority_Offset : constant Integer
+ := Dummy_TCB.Common'Position + Dummy_TCB.Common.Base_Priority'Position;
+ Current_Priority_Offset : constant Integer
+ := Dummy_TCB.Common'Position + Dummy_TCB.Common.Current_Priority'Position;
+ Stack_Size_Offset : constant Integer
+ := Dummy_TCB.Common'Position +
+ Dummy_TCB.Common.Compiler_Data.Pri_Stack_Info.Size'Position;
+ State_Offset : constant Integer
+ := Dummy_TCB.Common'Position + Dummy_TCB.Common.State'Position;
+ Task_Image_Offset : constant Integer
+ := Dummy_TCB.Common'Position + Dummy_TCB.Common.Task_Image'Position;
+ Thread_Offset : constant Integer
+ := Dummy_TCB.Common'Position + Dummy_TCB.Common.LL'Position +
+ Dummy_TCB.Common.LL.Thread'Position;
+
+begin
+
+ Ada.Text_IO.Create (C_File, Ada.Text_IO.Out_File, "a-tcbinf.c");
+
+ Pl ("");
+ Pl ("#include <sys/types.h>");
+ Pl ("");
+ Pl ("#define TCB_INFO_VERSION 2");
+ Pl ("#define TCB_LIBRARY_VERSION "
+ & Integer'Image (To_Integer (Version)));
+ Pl ("");
+ Pl ("typedef struct {");
+ Pl ("");
+ Pl (" __uint32_t info_version;");
+ Pl (" __uint32_t library_version;");
+ Pl ("");
+ Pl (" __uint32_t All_Tasks_Link_Offset;");
+ Pl (" __uint32_t Entry_Count_Offset;");
+ Pl (" __uint32_t Entry_Point_Offset;");
+ Pl (" __uint32_t Parent_Offset;");
+ Pl (" __uint32_t Base_Priority_Offset;");
+ Pl (" __uint32_t Current_Priority_Offset;");
+ Pl (" __uint32_t Stack_Size_Offset;");
+ Pl (" __uint32_t State_Offset;");
+ Pl (" __uint32_t Task_Image_Offset;");
+ Pl (" __uint32_t Thread_Offset;");
+ Pl ("");
+ Pl (" char **state_names;");
+ Pl (" __uint32_t state_names_max;");
+ Pl ("");
+ Pl ("} task_control_block_info_t;");
+ Pl ("");
+ Pl ("static char *accepting_state_names = NULL;");
+
+ Pl ("");
+ Pl ("static char *task_state_names[] = {");
+
+ for State in Task_States loop
+ Pl (" """ & State_Name (State) & """,");
+ end loop;
+ Pl (" """"};");
+
+ Pl ("");
+ Pl ("");
+ Pl ("task_control_block_info_t __task_control_block_info = {");
+ Pl ("");
+ Pl (" TCB_INFO_VERSION,");
+ Pl (" TCB_LIBRARY_VERSION,");
+ Pl ("");
+ Pl (" " & All_Tasks_Link_Offset'Img & ",");
+ Pl (" " & Entry_Count_Offset'Img & ",");
+ Pl (" " & Entry_Point_Offset'Img & ",");
+ Pl (" " & Parent_Offset'Img & ",");
+ Pl (" " & Base_Priority_Offset'Img & ",");
+ Pl (" " & Current_Priority_Offset'Img & ",");
+ Pl (" " & Stack_Size_Offset'Img & ",");
+ Pl (" " & State_Offset'Img & ",");
+ Pl (" " & Task_Image_Offset'Img & ",");
+ Pl (" " & Thread_Offset'Img & ",");
+ Pl ("");
+ Pl (" task_state_names,");
+ Pl (" sizeof (task_state_names),");
+ Pl ("");
+ Pl ("");
+ Pl ("};");
+
+ Ada.Text_IO.Close (C_File);
+
+end System.Task_Primitives.Gen_Tcbinf;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.14 $
+-- --
+-- Copyright (C) 1991-2001, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a DCE version of this package.
+-- Currently HP-UX and SNI use this file
+
+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.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+with Interfaces.C; use Interfaces.C;
+
+package body System.OS_Interface is
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec' (tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ function To_Duration (TV : struct_timeval) return Duration is
+ begin
+ return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
+ end To_Duration;
+
+ function To_Timeval (D : Duration) return struct_timeval 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 struct_timeval' (tv_sec => S,
+ tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
+ end To_Timeval;
+
+ ---------------------------
+ -- POSIX.1c Section 3 --
+ ---------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal)
+ return int
+ is
+ Result : int;
+
+ begin
+ Result := sigwait (set);
+
+ if Result = -1 then
+ sig.all := 0;
+ return errno;
+ end if;
+
+ sig.all := Signal (Result);
+ return 0;
+ end sigwait;
+
+ -- DCE_THREADS does not have pthread_kill. Instead, we just ignore it.
+
+ function pthread_kill (thread : pthread_t; sig : Signal) return int is
+ begin
+ return 0;
+ end pthread_kill;
+
+ ----------------------------
+ -- POSIX.1c Section 11 --
+ ----------------------------
+
+ -- For all the following functions, DCE Threads has a non standard
+ -- behavior: it sets errno but the standard Posix requires it to be
+ -- returned.
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t)
+ return int
+ is
+ function pthread_mutexattr_create
+ (attr : access pthread_mutexattr_t)
+ return int;
+ pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create");
+
+ begin
+ if pthread_mutexattr_create (attr) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_mutexattr_init;
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t)
+ return int
+ is
+ function pthread_mutexattr_delete
+ (attr : access pthread_mutexattr_t)
+ return int;
+ pragma Import (C, pthread_mutexattr_delete, "pthread_mutexattr_delete");
+
+ begin
+ if pthread_mutexattr_delete (attr) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_mutexattr_destroy;
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t)
+ return int
+ is
+ function pthread_mutex_init_base
+ (mutex : access pthread_mutex_t;
+ attr : pthread_mutexattr_t)
+ return int;
+ pragma Import (C, pthread_mutex_init_base, "pthread_mutex_init");
+
+ begin
+ if pthread_mutex_init_base (mutex, attr.all) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_mutex_init;
+
+ function pthread_mutex_destroy
+ (mutex : access pthread_mutex_t)
+ return int
+ is
+ function pthread_mutex_destroy_base
+ (mutex : access pthread_mutex_t)
+ return int;
+ pragma Import (C, pthread_mutex_destroy_base, "pthread_mutex_destroy");
+
+ begin
+ if pthread_mutex_destroy_base (mutex) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_mutex_destroy;
+
+ function pthread_mutex_lock
+ (mutex : access pthread_mutex_t)
+ return int
+ is
+ function pthread_mutex_lock_base
+ (mutex : access pthread_mutex_t)
+ return int;
+ pragma Import (C, pthread_mutex_lock_base, "pthread_mutex_lock");
+
+ begin
+ if pthread_mutex_lock_base (mutex) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_mutex_lock;
+
+ function pthread_mutex_unlock
+ (mutex : access pthread_mutex_t)
+ return int
+ is
+ function pthread_mutex_unlock_base
+ (mutex : access pthread_mutex_t)
+ return int;
+ pragma Import (C, pthread_mutex_unlock_base, "pthread_mutex_unlock");
+
+ begin
+ if pthread_mutex_unlock_base (mutex) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_mutex_unlock;
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t)
+ return int
+ is
+ function pthread_condattr_create
+ (attr : access pthread_condattr_t)
+ return int;
+ pragma Import (C, pthread_condattr_create, "pthread_condattr_create");
+
+ begin
+ if pthread_condattr_create (attr) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_condattr_init;
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t)
+ return int
+ is
+ function pthread_condattr_delete
+ (attr : access pthread_condattr_t)
+ return int;
+ pragma Import (C, pthread_condattr_delete, "pthread_condattr_delete");
+
+ begin
+ if pthread_condattr_delete (attr) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_condattr_destroy;
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t)
+ return int
+ is
+ function pthread_cond_init_base
+ (cond : access pthread_cond_t;
+ attr : pthread_condattr_t)
+ return int;
+ pragma Import (C, pthread_cond_init_base, "pthread_cond_init");
+
+ begin
+ if pthread_cond_init_base (cond, attr.all) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_cond_init;
+
+ function pthread_cond_destroy
+ (cond : access pthread_cond_t)
+ return int
+ is
+ function pthread_cond_destroy_base
+ (cond : access pthread_cond_t)
+ return int;
+ pragma Import (C, pthread_cond_destroy_base, "pthread_cond_destroy");
+
+ begin
+ if pthread_cond_destroy_base (cond) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_cond_destroy;
+
+ function pthread_cond_signal
+ (cond : access pthread_cond_t)
+ return int
+ is
+ function pthread_cond_signal_base
+ (cond : access pthread_cond_t)
+ return int;
+ pragma Import (C, pthread_cond_signal_base, "pthread_cond_signal");
+
+ begin
+ if pthread_cond_signal_base (cond) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_cond_signal;
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t)
+ return int
+ is
+ function pthread_cond_wait_base
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t)
+ return int;
+ pragma Import (C, pthread_cond_wait_base, "pthread_cond_wait");
+
+ begin
+ if pthread_cond_wait_base (cond, mutex) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_cond_wait;
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec)
+ return int
+ is
+ function pthread_cond_timedwait_base
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec)
+ return int;
+ pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait");
+
+ begin
+ if pthread_cond_timedwait_base (cond, mutex, abstime) /= 0 then
+ if errno = EAGAIN then
+ return ETIMEDOUT;
+ else
+ return errno;
+ end if;
+ else
+ return 0;
+ end if;
+ end pthread_cond_timedwait;
+
+ ----------------------------
+ -- POSIX.1c Section 13 --
+ ----------------------------
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int
+ is
+ function pthread_setscheduler
+ (thread : pthread_t;
+ policy : int;
+ priority : int)
+ return int;
+ pragma Import (C, pthread_setscheduler, "pthread_setscheduler");
+
+ begin
+ if pthread_setscheduler (thread, policy, param.sched_priority) = -1 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_setschedparam;
+
+ function sched_yield return int is
+ procedure pthread_yield;
+ pragma Import (C, pthread_yield, "pthread_yield");
+ begin
+ pthread_yield;
+ return 0;
+ end sched_yield;
+
+ -----------------------------
+ -- P1003.1c - Section 16 --
+ -----------------------------
+
+ function pthread_attr_init (attributes : access pthread_attr_t) return int
+ is
+ function pthread_attr_create
+ (attributes : access pthread_attr_t)
+ return int;
+ pragma Import (C, pthread_attr_create, "pthread_attr_create");
+
+ begin
+ if pthread_attr_create (attributes) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_attr_init;
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int
+ is
+ function pthread_attr_delete
+ (attributes : access pthread_attr_t)
+ return int;
+ pragma Import (C, pthread_attr_delete, "pthread_attr_delete");
+
+ begin
+ if pthread_attr_delete (attributes) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_attr_destroy;
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int
+ is
+ function pthread_attr_setstacksize_base
+ (attr : access pthread_attr_t;
+ stacksize : size_t)
+ return int;
+ pragma Import (C, pthread_attr_setstacksize_base,
+ "pthread_attr_setstacksize");
+
+ begin
+ if pthread_attr_setstacksize_base (attr, stacksize) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_attr_setstacksize;
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int
+ is
+ function pthread_create_base
+ (thread : access pthread_t;
+ attributes : pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address)
+ return int;
+ pragma Import (C, pthread_create_base, "pthread_create");
+
+ begin
+ if pthread_create_base
+ (thread, attributes.all, start_routine, arg) /= 0
+ then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_create;
+
+ ----------------------------
+ -- POSIX.1c Section 17 --
+ ----------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int
+ is
+ function pthread_setspecific_base
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific_base, "pthread_setspecific");
+
+ begin
+ if pthread_setspecific_base (key, value) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_setspecific;
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address is
+ function pthread_getspecific_base
+ (key : pthread_key_t;
+ value : access System.Address) return int;
+ pragma Import (C, pthread_getspecific_base, "pthread_getspecific");
+ Addr : aliased System.Address;
+
+ begin
+ if pthread_getspecific_base (key, Addr'Access) /= 0 then
+ return System.Null_Address;
+ else
+ return Addr;
+ end if;
+ end pthread_getspecific;
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int
+ is
+ function pthread_keycreate
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_keycreate, "pthread_keycreate");
+
+ begin
+ if pthread_keycreate (key, destructor) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_key_create;
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ function intr_attach (sig : int; handler : isr_address) return long is
+ function c_signal (sig : int; handler : isr_address) return long;
+ pragma Import (C, c_signal, "signal");
+
+ begin
+ return c_signal (sig, handler);
+ end intr_attach;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.28 $
+-- --
+-- Copyright (C) 1997-2001, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the HP-UX version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lcma");
+
+ subtype int is Interfaces.C.int;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ ETIME : constant := 52;
+ ETIMEDOUT : constant := 238;
+
+ FUNC_ERR : constant := -1;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 44;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ SIGVTALRM : constant := 20; -- virtual timer alarm
+ SIGPROF : constant := 21; -- profiling timer alarm
+ SIGIO : constant := 22; -- asynchronous I/O
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGWINCH : constant := 23; -- window size change
+ SIGSTOP : constant := 24; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 25; -- user stop requested from tty
+ SIGCONT : constant := 26; -- stopped process has been continued
+ SIGTTIN : constant := 27; -- background tty read attempted
+ SIGTTOU : constant := 28; -- background tty write attempted
+ SIGURG : constant := 29; -- urgent condition on IO channel
+ SIGLOST : constant := 30; -- remote lock lost (NFS)
+ SIGDIL : constant := 32; -- DIL signal
+ SIGXCPU : constant := 33; -- CPU time limit exceeded (setrlimit)
+ SIGXFSZ : constant := 34; -- file size limit exceeded (setrlimit)
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Note: on other targets, we usually use SIGABRT, but on HP/UX, it
+ -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set :=
+ (SIGBUS, SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP);
+
+ Reserved : constant Signal_Set := (SIGKILL, SIGSTOP);
+
+ type sigset_t is private;
+
+ type isr_address is access procedure (sig : int);
+
+ function intr_attach (sig : int; handler : isr_address) return long;
+
+ Intr_Attach_Reset : constant Boolean := True;
+ -- True if intr_attach is reset after an interrupt handler is called
+
+ function sigaddset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigaddset, "sigaddset");
+
+ function sigdelset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigdelset, "sigdelset");
+
+ function sigfillset (set : access sigset_t) return int;
+ pragma Import (C, sigfillset, "sigfillset");
+
+ function sigismember (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigismember, "sigismember");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "sigemptyset");
+
+ type Signal_Handler is access procedure (signo : Signal);
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SA_RESTART : constant := 16#40#;
+
+ SIG_BLOCK : constant := 0;
+ SIG_UNBLOCK : constant := 1;
+ SIG_SETMASK : constant := 2;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+ SIG_ERR : constant := -1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ type timespec is private;
+
+ function nanosleep (rqtp, rmtp : access timespec) return int;
+ pragma Import (C, nanosleep);
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+
+ function Clock_Gettime
+ (Clock_Id : clockid_t; Tp : access timespec) return int;
+ pragma Import (C, Clock_Gettime);
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ type struct_timeval is private;
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 0;
+ SCHED_RR : constant := 1;
+ SCHED_OTHER : constant := 2;
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ 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;
+
+ -----------
+ -- Stack --
+ -----------
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- This is a dummy procedure to share some GNULLI files
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ procedure pthread_init;
+ pragma Inline (pthread_init);
+ -- This is a dummy procedure to share some GNULLI files
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait (set : access sigset_t) return int;
+ pragma Import (C, sigwait, "cma_sigwait");
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ pragma Inline (sigwait);
+ -- DCE_THREADS has a nonstandard sigwait
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Inline (pthread_kill);
+ -- DCE_THREADS doesn't have pthread_kill
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ -- DCE THREADS does not have pthread_sigmask. Instead, it uses
+ -- sigprocmask to do the signal handling when the thread library is
+ -- sucked in.
+ pragma Import (C, pthread_sigmask, "sigprocmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ -- DCE_THREADS has a nonstandard pthread_mutexattr_init.
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ -- DCE_THREADS has a nonstandard pthread_mutexattr_destroy
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ -- DCE_THREADS has a nonstandard pthread_mutex_init
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ -- DCE_THREADS has a nonstandard pthread_mutex_destroy
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Inline (pthread_mutex_lock);
+ -- DCE_THREADS has nonstandard pthread_mutex_lock
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Inline (pthread_mutex_unlock);
+ -- DCE_THREADS has nonstandard pthread_mutex_lock
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ -- DCE_THREADS has nonstandard pthread_condattr_init
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ -- DCE_THREADS has nonstandard pthread_condattr_destroy
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ -- DCE_THREADS has nonstandard pthread_cond_init
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ -- DCE_THREADS has nonstandard pthread_cond_destroy
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Inline (pthread_cond_signal);
+ -- DCE_THREADS has nonstandard pthread_cond_signal
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Inline (pthread_cond_wait);
+ -- DCE_THREADS has a nonstandard pthread_cond_wait
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Inline (pthread_cond_timedwait);
+ -- DCE_THREADS has a nonstandard pthread_cond_timedwait
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ type struct_sched_param is record
+ sched_priority : int; -- scheduling priority
+ end record;
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int;
+ pragma Inline (pthread_setschedparam);
+ -- DCE_THREADS has a nonstandard pthread_setschedparam
+
+ function sched_yield return int;
+ pragma Inline (sched_yield);
+ -- DCE_THREADS has a nonstandard sched_yield
+
+ ---------------------------
+ -- P1003.1c - Section 16 --
+ ---------------------------
+
+ function pthread_attr_init (attributes : access pthread_attr_t) return int;
+ pragma Inline (pthread_attr_init);
+ -- DCE_THREADS has a nonstandard pthread_attr_init
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int;
+ pragma Inline (pthread_attr_destroy);
+ -- DCE_THREADS has a nonstandard pthread_attr_destroy
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Inline (pthread_attr_setstacksize);
+ -- DCE_THREADS has a nonstandard pthread_attr_setstacksize
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Inline (pthread_create);
+ -- DCE_THREADS has a nonstandard pthread_create
+
+ procedure pthread_detach (thread : access pthread_t);
+ pragma Import (C, pthread_detach);
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Inline (pthread_setspecific);
+ -- DCE_THREADS has a nonstandard pthread_setspecific
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Inline (pthread_getspecific);
+ -- DCE_THREADS has a nonstandard pthread_getspecific
+
+ type destructor_pointer is access procedure (arg : System.Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Inline (pthread_key_create);
+ -- DCE_THREADS has a nonstandard pthread_key_create
+
+private
+
+ type array_type_1 is array (Integer range 0 .. 7) of unsigned_long;
+ type sigset_t is record
+ X_X_sigbits : array_type_1;
+ end record;
+ pragma Convention (C, sigset_t);
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 1;
+
+ type struct_timeval is record
+ tv_sec : time_t;
+ tv_usec : time_t;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type cma_t_address is new System.Address;
+
+ type cma_t_handle is record
+ field1 : cma_t_address;
+ field2 : Short_Integer;
+ field3 : Short_Integer;
+ end record;
+ for cma_t_handle'Size use 64;
+
+ type pthread_attr_t is new cma_t_handle;
+ pragma Convention (C_Pass_By_Copy, pthread_attr_t);
+
+ type pthread_condattr_t is new cma_t_handle;
+ pragma Convention (C_Pass_By_Copy, pthread_condattr_t);
+
+ type pthread_mutexattr_t is new cma_t_handle;
+ pragma Convention (C_Pass_By_Copy, pthread_mutexattr_t);
+
+ type pthread_t is new cma_t_handle;
+ pragma Convention (C_Pass_By_Copy, pthread_t);
+
+ type pthread_mutex_t is new cma_t_handle;
+ pragma Convention (C_Pass_By_Copy, pthread_mutex_t);
+
+ type pthread_cond_t is new cma_t_handle;
+ pragma Convention (C_Pass_By_Copy, pthread_cond_t);
+
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the HP version of this package
+
+-- This package defines some system dependent parameters for GNAT. These
+-- are values that are referenced by the runtime library and are therefore
+-- relevant to the target machine.
+
+-- The parameters whose value is defined in the spec are not generally
+-- expected to be changed. If they are changed, it will be necessary to
+-- recompile the run-time library.
+
+-- The parameters which are defined by functions can be changed by modifying
+-- the body of System.Parameters in file s-parame.adb. A change to this body
+-- requires only rebinding and relinking of the application.
+
+-- Note: do not introduce any pragma Inline statements into this unit, since
+-- otherwise the relinking and rebinding capability would be deactivated.
+
+package System.Parameters is
+pragma Pure (Parameters);
+
+ ---------------------------------------
+ -- Task And Stack Allocation Control --
+ ---------------------------------------
+
+ type Task_Storage_Size is new Integer;
+ -- Type used in tasking units for task storage size
+
+ type Size_Type is new Task_Storage_Size;
+ -- Type used to provide task storage size to runtime
+
+ Unspecified_Size : constant Size_Type := Size_Type'First;
+ -- Value used to indicate that no size type is set
+
+ subtype Ratio is Size_Type range -1 .. 100;
+ Dynamic : constant Size_Type := -1;
+ -- The secondary stack ratio is a constant between 0 and 100 which
+ -- determines the percentage of the allocated task stack that is
+ -- used by the secondary stack (the rest being the primary stack).
+ -- The special value of minus one indicates that the secondary
+ -- stack is to be allocated from the heap instead.
+
+ Sec_Stack_Ratio : constant Ratio := Dynamic;
+ -- This constant defines the handling of the secondary stack
+
+ Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic;
+ -- Convenient Boolean for testing for dynamic secondary stack
+
+ function Default_Stack_Size return Size_Type;
+ -- Default task stack size used if none is specified
+
+ function Minimum_Stack_Size return Size_Type;
+ -- Minimum task stack size permitted
+
+ function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
+ -- Given the storage size stored in the TCB, return the Storage_Size
+ -- value required by the RM for the Storage_Size attribute. The
+ -- required adjustment is as follows:
+ --
+ -- when Size = Unspecified_Size, return Default_Stack_Size
+ -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
+ -- otherwise return given Size
+
+ Stack_Grows_Down : constant Boolean := False;
+ -- This constant indicates whether the stack grows up (False) or
+ -- down (True) in memory as functions are called. It is used for
+ -- proper implementation of the stack overflow check.
+
+ ----------------------------------------------
+ -- Characteristics of types in Interfaces.C --
+ ----------------------------------------------
+
+ long_bits : constant := Long_Integer'Size;
+ -- Number of bits in type long and unsigned_long. The normal convention
+ -- is that this is the same as type Long_Integer, but this is not true
+ -- of all targets. For example, in OpenVMS long /= Long_Integer.
+
+ ----------------------------------------------
+ -- Behavior of Pragma Finalize_Storage_Only --
+ ----------------------------------------------
+
+ -- Garbage_Collected is a Boolean constant whose value indicates the
+ -- effect of the pragma Finalize_Storage_Entry on a controlled type.
+
+ -- Garbage_Collected = False
+
+ -- The system releases all storage on program termination only,
+ -- but not other garbage collection occurs, so finalization calls
+ -- are ommitted only for outer level onjects can be omitted if
+ -- pragma Finalize_Storage_Only is used.
+
+ -- Garbage_Collected = True
+
+ -- The system provides full garbage collection, so it is never
+ -- necessary to release storage for controlled objects for which
+ -- a pragma Finalize_Storage_Only is used.
+
+ Garbage_Collected : constant Boolean := False;
+ -- The storage mode for this system (release on program exit)
+
+end System.Parameters;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (HP-UX Version) --
+-- --
+-- $Revision: 1.15 $
+-- --
+-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ 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 := Integer'Last;
+
+ 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 := Standard'Tick;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := Standard'Storage_Unit;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Standard'Address_Size;
+
+ -- 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;
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer
+ range 0 .. Standard'Max_Interrupt_Priority;
+
+ subtype Priority is Any_Priority
+ range 0 .. Standard'Max_Priority;
+
+ -- Functional notation is needed in the following to avoid visibility
+ -- problems when this package is compiled through rtsfind in the middle
+ -- of another compilation.
+
+ subtype Interrupt_Priority is Any_Priority
+ range
+ Standard."+" (Standard'Max_Priority, 1) ..
+ Standard'Max_Interrupt_Priority;
+
+ Default_Priority : constant Priority :=
+ Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
+
+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.
+
+ AAMP : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Denorm : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := False;
+ High_Integrity_Mode : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := False;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+ --------------------------
+ -- Underlying Priorities --
+ ---------------------------
+
+ -- Important note: this section of the file must come AFTER the
+ -- definition of the system implementation parameters to ensure
+ -- that the value of these parameters is available for analysis
+ -- of the declarations here (using Rtsfind at compile time).
+
+ -- The underlying priorities table provides a generalized mechanism
+ -- for mapping from Ada priorities to system priorities. In some
+ -- cases a 1-1 mapping is not the convenient or optimal choice.
+
+ -- For HP/UX DCE Threads, we use the full range of 31 priorities
+ -- in the Ada model, but map them by compression onto the more limited
+ -- range of priorities available in HP/UX.
+ -- For POSIX Threads, this table is ignored.
+
+ -- To replace the default values of the Underlying_Priorities mapping,
+ -- copy this source file into your build directory, edit the file to
+ -- reflect your desired behavior, and recompile with the command:
+
+ -- $ gcc -c -O2 -gnatpgn system.ads
+
+ -- then recompile the run-time parts that depend on this package:
+
+ -- $ gnatmake -a -gnatn -O2 <your application>
+
+ -- then force rebuilding your application if you need different options:
+
+ -- $ gnatmake -f <your options> <your application>
+
+ type Priorities_Mapping is array (Any_Priority) of Integer;
+ pragma Suppress_Initialization (Priorities_Mapping);
+ -- Suppress initialization in case gnat.adc specifies Normalize_Scalars
+
+ Underlying_Priorities : constant Priorities_Mapping :=
+
+ (Priority'First => 16,
+
+ 1 => 17,
+ 2 => 18,
+ 3 => 18,
+ 4 => 18,
+ 5 => 18,
+ 6 => 19,
+ 7 => 19,
+ 8 => 19,
+ 9 => 20,
+ 10 => 20,
+ 11 => 21,
+ 12 => 21,
+ 13 => 22,
+ 14 => 23,
+
+ Default_Priority => 24,
+
+ 16 => 25,
+ 17 => 25,
+ 18 => 25,
+ 19 => 26,
+ 20 => 26,
+ 21 => 26,
+ 22 => 27,
+ 23 => 27,
+ 24 => 27,
+ 25 => 28,
+ 26 => 28,
+ 27 => 29,
+ 28 => 29,
+ 29 => 30,
+
+ Priority'Last => 30,
+
+ Interrupt_Priority => 31);
+
+end System;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.42 $
+-- --
+-- Copyright (C) 1991-2001, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a HP-UX version of this package
+
+-- 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 System.Tasking.Debug;
+-- used for Known_Tasks
+
+with Interfaces.C;
+-- used for int
+-- size_t
+
+with System.Interrupt_Management;
+-- used for Keep_Unmasked
+-- Abort_Task_Interrupt
+-- Interrupt_ID
+
+with System.Interrupt_Management.Operations;
+-- used for Set_Interrupt_Mask
+-- All_Tasks_Mask
+pragma Elaborate_All (System.Interrupt_Management.Operations);
+
+with System.Parameters;
+-- used for Size_Type
+
+with System.Task_Primitives.Interrupt_Operations;
+-- used for Get_Interrupt_ID
+
+with System.Tasking;
+-- used for Ada_Task_Control_Block
+-- Task_ID
+
+with System.Soft_Links;
+-- used for Defer/Undefer_Abort
+
+-- Note that we do not use System.Tasking.Initialization directly since
+-- this 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.Initialization
+
+with System.OS_Primitives;
+-- used for Delay_Modes
+
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+package body System.Task_Primitives.Operations is
+
+ use System.Tasking.Debug;
+ use System.Tasking;
+ use Interfaces.C;
+ use System.OS_Interface;
+ use System.Parameters;
+ use System.OS_Primitives;
+
+ package PIO renames System.Task_Primitives.Interrupt_Operations;
+ package SSL renames System.Soft_Links;
+
+ ------------------
+ -- Local Data --
+ ------------------
+
+ -- The followings are logically constants, but need to be initialized
+ -- at run time.
+
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_ID associated with a thread
+
+ All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
+ -- See comments on locking rules in System.Tasking (spec).
+
+ Environment_Task_ID : Task_ID;
+ -- A variable to hold Task_ID for the environment task.
+
+ Unblocked_Signal_Mask : aliased sigset_t;
+ -- The set of signals that should unblocked in all tasks
+
+ Time_Slice_Val : Integer;
+ pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
+
+ Locking_Policy : Character;
+ pragma Import (C, Locking_Policy, "__gl_locking_policy");
+
+ Dispatching_Policy : Character;
+ pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
+
+ FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
+ -- Indicates whether FIFO_Within_Priorities is set.
+
+ -- The followings are internal configuration constants needed.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Abort_Handler (Sig : Signal);
+
+ function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
+
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ -- Target-dependent binding of inter-thread Abort signal to
+ -- the raising of the Abort_Signal exception.
+
+ -- The technical issues and alternatives here are essentially
+ -- the same as for raising exceptions in response to other
+ -- signals (e.g. Storage_Error). See code and comments in
+ -- the package body System.Interrupt_Management.
+
+ -- Some implementations may not allow an exception to be propagated
+ -- out of a handler, and others might leave the signal or
+ -- interrupt that invoked this handler masked after the exceptional
+ -- return to the application code.
+
+ -- GNAT exceptions are originally implemented using setjmp()/longjmp().
+ -- On most UNIX systems, this will allow transfer out of a signal handler,
+ -- which is usually the only mechanism available for implementing
+ -- asynchronous handlers of this kind. However, some
+ -- systems do not restore the signal mask on longjmp(), leaving the
+ -- abort signal masked.
+
+ -- Alternative solutions include:
+
+ -- 1. Change the PC saved in the system-dependent Context
+ -- parameter to point to code that raises the exception.
+ -- Normal return from this handler will then raise
+ -- the exception after the mask and other system state has
+ -- been restored (see example below).
+ -- 2. Use siglongjmp()/sigsetjmp() to implement exceptions.
+ -- 3. Unmask the signal in the Abortion_Signal exception handler
+ -- (in the RTS).
+
+ -- The following procedure would be needed if we can't lonjmp out of
+ -- a signal handler. (See below.)
+ -- procedure Raise_Abort_Signal is
+ -- begin
+ -- raise Standard'Abort_Signal;
+ -- end if;
+
+ procedure Abort_Handler (Sig : Signal) is
+ Self_Id : constant Task_ID := Self;
+ Result : Interfaces.C.int;
+ Old_Set : aliased sigset_t;
+
+ begin
+ -- Assuming it is safe to longjmp out of a signal handler, the
+ -- following code can be used:
+
+ if Self_Id.Deferral_Level = 0
+ and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level and then
+ not Self_Id.Aborting
+ then
+ Self_Id.Aborting := True;
+
+ -- Make sure signals used for RTS internal purpose are unmasked
+
+ Result := pthread_sigmask (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ raise Standard'Abort_Signal;
+ end if;
+
+ -- Otherwise, something like this is required:
+ -- if not Abort_Is_Deferred.all then
+ -- -- Overwrite the return PC address with the address of the
+ -- -- special raise routine, and "return" to that routine's
+ -- -- starting address.
+ -- Context.PC := Raise_Abort_Signal'Address;
+ -- return;
+ -- end if;
+ end Abort_Handler;
+
+ -----------------
+ -- Stack_Guard --
+ -----------------
+
+ -- The underlying thread system sets a guard page at the
+ -- bottom of a thread stack, so nothing is needed.
+ -- ??? Check the comment above
+
+ procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ begin
+ null;
+ end Stack_Guard;
+
+ -------------------
+ -- Get_Thread_Id --
+ -------------------
+
+ function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
+ begin
+ return T.Common.LL.Thread;
+ end Get_Thread_Id;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_ID is
+ Result : System.Address;
+
+ begin
+ Result := pthread_getspecific (ATCB_Key);
+ pragma Assert (Result /= System.Null_Address);
+ return To_Task_ID (Result);
+ end Self;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ -- Note: mutexes and cond_variables needed per-task basis are
+ -- initialized in Intialize_TCB and the Storage_Error is
+ -- handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...)
+ -- used in RTS is initialized before any status change of RTS.
+ -- Therefore rasing Storage_Error in the following routines
+ -- should be able to be handled safely.
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : access Lock)
+ is
+ Attributes : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutexattr_init (Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ L.Priority := Prio;
+
+ Result := pthread_mutex_init (L.L'Access, Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+ end Initialize_Lock;
+
+ procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) 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;
+
+ Result := pthread_mutex_init (L, Attributes'Access);
+
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_destroy (L.L'Access);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : 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 : access Lock; Ceiling_Violation : out Boolean) is
+ Result : Interfaces.C.int;
+
+ begin
+ L.Owner_Priority := Get_Priority (Self);
+
+ if L.Priority < L.Owner_Priority then
+ Ceiling_Violation := True;
+ return;
+ end if;
+
+ Result := pthread_mutex_lock (L.L'Access);
+ pragma Assert (Result = 0);
+ Ceiling_Violation := False;
+ end Write_Lock;
+
+ procedure Write_Lock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ Write_Lock (L, Ceiling_Violation);
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (L.L'Access);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ -------------
+ -- Sleep --
+ -------------
+
+ procedure Sleep (Self_ID : Task_ID;
+ Reason : System.Tasking.Task_States) is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Self_ID = Self);
+ Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access);
+ -- 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 : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ Check_Time : constant Duration := Monotonic_Clock;
+ 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;
+ else
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+ end if;
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ or else Self_ID.Pending_Priority_Change;
+
+ Result := pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
+ Request'Access);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ if Result = 0 or Result = EINTR then
+ -- somebody may have called Wakeup for us
+ Timedout := False;
+ exit;
+ end if;
+
+ pragma Assert (Result = ETIMEDOUT);
+ end loop;
+ end if;
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ -- 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
+ Check_Time : constant Duration := Monotonic_Clock;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+ begin
+
+ -- Only the little window between deferring abort and
+ -- locking Self_ID is the reason we need to
+ -- check for pending abort and priority change below! :(
+
+ SSL.Abort_Defer.all;
+ Write_Lock (Self_ID);
+
+ if Mode = Relative then
+ Abs_Time := Time + Check_Time;
+ else
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+ end if;
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+ Self_ID.Common.State := Delay_Sleep;
+
+ loop
+ if Self_ID.Pending_Priority_Change then
+ Self_ID.Pending_Priority_Change := False;
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
+ end if;
+
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access, Request'Access);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ pragma Assert (Result = 0 or else
+ Result = ETIMEDOUT or else
+ Result = EINTR);
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+ Result := sched_yield;
+ SSL.Abort_Undefer.all;
+ end Timed_Delay;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ TS : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := Clock_Gettime (CLOCK_REALTIME, TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+ return To_Duration (TS);
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ begin
+ return 10#1.0#E-6;
+ end RT_Resolution;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
+ 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;
+
+ begin
+ if Do_Yield then
+ Result := sched_yield;
+ end if;
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ type Prio_Array_Type is array (System.Any_Priority) of Integer;
+ pragma Atomic_Components (Prio_Array_Type);
+
+ Prio_Array : Prio_Array_Type;
+ -- Global array containing the id of the currently running task for
+ -- each priority.
+ --
+ -- Note: we assume that we are on a single processor with run-til-blocked
+ -- scheduling.
+
+ procedure Set_Priority
+ (T : Task_ID;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ Result : Interfaces.C.int;
+ Array_Item : Integer;
+ Param : aliased struct_sched_param;
+
+ begin
+ Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
+
+ if Time_Slice_Val > 0 then
+ Result := pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_RR, Param'Access);
+
+ elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
+ Result := pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
+
+ else
+ Result := pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
+ end if;
+
+ pragma Assert (Result = 0);
+
+ if FIFO_Within_Priorities then
+
+ -- Annex D requirement [RM D.2.2 par. 9]:
+ -- If the task drops its priority due to the loss of inherited
+ -- priority, it is added at the head of the ready queue for its
+ -- new active priority.
+
+ if Loss_Of_Inheritance
+ and then Prio < T.Common.Current_Priority
+ then
+ Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
+ Prio_Array (T.Common.Base_Priority) := Array_Item;
+
+ loop
+ -- Let some processes a chance to arrive
+
+ Yield;
+
+ -- Then wait for our turn to proceed
+
+ exit when Array_Item = Prio_Array (T.Common.Base_Priority)
+ or else Prio_Array (T.Common.Base_Priority) = 1;
+ end loop;
+
+ Prio_Array (T.Common.Base_Priority) :=
+ Prio_Array (T.Common.Base_Priority) - 1;
+ end if;
+ end if;
+
+ T.Common.Current_Priority := Prio;
+ end Set_Priority;
+
+ ------------------
+ -- Get_Priority --
+ ------------------
+
+ function Get_Priority (T : Task_ID) return System.Any_Priority is
+ begin
+ return T.Common.Current_Priority;
+ end Get_Priority;
+
+ ----------------
+ -- Enter_Task --
+ ----------------
+
+ procedure Enter_Task (Self_ID : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Self_ID.Common.LL.Thread := pthread_self;
+
+ Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID));
+ pragma Assert (Result = 0);
+
+ Lock_All_Tasks_List;
+ for I in Known_Tasks'Range loop
+ if Known_Tasks (I) = null then
+ Known_Tasks (I) := Self_ID;
+ Self_ID.Known_Tasks_Index := I;
+ exit;
+ end if;
+ end loop;
+ Unlock_All_Tasks_List;
+ 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;
+
+ ----------------------
+ -- Initialize_TCB --
+ ----------------------
+
+ procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
+ Mutex_Attr : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+ Cond_Attr : aliased pthread_condattr_t;
+
+ begin
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
+ Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
+ Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = 0 then
+ Succeeded := True;
+ else
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Succeeded := False;
+ end if;
+
+ Result := pthread_condattr_destroy (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+ end Initialize_TCB;
+
+ -----------------
+ -- Create_Task --
+ -----------------
+
+ procedure Create_Task
+ (T : Task_ID;
+ Wrapper : System.Address;
+ Stack_Size : System.Parameters.Size_Type;
+ Priority : System.Any_Priority;
+ Succeeded : out Boolean)
+ is
+ Attributes : aliased pthread_attr_t;
+ Adjusted_Stack_Size : Interfaces.C.size_t;
+ Result : Interfaces.C.int;
+
+ function Thread_Body_Access is new
+ Unchecked_Conversion (System.Address, Thread_Body);
+
+ begin
+ if Stack_Size = Unspecified_Size then
+ Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size);
+
+ elsif Stack_Size < Minimum_Stack_Size then
+ Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
+
+ else
+ Adjusted_Stack_Size := Interfaces.C.size_t (Stack_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_setstacksize
+ (Attributes'Access, Adjusted_Stack_Size);
+ pragma Assert (Result = 0);
+
+ -- Since the initial signal mask of a thread is inherited from the
+ -- creator, and the Environment task has all its signals masked, we
+ -- do not need to manipulate caller's signal mask at this point.
+ -- All tasks in RTS will have All_Tasks_Mask initially.
+
+ Result := pthread_create
+ (T.Common.LL.Thread'Access,
+ Attributes'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
+ pragma Assert (Result = 0 or else Result = EAGAIN);
+
+ Succeeded := Result = 0;
+
+ pthread_detach (T.Common.LL.Thread'Access);
+ -- Detach the thread using pthread_detach, sinc DCE threads do not have
+ -- pthread_attr_set_detachstate.
+
+ Result := pthread_attr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+
+ Set_Priority (T, Priority);
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_ID) is
+ Result : Interfaces.C.int;
+ Tmp : Task_ID := T;
+
+ procedure Free is new
+ Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
+
+ begin
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Result := pthread_cond_destroy (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+
+ if T.Known_Tasks_Index /= -1 then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ end if;
+
+ Free (Tmp);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ pthread_exit (System.Null_Address);
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_ID) is
+ begin
+ --
+ -- Interrupt Server_Tasks may be waiting on an "event" flag (signal)
+ --
+ if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then
+ System.Interrupt_Management.Operations.Interrupt_Self_Process
+ (System.Interrupt_Management.Interrupt_ID
+ (PIO.Get_Interrupt_ID (T)));
+ end if;
+ end Abort_Task;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy versions. The only currently working versions is for solaris
+ -- (native).
+
+ function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ 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_All_Tasks_List --
+ -------------------------
+
+ procedure Lock_All_Tasks_List is
+ begin
+ Write_Lock (All_Tasks_L'Access);
+ end Lock_All_Tasks_List;
+
+ ---------------------------
+ -- Unlock_All_Tasks_List --
+ ---------------------------
+
+ procedure Unlock_All_Tasks_List is
+ begin
+ Unlock (All_Tasks_L'Access);
+ end Unlock_All_Tasks_List;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ return False;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ return False;
+ end Resume_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;
+
+ begin
+
+ Environment_Task_ID := Environment_Task;
+
+ Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
+ -- Initialize the lock used to synchronize chain of all ATCBs.
+
+ Enter_Task (Environment_Task);
+
+ -- Install the abort-signal handler
+
+ 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 Initialize;
+
+ procedure do_nothing (arg : System.Address);
+
+ procedure do_nothing (arg : System.Address) is
+ begin
+ null;
+ end do_nothing;
+
+begin
+
+ declare
+ Result : Interfaces.C.int;
+ begin
+ -- NOTE: Unlike other pthread implementations, we do *not* mask all
+ -- signals here since we handle signals using the process-wide primitive
+ -- signal, rather than using sigthreadmask and sigwait. The reason of
+ -- this difference is that sigwait doesn't work when some critical
+ -- signals (SIGABRT, SIGPIPE) are masked.
+
+ Result := pthread_key_create (ATCB_Key'Access, do_nothing'Access);
+ pragma Assert (Result = 0);
+ end;
+
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- Copyright (C) 1991-2000 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a HP-UX version of this package.
+
+-- This package provides low-level support for most tasking features.
+
+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 System.OS_Interface;
+-- used for pthread_mutex_t
+-- pthread_cond_t
+-- pthread_t
+
+package System.Task_Primitives is
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects.
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system.
+ -- The difference between Lock and the RTS_Lock is that the later
+ -- one serves only as a semaphore so that do not check for
+ -- ceiling violations.
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper
+ -- declared local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task
+ -- basis. A component of this type is guaranteed to be included
+ -- in the Ada_Task_Control_Block.
+
+private
+ type Lock is record
+ L : aliased System.OS_Interface.pthread_mutex_t;
+ Priority : Integer;
+ Owner_Priority : Integer;
+ end record;
+
+ type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
+ type Private_Data is record
+ Thread : aliased System.OS_Interface.pthread_t;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb).
+ -- They put the same value (thr_self value). We do not want to
+ -- use lock on those operations and the only thing we have to
+ -- make sure is that they are updated in atomic fashion.
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+ L : aliased RTS_Lock;
+ -- protection for all components is lock L
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E B A C K --
+-- (HP/UX Version) --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.10 $
+-- --
+-- Copyright (C) 1999-2001 Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Conversion;
+
+package body System.Traceback is
+
+ -- This package implements the backtracing facility by way of a dedicated
+ -- HP library for stack unwinding described in the "Runtime Architecture
+ -- Document".
+
+ pragma Linker_Options ("/usr/lib/libcl.a");
+
+ -- The library basically offers services to fetch information about a
+ -- "previous" frame based on information about a "current" one.
+
+ type Current_Frame_Descriptor is record
+ cur_fsz : Address; -- Frame size of current routine.
+ cur_sp : Address; -- The current value of stack pointer.
+ cur_rls : Address; -- PC-space of the caller.
+ cur_rlo : Address; -- PC-offset of the caller.
+ cur_dp : Address; -- Data Pointer of the current routine.
+ top_rp : Address; -- Initial value of RP.
+ top_mrp : Address; -- Initial value of MRP.
+ top_sr0 : Address; -- Initial value of sr0.
+ top_sr4 : Address; -- Initial value of sr4.
+ top_r3 : Address; -- Initial value of gr3.
+ cur_r19 : Address; -- GR19 value of the calling routine.
+ top_r4 : Address; -- Initial value of gr4.
+ dummy : Address; -- Reserved.
+ out_rlo : Address; -- PC-offset of the caller after get_previous.
+ end record;
+
+ type Previous_Frame_Descriptor is record
+ prev_fsz : Address; -- frame size of calling routine.
+ prev_sp : Address; -- SP of calling routine.
+ prev_rls : Address; -- PC_space of calling routine's caller.
+ prev_rlo : Address; -- PC_offset of calling routine's caller.
+ prev_dp : Address; -- DP of calling routine.
+ udescr0 : Address; -- low word of calling routine's unwind desc.
+ udescr1 : Address; -- high word of calling routine's unwind desc.
+ ustart : Address; -- start of the unwind region.
+ uend : Address; -- end of the unwind region.
+ uw_index : Address; -- index into the unwind table.
+ prev_r19 : Address; -- GR19 value of the caller's caller.
+ top_r3 : Address; -- Caller's initial gr3.
+ top_r4 : Address; -- Caller's initial gr4.
+ end record;
+
+ -- Provide useful shortcuts for the names
+
+ subtype CFD is Current_Frame_Descriptor;
+ subtype PFD is Previous_Frame_Descriptor;
+
+ -- Frames with dynamic stack allocation are handled using the associated
+ -- frame pointer, but HP compilers and GCC setup this pointer differently.
+ -- HP compilers set it to point at the top (highest address) of the static
+ -- part of the frame, wheras GCC sets it to point at the bottom of this
+ -- region. We have to fake the unwinder to compensate for this difference,
+ -- for which we'll need to access some subprograms unwind descriptors.
+
+ type Bits_2_Value is mod 2 ** 2;
+ for Bits_2_Value'Size use 2;
+
+ type Bits_4_Value is mod 2 ** 4;
+ for Bits_4_Value'Size use 4;
+
+ type Bits_5_Value is mod 2 ** 5;
+ for Bits_5_Value'Size use 5;
+
+ type Bits_27_Value is mod 2 ** 27;
+ for Bits_27_Value'Size use 27;
+
+ type Unwind_Descriptor is record
+ cannot_unwind : Boolean;
+ mcode : Boolean;
+ mcode_save_restore : Boolean;
+ region_desc : Bits_2_Value;
+ reserved0 : Boolean;
+ entry_sr : Boolean;
+ entry_fr : Bits_4_Value;
+ entry_gr : Bits_5_Value;
+
+ args_stored : Boolean;
+ variable_frame : Boolean;
+ separate_package_body : Boolean;
+ frame_extension_mcode : Boolean;
+
+ stack_overflow_check : Boolean;
+ two_steps_sp_adjust : Boolean;
+ sr4_export : Boolean;
+ cxx_info : Boolean;
+
+ cxx_try_catch : Boolean;
+ sched_entry_seq : Boolean;
+ reserved1 : Boolean;
+ save_sp : Boolean;
+
+ save_rp : Boolean;
+ save_mrp : Boolean;
+ save_r19 : Boolean;
+ cleanups : Boolean;
+
+ hpe_interrupt_marker : Boolean;
+ hpux_interrupt_marker : Boolean;
+ large_frame : Boolean;
+ alloca_frame : Boolean;
+
+ reserved2 : Boolean;
+ frame_size : Bits_27_Value;
+ end record;
+
+ for Unwind_Descriptor'Size use 64;
+
+ for Unwind_Descriptor use record
+ cannot_unwind at 0 range 0 .. 0;
+ mcode at 0 range 1 .. 1;
+ mcode_save_restore at 0 range 2 .. 2;
+ region_desc at 0 range 3 .. 4;
+ reserved0 at 0 range 5 .. 5;
+ entry_sr at 0 range 6 .. 6;
+ entry_fr at 0 range 7 .. 10;
+
+ entry_gr at 1 range 3 .. 7;
+
+ args_stored at 2 range 0 .. 0;
+ variable_frame at 2 range 1 .. 1;
+ separate_package_body at 2 range 2 .. 2;
+ frame_extension_mcode at 2 range 3 .. 3;
+ stack_overflow_check at 2 range 4 .. 4;
+ two_steps_sp_adjust at 2 range 5 .. 5;
+ sr4_export at 2 range 6 .. 6;
+ cxx_info at 2 range 7 .. 7;
+
+ cxx_try_catch at 3 range 0 .. 0;
+ sched_entry_seq at 3 range 1 .. 1;
+ reserved1 at 3 range 2 .. 2;
+ save_sp at 3 range 3 .. 3;
+ save_rp at 3 range 4 .. 4;
+ save_mrp at 3 range 5 .. 5;
+ save_r19 at 3 range 6 .. 6;
+ cleanups at 3 range 7 .. 7;
+
+ hpe_interrupt_marker at 4 range 0 .. 0;
+ hpux_interrupt_marker at 4 range 1 .. 1;
+ large_frame at 4 range 2 .. 2;
+ alloca_frame at 4 range 3 .. 3;
+
+ reserved2 at 4 range 4 .. 4;
+ frame_size at 4 range 5 .. 31;
+ end record;
+
+ subtype UWD is Unwind_Descriptor;
+ type UWD_Ptr is access all UWD;
+
+ function To_UWD_Access is new Ada.Unchecked_Conversion (Address, UWD_Ptr);
+
+ -- The descriptor associated with a given code location is retrieved
+ -- using functions imported from the HP library, requiring the definition
+ -- of additional structures.
+
+ type Unwind_Table_Region is record
+ Table_Start : Address;
+ Table_End : Address;
+ end record;
+ -- An Unwind Table region, which is a memory area containing Unwind
+ -- Descriptors.
+
+ subtype UWT is Unwind_Table_Region;
+ type UWT_Ptr is access all UWT;
+
+ function To_UWT_Address is new Ada.Unchecked_Conversion (UWT_Ptr, Address);
+
+ -- The subprograms imported below are provided by the HP library
+
+ function U_get_unwind_table return UWT;
+ pragma Import (C, U_get_unwind_table, "U_get_unwind_table");
+ -- Get the unwind table region associated with the current executable.
+ -- This function is actually documented as having an argument, but which
+ -- is only used for the MPE/iX targets.
+
+ function U_get_shLib_unwind_table (r19 : Address) return UWT;
+ pragma Import (C, U_get_shLib_unwind_table, "U_get_shLib_unw_tbl");
+ -- Return the unwind table region associated with a possible shared
+ -- library, as determined by the provided r19 value.
+
+ function U_get_shLib_text_addr (r19 : Address) return Address;
+ pragma Import (C, U_get_shLib_text_addr, "U_get_shLib_text_addr");
+ -- Return the address at which the code for a shared library begins, or
+ -- -1 if the value provided for r19 does not identify shared library code.
+
+ function U_get_unwind_entry
+ (Pc : Address;
+ Space : Address;
+ Table_Start : Address;
+ Table_End : Address)
+ return Address;
+ pragma Import (C, U_get_unwind_entry, "U_get_unwind_entry");
+ -- Given the bounds of an unwind table, return the address of the
+ -- unwind descriptor associated with a code location/space. In the case
+ -- of shared library code, the offset from the beginning of the library
+ -- is expected as Pc.
+
+ procedure U_init_frame_record (Frame : access CFD);
+ pragma Import (C, U_init_frame_record, "U_init_frame_record");
+
+ procedure U_prep_frame_rec_for_unwind (Frame : access CFD);
+ pragma Import (C, U_prep_frame_rec_for_unwind,
+ "U_prep_frame_rec_for_unwind");
+
+ -- Fetch the description data of the frame in which these two procedures
+ -- are called.
+
+ function U_get_u_rlo (Cur : access CFD; Prev : access PFD) return Integer;
+ pragma Import (C, U_get_u_rlo, "U_IS_STUB_OR_CALLX");
+ -- From a complete current frame with a return location possibly located
+ -- into a linker generated stub, and basic information about the previous
+ -- frame, place the first non stub return location into the current frame.
+ -- Return -1 if something went wrong during the computation.
+
+ function U_is_shared_pc (rlo : Address; r19 : Address) return Address;
+ pragma Import (C, U_is_shared_pc, "U_is_shared_pc");
+ -- Return 0 if the provided return location does not correspond to code
+ -- in a shared library, or something non null otherwise.
+
+ function U_get_previous_frame_x
+ (current_frame : access CFD;
+ previous_frame : access PFD;
+ previous_size : Integer)
+ return Integer;
+ pragma Import (C, U_get_previous_frame_x, "U_get_previous_frame_x");
+ -- Fetch the data describing the "previous" frame relatively to the
+ -- "current" one. "previous_size" should be the size of the "previous"
+ -- frame descriptor provided.
+ --
+ -- The library provides a simpler interface without the size parameter
+ -- but it is not usable when frames with dynamically allocated space are
+ -- on the way.
+
+ ------------------
+ -- C_Call_Chain --
+ ------------------
+
+ function C_Call_Chain
+ (Traceback : System.Address;
+ Max_Len : Natural)
+ return Natural
+ is
+ Val : Natural;
+
+ begin
+ Call_Chain (Traceback, Max_Len, Val);
+ return Val;
+ end C_Call_Chain;
+
+ ----------------
+ -- Call_Chain --
+ ----------------
+
+ procedure Call_Chain
+ (Traceback : System.Address;
+ Max_Len : Natural;
+ Len : out Natural;
+ Exclude_Min : System.Address := System.Null_Address;
+ Exclude_Max : System.Address := System.Null_Address)
+ is
+ type Tracebacks_Array is array (1 .. Max_Len) of System.Address;
+ pragma Suppress_Initialization (Tracebacks_Array);
+
+ -- The code location returned by the unwinder is a return location but
+ -- what we need is a call point. Under HP-UX call instructions are 4
+ -- bytes long and the return point they specify is 4 bytes beyond the
+ -- next instruction because of the delay slot.
+
+ Call_Size : constant := 4;
+ DSlot_Size : constant := 4;
+ Rlo_Offset : constant := Call_Size + DSlot_Size;
+
+ -- Moreover, the return point is passed via a register which two least
+ -- significant bits specify a privilege level that we will have to mask.
+
+ Priv_Mask : constant := 16#00000003#;
+
+ Frame : aliased CFD;
+ Code : System.Address;
+ J : Natural := 1;
+ Pop_Success : Boolean;
+ Trace : Tracebacks_Array;
+ for Trace'Address use Traceback;
+
+ -- The backtracing process needs a set of subprograms :
+
+ function UWD_For_RLO_Of (Frame : access CFD) return UWD_Ptr;
+ -- Return an access to the unwind descriptor for the caller of
+ -- a given frame, using only the provided return location.
+
+ function UWD_For_Caller_Of (Frame : access CFD) return UWD_Ptr;
+ -- Return an access to the unwind descriptor for the user code caller
+ -- of a given frame, or null if the information is not available.
+
+ function Pop_Frame (Frame : access CFD) return Boolean;
+ -- Update the provided machine state structure so that it reflects
+ -- the state one call frame "above" the initial one.
+ --
+ -- Return True if the operation has been successful, False otherwise.
+ -- Failure typically occurs when the top of the call stack has been
+ -- reached.
+
+ function Prepare_For_Unwind_Of (Frame : access CFD) return Boolean;
+ -- Perform the necessary adaptations to the machine state before
+ -- calling the unwinder. Currently used for the specific case of
+ -- dynamically sized previous frames.
+ --
+ -- Return True if everything went fine, or False otherwise.
+
+ Program_UWT : constant UWT := U_get_unwind_table;
+
+ ---------------
+ -- Pop_Frame --
+ ---------------
+
+ function Pop_Frame (Frame : access CFD) return Boolean is
+ Up_Frame : aliased PFD;
+ State_Ready : Boolean;
+
+ begin
+ -- Check/adapt the state before calling the unwinder and return
+ -- if anything went wrong.
+
+ State_Ready := Prepare_For_Unwind_Of (Frame);
+
+ if not State_Ready then
+ return False;
+ end if;
+
+ -- Now, safely call the unwinder and use the results.
+
+ if U_get_previous_frame_x (Frame,
+ Up_Frame'Access,
+ Up_Frame'Size) /= 0
+ then
+ return False;
+ end if;
+
+ -- In case a stub is on the way, the usual previous return location
+ -- (the one in prev_rlo) is the one in the stub and the "real" one
+ -- is placed in the "current" record, so let's take this one into
+ -- account.
+
+ Frame.out_rlo := Frame.cur_rlo;
+
+ Frame.cur_fsz := Up_Frame.prev_fsz;
+ Frame.cur_sp := Up_Frame.prev_sp;
+ Frame.cur_rls := Up_Frame.prev_rls;
+ Frame.cur_rlo := Up_Frame.prev_rlo;
+ Frame.cur_dp := Up_Frame.prev_dp;
+ Frame.cur_r19 := Up_Frame.prev_r19;
+ Frame.top_r3 := Up_Frame.top_r3;
+ Frame.top_r4 := Up_Frame.top_r4;
+
+ return True;
+ end Pop_Frame;
+
+ ---------------------------------
+ -- Prepare_State_For_Unwind_Of --
+ ---------------------------------
+
+ function Prepare_For_Unwind_Of (Frame : access CFD) return Boolean
+ is
+ Caller_UWD : UWD_Ptr;
+ FP_Adjustment : Integer;
+
+ begin
+ -- No need to bother doing anything if the stack is already fully
+ -- unwound.
+
+ if Frame.cur_rlo = 0 then
+ return False;
+ end if;
+
+ -- When ALLOCA_FRAME is set in an unwind descriptor, the unwinder
+ -- uses the value provided in current.top_r3 or current.top_r4 as
+ -- a frame pointer to compute the size of the frame. What decides
+ -- between r3 or r4 is the unwind descriptor LARGE_FRAME bit, with
+ -- r4 chosen if the bit is set.
+
+ -- The size computed by the unwinder is STATIC_PART + (SP - FP),
+ -- which is correct with HP's frame pointer convention, but not
+ -- with GCC's one since we end up with the static part accounted
+ -- for twice.
+
+ -- We have to compute r4 when it is required because the unwinder
+ -- has looked for it at a place where it was not if we went through
+ -- GCC frames.
+
+ -- The size of the static part of a frame can be found in the
+ -- associated unwind descriptor.
+
+ Caller_UWD := UWD_For_Caller_Of (Frame);
+
+ -- If we cannot get it, we are unable to compute the potentially
+ -- necessary adjustments. We'd better not try to go on then.
+
+ if Caller_UWD = null then
+ return False;
+ end if;
+
+ -- If the caller frame is a GCC one, r3 is its frame pointer and
+ -- points to the bottom of the frame. The value to provide for r4
+ -- can then be computed directly from the one of r3, compensating
+ -- for the static part of the frame.
+
+ -- If the caller frame is an HP one, r3 is used to locate the
+ -- previous frame marker, that is it also points to the bottom of
+ -- the frame (this is why r3 cannot be used as the frame pointer in
+ -- the HP sense for large frames). The value to provide for r4 can
+ -- then also be computed from the one of r3 with the compensation
+ -- for the static part of the frame.
+
+ FP_Adjustment := Integer (Caller_UWD.frame_size * 8);
+ Frame.top_r4 := Address (Integer (Frame.top_r3) + FP_Adjustment);
+
+ return True;
+ end Prepare_For_Unwind_Of;
+
+ -----------------------
+ -- UWD_For_Caller_Of --
+ -----------------------
+
+ function UWD_For_Caller_Of (Frame : access CFD) return UWD_Ptr
+ is
+ UWD_Access : UWD_Ptr;
+
+ begin
+ -- First try the most direct path, using the return location data
+ -- associated with the frame.
+
+ UWD_Access := UWD_For_RLO_Of (Frame);
+
+ if UWD_Access /= null then
+ return UWD_Access;
+ end if;
+
+ -- If we did not get a result, we might face an in-stub return
+ -- address. In this case U_get_previous_frame can tell us what the
+ -- first not-in-stub return point is. We cannot call it directly,
+ -- though, because we haven't computed the potentially necessary
+ -- frame pointer adjustments, which might lead to SEGV in some
+ -- circumstances. Instead, we directly call the libcl routine which
+ -- is called by U_get_previous_frame and which only requires few
+ -- information. Take care, however, that the information is provided
+ -- in the "current" argument, so we need to work on a copy to avoid
+ -- disturbing our caller.
+
+ declare
+ U_Current : aliased CFD := Frame.all;
+ U_Previous : aliased PFD;
+
+ begin
+ U_Previous.prev_dp := U_Current.cur_dp;
+ U_Previous.prev_rls := U_Current.cur_rls;
+ U_Previous.prev_sp := U_Current.cur_sp - U_Current.cur_fsz;
+
+ if U_get_u_rlo (U_Current'Access, U_Previous'Access) /= -1 then
+ UWD_Access := UWD_For_RLO_Of (U_Current'Access);
+ end if;
+ end;
+
+ return UWD_Access;
+ end UWD_For_Caller_Of;
+
+ --------------------
+ -- UWD_For_RLO_Of --
+ --------------------
+
+ function UWD_For_RLO_Of (Frame : access CFD) return UWD_Ptr
+ is
+ UWD_Address : Address;
+
+ -- The addresses returned by the library point to full descriptors
+ -- including the frame information bits but also the applicable PC
+ -- range. We need to account for this.
+
+ Frame_Info_Offset : constant := 8;
+
+ begin
+ -- First try to locate the descriptor in the program's unwind table.
+
+ UWD_Address := U_get_unwind_entry (Frame.cur_rlo,
+ Frame.cur_rls,
+ Program_UWT.Table_Start,
+ Program_UWT.Table_End);
+
+ -- If we did not get it, we might have a frame from code in a
+ -- stub or shared library. For code in stub we would have to
+ -- compute the first non-stub return location but this is not
+ -- the role of this subprogram, so let's just try to see if we
+ -- can get a result from the tables in shared libraries.
+
+ if UWD_Address = -1
+ and then U_is_shared_pc (Frame.cur_rlo, Frame.cur_r19) /= 0
+ then
+ declare
+ Shlib_UWT : UWT := U_get_shLib_unwind_table (Frame.cur_r19);
+ Shlib_Start : Address := U_get_shLib_text_addr (Frame.cur_r19);
+ Rlo_Offset : Address := Frame.cur_rlo - Shlib_Start;
+
+ begin
+ UWD_Address := U_get_unwind_entry (Rlo_Offset,
+ Frame.cur_rls,
+ Shlib_UWT.Table_Start,
+ Shlib_UWT.Table_End);
+ end;
+ end if;
+
+ if UWD_Address /= -1 then
+ return To_UWD_Access (UWD_Address + Frame_Info_Offset);
+ else
+ return null;
+ end if;
+ end UWD_For_RLO_Of;
+
+ -- Start of processing for Call_Chain
+
+ begin
+ -- Fetch the state for this subprogram's frame and pop it so that the
+ -- backtrace starts at the right point for our caller, that is at its
+ -- own frame.
+
+ U_init_frame_record (Frame'Access);
+ Frame.top_sr0 := 0;
+ Frame.top_sr4 := 0;
+
+ U_prep_frame_rec_for_unwind (Frame'Access);
+
+ Pop_Success := Pop_Frame (Frame'Access);
+
+ -- Loop popping frames and storing locations until either a problem
+ -- occurs, or the top of the call chain is reached, or the provided
+ -- array is full.
+
+ loop
+ -- We have to test some conditions against the return location
+ -- as it is returned, so get it as is first.
+
+ Code := Frame.out_rlo;
+
+ exit when not Pop_Success or else Code = 0 or else J = Max_Len + 1;
+
+ -- Compute the call point from the retrieved return location :
+ -- Mask the privilege bits and account for the delta between the
+ -- call site and the return point.
+
+ Code := (Code and not Priv_Mask) - Rlo_Offset;
+
+ if Code < Exclude_Min or else Code > Exclude_Max then
+ Trace (J) := Code;
+ J := J + 1;
+ end if;
+
+ Pop_Success := Pop_Frame (Frame'Access);
+ end loop;
+
+ Len := J - 1;
+ end Call_Chain;
+
+end System.Traceback;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.12 $
+-- --
+-- Copyright (C) 1991-2001 Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a LinuxThreads, Solaris pthread and HP-UX pthread 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.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+with Interfaces.C; use Interfaces.C;
+package body System.OS_Interface is
+
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ -----------------
+ -- 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;
+
+ function To_Duration (TV : struct_timeval) return Duration is
+ begin
+ return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
+ 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;
+
+ ----------------
+ -- To_Timeval --
+ ----------------
+
+ function To_Timeval (D : Duration) return struct_timeval 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 struct_timeval'
+ (tv_sec => S, tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
+ end To_Timeval;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.27 $
+-- --
+-- Copyright (C) 1991-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Linux (LinuxThreads) version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lpthread");
+
+ 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;
+ EPERM : constant := 1;
+ ETIMEDOUT : constant := 110;
+
+ -------------
+ -- 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)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 7; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 10; -- user defined signal 1
+ SIGUSR2 : constant := 12; -- user defined signal 2
+ SIGCLD : constant := 17; -- alias for SIGCHLD
+ SIGCHLD : constant := 17; -- child status change
+ SIGPWR : constant := 30; -- power-fail restart
+ SIGWINCH : constant := 28; -- window size change
+ SIGURG : constant := 23; -- urgent condition on IO channel
+ SIGPOLL : constant := 29; -- pollable event occurred
+ SIGIO : constant := 29; -- I/O now possible (4.2 BSD)
+ SIGLOST : constant := 29; -- File lock lost
+ SIGSTOP : constant := 19; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 20; -- user stop requested from tty
+ SIGCONT : constant := 18; -- stopped process has been continued
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGUNUSED : constant := 31; -- unused signal (Linux)
+ SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux)
+ SIGLTHRRES : constant := 32; -- LinuxThreads restart signal
+ SIGLTHRCAN : constant := 33; -- LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 34; -- LinuxThreads debugger signal
+
+ 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,
+ -- To enable debugging on multithreaded applications, mark SIGTRAP to
+ -- be kept unmasked.
+
+ SIGBUS,
+
+ SIGTTIN, SIGTTOU, SIGTSTP,
+ -- Keep these three signals unmasked so that background processes
+ -- and IO behaves as normal "C" applications
+
+ SIGPROF,
+ -- To avoid confusing the profiler
+
+ SIGKILL, SIGSTOP,
+ -- These two signals actually cannot be masked;
+ -- POSIX simply won't allow it.
+
+ SIGLTHRRES, SIGLTHRCAN, SIGLTHRDBG);
+ -- These three signals are used by LinuxThreads starting from
+ -- glibc 2.1 (future 2.2).
+
+ Reserved : constant Signal_Set :=
+ -- I am not sure why the following two signals are reserved.
+ -- I guess they are not supported by this version of Linux.
+ (SIGVTALRM, SIGUNUSED);
+
+ 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 union_type_3 is new String (1 .. 116);
+ type siginfo_t is record
+ si_signo : int;
+ si_code : int;
+ si_errno : int;
+ X_data : union_type_3;
+ end record;
+ pragma Convention (C, siginfo_t);
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : unsigned_long;
+ sa_restorer : System.Address;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ type Machine_State is record
+ eip : unsigned_long;
+ ebx : unsigned_long;
+ esp : unsigned_long;
+ ebp : unsigned_long;
+ esi : unsigned_long;
+ edi : unsigned_long;
+ end record;
+ type Machine_State_Ptr is access all Machine_State;
+
+ 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 --
+ ----------
+
+ type timespec is private;
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ type struct_timeval is private;
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ function gettimeofday
+ (tv : access struct_timeval;
+ tz : System.Address := System.Null_Address) return int;
+ pragma Import (C, gettimeofday, "gettimeofday");
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_OTHER : constant := 0;
+ SCHED_FIFO : constant := 1;
+ SCHED_RR : constant := 2;
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ 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;
+
+ -----------
+ -- Stack --
+ -----------
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- This is a dummy procedure to share some GNULLI files
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ procedure pthread_init;
+ pragma Inline (pthread_init);
+ -- This is a dummy procedure to share some GNULLI files
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait (set : access sigset_t; sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill (thread : pthread_t; sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- 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");
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ type struct_sched_param is record
+ sched_priority : int; -- scheduling priority
+ end record;
+ pragma Convention (C, struct_sched_param);
+
+ 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_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import
+ (C, pthread_attr_setschedpolicy, "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, "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 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 pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+
+ type sigset_t is array (0 .. 31) of unsigned_long;
+ pragma Convention (C, sigset_t);
+ for sigset_t'Size use 1024;
+ -- This is for GNU libc version 2 but should be backward compatible with
+ -- other libc where sigset_t is smaller.
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type struct_timeval is record
+ tv_sec : time_t;
+ tv_usec : time_t;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type pthread_attr_t is record
+ detachstate : int;
+ schedpolicy : int;
+ schedparam : struct_sched_param;
+ inheritsched : int;
+ scope : int;
+ guardsize : size_t;
+ stackaddr_set : int;
+ stackaddr : System.Address;
+ stacksize : size_t;
+ end record;
+ pragma Convention (C_Pass_By_Copy, pthread_attr_t);
+
+ type pthread_condattr_t is record
+ dummy : int;
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_mutexattr_t is record
+ mutexkind : int;
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type pthread_t is new unsigned_long;
+
+ type struct_pthread_queue is record
+ head : System.Address;
+ tail : System.Address;
+ end record;
+ pragma Convention (C, struct_pthread_queue);
+
+ type pthread_mutex_t is record
+ m_spinlock : int;
+ m_count : int;
+ m_owner : System.Address;
+ m_kind : int;
+ m_waiting : struct_pthread_queue;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_cond_t is record
+ c_spinlock : int;
+ c_waiting : struct_pthread_queue;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new unsigned;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.43 $
+-- --
+-- Copyright (C) 1991-2001, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Linux (LinuxThreads) version of this package
+
+-- 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 System.Tasking.Debug;
+-- used for Known_Tasks
+
+with Interfaces.C;
+-- used for int
+-- size_t
+
+with System.Interrupt_Management;
+-- used for Keep_Unmasked
+-- Abort_Task_Interrupt
+-- Interrupt_ID
+
+with System.Interrupt_Management.Operations;
+-- used for Set_Interrupt_Mask
+-- All_Tasks_Mask
+pragma Elaborate_All (System.Interrupt_Management.Operations);
+
+with System.Parameters;
+-- used for Size_Type
+
+with System.Tasking;
+-- used for Ada_Task_Control_Block
+-- Task_ID
+
+with Ada.Exceptions;
+-- used for Raise_Exception
+-- Raise_From_Signal_Handler
+-- Exception_Id
+
+with System.Soft_Links;
+-- used for Defer/Undefer_Abort
+
+-- Note that we do not use System.Tasking.Initialization directly since
+-- this 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.Initialization
+
+with System.OS_Primitives;
+-- used for Delay_Modes
+
+with System.Soft_Links;
+-- used for Get_Machine_State_Addr
+
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+package body System.Task_Primitives.Operations is
+
+ use System.Tasking.Debug;
+ use System.Tasking;
+ use Interfaces.C;
+ use System.OS_Interface;
+ use System.Parameters;
+ use System.OS_Primitives;
+
+ package SSL renames System.Soft_Links;
+
+ ------------------
+ -- Local Data --
+ ------------------
+
+ Max_Stack_Size : constant := 2000 * 1024;
+ -- LinuxThreads does not return an error value when requesting
+ -- a task stack size which is too large, so we have to check this
+ -- ourselves.
+
+ -- The followings are logically constants, but need to be initialized
+ -- at run time.
+
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_ID associated with a thread
+
+ All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
+ -- See comments on locking rules in System.Tasking (spec).
+
+ Environment_Task_ID : Task_ID;
+ -- A variable to hold Task_ID for the environment task.
+
+ Unblocked_Signal_Mask : aliased sigset_t;
+ -- The set of signals that should unblocked in all tasks
+
+ -- The followings are internal configuration constants needed.
+ Priority_Ceiling_Emulation : constant Boolean := True;
+
+ Next_Serial_Number : Task_Serial_Number := 100;
+ -- We start at 100, to reserve some special values for
+ -- using in error checking.
+ -- The following are internal configuration constants needed.
+
+ 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");
+
+ FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
+ -- Indicates whether FIFO_Within_Priorities is set.
+
+ -- The following are effectively constants, but they need to
+ -- be initialized by calling a pthread_ function.
+
+ Mutex_Attr : aliased pthread_mutexattr_t;
+ Cond_Attr : aliased pthread_condattr_t;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+
+ procedure Abort_Handler
+ (signo : Signal;
+ gs : unsigned_short;
+ fs : unsigned_short;
+ es : unsigned_short;
+ ds : unsigned_short;
+ edi : unsigned_long;
+ esi : unsigned_long;
+ ebp : unsigned_long;
+ esp : unsigned_long;
+ ebx : unsigned_long;
+ edx : unsigned_long;
+ ecx : unsigned_long;
+ eax : unsigned_long;
+ trapno : unsigned_long;
+ err : unsigned_long;
+ eip : unsigned_long;
+ cs : unsigned_short;
+ eflags : unsigned_long;
+ esp_at_signal : unsigned_long;
+ ss : unsigned_short;
+ fpstate : System.Address;
+ oldmask : unsigned_long;
+ cr2 : unsigned_long);
+
+ function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
+
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+
+ function To_pthread_t is new Unchecked_Conversion
+ (Integer, System.OS_Interface.pthread_t);
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ -- Target-dependent binding of inter-thread Abort signal to
+ -- the raising of the Abort_Signal exception.
+
+ -- The technical issues and alternatives here are essentially
+ -- the same as for raising exceptions in response to other
+ -- signals (e.g. Storage_Error). See code and comments in
+ -- the package body System.Interrupt_Management.
+
+ -- Some implementations may not allow an exception to be propagated
+ -- out of a handler, and others might leave the signal or
+ -- interrupt that invoked this handler masked after the exceptional
+ -- return to the application code.
+
+ -- GNAT exceptions are originally implemented using setjmp()/longjmp().
+ -- On most UNIX systems, this will allow transfer out of a signal handler,
+ -- which is usually the only mechanism available for implementing
+ -- asynchronous handlers of this kind. However, some
+ -- systems do not restore the signal mask on longjmp(), leaving the
+ -- abort signal masked.
+
+ -- Alternative solutions include:
+
+ -- 1. Change the PC saved in the system-dependent Context
+ -- parameter to point to code that raises the exception.
+ -- Normal return from this handler will then raise
+ -- the exception after the mask and other system state has
+ -- been restored (see example below).
+ -- 2. Use siglongjmp()/sigsetjmp() to implement exceptions.
+ -- 3. Unmask the signal in the Abortion_Signal exception handler
+ -- (in the RTS).
+
+ -- Note that with the new exception mechanism, it is not correct to
+ -- simply "raise" an exception from a signal handler, that's why we
+ -- use Raise_From_Signal_Handler
+
+ procedure Abort_Handler
+ (signo : Signal;
+ gs : unsigned_short;
+ fs : unsigned_short;
+ es : unsigned_short;
+ ds : unsigned_short;
+ edi : unsigned_long;
+ esi : unsigned_long;
+ ebp : unsigned_long;
+ esp : unsigned_long;
+ ebx : unsigned_long;
+ edx : unsigned_long;
+ ecx : unsigned_long;
+ eax : unsigned_long;
+ trapno : unsigned_long;
+ err : unsigned_long;
+ eip : unsigned_long;
+ cs : unsigned_short;
+ eflags : unsigned_long;
+ esp_at_signal : unsigned_long;
+ ss : unsigned_short;
+ fpstate : System.Address;
+ oldmask : unsigned_long;
+ cr2 : unsigned_long)
+ is
+ Self_Id : Task_ID := Self;
+ Result : Interfaces.C.int;
+ Old_Set : aliased sigset_t;
+
+ function To_Machine_State_Ptr is new
+ Unchecked_Conversion (Address, Machine_State_Ptr);
+
+ -- These are not directly visible
+
+ procedure Raise_From_Signal_Handler
+ (E : Ada.Exceptions.Exception_Id;
+ M : System.Address);
+ pragma Import
+ (Ada, Raise_From_Signal_Handler,
+ "ada__exceptions__raise_from_signal_handler");
+ pragma No_Return (Raise_From_Signal_Handler);
+
+ mstate : Machine_State_Ptr;
+ message : aliased constant String := "" & ASCII.Nul;
+ -- a null terminated String.
+
+ begin
+ if Self_Id.Deferral_Level = 0
+ and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
+ and then not Self_Id.Aborting
+ then
+ Self_Id.Aborting := True;
+
+ -- Make sure signals used for RTS internal purpose are unmasked
+
+ Result := pthread_sigmask (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ mstate := To_Machine_State_Ptr (SSL.Get_Machine_State_Addr.all);
+ mstate.eip := eip;
+ mstate.ebx := ebx;
+ mstate.esp := esp_at_signal;
+ mstate.ebp := ebp;
+ mstate.esi := esi;
+ mstate.edi := edi;
+
+ Raise_From_Signal_Handler
+ (Standard'Abort_Signal'Identity, message'Address);
+ end if;
+ end Abort_Handler;
+
+ -------------------
+ -- Stack_Guard --
+ -------------------
+
+ -- The underlying thread system extends the memory (up to 2MB) when
+ -- needed.
+
+ procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ begin
+ null;
+ end Stack_Guard;
+
+ --------------------
+ -- Get_Thread_Id --
+ --------------------
+
+ function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
+ begin
+ return T.Common.LL.Thread;
+ end Get_Thread_Id;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_ID is
+ Result : System.Address;
+
+ begin
+ Result := pthread_getspecific (ATCB_Key);
+ pragma Assert (Result /= System.Null_Address);
+ return To_Task_ID (Result);
+ end Self;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ -- Note: mutexes and cond_variables needed per-task basis are
+ -- initialized in Intialize_TCB and the Storage_Error is
+ -- handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...)
+ -- used in RTS is initialized before any status change of RTS.
+ -- Therefore rasing Storage_Error in the following routines
+ -- should be able to be handled safely.
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : access Lock)
+ is
+ Result : Interfaces.C.int;
+ begin
+ if Priority_Ceiling_Emulation then
+ L.Ceiling := Prio;
+ end if;
+
+ Result := pthread_mutex_init (L.L'Access, Mutex_Attr'Access);
+
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ Ada.Exceptions.Raise_Exception (Storage_Error'Identity,
+ "Failed to allocate a lock");
+ end if;
+ end Initialize_Lock;
+
+ procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_init (L, Mutex_Attr'Access);
+
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_destroy (L.L'Access);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : 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 : access Lock; Ceiling_Violation : out Boolean) is
+ Result : Interfaces.C.int;
+
+ begin
+ if Priority_Ceiling_Emulation then
+ declare
+ Self_ID : constant Task_ID := Self;
+ begin
+ if Self_ID.Common.LL.Active_Priority > L.Ceiling then
+ Ceiling_Violation := True;
+ return;
+ end if;
+ L.Saved_Priority := Self_ID.Common.LL.Active_Priority;
+ if Self_ID.Common.LL.Active_Priority < L.Ceiling then
+ Self_ID.Common.LL.Active_Priority := L.Ceiling;
+ end if;
+ Result := pthread_mutex_lock (L.L'Access);
+ pragma Assert (Result = 0);
+ Ceiling_Violation := False;
+ end;
+ else
+ Result := pthread_mutex_lock (L.L'Access);
+ Ceiling_Violation := Result = EINVAL;
+ -- assumes the cause of EINVAL is a priority ceiling violation
+ pragma Assert (Result = 0 or else Result = EINVAL);
+ end if;
+ end Write_Lock;
+
+ procedure Write_Lock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ Write_Lock (L, Ceiling_Violation);
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ if Priority_Ceiling_Emulation then
+ declare
+ Self_ID : constant Task_ID := Self;
+ begin
+ Result := pthread_mutex_unlock (L.L'Access);
+ pragma Assert (Result = 0);
+ if Self_ID.Common.LL.Active_Priority > L.Saved_Priority then
+ Self_ID.Common.LL.Active_Priority := L.Saved_Priority;
+ end if;
+ end;
+ else
+ Result := pthread_mutex_unlock (L.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+ end Unlock;
+
+ procedure Unlock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+ -- Beware of any changes to this that might
+ -- require access to the ATCB after the mutex is unlocked.
+ -- This is the last operation performed by a task
+ -- before it allows its ATCB to be deallocated, so it
+ -- MUST NOT refer to the ATCB.
+
+ begin
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ -------------
+ -- Sleep --
+ -------------
+
+ procedure Sleep (Self_ID : Task_ID;
+ Reason : System.Tasking.Task_States) is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Self_ID = Self);
+ Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access);
+ -- 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 : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ Check_Time : constant Duration := Monotonic_Clock;
+ 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;
+ else
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+ end if;
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ or else Self_ID.Pending_Priority_Change;
+
+ Result := pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
+ Request'Access);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ if Result = 0 or Result = EINTR then
+ -- somebody may have called Wakeup for us
+ Timedout := False;
+ exit;
+ end if;
+
+ pragma Assert (Result = ETIMEDOUT);
+ end loop;
+ end if;
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ -- 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
+ Check_Time : constant Duration := Monotonic_Clock;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+ begin
+
+ -- Only the little window between deferring abort and
+ -- locking Self_ID is the reason we need to
+ -- check for pending abort and priority change below! :(
+
+ SSL.Abort_Defer.all;
+ Write_Lock (Self_ID);
+
+ if Mode = Relative then
+ Abs_Time := Time + Check_Time;
+ else
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+ end if;
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+ Self_ID.Common.State := Delay_Sleep;
+
+ loop
+ if Self_ID.Pending_Priority_Change then
+ Self_ID.Pending_Priority_Change := False;
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
+ end if;
+
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access, Request'Access);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ pragma Assert (Result = 0 or else
+ Result = ETIMEDOUT or else
+ Result = EINTR);
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+ Result := sched_yield;
+ SSL.Abort_Undefer.all;
+ end Timed_Delay;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ TV : aliased struct_timeval;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := gettimeofday (TV'Access, System.Null_Address);
+ pragma Assert (Result = 0);
+ return To_Duration (TV);
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ begin
+ return 10#1.0#E-6;
+ end RT_Resolution;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
+ 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;
+
+ begin
+ if Do_Yield then
+ Result := sched_yield;
+ end if;
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_Priority
+ (T : Task_ID;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ Result : Interfaces.C.int;
+ Param : aliased struct_sched_param;
+
+ begin
+ T.Common.Current_Priority := Prio;
+
+ if Priority_Ceiling_Emulation then
+ if T.Common.LL.Active_Priority < Prio then
+ T.Common.LL.Active_Priority := Prio;
+ end if;
+ end if;
+
+ -- Priorities are in range 1 .. 99 on Linux, so map 0 .. 31 to 1 .. 32
+ Param.sched_priority := Interfaces.C.int (Prio) + 1;
+
+ if Time_Slice_Val > 0 then
+ Result := pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_RR, Param'Access);
+
+ elsif FIFO_Within_Priorities 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 or else Result = EPERM);
+ 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
+ Result : Interfaces.C.int;
+
+ begin
+ Self_ID.Common.LL.Thread := pthread_self;
+
+ Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID));
+ pragma Assert (Result = 0);
+
+ Lock_All_Tasks_List;
+ for I in Known_Tasks'Range loop
+ if Known_Tasks (I) = null then
+ Known_Tasks (I) := Self_ID;
+ Self_ID.Known_Tasks_Index := I;
+ exit;
+ end if;
+ end loop;
+ Unlock_All_Tasks_List;
+ 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;
+
+ --------------------
+ -- Initialize_TCB --
+ --------------------
+
+ procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
+ Result : Interfaces.C.int;
+
+ 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);
+
+ Self_ID.Common.LL.Thread := To_pthread_t (-1);
+
+ Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
+ Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
+ Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = 0 then
+ Succeeded := True;
+ else
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Succeeded := False;
+ end if;
+
+ Result := pthread_condattr_destroy (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+ end Initialize_TCB;
+
+ -----------------
+ -- Create_Task --
+ -----------------
+
+ procedure Create_Task
+ (T : Task_ID;
+ Wrapper : System.Address;
+ Stack_Size : System.Parameters.Size_Type;
+ Priority : System.Any_Priority;
+ Succeeded : out Boolean)
+ is
+ Attributes : aliased pthread_attr_t;
+ Result : Interfaces.C.int;
+
+ function Thread_Body_Access is new
+ Unchecked_Conversion (System.Address, Thread_Body);
+
+ begin
+ Result := pthread_attr_init (Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 or else Stack_Size > Max_Stack_Size then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_attr_setdetachstate
+ (Attributes'Access, PTHREAD_CREATE_DETACHED);
+ pragma Assert (Result = 0);
+
+ -- Since the initial signal mask of a thread is inherited from the
+ -- creator, and the Environment task has all its signals masked, we
+ -- do not need to manipulate caller's signal mask at this point.
+ -- All tasks in RTS will have All_Tasks_Mask initially.
+
+ Result := pthread_create
+ (T.Common.LL.Thread'Access,
+ Attributes'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
+ pragma Assert (Result = 0 or else Result = EAGAIN);
+
+ Succeeded := Result = 0;
+
+ Result := pthread_attr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+
+ Set_Priority (T, Priority);
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_ID) is
+ Result : Interfaces.C.int;
+ Tmp : Task_ID := T;
+
+ procedure Free is new
+ Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
+
+ begin
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Result := pthread_cond_destroy (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+ if T.Known_Tasks_Index /= -1 then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ end if;
+ Free (Tmp);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ pthread_exit (System.Null_Address);
+ 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;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy versions. The only currently working versions is for solaris
+ -- (native).
+
+ function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ 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_All_Tasks_List --
+ -------------------------
+
+ procedure Lock_All_Tasks_List is
+ begin
+ Write_Lock (All_Tasks_L'Access);
+ end Lock_All_Tasks_List;
+
+ ---------------------------
+ -- Unlock_All_Tasks_List --
+ ---------------------------
+
+ procedure Unlock_All_Tasks_List is
+ begin
+ Unlock (All_Tasks_L'Access);
+ end Unlock_All_Tasks_List;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ if T.Common.LL.Thread /= Thread_Self then
+ return pthread_kill (T.Common.LL.Thread, SIGSTOP) = 0;
+ else
+ return True;
+ end if;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ if T.Common.LL.Thread /= Thread_Self then
+ return pthread_kill (T.Common.LL.Thread, SIGCONT) = 0;
+ else
+ return True;
+ end if;
+ end Resume_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;
+
+ begin
+ Environment_Task_ID := Environment_Task;
+
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
+ -- Initialize the lock used to synchronize chain of all ATCBs.
+
+ Enter_Task (Environment_Task);
+
+ -- Install the abort-signal handler
+
+ 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 (Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end Initialize;
+
+begin
+ declare
+ Result : Interfaces.C.int;
+ begin
+ -- Mask Environment task for all signals. The original mask of the
+ -- Environment task will be recovered by Interrupt_Server task
+ -- during the elaboration of s-interr.adb.
+
+ System.Interrupt_Management.Operations.Set_Interrupt_Mask
+ (System.Interrupt_Management.Operations.All_Tasks_Mask'Access);
+
+ -- 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;
+
+ Result := pthread_key_create (ATCB_Key'Access, null);
+ pragma Assert (Result = 0);
+ end;
+
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1991-2000 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Linux (LinuxThreads) version of this package.
+
+-- This package provides low-level support for most tasking features.
+
+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 System.OS_Interface;
+-- used for pthread_mutex_t
+-- pthread_cond_t
+-- pthread_t
+
+package System.Task_Primitives is
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects.
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system.
+ -- The difference between Lock and the RTS_Lock is that the later
+ -- one serves only as a semaphore so that do not check for
+ -- ceiling violations.
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper
+ -- declared local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task
+ -- basis. A component of this type is guaranteed to be included
+ -- in the Ada_Task_Control_Block.
+
+private
+
+ type Prio_Array_Type is array (System.Any_Priority) of Integer;
+
+ type Lock is record
+ L : aliased System.OS_Interface.pthread_mutex_t;
+ Ceiling : System.Any_Priority := System.Any_Priority'First;
+ Saved_Priority : System.Any_Priority := System.Any_Priority'First;
+ end record;
+
+ type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
+ type Private_Data is record
+ Thread : aliased System.OS_Interface.pthread_t;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb).
+ -- They put the same value (thr_self value). We do not want to
+ -- use lock on those operations and the only thing we have to
+ -- make sure is that they are updated in atomic fashion.
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+ L : aliased RTS_Lock;
+ -- protection for all components is lock L
+
+ Active_Priority : System.Any_Priority := System.Any_Priority'First;
+ -- Simulated active priority,
+ -- used only if Priority_Ceiling_Support is True.
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (VxWorks version M68K) --
+-- --
+-- $Revision: 1.11 $
+-- --
+-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ 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 := Integer'Last;
+
+ 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 := Standard'Tick;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := Standard'Storage_Unit;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Standard'Address_Size;
+
+ -- 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 :=
+ Bit_Order'Val (Standard'Default_Bit_Order);
+
+ -- Priority-related Declarations (RM D.1)
+
+ -- 256 is reserved for the VxWorks kernel
+ -- 248 - 255 correspond to hardware interrupt levels 0 .. 7
+ -- 247 is a catchall default "interrupt" priority for signals, allowing
+ -- higher priority than normal tasks, but lower than hardware
+ -- priority levels. Protected Object ceilings can override
+ -- these values
+ -- 246 is used by the Interrupt_Manager task
+
+ Max_Priority : constant Positive := 245;
+
+ Max_Interrupt_Priority : constant Positive := 255;
+
+ subtype Any_Priority is Integer
+ range 0 .. Standard'Max_Interrupt_Priority;
+
+ subtype Priority is Any_Priority
+ range 0 .. Standard'Max_Priority;
+
+ -- Functional notation is needed in the following to avoid visibility
+ -- problems when this package is compiled through rtsfind in the middle
+ -- of another compilation.
+
+ subtype Interrupt_Priority is Any_Priority
+ range
+ Standard."+" (Standard'Max_Priority, 1) ..
+ Standard'Max_Interrupt_Priority;
+
+ Default_Priority : constant Priority :=
+ Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
+
+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.
+
+ AAMP : constant Boolean := False;
+ Command_Line_Args : constant Boolean := False;
+ Denorm : constant Boolean := True;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := False;
+ High_Integrity_Mode : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := False;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := True;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+end System;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1998-2001 Free Software Foundation --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the M68K VxWorks version of this package.
+
+with Interfaces.C;
+
+package System.VxWorks is
+ pragma Preelaborate (System.VxWorks);
+
+ package IC renames Interfaces.C;
+
+ -- Define enough of a Wind Task Control Block in order to
+ -- obtain the inherited priority. When porting this to
+ -- different versions of VxWorks (this is based on 5.3[.1]),
+ -- be sure to look at the definition for WIND_TCB located
+ -- in $WIND_BASE/target/h/taskLib.h
+
+ type Wind_Fill_1 is array (0 .. 16#3F#) of IC.unsigned_char;
+ type Wind_Fill_2 is array (16#48# .. 16#107#) of IC.unsigned_char;
+
+ type Wind_TCB is record
+ Fill_1 : Wind_Fill_1; -- 0x00 - 0x3f
+ Priority : IC.int; -- 0x40 - 0x43, current (inherited) priority
+ Normal_Priority : IC.int; -- 0x44 - 0x47, base priority
+ Fill_2 : Wind_Fill_2; -- 0x48 - 0x107
+ spare1 : Address; -- 0x108 - 0x10b
+ spare2 : Address; -- 0x10c - 0x10f
+ spare3 : Address; -- 0x110 - 0x113
+ spare4 : Address; -- 0x114 - 0x117
+ end record;
+ type Wind_TCB_Ptr is access Wind_TCB;
+
+ -- Floating point context record. 68K version
+
+ FP_NUM_DREGS : constant := 8;
+ FP_STATE_FRAME_SIZE : constant := 216;
+
+ type DOUBLEX is array (1 .. 12) of Interfaces.Unsigned_8;
+ pragma Pack (DOUBLEX);
+ for DOUBLEX'Size use 12 * 8;
+
+ type DOUBLEX_Array is array (1 .. FP_NUM_DREGS) of DOUBLEX;
+ pragma Pack (DOUBLEX_Array);
+ for DOUBLEX_Array'Size use FP_NUM_DREGS * 12 * 8;
+
+ type FPREG_SET is record
+ fpcr : IC.int;
+ fpsr : IC.int;
+ fpiar : IC.int;
+ fpx : DOUBLEX_Array;
+ end record;
+
+ type Fp_State_Frame_Array is array (1 .. FP_STATE_FRAME_SIZE) of IC.char;
+ pragma Pack (Fp_State_Frame_Array);
+ for Fp_State_Frame_Array'Size use 8 * FP_STATE_FRAME_SIZE;
+
+ type FP_CONTEXT is record
+ fpRegSet : FPREG_SET;
+ stateFrame : Fp_State_Frame_Array;
+ end record;
+ pragma Convention (C, FP_CONTEXT);
+
+ Num_HW_Interrupts : constant := 256;
+ -- Number of entries in the hardware interrupt vector table
+
+ -- VxWorks 5.3 and 5.4 version
+ type TASK_DESC is record
+ td_id : IC.int; -- task id
+ td_name : Address; -- name of task
+ td_priority : IC.int; -- task priority
+ td_status : IC.int; -- task status
+ td_options : IC.int; -- task option bits (see below)
+ td_entry : Address; -- original entry point of task
+ td_sp : Address; -- saved stack pointer
+ td_pStackBase : Address; -- the bottom of the stack
+ td_pStackLimit : Address; -- the effective end of the stack
+ td_pStackEnd : Address; -- the actual end of the stack
+ td_stackSize : IC.int; -- size of stack in bytes
+ td_stackCurrent : IC.int; -- current stack usage in bytes
+ td_stackHigh : IC.int; -- maximum stack usage in bytes
+ td_stackMargin : IC.int; -- current stack margin in bytes
+ td_errorStatus : IC.int; -- most recent task error status
+ td_delay : IC.int; -- delay/timeout ticks
+ end record;
+ pragma Convention (C, TASK_DESC);
+
+end System.VxWorks;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.18 $
+-- --
+-- Copyright (C) 1991-2001 Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Linux version of this package
+
+-- This file performs the system-dependent translation between machine
+-- exceptions and the Ada exceptions, if any, that should be raised when they
+-- occur. This version works for the x86 running linux.
+
+-- This is a Sun OS (FSU THREADS) version of this package
+
+-- PLEASE DO NOT add any dependences on other packages. ??? why not ???
+-- This package is designed to work with or without tasking support.
+
+-- Make a careful study of all signals available under the OS, to see which
+-- need to be reserved, kept always unmasked, or kept always unmasked. Be on
+-- the lookout for special signals that may be used by the thread library.
+
+-- The definitions of "reserved" differ slightly between the ARM and POSIX.
+-- Here is the ARM definition of reserved interrupt:
+
+-- The set of reserved interrupts is implementation defined. A reserved
+-- interrupt is either an interrupt for which user-defined handlers are not
+-- supported, or one which already has an attached handler by some other
+-- implementation-defined means. Program units can be connected to
+-- non-reserved interrupts.
+
+-- POSIX.5b/.5c specifies further:
+
+-- Signals which the application cannot accept, and for which the application
+-- cannot modify the signal action or masking, because the signals are
+-- reserved for use by the Ada language implementation. The reserved signals
+-- defined by this standard are Signal_Abort, Signal_Alarm,
+-- Signal_Floating_Point_Error, Signal_Illegal_Instruction,
+-- Signal_Segmentation_Violation, Signal_Bus_Error. If the implementation
+-- supports any signals besides those defined by this standard, the
+-- implementation may also reserve some of those.
+
+-- The signals defined by POSIX.5b/.5c that are not specified as being
+-- reserved are SIGHUP, SIGINT, SIGPIPE, SIGQUIT, SIGTERM, SIGUSR1, SIGUSR2,
+-- SIGCHLD, SIGCONT, SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU, SIGIO SIGURG, and all
+-- the real-time signals.
+
+-- Beware of reserving signals that POSIX.5b/.5c require to be available for
+-- users. POSIX.5b/.5c say:
+
+-- An implementation shall not impose restrictions on the ability of an
+-- application to send, accept, block, or ignore the signals defined by this
+-- standard, except as specified in this standard.
+
+-- Here are some other relevant requirements from POSIX.5b/.5c:
+
+-- For the environment task, the initial signal mask is that specified for
+-- the process...
+
+-- It is anticipated that the paragraph above may be modified by a future
+-- revision of this standard, to require that the realtime signals always be
+-- initially masked for a process that is an Ada active partition.
+
+-- For all other tasks, the initial signal mask shall include all the signals
+-- that are not reserved signals and are not bound to entries of the task.
+
+with Interfaces.C;
+-- used for int and other types
+
+with System.Error_Reporting;
+-- used for Shutdown
+
+with System.OS_Interface;
+-- used for various Constants, Signal and types
+
+with Ada.Exceptions;
+-- used for Exception_Id
+-- Raise_From_Signal_Handler
+
+with System.Soft_Links;
+-- used for Get_Machine_State_Addr
+
+with Unchecked_Conversion;
+
+package body System.Interrupt_Management is
+
+ use Interfaces.C;
+ use System.Error_Reporting;
+ use System.OS_Interface;
+
+ package TSL renames System.Soft_Links;
+
+ type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
+ Exception_Interrupts : constant Interrupt_List :=
+ (SIGFPE, SIGILL, SIGSEGV);
+
+ Unreserve_All_Interrupts : Interfaces.C.int;
+ pragma Import
+ (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
+
+ subtype int is Interfaces.C.int;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+
+ ----------------------
+ -- Notify_Exception --
+ ----------------------
+
+ Signal_Mask : aliased sigset_t;
+ -- The set of signals handled by Notify_Exception
+
+ -- This function identifies the Ada exception to be raised using
+ -- the information when the system received a synchronous signal.
+ -- Since this function is machine and OS dependent, different code
+ -- has to be provided for different target.
+
+ procedure Notify_Exception
+ (signo : Signal;
+ gs : unsigned_short;
+ fs : unsigned_short;
+ es : unsigned_short;
+ ds : unsigned_short;
+ edi : unsigned_long;
+ esi : unsigned_long;
+ ebp : unsigned_long;
+ esp : unsigned_long;
+ ebx : unsigned_long;
+ edx : unsigned_long;
+ ecx : unsigned_long;
+ eax : unsigned_long;
+ trapno : unsigned_long;
+ err : unsigned_long;
+ eip : unsigned_long;
+ cs : unsigned_short;
+ eflags : unsigned_long;
+ esp_at_signal : unsigned_long;
+ ss : unsigned_short;
+ fpstate : System.Address;
+ oldmask : unsigned_long;
+ cr2 : unsigned_long);
+
+ procedure Notify_Exception
+ (signo : Signal;
+ gs : unsigned_short;
+ fs : unsigned_short;
+ es : unsigned_short;
+ ds : unsigned_short;
+ edi : unsigned_long;
+ esi : unsigned_long;
+ ebp : unsigned_long;
+ esp : unsigned_long;
+ ebx : unsigned_long;
+ edx : unsigned_long;
+ ecx : unsigned_long;
+ eax : unsigned_long;
+ trapno : unsigned_long;
+ err : unsigned_long;
+ eip : unsigned_long;
+ cs : unsigned_short;
+ eflags : unsigned_long;
+ esp_at_signal : unsigned_long;
+ ss : unsigned_short;
+ fpstate : System.Address;
+ oldmask : unsigned_long;
+ cr2 : unsigned_long)
+ is
+
+ function To_Machine_State_Ptr is new
+ Unchecked_Conversion (Address, Machine_State_Ptr);
+
+ -- These are not directly visible
+
+ procedure Raise_From_Signal_Handler
+ (E : Ada.Exceptions.Exception_Id;
+ M : System.Address);
+ pragma Import
+ (Ada, Raise_From_Signal_Handler,
+ "ada__exceptions__raise_from_signal_handler");
+ pragma No_Return (Raise_From_Signal_Handler);
+
+ mstate : Machine_State_Ptr;
+ message : aliased constant String := "" & ASCII.Nul;
+ -- a null terminated String.
+
+ Result : int;
+
+ begin
+
+ -- Raise_From_Signal_Handler makes sure that the exception is raised
+ -- safely from this signal handler.
+
+ -- ??? The original signal mask (the one we had before coming into this
+ -- signal catching function) should be restored by
+ -- Raise_From_Signal_Handler. For now, restore it explicitely
+
+ Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null);
+ pragma Assert (Result = 0);
+
+ -- Check that treatment of exception propagation here
+ -- is consistent with treatment of the abort signal in
+ -- System.Task_Primitives.Operations.
+
+ mstate := To_Machine_State_Ptr (TSL.Get_Machine_State_Addr.all);
+ mstate.eip := eip;
+ mstate.ebx := ebx;
+ mstate.esp := esp_at_signal;
+ mstate.ebp := ebp;
+ mstate.esi := esi;
+ mstate.edi := edi;
+
+ case signo is
+ when SIGFPE =>
+ Raise_From_Signal_Handler
+ (Constraint_Error'Identity, message'Address);
+ when SIGILL =>
+ Raise_From_Signal_Handler
+ (Constraint_Error'Identity, message'Address);
+ when SIGSEGV =>
+ Raise_From_Signal_Handler
+ (Storage_Error'Identity, message'Address);
+ when others =>
+ if Shutdown ("Unexpected signal") then
+ null;
+ end if;
+ end case;
+ end Notify_Exception;
+
+ ---------------------------
+ -- Initialize_Interrupts --
+ ---------------------------
+
+ -- Nothing needs to be done on this platform.
+
+ procedure Initialize_Interrupts is
+ begin
+ null;
+ end Initialize_Interrupts;
+
+begin
+ declare
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Result : int;
+
+ begin
+
+ -- Need to call pthread_init very early because it is doing signal
+ -- initializations.
+
+ pthread_init;
+
+ Abort_Task_Interrupt := SIGADAABORT;
+
+ act.sa_handler := Notify_Exception'Address;
+
+ act.sa_flags := 0;
+ -- On some targets, we set sa_flags to SA_NODEFER so that during the
+ -- handler execution we do not change the Signal_Mask to be masked for
+ -- the Signal.
+ -- This is a temporary fix to the problem that the Signal_Mask is
+ -- not restored after the exception (longjmp) from the handler.
+ -- The right fix should be made in sigsetjmp so that we save
+ -- the Signal_Set and restore it after a longjmp.
+ -- Since SA_NODEFER is obsolete, instead we reset explicitely
+ -- the mask in the exception handler.
+
+ Result := sigemptyset (Signal_Mask'Access);
+ pragma Assert (Result = 0);
+
+ for J in Exception_Interrupts'Range loop
+ Result :=
+ sigaddset (Signal_Mask'Access, Signal (Exception_Interrupts (J)));
+ pragma Assert (Result = 0);
+ end loop;
+
+ act.sa_mask := Signal_Mask;
+
+ Result :=
+ sigaction
+ (Signal (SIGFPE), act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ for J in Exception_Interrupts'First + 1 .. Exception_Interrupts'Last loop
+ Keep_Unmasked (Exception_Interrupts (J)) := True;
+ if Unreserve_All_Interrupts = 0 then
+ Result :=
+ sigaction
+ (Signal (Exception_Interrupts (J)),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
+
+ Keep_Unmasked (Abort_Task_Interrupt) := True;
+ Keep_Unmasked (SIGXCPU) := True;
+ Keep_Unmasked (SIGBUS) := True;
+ Keep_Unmasked (SIGFPE) := True;
+
+ -- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but in the
+ -- same time, disable the ability of handling this signal
+ -- via Ada.Interrupts.
+ -- The pragma Unreserve_All_Interrupts let the user the ability to
+ -- change this behavior.
+
+ if Unreserve_All_Interrupts = 0 then
+ Keep_Unmasked (SIGINT) := True;
+ end if;
+
+ for J in Unmasked'Range loop
+ Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
+ end loop;
+
+ Reserve := Keep_Unmasked or Keep_Masked;
+
+ for J in Reserved'Range loop
+ Reserve (Interrupt_ID (Reserved (J))) := True;
+ end loop;
+
+ Reserve (0) := True;
+ -- We do not have Signal 0 in reality. We just use this value
+ -- to identify non-existent signals (see s-intnam.ads). Therefore,
+ -- Signal 0 should not be used in all signal related operations hence
+ -- mark it as reserved.
+
+ end;
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . T G T --
+-- (Linux Version) --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 2001, Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a set of target dependent routines to build
+-- static, dynamic and shared libraries.
+
+-- This is the Linux version of the body.
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with MLib.Fil;
+with MLib.Utl;
+with Namet; use Namet;
+with Opt;
+with Osint; use Osint;
+with Output; use Output;
+with System;
+
+package body MLib.Tgt is
+
+ use GNAT;
+ use MLib;
+
+ -- ??? serious lack of comments below, all these declarations need to
+ -- be commented, none are:
+
+ package Files renames MLib.Fil;
+ package Tools renames MLib.Utl;
+
+ Args : Argument_List_Access := new Argument_List (1 .. 20);
+ Last_Arg : Natural := 0;
+
+ Cp : constant String_Access := Locate_Exec_On_Path ("cp");
+ Force : constant String_Access := new String'("-f");
+
+ procedure Add_Arg (Arg : String);
+
+ -------------
+ -- Add_Arg --
+ -------------
+
+ procedure Add_Arg (Arg : String) is
+ begin
+ if Last_Arg = Args'Last then
+ declare
+ New_Args : constant Argument_List_Access :=
+ new Argument_List (1 .. Args'Last * 2);
+
+ begin
+ New_Args (Args'Range) := Args.all;
+ Args := New_Args;
+ end;
+ end if;
+
+ Last_Arg := Last_Arg + 1;
+ Args (Last_Arg) := new String'(Arg);
+ end Add_Arg;
+
+ -----------------
+ -- Archive_Ext --
+ -----------------
+
+ function Archive_Ext return String is
+ begin
+ return "a";
+ end Archive_Ext;
+
+ -----------------
+ -- Base_Option --
+ -----------------
+
+ function Base_Option return String is
+ begin
+ return "";
+ end Base_Option;
+
+ ---------------------------
+ -- Build_Dynamic_Library --
+ ---------------------------
+
+ procedure Build_Dynamic_Library
+ (Ofiles : Argument_List;
+ Foreign : Argument_List;
+ Afiles : Argument_List;
+ Options : Argument_List;
+ Lib_Filename : String;
+ Lib_Dir : String;
+ Lib_Address : String := "";
+ Lib_Version : String := "";
+ Relocatable : Boolean := False)
+ is
+ Lib_File : constant String :=
+ Lib_Dir & Directory_Separator & "lib" &
+ Files.Ext_To (Lib_Filename, DLL_Ext);
+
+ use type Argument_List;
+ use type String_Access;
+
+ Version_Arg : String_Access;
+
+ Symbolic_Link_Needed : Boolean := False;
+
+ begin
+ if Opt.Verbose_Mode then
+ Write_Str ("building relocatable shared library ");
+ Write_Line (Lib_File);
+ end if;
+
+ if Lib_Version = "" then
+ Tools.Gcc
+ (Output_File => Lib_File,
+ Objects => Ofiles,
+ Options => Options);
+
+ else
+ Version_Arg := new String'("-Wl,-soname," & Lib_Version);
+
+ if Is_Absolute_Path (Lib_Version) then
+ Tools.Gcc
+ (Output_File => Lib_Version,
+ Objects => Ofiles,
+ Options => Options & Version_Arg);
+ Symbolic_Link_Needed := Lib_Version /= Lib_File;
+
+ else
+ Tools.Gcc
+ (Output_File => Lib_Dir & Directory_Separator & Lib_Version,
+ Objects => Ofiles,
+ Options => Options & Version_Arg);
+ Symbolic_Link_Needed :=
+ Lib_Dir & Directory_Separator & Lib_Version /= Lib_File;
+ end if;
+
+ if Symbolic_Link_Needed then
+ declare
+ Success : Boolean;
+ Oldpath : String (1 .. Lib_Version'Length + 1);
+ Newpath : String (1 .. Lib_File'Length + 1);
+ Result : Integer;
+
+ function Symlink
+ (Oldpath : System.Address;
+ Newpath : System.Address)
+ return Integer;
+ pragma Import (C, Symlink, "__gnat_symlink");
+
+ begin
+ Oldpath (1 .. Lib_Version'Length) := Lib_Version;
+ Oldpath (Oldpath'Last) := ASCII.NUL;
+ Newpath (1 .. Lib_File'Length) := Lib_File;
+ Newpath (Newpath'Last) := ASCII.NUL;
+
+ Delete_File (Lib_File, Success);
+
+ Result := Symlink (Oldpath'Address, Newpath'Address);
+ end;
+ end if;
+ end if;
+ end Build_Dynamic_Library;
+
+ --------------------
+ -- Copy_ALI_Files --
+ --------------------
+
+ procedure Copy_ALI_Files
+ (From : Name_Id;
+ To : Name_Id)
+ is
+ Dir : Dir_Type;
+ Name : String (1 .. 1_000);
+ Last : Natural;
+ Success : Boolean;
+ From_Dir : constant String := Get_Name_String (From);
+ To_Dir : constant String_Access :=
+ new String'(Get_Name_String (To));
+
+ begin
+ Last_Arg := 0;
+ Open (Dir, From_Dir);
+
+ loop
+ Read (Dir, Name, Last);
+ exit when Last = 0;
+ if Last > 4
+
+ and then
+ To_Lower (Name (Last - 3 .. Last)) = ".ali"
+ then
+ Add_Arg (From_Dir & Directory_Separator & Name (1 .. Last));
+ end if;
+ end loop;
+
+ if Last_Arg /= 0 then
+ if not Opt.Quiet_Output then
+ Write_Str ("cp -f ");
+
+ for J in 1 .. Last_Arg loop
+ Write_Str (Args (J).all);
+ Write_Char (' ');
+ end loop;
+
+ Write_Line (To_Dir.all);
+ end if;
+
+ Spawn (Cp.all,
+ Force & Args (1 .. Last_Arg) & To_Dir,
+ Success);
+
+ if not Success then
+ Fail ("could not copy ALI files to library dir");
+ end if;
+ end if;
+ end Copy_ALI_Files;
+
+ -------------------------
+ -- Default_DLL_Address --
+ -------------------------
+
+ function Default_DLL_Address return String is
+ begin
+ return "";
+ end Default_DLL_Address;
+
+ -------------
+ -- DLL_Ext --
+ -------------
+
+ function DLL_Ext return String is
+ begin
+ return "so";
+ end DLL_Ext;
+
+ --------------------
+ -- Dynamic_Option --
+ --------------------
+
+ function Dynamic_Option return String is
+ begin
+ return "-shared";
+ end Dynamic_Option;
+
+ -------------------
+ -- Is_Object_Ext --
+ -------------------
+
+ function Is_Object_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".o";
+ end Is_Object_Ext;
+
+ --------------
+ -- Is_C_Ext --
+ --------------
+
+ function Is_C_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".c";
+ end Is_C_Ext;
+
+ --------------------
+ -- Is_Archive_Ext --
+ --------------------
+
+ function Is_Archive_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".a" or else Ext = ".so";
+ end Is_Archive_Ext;
+
+ -------------
+ -- Libgnat --
+ -------------
+
+ function Libgnat return String is
+ begin
+ return "libgnat.a";
+ end Libgnat;
+
+ -----------------------------
+ -- Libraries_Are_Supported --
+ -----------------------------
+
+ function Libraries_Are_Supported return Boolean is
+ begin
+ return True;
+ end Libraries_Are_Supported;
+
+ --------------------------------
+ -- Linker_Library_Path_Option --
+ --------------------------------
+
+ function Linker_Library_Path_Option
+ (Directory : String)
+ return String_Access
+ is
+ begin
+ return new String'("-Wl,-rpath," & Directory);
+ end Linker_Library_Path_Option;
+
+ ----------------
+ -- Object_Ext --
+ ----------------
+
+ function Object_Ext return String is
+ begin
+ return "o";
+ end Object_Ext;
+
+ ----------------
+ -- PIC_Option --
+ ----------------
+
+ function PIC_Option return String is
+ begin
+ return "-fPIC";
+ end PIC_Option;
+
+end MLib.Tgt;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.27 $
+-- --
+-- Copyright (C) 1991-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Linux (FSU THREADS) version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lgthreads");
+ pragma Linker_Options ("-lmalloc");
+
+ 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 := 110;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 31;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 7; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 10; -- user defined signal 1
+ SIGUSR2 : constant := 12; -- user defined signal 2
+ SIGCLD : constant := 17; -- alias for SIGCHLD
+ SIGCHLD : constant := 17; -- child status change
+ SIGPWR : constant := 30; -- power-fail restart
+ SIGWINCH : constant := 28; -- window size change
+ SIGURG : constant := 23; -- urgent condition on IO channel
+ SIGPOLL : constant := 29; -- pollable event occurred
+ SIGIO : constant := 29; -- I/O now possible (4.2 BSD)
+ SIGLOST : constant := 29; -- File lock lost
+ SIGSTOP : constant := 19; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 20; -- user stop requested from tty
+ SIGCONT : constant := 18; -- stopped process has been continued
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGUNUSED : constant := 31; -- unused signal (Linux)
+ SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux)
+
+ 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, SIGBUS, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF);
+
+ Reserved : constant Signal_Set :=
+ (SIGKILL, SIGSTOP, SIGALRM, SIGVTALRM, SIGUNUSED);
+
+ 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 : unsigned_long;
+ sa_restorer : System.Address;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ type Machine_State is record
+ eip : unsigned_long;
+ ebx : unsigned_long;
+ esp : unsigned_long;
+ ebp : unsigned_long;
+ esi : unsigned_long;
+ edi : unsigned_long;
+ end record;
+ type Machine_State_Ptr is access all Machine_State;
+
+ 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 := False;
+ -- Indicates wether time slicing is supported (i.e FSU threads have been
+ -- compiled with DEF_RR)
+
+ type timespec is private;
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "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_timeval is private;
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 0;
+ SCHED_RR : constant := 1;
+ SCHED_OTHER : constant := 2;
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- 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;
+ 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;
+
+ -----------
+ -- Stack --
+ -----------
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates wether the stack base is available on this target.
+ -- This allows us to share s-osinte.adb between all the FSU run time.
+ -- Note that this value can only be true if pthread_t has a complete
+ -- definition that corresponds exactly to the C header files.
+
+ 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_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
+
+ PROT_ON : constant := PROT_NONE;
+ 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;
+ -- FSU_THREADS requires pthread_init, which is nonstandard
+ -- and this should be invoked during the elaboration of s-taprop.adb
+ pragma Import (C, pthread_init, "pthread_init");
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ pragma Inline (sigwait);
+ -- FSU_THREADS has a nonstandard sigwait
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ -- FSU threads does not have pthread_sigmask. Instead, it uses
+ -- sigprocmask to do the signal handling when the thread library is
+ -- sucked in.
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "sigprocmask");
+
+ --------------------------
+ -- 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 Inline (pthread_mutex_lock);
+ -- FSU_THREADS has nonstandard pthread_mutex_lock
+
+ function pthread_mutex_unlock
+ (mutex : access pthread_mutex_t) return int;
+ pragma Inline (pthread_mutex_unlock);
+ -- FSU_THREADS has nonstandard pthread_mutex_lock
+
+ 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 Inline (pthread_cond_wait);
+ -- FSU_THREADS has a nonstandard pthread_cond_wait
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Inline (pthread_cond_timedwait);
+ -- FSU_THREADS has a nonstandard 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_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ 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,
+ "pthread_mutexattr_setprio_ceiling");
+
+ 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);
+ -- FSU_THREADS does not have 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, "pthread_attr_setsched");
+
+ function sched_yield return int;
+ pragma Inline (sched_yield);
+ -- FSU_THREADS does not have 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 Inline (pthread_attr_setdetachstate);
+ -- FSU_THREADS has a nonstandard 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 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 pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Inline (pthread_getspecific);
+ -- FSU_THREADS has a nonstandard pthread_getspecific
+
+ type destructor_pointer is access procedure (arg : System.Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+
+ type sigset_t is array (0 .. 31) of unsigned_long;
+ pragma Convention (C, sigset_t);
+ -- This is for GNU libc version 2 but should be backward compatible with
+ -- other libc where sigset_t is smaller.
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 0;
+
+ type struct_timeval is record
+ tv_sec : long;
+ tv_usec : long;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type pthread_attr_t is record
+ flags : int;
+ stacksize : int;
+ contentionscope : int;
+ inheritsched : int;
+ detachstate : int;
+ sched : int;
+ prio : int;
+ starttime : timespec;
+ deadline : timespec;
+ period : timespec;
+ end record;
+ pragma Convention (C_Pass_By_Copy, pthread_attr_t);
+
+ type pthread_condattr_t is record
+ flags : int;
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_mutexattr_t is record
+ flags : int;
+ prio_ceiling : int;
+ protocol : int;
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type sigjmp_buf is array (Integer range 0 .. 38) of int;
+
+ type pthread_t_struct is record
+ context : sigjmp_buf;
+ pbody : sigjmp_buf;
+ errno : int;
+ ret : int;
+ stack_base : System.Address;
+ end record;
+ pragma Convention (C, pthread_t_struct);
+
+ type pthread_t is access all pthread_t_struct;
+
+ type queue_t is record
+ head : System.Address;
+ tail : System.Address;
+ end record;
+ pragma Convention (C, queue_t);
+
+ type pthread_mutex_t is record
+ queue : queue_t;
+ lock : plain_char;
+ owner : System.Address;
+ flags : int;
+ prio_ceiling : int;
+ protocol : int;
+ prev_max_ceiling_prio : int;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_cond_t is record
+ queue : queue_t;
+ flags : int;
+ waiters : int;
+ mutex : System.Address;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (Linux/x86 Version)
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ 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 := Integer'Last;
+
+ 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 := Standard'Tick;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := Standard'Storage_Unit;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Standard'Address_Size;
+
+ -- 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 :=
+ Bit_Order'Val (Standard'Default_Bit_Order);
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer
+ range 0 .. Standard'Max_Interrupt_Priority;
+
+ subtype Priority is Any_Priority
+ range 0 .. Standard'Max_Priority;
+
+ -- Functional notation is needed in the following to avoid visibility
+ -- problems when this package is compiled through rtsfind in the middle
+ -- of another compilation.
+
+ subtype Interrupt_Priority is Any_Priority
+ range
+ Standard."+" (Standard'Max_Priority, 1) ..
+ Standard'Max_Interrupt_Priority;
+
+ Default_Priority : constant Priority :=
+ Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
+
+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.
+
+ AAMP : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Denorm : constant Boolean := True;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+ High_Integrity_Mode : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := True;
+end System;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.19 $
+-- --
+-- Copyright (C) 1997-2001, 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a MACOS (FSU THREAD) version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lgthreads");
+
+ 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 := 35;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ ETIMEDOUT : constant := 60;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 31;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGWINCH : constant := 28; -- window size change
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
+ 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
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+
+ SIGADAABORT : constant := SIGABRT;
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set := (SIGTRAP, SIGALRM, SIGEMT, SIGCHLD);
+ Reserved : constant Signal_Set := (SIGKILL, SIGSTOP);
+
+ 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;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ 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 := False;
+ -- Indicates wether time slicing is supported (i.e FSU threads have been
+ -- compiled with DEF_RR)
+
+ type timespec is private;
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "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_timeval is private;
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 0;
+ SCHED_RR : constant := 1;
+ SCHED_OTHER : constant := 2;
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- 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;
+
+ 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;
+
+ -----------
+ -- Stack --
+ -----------
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates wether the stack base is available on this target.
+ -- This allows us to share s-osinte.adb between all the FSU run time.
+ -- Note that this value can only be true if pthread_t has a complete
+ -- definition that corresponds exactly to the C header files.
+
+ 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_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
+
+ PROT_ON : constant := PROT_NONE;
+ 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;
+ -- FSU_THREADS requires pthread_init, which is nonstandard
+ -- and this should be invoked during the elaboration of s-taprop.adb
+ pragma Import (C, pthread_init, "pthread_init");
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ -- FSU_THREADS has a nonstandard sigwait
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr)
+ return int;
+ pragma Import (C, pthread_sigmask, "sigprocmask");
+
+ --------------------------
+ -- 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;
+ -- FSU_THREADS has nonstandard pthread_mutex_lock
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ -- FSU_THREADS has nonstandard pthread_mutex_lock
+
+ 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;
+ -- FSU_THREADS has a nonstandard pthread_cond_wait
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ -- FSU_THREADS has a nonstandard 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_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ 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,
+ "pthread_mutexattr_setprio_ceiling");
+
+ 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;
+ -- FSU_THREADS does not have 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, "pthread_attr_setsched");
+
+ function pthread_attr_setschedparam
+ (attr : access pthread_attr_t;
+ sched_param : int) return int;
+ pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam");
+
+ function sched_yield return int;
+ -- FSU_THREADS does not have 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;
+ -- FSU_THREADS has a nonstandard 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 pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ -- FSU_THREADS has a nonstandard pthread_getspecific
+
+ type destructor_pointer is access procedure (arg : System.Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+
+ type sigset_t is new int;
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 0;
+
+ type struct_timeval is record
+ tv_sec : long;
+ tv_usec : long;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type pthread_attr_t is record
+ flags : int;
+ stacksize : int;
+ contentionscope : int;
+ inheritsched : int;
+ detachstate : int;
+ sched : int;
+ prio : int;
+ starttime : timespec;
+ deadline : timespec;
+ period : timespec;
+ end record;
+ pragma Convention (C, pthread_attr_t);
+
+ type pthread_condattr_t is record
+ flags : int;
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_mutexattr_t is record
+ flags : int;
+ prio_ceiling : int;
+ protocol : int;
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type sigjmp_buf is array (Integer range 0 .. 9) of int;
+
+ type pthread_t_struct is record
+ context : sigjmp_buf;
+ pbody : sigjmp_buf;
+ errno : int;
+ ret : int;
+ stack_base : System.Address;
+ end record;
+ pragma Convention (C, pthread_t_struct);
+
+ type pthread_t is access all pthread_t_struct;
+
+ type queue_t is record
+ head : System.Address;
+ tail : System.Address;
+ end record;
+ pragma Convention (C, queue_t);
+
+ type pthread_mutex_t is record
+ queue : queue_t;
+ lock : plain_char;
+ owner : System.Address;
+ flags : int;
+ prio_ceiling : int;
+ protocol : int;
+ prev_max_ceiling_prio : int;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_cond_t is record
+ queue : queue_t;
+ flags : int;
+ waiters : int;
+ mutex : System.Address;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 1998-2001 Free Software Foundation --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the MIPS VxWorks version of this package.
+
+with Interfaces.C;
+
+package System.VxWorks is
+ pragma Preelaborate (System.VxWorks);
+
+ package IC renames Interfaces.C;
+
+ -- Define enough of a Wind Task Control Block in order to
+ -- obtain the inherited priority. When porting this to
+ -- different versions of VxWorks (this is based on 5.3[.1]),
+ -- be sure to look at the definition for WIND_TCB located
+ -- in $WIND_BASE/target/h/taskLib.h
+
+ type Wind_Fill_1 is array (0 .. 16#3F#) of IC.unsigned_char;
+ type Wind_Fill_2 is array (16#48# .. 16#107#) of IC.unsigned_char;
+
+ type Wind_TCB is record
+ Fill_1 : Wind_Fill_1; -- 0x00 - 0x3f
+ Priority : IC.int; -- 0x40 - 0x43, current (inherited) priority
+ Normal_Priority : IC.int; -- 0x44 - 0x47, base priority
+ Fill_2 : Wind_Fill_2; -- 0x48 - 0x107
+ spare1 : Address; -- 0x108 - 0x10b
+ spare2 : Address; -- 0x10c - 0x10f
+ spare3 : Address; -- 0x110 - 0x113
+ spare4 : Address; -- 0x114 - 0x117
+ end record;
+ type Wind_TCB_Ptr is access Wind_TCB;
+
+ -- Floating point context record. MIPS version
+
+ FP_NUM_DREGS : constant := 16;
+ type Fpx_Array is array (1 .. FP_NUM_DREGS) of IC.double;
+
+ type FP_CONTEXT is record
+ fpx : Fpx_Array;
+ fpcsr : IC.int;
+ end record;
+ pragma Convention (C, FP_CONTEXT);
+
+ -- Number of entries in hardware interrupt vector table. Value of
+ -- 0 disables hardware interrupt handling until it can be tested
+ Num_HW_Interrupts : constant := 0;
+
+ -- VxWorks 5.3 and 5.4 version
+ type TASK_DESC is record
+ td_id : IC.int; -- task id
+ td_name : Address; -- name of task
+ td_priority : IC.int; -- task priority
+ td_status : IC.int; -- task status
+ td_options : IC.int; -- task option bits (see below)
+ td_entry : Address; -- original entry point of task
+ td_sp : Address; -- saved stack pointer
+ td_pStackBase : Address; -- the bottom of the stack
+ td_pStackLimit : Address; -- the effective end of the stack
+ td_pStackEnd : Address; -- the actual end of the stack
+ td_stackSize : IC.int; -- size of stack in bytes
+ td_stackCurrent : IC.int; -- current stack usage in bytes
+ td_stackHigh : IC.int; -- maximum stack usage in bytes
+ td_stackMargin : IC.int; -- current stack margin in bytes
+ td_errorStatus : IC.int; -- most recent task error status
+ td_delay : IC.int; -- delay/timeout ticks
+ end record;
+ pragma Convention (C, TASK_DESC);
+
+end System.VxWorks;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T . --
+-- O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992-1998 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a NO tasking version of this package.
+
+package body System.Interrupt_Management.Operations is
+
+ ----------------------------
+ -- Thread_Block_Interrupt --
+ ----------------------------
+
+ procedure Thread_Block_Interrupt
+ (Interrupt : Interrupt_ID)
+ is
+ begin
+ null;
+ end Thread_Block_Interrupt;
+
+ ------------------------------
+ -- Thread_Unblock_Interrupt --
+ ------------------------------
+
+ procedure Thread_Unblock_Interrupt
+ (Interrupt : Interrupt_ID)
+ is
+ begin
+ null;
+ end Thread_Unblock_Interrupt;
+
+ ------------------------
+ -- Set_Interrupt_Mask --
+ ------------------------
+
+ procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ begin
+ null;
+ end Set_Interrupt_Mask;
+
+ procedure Set_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ OMask : access Interrupt_Mask) is
+ begin
+ null;
+ end Set_Interrupt_Mask;
+
+ ------------------------
+ -- Get_Interrupt_Mask --
+ ------------------------
+
+ procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ begin
+ null;
+ end Get_Interrupt_Mask;
+
+ --------------------
+ -- Interrupt_Wait --
+ --------------------
+
+ function Interrupt_Wait
+ (Mask : access Interrupt_Mask)
+ return Interrupt_ID
+ is
+ begin
+ return 0;
+ end Interrupt_Wait;
+
+ ----------------------------
+ -- Install_Default_Action --
+ ----------------------------
+
+ procedure Install_Default_Action (Interrupt : Interrupt_ID) is
+ begin
+ null;
+ end Install_Default_Action;
+
+ ---------------------------
+ -- Install_Ignore_Action --
+ ---------------------------
+
+ procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
+ begin
+ null;
+ end Install_Ignore_Action;
+
+ -------------------------
+ -- Fill_Interrupt_Mask --
+ -------------------------
+
+ procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ begin
+ null;
+ end Fill_Interrupt_Mask;
+
+ --------------------------
+ -- Empty_Interrupt_Mask --
+ --------------------------
+
+ procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ begin
+ null;
+ end Empty_Interrupt_Mask;
+
+ -----------------------
+ -- Add_To_Sigal_Mask --
+ -----------------------
+
+ procedure Add_To_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID)
+ is
+ begin
+ null;
+ end Add_To_Interrupt_Mask;
+
+ --------------------------------
+ -- Delete_From_Interrupt_Mask --
+ --------------------------------
+
+ procedure Delete_From_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID)
+ is
+ begin
+ null;
+ end Delete_From_Interrupt_Mask;
+
+ ---------------
+ -- Is_Member --
+ ---------------
+
+ function Is_Member
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID) return Boolean
+ is
+ begin
+ return False;
+ end Is_Member;
+
+ -------------------------
+ -- Copy_Interrupt_Mask --
+ -------------------------
+
+ procedure Copy_Interrupt_Mask
+ (X : out Interrupt_Mask;
+ Y : Interrupt_Mask)
+ is
+ begin
+ X := Y;
+ end Copy_Interrupt_Mask;
+
+ -------------------------
+ -- Interrupt_Self_Process --
+ -------------------------
+
+ procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
+ begin
+ null;
+ end Interrupt_Self_Process;
+
+end System.Interrupt_Management.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1991-1996, 1998 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Interrupt_Management is
+
+ ---------------------------
+ -- Initialize_Interrupts --
+ ---------------------------
+
+ -- Nothing needs to be done on this platform.
+
+ procedure Initialize_Interrupts is
+ begin
+ null;
+ end Initialize_Interrupts;
+
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.8 $
+-- --
+-- Copyright (C) 1991-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the no tasking version
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 2;
+ type Signal is new int range 0 .. Max_Interrupt;
+
+ type sigset_t is new Integer;
+ type Thread_Id is new Integer;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.33 $
+-- --
+-- Copyright (C) 1991-2001, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a no tasking version of this package
+
+-- 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 System.Tasking;
+-- used for Ada_Task_Control_Block
+-- Task_ID
+
+with System.OS_Primitives;
+-- used for Delay_Modes
+
+with System.Error_Reporting;
+-- used for Shutdown
+
+package body System.Task_Primitives.Operations is
+
+ use System.Tasking;
+ use System.Parameters;
+ use System.OS_Primitives;
+
+ -------------------
+ -- Stack_Guard --
+ -------------------
+
+ procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ begin
+ null;
+ end Stack_Guard;
+
+ --------------------
+ -- Get_Thread_Id --
+ --------------------
+
+ function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
+ begin
+ return OSI.Thread_Id (T.Common.LL.Thread);
+ end Get_Thread_Id;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_ID is
+ begin
+ return Null_Task;
+ end Self;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : access Lock)
+ is
+ begin
+ null;
+ end Initialize_Lock;
+
+ procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
+ begin
+ null;
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : access Lock) is
+ begin
+ null;
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : access RTS_Lock) is
+ begin
+ null;
+ end Finalize_Lock;
+
+ ----------------
+ -- Write_Lock --
+ ----------------
+
+ procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ Ceiling_Violation := False;
+ end Write_Lock;
+
+ procedure Write_Lock (L : access RTS_Lock) is
+ begin
+ null;
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_ID) is
+ begin
+ null;
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ Ceiling_Violation := False;
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : access Lock) is
+ begin
+ null;
+ end Unlock;
+
+ procedure Unlock (L : access RTS_Lock) is
+ begin
+ null;
+ end Unlock;
+
+ procedure Unlock (T : Task_ID) is
+ begin
+ null;
+ end Unlock;
+
+ -------------
+ -- Sleep --
+ -------------
+
+ procedure Sleep (Self_ID : Task_ID;
+ Reason : System.Tasking.Task_States) is
+ begin
+ null;
+ end Sleep;
+
+ -----------------
+ -- Timed_Sleep --
+ -----------------
+
+ procedure Timed_Sleep
+ (Self_ID : Task_ID;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean) is
+ begin
+ Timedout := False;
+ Yielded := False;
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Self_ID : Task_ID;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ Rel_Time : Duration;
+
+ procedure sleep (How_Long : Natural);
+ pragma Import (C, sleep, "sleep");
+
+ begin
+ if Mode = Relative then
+ Rel_Time := Time;
+ else
+ Rel_Time := Time - Monotonic_Clock;
+ end if;
+
+ if Rel_Time > 0.0 then
+ sleep (Natural (Rel_Time));
+ end if;
+ end Timed_Delay;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ begin
+ return 0.0;
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ begin
+ return 10#1.0#E-6;
+ end RT_Resolution;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
+ begin
+ null;
+ end Wakeup;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_Priority
+ (T : Task_ID;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False) is
+ begin
+ null;
+ end Set_Priority;
+
+ ------------------
+ -- Get_Priority --
+ ------------------
+
+ function Get_Priority (T : Task_ID) return System.Any_Priority is
+ begin
+ return 0;
+ end Get_Priority;
+
+ ----------------
+ -- Enter_Task --
+ ----------------
+
+ procedure Enter_Task (Self_ID : Task_ID) is
+ begin
+ null;
+ 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;
+
+ ----------------------
+ -- Initialize_TCB --
+ ----------------------
+
+ procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
+ begin
+ Succeeded := False;
+ 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
+ begin
+ Succeeded := False;
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_ID) is
+ begin
+ null;
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ null;
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_ID) is
+ begin
+ null;
+ end Abort_Task;
+
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ begin
+ null;
+ end Yield;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy versions. The only currently working versions is for solaris
+ -- (native).
+
+ function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ begin
+ return True;
+ end Check_No_Locks;
+
+ ----------------------
+ -- Environment_Task --
+ ----------------------
+
+ function Environment_Task return Task_ID is
+ begin
+ return null;
+ end Environment_Task;
+
+ -------------------------
+ -- Lock_All_Tasks_List --
+ -------------------------
+
+ procedure Lock_All_Tasks_List is
+ begin
+ null;
+ end Lock_All_Tasks_List;
+
+ ---------------------------
+ -- Unlock_All_Tasks_List --
+ ---------------------------
+
+ procedure Unlock_All_Tasks_List is
+ begin
+ null;
+ end Unlock_All_Tasks_List;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_ID;
+ Thread_Self : OSI.Thread_Id) return Boolean is
+ begin
+ return False;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_ID;
+ Thread_Self : OSI.Thread_Id) return Boolean is
+ begin
+ return False;
+ end Resume_Task;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_ID) is
+ begin
+ null;
+ end Initialize;
+
+ No_Tasking : Boolean;
+
+begin
+
+ -- Can't raise an exception because target independent packages try to
+ -- do an Abort_Defer, which gets a memory fault.
+
+ No_Tasking :=
+ System.Error_Reporting.Shutdown
+ ("Tasking not implemented on this configuration");
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.6 $
+-- --
+-- Copyright (C) 1991-2000 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a no tasking 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 System.Task_Primitives is
+ pragma Preelaborate;
+
+ type Lock is new Integer;
+
+ type RTS_Lock is new Integer;
+
+ type Task_Body_Access is access procedure;
+
+ type Private_Data is record
+ Thread : aliased Integer;
+ CV : aliased Integer;
+ L : aliased RTS_Lock;
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1991-2000 Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is an OS/2 version of this package.
+
+-- This version is a stub, for systems that
+-- do not support interrupts (or signals).
+
+with Ada.Exceptions;
+
+package body System.Interrupts is
+
+ use System.Tasking;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Unimplemented;
+ -- This procedure raises a Program_Error with an appropriate message
+ -- indicating that an unimplemented feature has been used.
+
+ --------------------
+ -- Attach_Handler --
+ --------------------
+
+ procedure Attach_Handler
+ (New_Handler : in Parameterless_Handler;
+ Interrupt : in Interrupt_ID;
+ Static : in Boolean := False)
+ is
+ begin
+ Unimplemented;
+ end Attach_Handler;
+
+ -----------------------------
+ -- Bind_Interrupt_To_Entry --
+ -----------------------------
+
+ procedure Bind_Interrupt_To_Entry
+ (T : Task_ID;
+ E : Task_Entry_Index;
+ Int_Ref : System.Address)
+ is
+ begin
+ Unimplemented;
+ end Bind_Interrupt_To_Entry;
+
+ ---------------------
+ -- Block_Interrupt --
+ ---------------------
+
+ procedure Block_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented;
+ end Block_Interrupt;
+
+ ---------------------
+ -- Current_Handler --
+ ---------------------
+
+ function Current_Handler
+ (Interrupt : Interrupt_ID)
+ return Parameterless_Handler
+ is
+ begin
+ Unimplemented;
+ return null;
+ end Current_Handler;
+
+ --------------------
+ -- Detach_Handler --
+ --------------------
+
+ procedure Detach_Handler
+ (Interrupt : in Interrupt_ID;
+ Static : in Boolean := False)
+ is
+ begin
+ Unimplemented;
+ end Detach_Handler;
+
+ ------------------------------
+ -- Detach_Interrupt_Entries --
+ ------------------------------
+
+ procedure Detach_Interrupt_Entries (T : Task_ID) is
+ begin
+ Unimplemented;
+ end Detach_Interrupt_Entries;
+
+ ----------------------
+ -- Exchange_Handler --
+ ----------------------
+
+ procedure Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : in Parameterless_Handler;
+ Interrupt : in Interrupt_ID;
+ Static : in Boolean := False)
+ is
+ begin
+ Old_Handler := null;
+ Unimplemented;
+ end Exchange_Handler;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Static_Interrupt_Protection) is
+ begin
+ Unimplemented;
+ end Finalize;
+
+ -------------------------------------
+ -- Has_Interrupt_Or_Attach_Handler --
+ -------------------------------------
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Dynamic_Interrupt_Protection)
+ return Boolean
+ is
+ begin
+ Unimplemented;
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Static_Interrupt_Protection)
+ return Boolean
+ is
+ begin
+ Unimplemented;
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ ----------------------
+ -- Ignore_Interrupt --
+ ----------------------
+
+ procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented;
+ end Ignore_Interrupt;
+
+ ----------------------
+ -- Install_Handlers --
+ ----------------------
+
+ procedure Install_Handlers
+ (Object : access Static_Interrupt_Protection;
+ New_Handlers : in New_Handler_Array)
+ is
+ begin
+ Unimplemented;
+ end Install_Handlers;
+
+ ----------------
+ -- Is_Blocked --
+ ----------------
+
+ function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented;
+ return True;
+ end Is_Blocked;
+
+ -----------------------
+ -- Is_Entry_Attached --
+ -----------------------
+
+ function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented;
+ return True;
+ end Is_Entry_Attached;
+
+ -------------------------
+ -- Is_Handler_Attached --
+ -------------------------
+
+ function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented;
+ return True;
+ end Is_Handler_Attached;
+
+ ----------------
+ -- Is_Ignored --
+ ----------------
+
+ function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented;
+ return True;
+ end Is_Ignored;
+
+ -----------------
+ -- Is_Reserved --
+ -----------------
+
+ function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented;
+ return True;
+ end Is_Reserved;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference (Interrupt : Interrupt_ID) return System.Address is
+ begin
+ Unimplemented;
+ return Interrupt'Address;
+ end Reference;
+
+ --------------------------------
+ -- Register_Interrupt_Handler --
+ --------------------------------
+
+ procedure Register_Interrupt_Handler
+ (Handler_Addr : System.Address)
+ is
+ begin
+ Unimplemented;
+ end Register_Interrupt_Handler;
+
+ -----------------------
+ -- Unblock_Interrupt --
+ -----------------------
+
+ procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented;
+ end Unblock_Interrupt;
+
+ ------------------
+ -- Unblocked_By --
+ ------------------
+
+ function Unblocked_By (Interrupt : Interrupt_ID)
+ return System.Tasking.Task_ID is
+ begin
+ Unimplemented;
+ return null;
+ end Unblocked_By;
+
+ ------------------------
+ -- Unignore_Interrupt --
+ ------------------------
+
+ procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented;
+ end Unignore_Interrupt;
+
+ -------------------
+ -- Unimplemented; --
+ -------------------
+
+ procedure Unimplemented is
+ begin
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "interrupts/signals not implemented");
+ raise Program_Error;
+ end Unimplemented;
+
+end System.Interrupts;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- SYSTEM.MACHINE_STATE_OPERATIONS --
+-- --
+-- B o d y --
+-- (Version for x86) --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- Copyright (C) 1999-2001 Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Note: it is very important that this unit not generate any exception
+-- tables of any kind. Otherwise we get a nasty rtsfind recursion problem.
+-- This means no subprograms, including implicitly generated ones.
+
+with Unchecked_Conversion;
+with System.Storage_Elements;
+with System.Machine_Code; use System.Machine_Code;
+
+package body System.Machine_State_Operations is
+
+ use System.Exceptions;
+
+ type Uns8 is mod 2 ** 8;
+ type Uns32 is mod 2 ** 32;
+
+ type Bits5 is mod 2 ** 5;
+ type Bits6 is mod 2 ** 6;
+
+ function To_Address is new Unchecked_Conversion (Uns32, Address);
+
+ function To_Uns32 is new Unchecked_Conversion (Integer, Uns32);
+ function To_Uns32 is new Unchecked_Conversion (Address, Uns32);
+
+ type Uns32_Ptr is access all Uns32;
+ function To_Uns32_Ptr is new Unchecked_Conversion (Address, Uns32_Ptr);
+ function To_Uns32_Ptr is new Unchecked_Conversion (Uns32, Uns32_Ptr);
+
+ -- Note: the type Uns32 has an alignment of 4. However, in some cases
+ -- values of type Uns32_Ptr will not be aligned (notably in the case
+ -- where we get the immediate field from an instruction). However this
+ -- does not matter in practice, since the x86 does not require that
+ -- operands be aligned.
+
+ ----------------------
+ -- General Approach --
+ ----------------------
+
+ -- For the x86 version of this unit, the Subprogram_Info_Type values
+ -- are simply the starting code address for the subprogram. Popping
+ -- of stack frames works by analyzing the code in the prolog, and
+ -- deriving from this analysis the necessary information for restoring
+ -- the registers, including the return point.
+
+ ---------------------------
+ -- Description of Prolog --
+ ---------------------------
+
+ -- If a frame pointer is present, the prolog looks like
+
+ -- pushl %ebp
+ -- movl %esp,%ebp
+ -- subl $nnn,%esp omitted if nnn = 0
+ -- pushl %edi omitted if edi not used
+ -- pushl %esi omitted if esi not used
+ -- pushl %ebx omitted if ebx not used
+
+ -- If a frame pointer is not present, the prolog looks like
+
+ -- subl $nnn,%esp omitted if nnn = 0
+ -- pushl %ebp omitted if ebp not used
+ -- pushl %edi omitted if edi not used
+ -- pushl %esi omitted if esi not used
+ -- pushl %ebx omitted if ebx not used
+
+ -- Note: any or all of the save over call registers may be used and
+ -- if so, will be saved using pushl as shown above. The order of the
+ -- pushl instructions will be as shown above for gcc generated code,
+ -- but the code in this unit does not assume this.
+
+ -------------------------
+ -- Description of Call --
+ -------------------------
+
+ -- A call looks like:
+
+ -- pushl ... push parameters
+ -- pushl ...
+ -- call ... perform the call
+ -- addl $nnn,%esp omitted if no parameters
+
+ -- Note that we are not absolutely guaranteed that the call is always
+ -- followed by an addl operation that readjusts %esp for this particular
+ -- call. There are two reasons for this:
+
+ -- 1) The addl can be delayed and combined in the case where more than
+ -- one call appears in sequence. This can be suppressed by using the
+ -- switch -fno-defer-pop and for Ada code, we automatically use
+ -- this switch, but we could still be dealing with C code that was
+ -- compiled without using this switch.
+
+ -- 2) Scheduling may result in moving the addl instruction away from
+ -- the call. It is not clear if this actually can happen at the
+ -- current time, but it is certainly conceptually possible.
+
+ -- The addl after the call is important, since we need to be able to
+ -- restore the proper %esp value when we pop the stack. However, we do
+ -- not try to compensate for either of the above effects. As noted above,
+ -- case 1 does not occur for Ada code, and it does not appear in practice
+ -- that case 2 occurs with any significant frequency (we have never seen
+ -- an example so far for gcc generated code).
+
+ -- Furthermore, it is only in the case of -fomit-frame-pointer that we
+ -- really get into trouble from not properly restoring %esp. If we have
+ -- a frame pointer, then the worst that happens is that %esp is slightly
+ -- more depressed than it should be. This could waste a bit of space on
+ -- the stack, and even in some cases cause a storage leak on the stack,
+ -- but it will not affect the functional correctness of the processing.
+
+ ----------------------------------------
+ -- Definitions of Instruction Formats --
+ ----------------------------------------
+
+ type Rcode is (eax, ecx, edx, ebx, esp, ebp, esi, edi);
+ pragma Warnings (Off, Rcode);
+ -- Code indicating which register is referenced in an instruction
+
+ -- The following define the format of a pushl instruction
+
+ Op_pushl : constant Bits5 := 2#01010#;
+
+ type Ins_pushl is record
+ Op : Bits5 := Op_pushl;
+ Reg : Rcode;
+ end record;
+
+ for Ins_pushl use record
+ Op at 0 range 3 .. 7;
+ Reg at 0 range 0 .. 2;
+ end record;
+
+ Ins_pushl_ebp : constant Ins_pushl := (Op_pushl, Reg => ebp);
+
+ type Ins_pushl_Ptr is access all Ins_pushl;
+
+ -- For the movl %esp,%ebp instruction, we only need to know the length
+ -- because we simply skip past it when we analyze the prolog.
+
+ Ins_movl_length : constant := 2;
+
+ -- The following define the format of addl/subl esp instructions
+
+ Op_Immed : constant Bits6 := 2#100000#;
+
+ Op2_addl_Immed : constant Bits5 := 2#11100#;
+ Op2_subl_Immed : constant Bits5 := 2#11101#;
+
+ type Word_Byte is (Word, Byte);
+
+ type Ins_addl_subl_byte is record
+ Op : Bits6; -- Set to Op_Immed
+ w : Word_Byte; -- Word/Byte flag (set to 1 = byte)
+ s : Boolean; -- Sign extension bit (1 = extend)
+ Op2 : Bits5; -- Secondary opcode
+ Reg : Rcode; -- Register
+ Imm8 : Uns8; -- Immediate operand
+ end record;
+
+ for Ins_addl_subl_byte use record
+ Op at 0 range 2 .. 7;
+ w at 0 range 1 .. 1;
+ s at 0 range 0 .. 0;
+ Op2 at 1 range 3 .. 7;
+ Reg at 1 range 0 .. 2;
+ Imm8 at 2 range 0 .. 7;
+ end record;
+
+ type Ins_addl_subl_word is record
+ Op : Bits6; -- Set to Op_Immed
+ w : Word_Byte; -- Word/Byte flag (set to 0 = word)
+ s : Boolean; -- Sign extension bit (1 = extend)
+ Op2 : Bits5; -- Secondary opcode
+ Reg : Rcode; -- Register
+ Imm32 : Uns32; -- Immediate operand
+ end record;
+
+ for Ins_addl_subl_word use record
+ Op at 0 range 2 .. 7;
+ w at 0 range 1 .. 1;
+ s at 0 range 0 .. 0;
+ Op2 at 1 range 3 .. 7;
+ Reg at 1 range 0 .. 2;
+ Imm32 at 2 range 0 .. 31;
+ end record;
+
+ type Ins_addl_subl_byte_Ptr is access all Ins_addl_subl_byte;
+ type Ins_addl_subl_word_Ptr is access all Ins_addl_subl_word;
+
+ ---------------------
+ -- Prolog Analysis --
+ ---------------------
+
+ -- The analysis of the prolog answers the following questions:
+
+ -- 1. Is %ebp used as a frame pointer?
+ -- 2. How far is SP depressed (i.e. what is the stack frame size)
+ -- 3. Which registers are saved in the prolog, and in what order
+
+ -- The following data structure stores the answers to these questions
+
+ subtype SOC is Rcode range ebx .. edi;
+ -- Possible save over call registers
+
+ SOC_Max : constant := 4;
+ -- Max number of SOC registers that can be pushed
+
+ type SOC_Push_Regs_Type is array (1 .. 4) of Rcode;
+ -- Used to hold the register codes of pushed SOC registers
+
+ type Prolog_Type is record
+
+ Frame_Reg : Boolean;
+ -- This is set to True if %ebp is used as a frame register, and
+ -- False otherwise (in the False case, %ebp may be saved in the
+ -- usual manner along with the other SOC registers).
+
+ Frame_Length : Uns32;
+ -- Amount by which ESP is decremented on entry, includes the effects
+ -- of push's of save over call registers as indicated above, e.g. if
+ -- the prolog of a routine is:
+ --
+ -- pushl %ebp
+ -- movl %esp,%ebp
+ -- subl $424,%esp
+ -- pushl %edi
+ -- pushl %esi
+ -- pushl %ebx
+ --
+ -- Then the value of Frame_Length would be 436 (424 + 3 * 4). A
+ -- precise definition is that it is:
+ --
+ -- %esp on entry minus %esp after last SOC push
+ --
+ -- That definition applies both in the frame pointer present and
+ -- the frame pointer absent cases.
+
+ Num_SOC_Push : Integer range 0 .. SOC_Max;
+ -- Number of save over call registers actually saved by pushl
+ -- instructions (other than the initial pushl to save the frame
+ -- pointer if a frame pointer is in use).
+
+ SOC_Push_Regs : SOC_Push_Regs_Type;
+ -- The First Num_SOC_Push entries of this array are used to contain
+ -- the codes for the SOC registers, in the order in which they were
+ -- pushed. Note that this array excludes %ebp if it is used as a frame
+ -- register, since although %ebp is still considered an SOC register
+ -- in this case, it is saved and restored by a separate mechanism.
+ -- Also we will never see %esp represented in this list. Again, it is
+ -- true that %esp is saved over call, but it is restored by a separate
+ -- mechanism.
+
+ end record;
+
+ procedure Analyze_Prolog (A : Address; Prolog : out Prolog_Type);
+ -- Given the address of the start of the prolog for a procedure,
+ -- analyze the instructions of the prolog, and set Prolog to contain
+ -- the information obtained from this analysis.
+
+ ----------------------------------
+ -- Machine_State_Representation --
+ ----------------------------------
+
+ -- The type Machine_State is defined in the body of Ada.Exceptions as
+ -- a Storage_Array of length 1 .. Machine_State_Length. But really it
+ -- has structure as defined here. We use the structureless declaration
+ -- in Ada.Exceptions to avoid this unit from being implementation
+ -- dependent. The actual definition of Machine_State is as follows:
+
+ type SOC_Regs_Type is array (SOC) of Uns32;
+
+ type MState is record
+ eip : Uns32;
+ -- The instruction pointer location (which is the return point
+ -- value from the next level down in all cases).
+
+ Regs : SOC_Regs_Type;
+ -- Values of the save over call registers
+ end record;
+
+ for MState use record
+ eip at 0 range 0 .. 31;
+ Regs at 4 range 0 .. 5 * 32 - 1;
+ end record;
+ -- Note: the routines Enter_Handler, and Set_Machine_State reference
+ -- the fields in this structure non-symbolically.
+
+ type MState_Ptr is access all MState;
+
+ function To_MState_Ptr is
+ new Unchecked_Conversion (Machine_State, MState_Ptr);
+
+ ----------------------------
+ -- Allocate_Machine_State --
+ ----------------------------
+
+ function Allocate_Machine_State return Machine_State is
+
+ use System.Storage_Elements;
+
+ function Gnat_Malloc (Size : Storage_Offset) return Machine_State;
+ pragma Import (C, Gnat_Malloc, "__gnat_malloc");
+
+ begin
+ return Gnat_Malloc (MState'Max_Size_In_Storage_Elements);
+ end Allocate_Machine_State;
+
+ --------------------
+ -- Analyze_Prolog --
+ --------------------
+
+ procedure Analyze_Prolog (A : Address; Prolog : out Prolog_Type) is
+ Ptr : Address;
+ Ppl : Ins_pushl_Ptr;
+ Pas : Ins_addl_subl_byte_Ptr;
+
+ function To_Ins_pushl_Ptr is
+ new Unchecked_Conversion (Address, Ins_pushl_Ptr);
+
+ function To_Ins_addl_subl_byte_Ptr is
+ new Unchecked_Conversion (Address, Ins_addl_subl_byte_Ptr);
+
+ function To_Ins_addl_subl_word_Ptr is
+ new Unchecked_Conversion (Address, Ins_addl_subl_word_Ptr);
+
+ begin
+ Ptr := A;
+ Prolog.Frame_Length := 0;
+
+ if Ptr = Null_Address then
+ Prolog.Num_SOC_Push := 0;
+ Prolog.Frame_Reg := True;
+ return;
+ end if;
+
+ if To_Ins_pushl_Ptr (Ptr).all = Ins_pushl_ebp then
+ Ptr := Ptr + 1 + Ins_movl_length;
+ Prolog.Frame_Reg := True;
+ else
+ Prolog.Frame_Reg := False;
+ end if;
+
+ Pas := To_Ins_addl_subl_byte_Ptr (Ptr);
+
+ if Pas.Op = Op_Immed
+ and then Pas.Op2 = Op2_subl_Immed
+ and then Pas.Reg = esp
+ then
+ if Pas.w = Word then
+ Prolog.Frame_Length := Prolog.Frame_Length +
+ To_Ins_addl_subl_word_Ptr (Ptr).Imm32;
+ Ptr := Ptr + 6;
+
+ else
+ Prolog.Frame_Length := Prolog.Frame_Length + Uns32 (Pas.Imm8);
+ Ptr := Ptr + 3;
+
+ -- Note: we ignore sign extension, since a sign extended
+ -- value that was negative would imply a ludicrous frame size.
+ end if;
+ end if;
+
+ -- Now scan push instructions for SOC registers
+
+ Prolog.Num_SOC_Push := 0;
+
+ loop
+ Ppl := To_Ins_pushl_Ptr (Ptr);
+
+ if Ppl.Op = Op_pushl and then Ppl.Reg in SOC then
+ Prolog.Num_SOC_Push := Prolog.Num_SOC_Push + 1;
+ Prolog.SOC_Push_Regs (Prolog.Num_SOC_Push) := Ppl.Reg;
+ Prolog.Frame_Length := Prolog.Frame_Length + 4;
+ Ptr := Ptr + 1;
+
+ else
+ exit;
+ end if;
+ end loop;
+
+ end Analyze_Prolog;
+
+ -------------------
+ -- Enter_Handler --
+ -------------------
+
+ procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
+ begin
+ Asm ("mov %0,%%edx", Inputs => Machine_State'Asm_Input ("r", M));
+ Asm ("mov %0,%%eax", Inputs => Handler_Loc'Asm_Input ("r", Handler));
+
+ Asm ("mov 4(%%edx),%%ebx"); -- M.Regs (ebx)
+ Asm ("mov 12(%%edx),%%ebp"); -- M.Regs (ebp)
+ Asm ("mov 16(%%edx),%%esi"); -- M.Regs (esi)
+ Asm ("mov 20(%%edx),%%edi"); -- M.Regs (edi)
+ Asm ("mov 8(%%edx),%%esp"); -- M.Regs (esp)
+ Asm ("jmp %*%%eax");
+ end Enter_Handler;
+
+ ----------------
+ -- Fetch_Code --
+ ----------------
+
+ function Fetch_Code (Loc : Code_Loc) return Code_Loc is
+ begin
+ return Loc;
+ end Fetch_Code;
+
+ ------------------------
+ -- Free_Machine_State --
+ ------------------------
+
+ procedure Free_Machine_State (M : in out Machine_State) is
+ procedure Gnat_Free (M : in Machine_State);
+ pragma Import (C, Gnat_Free, "__gnat_free");
+
+ begin
+ Gnat_Free (M);
+ M := Machine_State (Null_Address);
+ end Free_Machine_State;
+
+ ------------------
+ -- Get_Code_Loc --
+ ------------------
+
+ function Get_Code_Loc (M : Machine_State) return Code_Loc is
+
+ Asm_Call_Size : constant := 2;
+ -- Minimum size for a call instruction under ix86. Using the minimum
+ -- size is safe here as the call point computed from the return point
+ -- will always be inside the call instruction.
+
+ MS : constant MState_Ptr := To_MState_Ptr (M);
+
+ begin
+ if MS.eip = 0 then
+ return To_Address (MS.eip);
+ else
+ -- When doing a call the return address is pushed to the stack.
+ -- We want to return the call point address, so we substract
+ -- Asm_Call_Size from the return address. This value is set
+ -- to 5 as an asm call takes 5 bytes on x86 architectures.
+
+ return To_Address (MS.eip - Asm_Call_Size);
+ end if;
+ end Get_Code_Loc;
+
+ --------------------------
+ -- Machine_State_Length --
+ --------------------------
+
+ function Machine_State_Length
+ return System.Storage_Elements.Storage_Offset
+ is
+ begin
+ return MState'Max_Size_In_Storage_Elements;
+ end Machine_State_Length;
+
+ ---------------
+ -- Pop_Frame --
+ ---------------
+
+ procedure Pop_Frame
+ (M : Machine_State;
+ Info : Subprogram_Info_Type)
+ is
+ MS : constant MState_Ptr := To_MState_Ptr (M);
+ PL : Prolog_Type;
+
+ SOC_Ptr : Uns32;
+ -- Pointer to stack location after last SOC push
+
+ Rtn_Ptr : Uns32;
+ -- Pointer to stack location containing return address
+
+ begin
+ Analyze_Prolog (Info, PL);
+
+ -- Case of frame register, use EBP, safer than ESP
+
+ if PL.Frame_Reg then
+ SOC_Ptr := MS.Regs (ebp) - PL.Frame_Length;
+ Rtn_Ptr := MS.Regs (ebp) + 4;
+ MS.Regs (ebp) := To_Uns32_Ptr (MS.Regs (ebp)).all;
+
+ -- No frame pointer, use ESP, and hope we have it exactly right!
+
+ else
+ SOC_Ptr := MS.Regs (esp);
+ Rtn_Ptr := SOC_Ptr + PL.Frame_Length;
+ end if;
+
+ -- Get saved values of SOC registers
+
+ for J in reverse 1 .. PL.Num_SOC_Push loop
+ MS.Regs (PL.SOC_Push_Regs (J)) := To_Uns32_Ptr (SOC_Ptr).all;
+ SOC_Ptr := SOC_Ptr + 4;
+ end loop;
+
+ MS.eip := To_Uns32_Ptr (Rtn_Ptr).all;
+ MS.Regs (esp) := Rtn_Ptr + 4;
+ end Pop_Frame;
+
+ -----------------------
+ -- Set_Machine_State --
+ -----------------------
+
+ procedure Set_Machine_State (M : Machine_State) is
+ N : constant Asm_Output_Operand := No_Output_Operands;
+
+ begin
+ Asm ("mov %0,%%edx", N, Machine_State'Asm_Input ("r", M));
+
+ -- At this stage, we have the following situation (note that we
+ -- are assuming that the -fomit-frame-pointer switch has not been
+ -- used in compiling this procedure.
+
+ -- (value of M)
+ -- return point
+ -- old ebp <------ current ebp/esp value
+
+ -- The values of registers ebx/esi/edi are unchanged from entry
+ -- so they have the values we want, and %edx points to the parameter
+ -- value M, so we can store these values directly.
+
+ Asm ("mov %%ebx,4(%%edx)"); -- M.Regs (ebx)
+ Asm ("mov %%esi,16(%%edx)"); -- M.Regs (esi)
+ Asm ("mov %%edi,20(%%edx)"); -- M.Regs (edi)
+
+ -- The desired value of ebp is the old value
+
+ Asm ("mov 0(%%ebp),%%eax");
+ Asm ("mov %%eax,12(%%edx)"); -- M.Regs (ebp)
+
+ -- The return point is the desired eip value
+
+ Asm ("mov 4(%%ebp),%%eax");
+ Asm ("mov %%eax,(%%edx)"); -- M.eip
+
+ -- Finally, the desired %esp value is the value at the point of
+ -- call to this routine *before* pushing the parameter value.
+
+ Asm ("lea 12(%%ebp),%%eax");
+ Asm ("mov %%eax,8(%%edx)"); -- M.Regs (esp)
+ end Set_Machine_State;
+
+ ------------------------------
+ -- Set_Signal_Machine_State --
+ ------------------------------
+
+ procedure Set_Signal_Machine_State
+ (M : Machine_State;
+ Context : System.Address) is
+ begin
+ null;
+ end Set_Signal_Machine_State;
+
+end System.Machine_State_Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.11 $
+-- --
+-- Copyright (C) 1991-2000 Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the OS/2 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.
+
+with Interfaces.C.Strings;
+with Interfaces.OS2Lib.Errors;
+with Interfaces.OS2Lib.Synchronization;
+
+package body System.OS_Interface is
+
+ use Interfaces;
+ use Interfaces.OS2Lib;
+ use Interfaces.OS2Lib.Synchronization;
+ use Interfaces.OS2Lib.Errors;
+
+ ------------------
+ -- Timer (spec) --
+ ------------------
+
+ -- Although the OS uses a 32-bit integer representing milliseconds
+ -- as timer value that doesn't work for us since 32 bits are not
+ -- enough for absolute timing. Also it is useful to use better
+ -- intermediate precision when adding/substracting timing intervals.
+ -- So we use the standard Ada Duration type which is implemented using
+ -- microseconds.
+
+ -- Shouldn't the timer be moved to a seperate package ???
+
+ type Timer is record
+ Handle : aliased HTIMER := NULLHANDLE;
+ Event : aliased HEV := NULLHANDLE;
+ end record;
+
+ procedure Initialize (T : out Timer);
+ procedure Finalize (T : in out Timer);
+ procedure Wait (T : in out Timer);
+ procedure Reset (T : in out Timer);
+
+ procedure Set_Timer_For (T : in out Timer; Period : in Duration);
+ procedure Set_Timer_At (T : in out Timer; Time : in Duration);
+ -- Add a hook to locate the Epoch, for use with Calendar????
+
+ -----------
+ -- Yield --
+ -----------
+
+ -- Give up the remainder of the time-slice and yield the processor
+ -- to other threads of equal priority. Yield will return immediately
+ -- without giving up the current time-slice when the only threads
+ -- that are ready have a lower priority.
+
+ -- ??? Just giving up the current time-slice seems not to be enough
+ -- to get the thread to the end of the ready queue if OS/2 does use
+ -- a queue at all. As a partial work-around, we give up two time-slices.
+
+ -- This is the best we can do now, and at least is sufficient for passing
+ -- the ACVC 2.0.1 Annex D tests.
+
+ procedure Yield is
+ begin
+ Delay_For (0);
+ Delay_For (0);
+ end Yield;
+
+ ---------------
+ -- Delay_For --
+ ---------------
+
+ procedure Delay_For (Period : in Duration_In_Millisec) is
+ Result : APIRET;
+
+ begin
+ pragma Assert (Period >= 0, "GNULLI---Delay_For: negative argument");
+
+ -- ??? DosSleep is not the appropriate function for a delay in real
+ -- time. It only gives up some number of scheduled time-slices.
+ -- Use a timer instead or block for some semaphore with a time-out.
+ Result := DosSleep (ULONG (Period));
+
+ if Result = ERROR_TS_WAKEUP then
+
+ -- Do appropriate processing for interrupted sleep
+ -- Can we raise an exception here?
+
+ null;
+ end if;
+
+ pragma Assert (Result = NO_ERROR, "GNULLI---Error in Delay_For");
+ end Delay_For;
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock return Duration is
+
+ -- Implement conversion from tick count to Duration
+ -- using fixed point arithmetic. The frequency of
+ -- the Intel 8254 timer chip is 18.2 * 2**16 Hz.
+
+ Tick_Duration : constant := 1.0 / (18.2 * 2**16);
+ Tick_Count : aliased QWORD;
+
+ begin
+
+ -- Read nr of clock ticks since boot time
+ Must_Not_Fail (DosTmrQueryTime (Tick_Count'Access));
+
+ return Tick_Count * Tick_Duration;
+ end Clock;
+
+ ----------------------
+ -- Initialize Timer --
+ ----------------------
+
+ procedure Initialize (T : out Timer) is
+ begin
+ pragma Assert
+ (T.Handle = NULLHANDLE, "GNULLI---Timer already initialized");
+
+ Must_Not_Fail (DosCreateEventSem
+ (pszName => Interfaces.C.Strings.Null_Ptr,
+ f_phev => T.Event'Unchecked_Access,
+ flAttr => DC_SEM_SHARED,
+ fState => False32));
+ end Initialize;
+
+ -------------------
+ -- Set_Timer_For --
+ -------------------
+
+ procedure Set_Timer_For
+ (T : in out Timer;
+ Period : in Duration)
+ is
+ Rel_Time : Duration_In_Millisec :=
+ Duration_In_Millisec (Period * 1_000.0);
+
+ begin
+ pragma Assert
+ (T.Event /= NULLHANDLE, "GNULLI---Timer not initialized");
+ pragma Assert
+ (T.Handle = NULLHANDLE, "GNULLI---Timer already in use");
+
+ Must_Not_Fail (DosAsyncTimer
+ (msec => ULONG (Rel_Time),
+ F_hsem => HSEM (T.Event),
+ F_phtimer => T.Handle'Unchecked_Access));
+ end Set_Timer_For;
+
+ ------------------
+ -- Set_Timer_At --
+ ------------------
+
+ -- Note that the timer is started in a critical section to prevent the
+ -- race condition when absolute time is converted to time relative to
+ -- current time. T.Event will be posted when the Time has passed
+
+ procedure Set_Timer_At
+ (T : in out Timer;
+ Time : in Duration)
+ is
+ Relative_Time : Duration;
+
+ begin
+ Must_Not_Fail (DosEnterCritSec);
+
+ begin
+ Relative_Time := Time - Clock;
+ if Relative_Time > 0.0 then
+ Set_Timer_For (T, Period => Time - Clock);
+ else
+ Sem_Must_Not_Fail (DosPostEventSem (T.Event));
+ end if;
+ end;
+
+ Must_Not_Fail (DosExitCritSec);
+ end Set_Timer_At;
+
+ ----------
+ -- Wait --
+ ----------
+
+ procedure Wait (T : in out Timer) is
+ begin
+ Sem_Must_Not_Fail (DosWaitEventSem (T.Event, SEM_INDEFINITE_WAIT));
+ T.Handle := NULLHANDLE;
+ end Wait;
+
+ -----------
+ -- Reset --
+ -----------
+
+ procedure Reset (T : in out Timer) is
+ Dummy_Count : aliased ULONG;
+
+ begin
+ if T.Handle /= NULLHANDLE then
+ Must_Not_Fail (DosStopTimer (T.Handle));
+ T.Handle := NULLHANDLE;
+ end if;
+
+ Sem_Must_Not_Fail
+ (DosResetEventSem (T.Event, Dummy_Count'Unchecked_Access));
+ end Reset;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (T : in out Timer) is
+ begin
+ Reset (T);
+ Must_Not_Fail (DosCloseEventSem (T.Event));
+ T.Event := NULLHANDLE;
+ end Finalize;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.10 $
+-- --
+-- Copyright (C) 1991-2001 Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the OS/2 version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Preelaborate.
+
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ package C renames Interfaces.C;
+
+ subtype int is C.int;
+ subtype unsigned_long is C.unsigned_long;
+
+ type Duration_In_Millisec is new C.long;
+ -- New type to prevent confusing time functions in this package
+ -- with time functions returning seconds or other units.
+
+ type Thread_Id is new unsigned_long;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := 5;
+ EINTR : constant := 13;
+ EINVAL : constant := 14;
+ ENOMEM : constant := 25;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 15;
+ type Signal is new int range 0 .. Max_Interrupt;
+
+ -- Signals for OS/2, only SIGTERM used currently. The values are
+ -- fake, since OS/2 uses 32 bit exception numbers that cannot be
+ -- used to index arrays etc. The GNULLI maps these Unix-like signals
+ -- to OS/2 exception numbers.
+
+ -- SIGTERM is used for the abort interrupt.
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGEMT : constant := 0; -- 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
+
+ subtype sigset_t is unsigned_long;
+
+ ----------
+ -- Time --
+ ----------
+
+ function Clock return Duration;
+ pragma Inline (Clock);
+ -- Clock measuring time since the epoch, which is the boot-time.
+ -- The clock resolution is approximately 838 ns.
+
+ procedure Delay_For (Period : in Duration_In_Millisec);
+ pragma Inline (Delay_For);
+ -- Changed Sleep to Delay_For, for consistency with System.Time_Operations
+
+ ----------------
+ -- Scheduling --
+ ----------------
+
+ -- Put the calling task at the end of the ready queue for its priority
+
+ procedure Yield;
+ pragma Inline (Yield);
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ P R I M I T I V E S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- Copyright (C) 1998-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the OS/2 version of this package
+
+with Interfaces.C; use Interfaces.C;
+with Interfaces.OS2Lib; use Interfaces.OS2Lib;
+with Interfaces.OS2Lib.Synchronization; use Interfaces.OS2Lib.Synchronization;
+
+package body System.OS_Primitives is
+
+ ----------------
+ -- Local Data --
+ ----------------
+
+ Epoch_Offset : Duration; -- See Set_Epoch_Offset
+ Max_Tick_Count : QWORD := 0.0;
+ -- This is needed to compensate for small glitches in the
+ -- hardware clock or the way it is read by the OS
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Set_Epoch_Offset;
+ -- Initializes the Epoch_1970_Offset to the offset of the System_Clock
+ -- relative to the Unix epoch (Jan 1, 1970), such that
+ -- Clock = System_Clock + Epoch_1970_Offset
+
+ function System_Clock return Duration;
+ pragma Inline (System_Clock);
+ -- Function returning value of system clock with system-dependent timebase.
+ -- For OS/2 the system clock returns the elapsed time since system boot.
+ -- The clock resolution is approximately 838 ns.
+
+ ------------------
+ -- System_Clock --
+ ------------------
+
+ function System_Clock return Duration is
+
+ -- Implement conversion from tick count to Duration
+ -- using fixed point arithmetic. The frequency of
+ -- the Intel 8254 timer chip is 18.2 * 2**16 Hz.
+
+ Tick_Duration : constant := 1.0 / (18.2 * 2**16);
+ Tick_Count : aliased QWORD;
+
+ begin
+ Must_Not_Fail (DosTmrQueryTime (Tick_Count'Access));
+ -- Read nr of clock ticks since boot time
+
+ Max_Tick_Count := QWORD'Max (Tick_Count, Max_Tick_Count);
+
+ return Max_Tick_Count * Tick_Duration;
+ end System_Clock;
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock return Duration is
+ begin
+ return System_Clock + Epoch_Offset;
+ end Clock;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration renames Clock;
+
+ ----------------------
+ -- Set_Epoch_Offset --
+ ----------------------
+
+ procedure Set_Epoch_Offset is
+
+ -- Interface to Unix C style gettimeofday
+
+ type timeval is record
+ tv_sec : long;
+ tv_usec : long;
+ end record;
+
+ procedure gettimeofday
+ (time : access timeval;
+ zone : System.Address := System.Address'Null_Parameter);
+ pragma Import (C, gettimeofday);
+
+ Time_Of_Day : aliased timeval;
+ Micro_To_Nano : constant := 1.0E3;
+ Sec_To_Nano : constant := 1.0E9;
+ Nanos_Since_Epoch : QWORD;
+
+ begin
+ gettimeofday (Time_Of_Day'Access);
+ Nanos_Since_Epoch := QWORD (Time_Of_Day.tv_sec) * Sec_To_Nano
+ + QWORD (Time_Of_Day.tv_usec) * Micro_To_Nano;
+
+ Epoch_Offset :=
+ Duration'(Nanos_Since_Epoch / Sec_To_Nano) - System_Clock;
+
+ end Set_Epoch_Offset;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Time : Duration;
+ Mode : Integer)
+ is
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Check_Time : Duration := Clock;
+
+ begin
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Time + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ loop
+ Must_Not_Fail (DosSleep (ULONG (Rel_Time * 1000.0)));
+
+ Check_Time := Clock;
+
+ exit when Abs_Time <= Check_Time;
+
+ Rel_Time := Abs_Time - Check_Time;
+ end loop;
+ end if;
+ end Timed_Delay;
+
+begin
+ Set_Epoch_Offset;
+end System.OS_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1997-1998 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the OS/2 specific version - default stacksizes need to be large
+
+package body System.Parameters is
+
+ ------------------------
+ -- Default_Stack_Size --
+ ------------------------
+
+ function Default_Stack_Size return Size_Type is
+ begin
+ -- The default stack size for extra tasks is based on the
+ -- default stack size for the main task (8 MB) and for the heap
+ -- (32 MB).
+
+ -- In OS/2 it doesn't hurt to define large stacks, unless
+ -- the system is configured to commit all memory reservations.
+ -- This is not a default configuration however.
+
+ return 1024 * 1024;
+ end Default_Stack_Size;
+
+ ------------------------
+ -- Minimum_Stack_Size --
+ ------------------------
+
+ function Minimum_Stack_Size return Size_Type is
+ begin
+ -- System functions may need 8 kB of stack, so 12 kB seems a
+ -- good minimum.
+ return 12 * 1024;
+ end Minimum_Stack_Size;
+
+ -------------------------
+ -- Adjust_Storage_Size --
+ -------------------------
+
+ function Adjust_Storage_Size (Size : Size_Type) return Size_Type is
+ begin
+ if Size = Unspecified_Size then
+ return Default_Stack_Size;
+
+ elsif Size < Minimum_Stack_Size then
+ return Minimum_Stack_Size;
+
+ else
+ return Size;
+ end if;
+ end Adjust_Storage_Size;
+
+end System.Parameters;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (OS/2 Version) --
+-- --
+-- $Revision: 1.9 $
+-- --
+-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ 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 := Integer'Last;
+
+ 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 := Standard'Tick;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := Standard'Storage_Unit;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Standard'Address_Size;
+
+ -- 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 :=
+ Bit_Order'Val (Standard'Default_Bit_Order);
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer
+ range 0 .. Standard'Max_Interrupt_Priority;
+
+ subtype Priority is Any_Priority
+ range 0 .. Standard'Max_Priority;
+
+ -- Functional notation is needed in the following to avoid visibility
+ -- problems when this package is compiled through rtsfind in the middle
+ -- of another compilation.
+
+ subtype Interrupt_Priority is Any_Priority
+ range
+ Standard."+" (Standard'Max_Priority, 1) ..
+ Standard'Max_Interrupt_Priority;
+
+ Default_Priority : constant Priority :=
+ Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
+
+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.
+
+ AAMP : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Denorm : constant Boolean := True;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+ High_Integrity_Mode : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+end System;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.57 $
+-- --
+-- Copyright (C) 1991-2001 Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is an OS/2 version of this package
+
+-- 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 System.Tasking.Debug;
+-- used for Known_Tasks
+
+with Interfaces.C;
+-- used for size_t
+
+with Interfaces.C.Strings;
+-- used for Null_Ptr
+
+with Interfaces.OS2Lib.Errors;
+with Interfaces.OS2Lib.Threads;
+with Interfaces.OS2Lib.Synchronization;
+
+with System.Parameters;
+-- used for Size_Type
+
+with System.Tasking;
+-- used for Task_ID
+
+with System.Parameters;
+-- used for Size_Type
+
+with System.Soft_Links;
+-- used for Defer/Undefer_Abort
+
+-- Note that we do not use System.Tasking.Initialization directly since
+-- this 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.Initialization
+
+with System.OS_Primitives;
+-- used for Delay_Modes
+-- Clock
+
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+package body System.Task_Primitives.Operations is
+
+ package IC renames Interfaces.C;
+ package ICS renames Interfaces.C.Strings;
+ package OSP renames System.OS_Primitives;
+ package SSL renames System.Soft_Links;
+
+ use Interfaces.OS2Lib;
+ use Interfaces.OS2Lib.Errors;
+ use Interfaces.OS2Lib.Threads;
+ use Interfaces.OS2Lib.Synchronization;
+ use System.Tasking.Debug;
+ use System.Tasking;
+ use System.OS_Interface;
+ use Interfaces.C;
+ use System.OS_Primitives;
+
+ ----------------------
+ -- Local Constants --
+ ----------------------
+
+ Max_Locks_Per_Task : constant := 100;
+ Suppress_Owner_Check : constant Boolean := False;
+
+ ------------------
+ -- Local Types --
+ ------------------
+
+ type Microseconds is new IC.long;
+ subtype Lock_Range is Integer range 0 .. Max_Locks_Per_Task;
+
+ ------------------
+ -- Local Data --
+ ------------------
+
+ -- The OS/2 DosAllocThreadLocalMemory API is used to allocate our TCB_Ptr.
+
+ -- This API reserves a small range of virtual addresses that is backed
+ -- by different physical memory for each running thread. In this case we
+ -- create a pointer at a fixed address that points to the TCB_Ptr for the
+ -- running thread. So all threads will be able to query and update their
+ -- own TCB_Ptr without destroying the TCB_Ptr of other threads.
+
+ type Thread_Local_Data is record
+ Self_ID : Task_ID; -- ID of the current thread
+ Lock_Prio_Level : Lock_Range; -- Nr of priority changes due to locks
+
+ -- ... room for expansion here, if we decide to make access to
+ -- jump-buffer and exception stack more efficient in future
+ end record;
+
+ type Access_Thread_Local_Data is access all Thread_Local_Data;
+
+ -- Pointer to Thread Local Data
+ Thread_Local_Data_Ptr : aliased Access_Thread_Local_Data;
+
+ type PPTLD is access all Access_Thread_Local_Data;
+
+ All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
+ -- See comments on locking rules in System.Tasking (spec).
+
+ Environment_Task_ID : Task_ID;
+ -- A variable to hold Task_ID for the environment task.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function To_PPVOID is new Unchecked_Conversion (PPTLD, PPVOID);
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+ function To_PFNTHREAD is
+ new Unchecked_Conversion (System.Address, PFNTHREAD);
+
+ function To_MS (D : Duration) return ULONG;
+
+ procedure Set_Temporary_Priority
+ (T : in Task_ID;
+ New_Priority : in System.Any_Priority);
+
+ -----------
+ -- To_MS --
+ -----------
+
+ function To_MS (D : Duration) return ULONG is
+ begin
+ return ULONG (D * 1_000);
+ end To_MS;
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Monotonic_Clock return Duration renames OSP.Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ begin
+ return 10#1.0#E-6;
+ end RT_Resolution;
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ -- OS/2 only has limited support for asynchronous signals.
+ -- It seems not to be possible to jump out of an exception
+ -- handler or to change the execution context of the thread.
+ -- So asynchonous transfer of control is not supported.
+
+ -------------------
+ -- Stack_Guard --
+ -------------------
+
+ -- The underlying thread system sets a guard page at the
+ -- bottom of a thread stack, so nothing is needed.
+ -- ??? Check the comment above
+
+ procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ begin
+ null;
+ end Stack_Guard;
+
+ --------------------
+ -- Get_Thread_Id --
+ --------------------
+
+ function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
+ begin
+ return OSI.Thread_Id (T.Common.LL.Thread);
+ end Get_Thread_Id;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_ID is
+ Self_ID : Task_ID renames Thread_Local_Data_Ptr.Self_ID;
+
+ begin
+ -- Check that the thread local data has been initialized.
+
+ pragma Assert
+ ((Thread_Local_Data_Ptr /= null
+ and then Thread_Local_Data_Ptr.Self_ID /= null));
+
+ return Self_ID;
+ end Self;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : access Lock)
+ is
+ begin
+ if DosCreateMutexSem
+ (ICS.Null_Ptr, L.Mutex'Unchecked_Access, 0, False32) /= NO_ERROR
+ then
+ raise Storage_Error;
+ end if;
+
+ pragma Assert (L.Mutex /= 0, "Error creating Mutex");
+ L.Priority := Prio;
+ L.Owner_ID := Null_Address;
+ end Initialize_Lock;
+
+ procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
+ begin
+ if DosCreateMutexSem
+ (ICS.Null_Ptr, L.Mutex'Unchecked_Access, 0, False32) /= NO_ERROR
+ then
+ raise Storage_Error;
+ end if;
+
+ pragma Assert (L.Mutex /= 0, "Error creating Mutex");
+
+ L.Priority := System.Any_Priority'Last;
+ L.Owner_ID := Null_Address;
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : access Lock) is
+ begin
+ Must_Not_Fail (DosCloseMutexSem (L.Mutex));
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : access RTS_Lock) is
+ begin
+ Must_Not_Fail (DosCloseMutexSem (L.Mutex));
+ end Finalize_Lock;
+
+ ----------------
+ -- Write_Lock --
+ ----------------
+
+ procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ Self_ID : constant Task_ID := Thread_Local_Data_Ptr.Self_ID;
+ Old_Priority : constant Any_Priority :=
+ Self_ID.Common.LL.Current_Priority;
+
+ begin
+ if L.Priority < Old_Priority then
+ Ceiling_Violation := True;
+ return;
+ end if;
+
+ Ceiling_Violation := False;
+
+ -- Increase priority before getting the lock
+ -- to prevent priority inversion
+
+ Thread_Local_Data_Ptr.Lock_Prio_Level :=
+ Thread_Local_Data_Ptr.Lock_Prio_Level + 1;
+ if L.Priority > Old_Priority then
+ Set_Temporary_Priority (Self_ID, L.Priority);
+ end if;
+
+ -- Request the lock and then update the lock owner data
+
+ Must_Not_Fail (DosRequestMutexSem (L.Mutex, SEM_INDEFINITE_WAIT));
+ L.Owner_Priority := Old_Priority;
+ L.Owner_ID := Self_ID.all'Address;
+ end Write_Lock;
+
+ procedure Write_Lock (L : access RTS_Lock) is
+ Self_ID : constant Task_ID := Thread_Local_Data_Ptr.Self_ID;
+ Old_Priority : constant Any_Priority :=
+ Self_ID.Common.LL.Current_Priority;
+
+ begin
+ -- Increase priority before getting the lock
+ -- to prevent priority inversion
+
+ Thread_Local_Data_Ptr.Lock_Prio_Level :=
+ Thread_Local_Data_Ptr.Lock_Prio_Level + 1;
+
+ if L.Priority > Old_Priority then
+ Set_Temporary_Priority (Self_ID, L.Priority);
+ end if;
+
+ -- Request the lock and then update the lock owner data
+
+ Must_Not_Fail (DosRequestMutexSem (L.Mutex, SEM_INDEFINITE_WAIT));
+ L.Owner_Priority := Old_Priority;
+ L.Owner_ID := Self_ID.all'Address;
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_ID) is
+ begin
+ -- Request the lock and then update the lock owner data
+
+ Must_Not_Fail
+ (DosRequestMutexSem (T.Common.LL.L.Mutex, SEM_INDEFINITE_WAIT));
+ T.Common.LL.L.Owner_ID := Null_Address;
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean)
+ renames Write_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : access Lock) is
+ Self_ID : constant Task_ID := Thread_Local_Data_Ptr.Self_ID;
+ Old_Priority : constant Any_Priority := L.Owner_Priority;
+
+ begin
+ -- Check that this task holds the lock
+
+ pragma Assert (Suppress_Owner_Check
+ or else L.Owner_ID = Self_ID.all'Address);
+
+ -- Upate the owner data
+
+ L.Owner_ID := Null_Address;
+
+ -- Do the actual unlocking. No more references
+ -- to owner data of L after this point.
+
+ Must_Not_Fail (DosReleaseMutexSem (L.Mutex));
+
+ -- Reset priority after unlocking to avoid priority inversion
+
+ Thread_Local_Data_Ptr.Lock_Prio_Level :=
+ Thread_Local_Data_Ptr.Lock_Prio_Level - 1;
+ if L.Priority /= Old_Priority then
+ Set_Temporary_Priority (Self_ID, Old_Priority);
+ end if;
+ end Unlock;
+
+ procedure Unlock (L : access RTS_Lock) is
+ Self_ID : constant Task_ID := Thread_Local_Data_Ptr.Self_ID;
+ Old_Priority : constant Any_Priority := L.Owner_Priority;
+
+ begin
+ -- Check that this task holds the lock
+
+ pragma Assert (Suppress_Owner_Check
+ or else L.Owner_ID = Self_ID.all'Address);
+
+ -- Upate the owner data
+
+ L.Owner_ID := Null_Address;
+
+ -- Do the actual unlocking. No more references
+ -- to owner data of L after this point.
+
+ Must_Not_Fail (DosReleaseMutexSem (L.Mutex));
+
+ -- Reset priority after unlocking to avoid priority inversion
+ Thread_Local_Data_Ptr.Lock_Prio_Level :=
+ Thread_Local_Data_Ptr.Lock_Prio_Level - 1;
+
+ if L.Priority /= Old_Priority then
+ Set_Temporary_Priority (Self_ID, Old_Priority);
+ end if;
+ end Unlock;
+
+ procedure Unlock (T : Task_ID) is
+ begin
+ -- Check the owner data
+
+ pragma Assert (Suppress_Owner_Check
+ or else T.Common.LL.L.Owner_ID = Null_Address);
+
+ -- Do the actual unlocking. No more references
+ -- to owner data of T.Common.LL.L after this point.
+
+ Must_Not_Fail (DosReleaseMutexSem (T.Common.LL.L.Mutex));
+ end Unlock;
+
+ -----------
+ -- Sleep --
+ -----------
+
+ procedure Sleep (Self_ID : Task_ID;
+ Reason : System.Tasking.Task_States) is
+ Count : aliased ULONG; -- Used to store dummy result
+
+ begin
+ -- Must reset Cond BEFORE L is unlocked.
+
+ Sem_Must_Not_Fail
+ (DosResetEventSem (Self_ID.Common.LL.CV, Count'Unchecked_Access));
+ Unlock (Self_ID);
+
+ -- No problem if we are interrupted here.
+ -- If the condition is signaled, DosWaitEventSem will simply not block.
+
+ Sem_Must_Not_Fail
+ (DosWaitEventSem (Self_ID.Common.LL.CV, SEM_INDEFINITE_WAIT));
+
+ -- Since L was previously accquired, lock operation should not fail.
+
+ Write_Lock (Self_ID);
+ 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.
+
+ -- Pre-assertion: Cond is posted
+ -- Self is locked.
+
+ -- Post-assertion: Cond is posted
+ -- Self is locked.
+
+ procedure Timed_Sleep
+ (Self_ID : Task_ID;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ Check_Time : constant Duration := OSP.Monotonic_Clock;
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Time_Out : ULONG;
+ Result : APIRET;
+ Count : aliased ULONG; -- Used to store dummy result
+
+ begin
+ -- Must reset Cond BEFORE Self_ID is unlocked.
+
+ Sem_Must_Not_Fail
+ (DosResetEventSem (Self_ID.Common.LL.CV,
+ Count'Unchecked_Access));
+ Unlock (Self_ID);
+
+ Timedout := True;
+ Yielded := False;
+
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ or else Self_ID.Pending_Priority_Change;
+
+ Time_Out := To_MS (Rel_Time);
+ Result := DosWaitEventSem (Self_ID.Common.LL.CV, Time_Out);
+ pragma Assert
+ ((Result = NO_ERROR or Result = ERROR_TIMEOUT
+ or Result = ERROR_INTERRUPT));
+
+ -- ???
+ -- What to do with error condition ERROR_NOT_ENOUGH_MEMORY? Can
+ -- we raise an exception here? And what about ERROR_INTERRUPT?
+ -- Should that be treated as a simple timeout?
+ -- For now, consider only ERROR_TIMEOUT to be a timeout.
+
+ exit when Abs_Time <= OSP.Monotonic_Clock;
+
+ if Result /= ERROR_TIMEOUT then
+ -- somebody may have called Wakeup for us
+ Timedout := False;
+ exit;
+ end if;
+
+ Rel_Time := Abs_Time - OSP.Monotonic_Clock;
+ end loop;
+ end if;
+
+ -- Ensure post-condition
+
+ Write_Lock (Self_ID);
+
+ if Timedout then
+ Sem_Must_Not_Fail (DosPostEventSem (Self_ID.Common.LL.CV));
+ end if;
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Self_ID : Task_ID;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ Check_Time : constant Duration := OSP.Monotonic_Clock;
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Timedout : Boolean := True;
+ Time_Out : ULONG;
+ Result : APIRET;
+ Count : aliased ULONG; -- Used to store dummy result
+
+ begin
+ -- Only the little window between deferring abort and
+ -- locking Self_ID is the reason we need to
+ -- check for pending abort and priority change below! :(
+
+ SSL.Abort_Defer.all;
+ Write_Lock (Self_ID);
+
+ -- Must reset Cond BEFORE Self_ID is unlocked.
+
+ Sem_Must_Not_Fail
+ (DosResetEventSem (Self_ID.Common.LL.CV,
+ Count'Unchecked_Access));
+ Unlock (Self_ID);
+
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Time + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ Self_ID.Common.State := Delay_Sleep;
+ loop
+ if Self_ID.Pending_Priority_Change then
+ Self_ID.Pending_Priority_Change := False;
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
+ end if;
+
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Time_Out := To_MS (Rel_Time);
+ Result := DosWaitEventSem (Self_ID.Common.LL.CV, Time_Out);
+
+ exit when Abs_Time <= OSP.Monotonic_Clock;
+
+ Rel_Time := Abs_Time - OSP.Monotonic_Clock;
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ Timedout := Result = ERROR_TIMEOUT;
+ end if;
+
+ -- Ensure post-condition
+
+ Write_Lock (Self_ID);
+
+ if Timedout then
+ Sem_Must_Not_Fail (DosPostEventSem (Self_ID.Common.LL.CV));
+ end if;
+
+ Unlock (Self_ID);
+ System.OS_Interface.Yield;
+ SSL.Abort_Undefer.all;
+ end Timed_Delay;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
+ begin
+ Sem_Must_Not_Fail (DosPostEventSem (T.Common.LL.CV));
+ end Wakeup;
+
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ begin
+ if Do_Yield then
+ System.OS_Interface.Yield;
+ end if;
+ end Yield;
+
+ ----------------------------
+ -- Set_Temporary_Priority --
+ ----------------------------
+
+ procedure Set_Temporary_Priority
+ (T : Task_ID;
+ New_Priority : System.Any_Priority)
+ is
+ use Interfaces.C;
+ Delta_Priority : Integer;
+
+ begin
+ -- When Lock_Prio_Level = 0, we always need to set the
+ -- Active_Priority. In this way we can make priority changes
+ -- due to locking independent of those caused by calling
+ -- Set_Priority.
+
+ if Thread_Local_Data_Ptr.Lock_Prio_Level = 0
+ or else New_Priority < T.Common.Current_Priority
+ then
+ Delta_Priority := T.Common.Current_Priority -
+ T.Common.LL.Current_Priority;
+ else
+ Delta_Priority := New_Priority - T.Common.LL.Current_Priority;
+ end if;
+
+ if Delta_Priority /= 0 then
+
+ -- ??? There is a race-condition here
+ -- The TCB is updated before the system call to make
+ -- pre-emption in the critical section less likely.
+
+ T.Common.LL.Current_Priority :=
+ T.Common.LL.Current_Priority + Delta_Priority;
+ Must_Not_Fail
+ (DosSetPriority (Scope => PRTYS_THREAD,
+ Class => PRTYC_NOCHANGE,
+ Delta_P => IC.long (Delta_Priority),
+ PorTid => T.Common.LL.Thread));
+ end if;
+ end Set_Temporary_Priority;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_Priority
+ (T : Task_ID;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False) is
+ begin
+ T.Common.Current_Priority := Prio;
+ Set_Temporary_Priority (T, 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
+
+ -- Initialize thread local data. Must be done first.
+
+ Thread_Local_Data_Ptr.Self_ID := Self_ID;
+ Thread_Local_Data_Ptr.Lock_Prio_Level := 0;
+
+ Lock_All_Tasks_List;
+ for I in Known_Tasks'Range loop
+ if Known_Tasks (I) = null then
+ Known_Tasks (I) := Self_ID;
+ Self_ID.Known_Tasks_Index := I;
+ exit;
+ end if;
+ end loop;
+ Unlock_All_Tasks_List;
+
+ -- For OS/2, we can set Self_ID.Common.LL.Thread in
+ -- Create_Task, since the thread is created suspended.
+ -- That is, there is no danger of the thread racing ahead
+ -- and trying to reference Self_ID.Common.LL.Thread before it
+ -- has been initialized.
+
+ -- .... Do we need to do anything with signals for OS/2 ???
+ null;
+ 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;
+
+ ----------------------
+ -- Initialize_TCB --
+ ----------------------
+
+ procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
+ begin
+ if DosCreateEventSem (ICS.Null_Ptr,
+ Self_ID.Common.LL.CV'Unchecked_Access, 0, True32) = NO_ERROR
+ then
+ if DosCreateMutexSem (ICS.Null_Ptr,
+ Self_ID.Common.LL.L.Mutex'Unchecked_Access, 0, False32) /= NO_ERROR
+ then
+ Succeeded := False;
+ Must_Not_Fail (DosCloseEventSem (Self_ID.Common.LL.CV));
+ else
+ Succeeded := True;
+ end if;
+
+ pragma Assert (Self_ID.Common.LL.L.Mutex /= 0);
+
+ -- We now want to do the equivalent of:
+
+ -- Initialize_Lock
+ -- (Self_ID.Common.LL.L'Unchecked_Access, ATCB_Level);
+
+ -- But we avoid that because the Initialize_TCB routine has an
+ -- exception handler, and it is too early for us to deal with
+ -- installing handlers (see comment below), so we do our own
+ -- Initialize_Lock operation manually.
+
+ Self_ID.Common.LL.L.Priority := System.Any_Priority'Last;
+ Self_ID.Common.LL.L.Owner_ID := Null_Address;
+
+ else
+ Succeeded := False;
+ end if;
+
+ -- Note: at one time we had anb exception handler here, whose code
+ -- was as follows:
+
+ -- exception
+
+ -- Assumes any failure must be due to insufficient resources
+
+ -- when Storage_Error =>
+ -- Must_Not_Fail (DosCloseEventSem (Self_ID.Common.LL.CV));
+ -- Succeeded := False;
+
+ -- but that won't work with the old exception scheme, since it would
+ -- result in messing with Jmpbuf values too early. If and when we get
+ -- switched entirely to the new zero-cost exception scheme, we could
+ -- put this handler back in!
+
+ 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
+ Result : aliased APIRET;
+ Adjusted_Stack_Size : System.Parameters.Size_Type;
+ use System.Parameters;
+
+ begin
+ -- In OS/2 the allocated stack size should be based on the
+ -- amount of address space that should be reserved for the stack.
+ -- Actual memory will only be used when the stack is touched anyway.
+
+ -- The new minimum size is 12 kB, although the EMX docs
+ -- recommend a minimum size of 32 kB. (The original was 4 kB)
+ -- Systems that use many tasks (say > 30) and require much
+ -- memory may run out of virtual address space, since OS/2
+ -- has a per-proces limit of 512 MB, of which max. 300 MB is
+ -- usable in practise.
+
+ if Stack_Size = Unspecified_Size then
+ Adjusted_Stack_Size := Default_Stack_Size;
+
+ elsif Stack_Size < Minimum_Stack_Size then
+ Adjusted_Stack_Size := Minimum_Stack_Size;
+
+ else
+ Adjusted_Stack_Size := Stack_Size;
+ end if;
+
+ -- GB970222:
+ -- Because DosCreateThread is called directly here, the
+ -- C RTL doesn't get initialized for the new thead. EMX by
+ -- default uses per-thread local heaps in addition to the
+ -- global heap. There might be other effects of by-passing the
+ -- C library here.
+
+ -- When using _beginthread the newly created thread is not
+ -- blocked initially. Does this matter or can I create the
+ -- thread running anyway? The LL.Thread variable will be set
+ -- anyway because the variable is passed by reference to OS/2.
+
+ T.Common.LL.Wrapper := To_PFNTHREAD (Wrapper);
+
+ -- The OS implicitly gives the new task the priority of this task.
+
+ T.Common.LL.Current_Priority := Self.Common.LL.Current_Priority;
+
+ -- If task was locked before activator task was
+ -- initialized, assume it has OS standard priority
+
+ if T.Common.LL.L.Owner_Priority not in Any_Priority'Range then
+ T.Common.LL.L.Owner_Priority := 1;
+ end if;
+
+ -- Create the thread, in blocked mode
+
+ Result := DosCreateThread
+ (F_ptid => T.Common.LL.Thread'Unchecked_Access,
+ pfn => T.Common.LL.Wrapper,
+ param => To_Address (T),
+ flag => Block_Child + Commit_Stack,
+ cbStack => ULONG (Adjusted_Stack_Size));
+
+ Succeeded := (Result = NO_ERROR);
+
+ if not Succeeded then
+ return;
+ end if;
+
+ -- Set the new thread's priority
+ -- (child has inherited priority from parent)
+
+ Set_Priority (T, Priority);
+
+ -- Start the thread executing
+
+ Must_Not_Fail (DosResumeThread (T.Common.LL.Thread));
+
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_ID) is
+ Tmp : Task_ID := T;
+
+ procedure Free is new
+ Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
+ begin
+ Must_Not_Fail (DosCloseEventSem (T.Common.LL.CV));
+ Finalize_Lock (T.Common.LL.L'Unchecked_Access);
+ if T.Known_Tasks_Index /= -1 then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ end if;
+ Free (Tmp);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ DosExit (EXIT_THREAD, 0);
+
+ -- Do not finalize TCB here.
+ -- GNARL layer is responsible for that.
+
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_ID) is
+ begin
+ null;
+
+ -- Task abortion not implemented yet.
+ -- Should perform other action ???
+
+ end Abort_Task;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy versions. The only currently working versions is for solaris
+ -- (native).
+
+ function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ begin
+ return Check_No_Locks (Self_ID);
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ TLD : constant Access_Thread_Local_Data := Thread_Local_Data_Ptr;
+ begin
+ return Self_ID = TLD.Self_ID
+ and then TLD.Lock_Prio_Level = 0;
+ end Check_No_Locks;
+
+ ----------------------
+ -- Environment_Task --
+ ----------------------
+
+ function Environment_Task return Task_ID is
+ begin
+ return Environment_Task_ID;
+ end Environment_Task;
+
+ -------------------------
+ -- Lock_All_Tasks_List --
+ -------------------------
+
+ procedure Lock_All_Tasks_List is
+ begin
+ Write_Lock (All_Tasks_L'Access);
+ end Lock_All_Tasks_List;
+
+ ---------------------------
+ -- Unlock_All_Tasks_List --
+ ---------------------------
+
+ procedure Unlock_All_Tasks_List is
+ begin
+ Unlock (All_Tasks_L'Access);
+ end Unlock_All_Tasks_List;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ if Thread_Id (T.Common.LL.Thread) /= Thread_Self then
+ return DosSuspendThread (T.Common.LL.Thread) = NO_ERROR;
+ else
+ return True;
+ end if;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ if Thread_Id (T.Common.LL.Thread) /= Thread_Self then
+ return DosResumeThread (T.Common.LL.Thread) = NO_ERROR;
+ else
+ return True;
+ end if;
+ end Resume_Task;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_ID) is
+ Succeeded : Boolean;
+
+ begin
+ Environment_Task_ID := Environment_Task;
+
+ Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
+ -- Initialize the lock used to synchronize chain of all ATCBs.
+
+ -- Set ID of environment task.
+
+ Thread_Local_Data_Ptr.Self_ID := Environment_Task;
+ Environment_Task.Common.LL.Thread := 1; -- By definition
+
+ -- This priority is unknown in fact.
+ -- If actual current priority is different,
+ -- it will get synchronized later on anyway.
+
+ Environment_Task.Common.LL.Current_Priority :=
+ Environment_Task.Common.Current_Priority;
+
+ -- Initialize TCB for this task.
+ -- This includes all the normal task-external initialization.
+ -- This is also done by Initialize_ATCB, why ???
+
+ Initialize_TCB (Environment_Task, Succeeded);
+
+ -- Consider raising Storage_Error,
+ -- if propagation can be tolerated ???
+
+ pragma Assert (Succeeded);
+
+ -- Do normal task-internal initialization,
+ -- which depends on an initialized TCB.
+
+ Enter_Task (Environment_Task);
+
+ -- Insert here any other special
+ -- initialization needed for the environment task.
+
+ end Initialize;
+
+begin
+ -- Initialize pointer to task local data.
+ -- This is done once, for all tasks.
+
+ Must_Not_Fail (DosAllocThreadLocalMemory
+ ((Thread_Local_Data'Size + 31) / 32, -- nr of 32-bit words
+ To_PPVOID (Thread_Local_Data_Ptr'Access)));
+
+ -- Initialize thread local data for main thread
+
+ Thread_Local_Data_Ptr.Self_ID := null;
+ Thread_Local_Data_Ptr.Lock_Prio_Level := 0;
+
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1991-1999 Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is an OS/2 version of this package.
+
+-- This package provides low-level support for most tasking features.
+
+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 Interfaces.OS2Lib.Threads;
+with Interfaces.OS2Lib.Synchronization;
+
+package System.Task_Primitives is
+
+ pragma Preelaborate;
+
+-- type Lock is limited private;
+ -- Should be used for implementation of protected objects.
+
+-- type RTS_Lock is limited private;
+ -- Should be used inside the runtime system.
+ -- The difference between Lock and the RTS_Lock is that the later
+ -- one serves only as a semaphore so that do not check for
+ -- ceiling violations.
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper
+ -- declared local to the GNARL).
+
+-- type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task
+ -- basis. A component of this type is guaranteed to be included
+ -- in the Ada_Task_Control_Block.
+
+-- private
+
+ type Lock is
+ record
+ Mutex : aliased Interfaces.OS2Lib.Synchronization.HMTX;
+ Priority : Integer;
+ Owner_Priority : Integer;
+ Owner_ID : Address;
+ end record;
+
+ type RTS_Lock is new Lock;
+
+ type Private_Data is record
+ Thread : aliased Interfaces.OS2Lib.Threads.TID;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb).
+ -- They put the same value (thr_self value). We do not want to
+ -- use lock on those operations and the only thing we have to
+ -- make sure is that they are updated in atomic fashion.
+
+ CV : aliased Interfaces.OS2Lib.Synchronization.HEV;
+
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
+
+ Current_Priority : Integer := -1;
+ -- The Current_Priority is the actual priority of a thread.
+ -- This field is needed because it is only possible to set a
+ -- delta priority in OS/2. The only places where this field should
+ -- be set are Set_Priority, Create_Task and Initialize (Environment).
+
+ Wrapper : Interfaces.OS2Lib.Threads.PFNTHREAD;
+ -- This is the original wrapper passed by Operations.Create_Task.
+ -- When installing an exception handler in a thread, the thread
+ -- starts executing the Exception_Wrapper which calls Wrapper
+ -- when the handler has been installed. The handler is removed when
+ -- wrapper returns.
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.18 $
+-- --
+-- Copyright (C) 1997-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a OpenNT/Interix (FSU THREADS) version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lgthreads");
+ pragma Linker_Options ("-lmalloc");
+
+ 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 := 31;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 0; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 0; -- power-fail restart
+ SIGWINCH : constant := 20; -- window size change
+ SIGURG : constant := 21; -- urgent condition on IO channel
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGIO : constant := 19; -- I/O possible (Solaris SIGPOLL alias)
+ SIGSTOP : constant := 23; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 24; -- user stop requested from tty
+ SIGCONT : constant := 25; -- stopped process has been continued
+ SIGTTIN : constant := 26; -- background tty read attempted
+ SIGTTOU : constant := 27; -- background tty write attempted
+ SIGVTALRM : constant := 28; -- virtual timer expired
+ SIGPROF : constant := 29; -- profiling timer expired
+ SIGXCPU : constant := 30; -- CPU time limit exceeded
+ SIGXFSZ : constant := 31; -- filesize limit exceeded
+
+ SIGADAABORT : constant := SIGABRT;
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set :=
+ (SIGTRAP, SIGALRM, SIGVTALRM, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF);
+
+ Reserved : constant Signal_Set := (SIGKILL, SIGSTOP);
+
+ 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;
+ sa_restorer : System.Address;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ -- FSU pthreads redefines sigaction and then uses a special syscall
+ -- API to call the system version. Doing syscalls on OpenNT is very
+ -- difficult, so we rename the pthread version instead.
+ pragma Import (C, sigaction, "pthread_wrapper_sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ Time_Slice_Supported : constant Boolean := False;
+ -- Indicates wether time slicing is supported (i.e FSU threads have been
+ -- compiled with DEF_RR)
+
+ type timespec is private;
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "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_timeval is private;
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 0;
+ SCHED_RR : constant := 1;
+ SCHED_OTHER : constant := 2;
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- 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;
+ 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 --
+ -----------
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates wether the stack base is available on this target.
+ -- This allows us to share s-osinte.adb between all the FSU run time.
+ -- Note that this value can only be true if pthread_t has a complete
+ -- definition that corresponds exactly to the C header files.
+
+ 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_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
+
+ PROT_ON : constant := PROT_NONE;
+ 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;
+ -- FSU_THREADS requires pthread_init, which is nonstandard
+ -- and this should be invoked during the elaboration of s-taprop.adb
+ pragma Import (C, pthread_init, "pthread_init");
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ -- FSU_THREADS has a nonstandard sigwait
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "pthread_wrapper_sigprocmask");
+
+ --------------------------
+ -- 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;
+ -- FSU_THREADS has nonstandard pthread_mutex_lock
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ -- FSU_THREADS has nonstandard pthread_mutex_lock
+
+ 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;
+ -- FSU_THREADS has a nonstandard pthread_cond_wait
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ -- FSU_THREADS has a nonstandard 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_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ 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,
+ "pthread_mutexattr_setprio_ceiling");
+
+ 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;
+ -- FSU_THREADS does not have 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, "pthread_attr_setsched");
+
+ function sched_yield return int;
+ -- FSU_THREADS does not have 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;
+ -- FSU_THREADS has a nonstandard 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 pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ -- FSU_THREADS has a nonstandard pthread_getspecific
+
+ type destructor_pointer is access procedure (arg : System.Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+
+ type sigset_t is new unsigned_long;
+ pragma Convention (C, sigset_t);
+
+ type pid_t is new int;
+
+ subtype time_t is long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 0;
+
+ type struct_timeval is record
+ tv_sec : time_t;
+ tv_usec : long;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type pthread_attr_t is record
+ flags : int;
+ stacksize : int;
+ contentionscope : int;
+ inheritsched : int;
+ detachstate : int;
+ sched : int;
+ prio : int;
+ starttime : timespec;
+ deadline : timespec;
+ period : timespec;
+ end record;
+ pragma Convention (C_Pass_By_Copy, pthread_attr_t);
+
+ type pthread_condattr_t is record
+ flags : int;
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_mutexattr_t is record
+ flags : int;
+ prio_ceiling : int;
+ protocol : int;
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type sigjmp_buf is array (Integer range 0 .. 17) of int;
+
+ type pthread_t_struct is record
+ context : sigjmp_buf;
+ pbody : sigjmp_buf;
+ errno : int;
+ ret : int;
+ stack_base : System.Address;
+ end record;
+ pragma Convention (C, pthread_t_struct);
+
+ type pthread_t is access all pthread_t_struct;
+
+ type queue_t is record
+ head : System.Address;
+ tail : System.Address;
+ end record;
+ pragma Convention (C, queue_t);
+
+ type pthread_mutex_t is record
+ queue : queue_t;
+ lock : plain_char;
+ owner : System.Address;
+ flags : int;
+ prio_ceiling : int;
+ protocol : int;
+ prev_max_ceiling_prio : int;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_cond_t is record
+ queue : queue_t;
+ flags : int;
+ waiters : int;
+ mutex : System.Address;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ P R I M I T I V E S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.8 $
+-- --
+-- Copyright (C) 1998-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This version uses gettimeofday and select
+-- Currently OpenNT, Dec Unix, Solaris and SCO UnixWare use this file.
+
+package body System.OS_Primitives is
+
+ -- ??? These definitions are duplicated from System.OS_Interface
+ -- because we don't want to depend on any package. Consider removing
+ -- these declarations in System.OS_Interface and move these ones in
+ -- the spec.
+
+ type struct_timezone is record
+ tz_minuteswest : Integer;
+ tz_dsttime : Integer;
+ end record;
+ pragma Convention (C, struct_timezone);
+ type struct_timezone_ptr is access all struct_timezone;
+
+ type struct_timeval is record
+ tv_sec : Integer;
+ tv_usec : Integer;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ function gettimeofday
+ (tv : access struct_timeval;
+ tz : struct_timezone_ptr) return Integer;
+ pragma Import (C, gettimeofday, "gettimeofday");
+
+ type fd_set is null record;
+ type fd_set_ptr is access all fd_set;
+
+ function C_select
+ (n : Integer := 0;
+ readfds,
+ writefds,
+ exceptfds : fd_set_ptr := null;
+ timeout : access struct_timeval) return Integer;
+ pragma Import (C, C_select, "select");
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock return Duration is
+ TV : aliased struct_timeval;
+ Result : Integer;
+
+ begin
+ Result := gettimeofday (TV'Access, null);
+ return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
+ end Clock;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration renames Clock;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Time : Duration;
+ Mode : Integer)
+ is
+ Result : Integer;
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Check_Time : Duration := Clock;
+ timeval : aliased struct_timeval;
+
+ begin
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Time + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ loop
+ timeval.tv_sec := Integer (Rel_Time);
+
+ if Duration (timeval.tv_sec) > Rel_Time then
+ timeval.tv_sec := timeval.tv_sec - 1;
+ end if;
+
+ timeval.tv_usec :=
+ Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6);
+
+ Result := C_select (timeout => timeval'Unchecked_Access);
+ Check_Time := Clock;
+
+ exit when Abs_Time <= Check_Time;
+
+ Rel_Time := Abs_Time - Check_Time;
+ end loop;
+ end if;
+ end Timed_Delay;
+
+end System.OS_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 1998 - 2001 Free Software Foundation --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the PPC VxWorks 5.x version of this package. A different version
+-- is used for VxWorks 6.0
+
+with Interfaces.C;
+
+package System.VxWorks is
+ pragma Preelaborate (System.VxWorks);
+
+ package IC renames Interfaces.C;
+
+ -- Define enough of a Wind Task Control Block in order to
+ -- obtain the inherited priority. When porting this to
+ -- different versions of VxWorks (this is based on 5.3[.1]),
+ -- be sure to look at the definition for WIND_TCB located
+ -- in $WIND_BASE/target/h/taskLib.h
+
+ type Wind_Fill_1 is array (0 .. 16#3F#) of IC.unsigned_char;
+ type Wind_Fill_2 is array (16#48# .. 16#107#) of IC.unsigned_char;
+
+ type Wind_TCB is record
+ Fill_1 : Wind_Fill_1; -- 0x00 - 0x3f
+ Priority : IC.int; -- 0x40 - 0x43, current (inherited) priority
+ Normal_Priority : IC.int; -- 0x44 - 0x47, base priority
+ Fill_2 : Wind_Fill_2; -- 0x48 - 0x107
+ spare1 : Address; -- 0x108 - 0x10b
+ spare2 : Address; -- 0x10c - 0x10f
+ spare3 : Address; -- 0x110 - 0x113
+ spare4 : Address; -- 0x114 - 0x117
+ end record;
+ type Wind_TCB_Ptr is access Wind_TCB;
+
+ -- Floating point context record. PPC version
+
+ FP_NUM_DREGS : constant := 32;
+ type Fpr_Array is array (1 .. FP_NUM_DREGS) of IC.double;
+
+ type FP_CONTEXT is record
+ fpr : Fpr_Array;
+ fpcsr : IC.int;
+ pad : IC.int;
+ end record;
+ pragma Convention (C, FP_CONTEXT);
+
+ Num_HW_Interrupts : constant := 256;
+
+ -- VxWorks 5.3 and 5.4 version
+ type TASK_DESC is record
+ td_id : IC.int; -- task id
+ td_name : Address; -- name of task
+ td_priority : IC.int; -- task priority
+ td_status : IC.int; -- task status
+ td_options : IC.int; -- task option bits (see below)
+ td_entry : Address; -- original entry point of task
+ td_sp : Address; -- saved stack pointer
+ td_pStackBase : Address; -- the bottom of the stack
+ td_pStackLimit : Address; -- the effective end of the stack
+ td_pStackEnd : Address; -- the actual end of the stack
+ td_stackSize : IC.int; -- size of stack in bytes
+ td_stackCurrent : IC.int; -- current stack usage in bytes
+ td_stackHigh : IC.int; -- maximum stack usage in bytes
+ td_stackMargin : IC.int; -- current stack margin in bytes
+ td_errorStatus : IC.int; -- most recent task error status
+ td_delay : IC.int; -- delay/timeout ticks
+ end record;
+ pragma Convention (C, TASK_DESC);
+
+end System.VxWorks;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1991-2000 Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- RT Linux version.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+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
+
+ type Require_Body is new Integer;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.8 $
+-- --
+-- Copyright (C) 1991-2001 Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- RT Linux version.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+
+package System.OS_Interface is
+
+ pragma Preelaborate;
+
+ subtype int is Interfaces.C.int;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+
+ -- RT Linux kernel threads should not use the
+ -- OS signal interfaces.
+
+ Max_Interrupt : constant := 2;
+ type Signal is new int range 0 .. Max_Interrupt;
+ type sigset_t is new Integer;
+
+ ----------
+ -- Time --
+ ----------
+
+ RT_TICKS_PER_SEC : constant := 1193180;
+ -- the amount of time units in one second.
+
+ RT_TIME_END : constant := 16#7fffFfffFfffFfff#;
+
+ type RTIME is range -2 ** 63 .. 2 ** 63 - 1;
+ -- the introduction of type RTIME is due to the fact that RT-Linux
+ -- uses this type to represent time. In RT-Linux, it's a long long
+ -- integer that takes 64 bits for storage
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ RT_LOWEST_PRIORITY : constant System.Any_Priority :=
+ System.Any_Priority'First;
+ -- for the lowest priority task in RT_Linux. By the design, this task
+ -- is the regular linux kernel.
+
+ RT_TASK_MAGIC : constant := 16#754d2774#;
+ -- a special constant used as a label for a task that has been created
+
+ ----------------------------
+ -- RT constants and types --
+ ----------------------------
+
+ SFIF : Integer;
+ pragma Import (C, SFIF, "SFIF");
+ -- Interrupt emulation flag used by RT-Linux. If it's 0, the regular
+ -- Linux kernel is preempted. Otherwise, the regular Linux kernel is
+ -- running
+
+ GFP_ATOMIC : constant := 16#1#;
+ GFP_KERNEL : constant := 16#3#;
+ -- constants to indicate the priority of a call to kmalloc.
+ -- GFP_KERNEL is used in the current implementation to allocate
+ -- stack space for a task. Since GFP_ATOMIC has higher priority,
+ -- if necessary, replace GFP_KERNEL with GFP_ATOMIC
+
+ type Rt_Task_States is (RT_TASK_READY, RT_TASK_DELAYED, RT_TASK_DORMANT);
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+
+ -- ??? need to define a type for references to (IDs of)
+ -- RT Linux lock objects, and implement the lock objects.
+
+ subtype Thread_Id is System.Address;
+
+ -------------------------------
+ -- Useful imported functions --
+ -------------------------------
+
+ ---------------------------------
+ -- functions from linux kernel --
+ ---------------------------------
+
+ function Kmalloc (size : Integer; Priority : Integer) return System.Address;
+ pragma Import (C, Kmalloc, "kmalloc");
+
+ procedure Kfree (Ptr : System.Address);
+ pragma Import (C, Kfree, "kfree");
+
+ procedure Printk (Msg : String);
+ pragma Import (C, Printk, "printk");
+
+ ---------------------
+ -- RT time related --
+ ---------------------
+
+ function Rt_Get_Time return RTIME;
+ pragma Import (C, Rt_Get_Time, "rt_get_time");
+
+ function Rt_Request_Timer (Fn : System.Address) return Integer;
+ procedure Rt_Request_Timer (Fn : System.Address);
+ pragma Import (C, Rt_Request_Timer, "rt_request_timer");
+
+ procedure Rt_Free_Timer;
+ pragma Import (C, Rt_Free_Timer, "rt_free_timer");
+
+ procedure Rt_Set_Timer (T : RTIME);
+ pragma Import (C, Rt_Set_Timer, "rt_set_timer");
+
+ procedure Rt_No_Timer;
+ pragma Import (C, Rt_No_Timer, "rt_no_timer");
+
+ ---------------------
+ -- RT FIFO related --
+ ---------------------
+
+ function Rtf_Create (Fifo : Integer; Size : Integer) return Integer;
+ pragma Import (C, Rtf_Create, "rtf_create");
+
+ function Rtf_Destroy (Fifo : Integer) return Integer;
+ pragma Import (C, Rtf_Destroy, "rtf_destroy");
+
+ function Rtf_Resize (Minor : Integer; Size : Integer) return Integer;
+ pragma Import (C, Rtf_Resize, "rtf_resize");
+
+ function Rtf_Put
+ (Fifo : Integer;
+ Buf : System.Address;
+ Count : Integer) return Integer;
+ pragma Import (C, Rtf_Put, "rtf_put");
+
+ function Rtf_Get
+ (Fifo : Integer;
+ Buf : System.Address;
+ Count : Integer) return Integer;
+ pragma Import (C, Rtf_Get, "rtf_get");
+
+ function Rtf_Create_Handler
+ (Fifo : Integer;
+ Handler : System.Address) return Integer;
+ pragma Import (C, Rtf_Create_Handler, "rtf_create_handler");
+
+private
+ type Require_Body;
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $
+-- --
+-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the RT-Linux version.
+-- Blank line intentional so that it lines up exactly with default.
+
+-- This package defines some system dependent parameters for GNAT. These
+-- are values that are referenced by the runtime library and are therefore
+-- relevant to the target machine.
+
+-- The parameters whose value is defined in the spec are not generally
+-- expected to be changed. If they are changed, it will be necessary to
+-- recompile the run-time library.
+
+-- The parameters which are defined by functions can be changed by modifying
+-- the body of System.Parameters in file s-parame.adb. A change to this body
+-- requires only rebinding and relinking of the application.
+
+-- Note: do not introduce any pragma Inline statements into this unit, since
+-- otherwise the relinking and rebinding capability would be deactivated.
+
+package System.Parameters is
+pragma Pure (Parameters);
+
+ ---------------------------------------
+ -- Task And Stack Allocation Control --
+ ---------------------------------------
+
+ type Task_Storage_Size is new Integer;
+ -- Type used in tasking units for task storage size
+
+ type Size_Type is new Task_Storage_Size;
+ -- Type used to provide task storage size to runtime
+
+ Unspecified_Size : constant Size_Type := Size_Type'First;
+ -- Value used to indicate that no size type is set
+
+ subtype Ratio is Size_Type range -1 .. 100;
+ Dynamic : constant Size_Type := 10;
+ -- The secondary stack ratio is a constant between 0 and 100 which
+ -- determines the percentage of the allocated task stack that is
+ -- used by the secondary stack (the rest being the primary stack).
+ -- The special value of minus one indicates that the secondary
+ -- stack is to be allocated from the heap instead.
+
+ Sec_Stack_Ratio : constant Ratio := Dynamic;
+ -- This constant defines the handling of the secondary stack
+
+ Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic;
+ -- Convenient Boolean for testing for dynamic secondary stack
+
+ function Default_Stack_Size return Size_Type;
+ -- Default task stack size used if none is specified
+
+ function Minimum_Stack_Size return Size_Type;
+ -- Minimum task stack size permitted
+
+ function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
+ -- Given the storage size stored in the TCB, return the Storage_Size
+ -- value required by the RM for the Storage_Size attribute. The
+ -- required adjustment is as follows:
+ --
+ -- when Size = Unspecified_Size, return Default_Stack_Size
+ -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
+ -- otherwise return given Size
+
+ Stack_Grows_Down : constant Boolean := True;
+ -- This constant indicates whether the stack grows up (False) or
+ -- down (True) in memory as functions are called. It is used for
+ -- proper implementation of the stack overflow check.
+
+ ----------------------------------------------
+ -- Characteristics of types in Interfaces.C --
+ ----------------------------------------------
+
+ long_bits : constant := Long_Integer'Size;
+ -- Number of bits in type long and unsigned_long. The normal convention
+ -- is that this is the same as type Long_Integer, but this is not true
+ -- of all targets. For example, in OpenVMS long /= Long_Integer.
+
+ ----------------------------------------------
+ -- Behavior of Pragma Finalize_Storage_Only --
+ ----------------------------------------------
+
+ -- Garbage_Collected is a Boolean constant whose value indicates the
+ -- effect of the pragma Finalize_Storage_Entry on a controlled type.
+
+ -- Garbage_Collected = False
+
+ -- The system releases all storage on program termination only,
+ -- but not other garbage collection occurs, so finalization calls
+ -- are ommitted only for outer level onjects can be omitted if
+ -- pragma Finalize_Storage_Only is used.
+
+ -- Garbage_Collected = True
+
+ -- The system provides full garbage collection, so it is never
+ -- necessary to release storage for controlled objects for which
+ -- a pragma Finalize_Storage_Only is used.
+
+ Garbage_Collected : constant Boolean := False;
+ -- The storage mode for this system (release on program exit)
+
+end System.Parameters;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . S T A C K _ C H E C K I N G --
+-- --
+-- B o d y --
+-- (Dummy version) --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 2000 Ada Core Technologies, 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Stack_Checking is
+
+ -----------------
+ -- Stack_Check --
+ -----------------
+
+ function Stack_Check (Stack_Address : System.Address) return Stack_Access is
+ begin
+ return null;
+ end Stack_Check;
+
+ ----------------------------
+ -- Invalidate_Stack_Cache --
+ ----------------------------
+
+ procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is
+ begin
+ null;
+ end Invalidate_Stack_Cache;
+
+ --------------------
+ -- Set_Stack_Size --
+ --------------------
+
+ -- Specify the stack size for the current frame.
+
+ procedure Set_Stack_Size
+ (Stack_Size : System.Storage_Elements.Storage_Offset) is
+ begin
+ null;
+ end Set_Stack_Size;
+
+ ------------------------
+ -- Update_Stack_Cache --
+ ------------------------
+
+ procedure Update_Stack_Cache (Stack : Stack_Access) is
+ begin
+ null;
+ end Update_Stack_Cache;
+
+end System.Stack_Checking;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.10 $
+-- --
+-- Copyright (C) 1991-2001, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- RT Linux version
+
+-- ???? Later, look at what we might want to provide for interrupt
+-- management.
+
+pragma Suppress (All_Checks);
+
+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 System.Machine_Code;
+-- used for Asm
+
+with System.OS_Interface;
+-- used for various types, constants, and operations
+
+with System.OS_Primitives;
+-- used for Delay_Modes
+
+with System.Parameters;
+-- used for Size_Type
+
+with System.Storage_Elements;
+
+with System.Tasking;
+-- used for Ada_Task_Control_Block
+-- Task_ID
+
+with Ada.Unchecked_Conversion;
+
+package body System.Task_Primitives.Operations is
+
+ use System.Machine_Code,
+ System.OS_Interface,
+ System.OS_Primitives,
+ System.Parameters,
+ System.Tasking,
+ System.Storage_Elements;
+
+ ----------------------------
+ -- RT Linux specific Data --
+ ----------------------------
+
+ -- Define two important parameters necessary for a Linux kernel module.
+ -- Any module that is going to be loaded into the kernel space needs these
+ -- parameters.
+
+ Mod_Use_Count : Integer;
+ pragma Export (C, Mod_Use_Count, "mod_use_count_");
+ -- for module usage tracking by the kernel
+
+ type Aliased_String is array (Positive range <>) of aliased Character;
+ pragma Convention (C, Aliased_String);
+
+ Kernel_Version : constant Aliased_String := "2.0.33" & ASCII.Nul;
+ pragma Export (C, Kernel_Version, "kernel_version");
+ -- So that insmod can find the version number.
+
+ -- The following procedures have their name specified by the linux module
+ -- loader. Note that they simply correspond to adainit/adafinal.
+
+ function Init_Module return Integer;
+ pragma Export (C, Init_Module, "init_module");
+
+ procedure Cleanup_Module;
+ pragma Export (C, Cleanup_Module, "cleanup_module");
+
+ ----------------
+ -- Local Data --
+ ----------------
+
+ LF : constant String := ASCII.LF & ASCII.Nul;
+
+ LFHT : constant String := ASCII.LF & ASCII.HT;
+ -- used in inserted assembly code
+
+ Max_Tasks : constant := 10;
+ -- ??? Eventually, this should probably be in System.Parameters.
+
+ Known_Tasks : array (0 .. Max_Tasks) of Task_ID;
+ -- Global array of tasks read by gdb, and updated by Create_Task and
+ -- Finalize_TCB. It's from System.Tasking.Debug. We moved it here to
+ -- cut the dependence on that package. Consider moving it here or to
+ -- this package specification, permanently????
+
+ Max_Sensible_Delay : constant RTIME :=
+ 365 * 24 * 60 * 60 * RT_TICKS_PER_SEC;
+ -- Max of one year delay, needed to prevent exceptions for large
+ -- delay values. It seems unlikely that any test will notice this
+ -- restriction.
+ -- ??? This is really declared in System.OS_Primitives,
+ -- and the type is Duration, here its type is RTIME.
+
+ Tick_Count : constant := RT_TICKS_PER_SEC / 20;
+ Nano_Count : constant := 50_000_000;
+ -- two constants used in conversions between RTIME and Duration.
+
+ Addr_Bytes : constant Storage_Offset :=
+ System.Address'Max_Size_In_Storage_Elements;
+ -- number of bytes needed for storing an address.
+
+ Guess : constant RTIME := 10;
+ -- an approximate amount of RTIME used in scheduler to awake a task having
+ -- its resume time within 'current time + Guess'
+ -- The value of 10 is estimated here and may need further refinement
+
+ TCB_Array : array (0 .. Max_Tasks)
+ of aliased Restricted_Ada_Task_Control_Block (Entry_Num => 0);
+ pragma Volatile_Components (TCB_Array);
+
+ Available_TCBs : Task_ID;
+ pragma Atomic (Available_TCBs);
+ -- Head of linear linked list of available TCB's, linked using TCB's
+ -- LL.Next. This list is Initialized to contain a fixed number of tasks,
+ -- when the runtime system starts up.
+
+ Current_Task : Task_ID;
+ pragma Export (C, Current_Task, "current_task");
+ pragma Atomic (Current_Task);
+ -- This is the task currently running. We need the pragma here to specify
+ -- the link-name for Current_Task is "current_task", rather than the long
+ -- name (including the package name) that the Ada compiler would normally
+ -- generate. "current_task" is referenced in procedure Rt_Switch_To below
+
+ Idle_Task : aliased Restricted_Ada_Task_Control_Block (Entry_Num => 0);
+ -- Tail of the circular queue of ready to run tasks.
+
+ Scheduler_Idle : Boolean := False;
+ -- True when the scheduler is idle (no task other than the idle task
+ -- is on the ready queue).
+
+ In_Elab_Code : Boolean := True;
+ -- True when we are elaborating our application.
+ -- Init_Module will set this flag to false and never revert it.
+
+ Timer_Queue : aliased Restricted_Ada_Task_Control_Block (Entry_Num => 0);
+ -- Header of the queue of delayed real-time tasks.
+ -- Timer_Queue.LL has to be initialized properly before being used
+
+ Timer_Expired : Boolean := False;
+ -- flag to show whether the Timer_Queue needs to be checked
+ -- when it becomes true, it means there is a task in the
+ -- Timer_Queue having to be awakened and be moved to ready queue
+
+ Environment_Task_ID : Task_ID;
+ -- A variable to hold Task_ID for the environment task.
+ -- Once initialized, this behaves as a constant.
+ -- In the current implementation, this is the task assigned permanently
+ -- as the regular Linux kernel.
+
+ All_Tasks_L : aliased RTS_Lock;
+ -- See comments on locking rules in System.Tasking (spec).
+
+ -- The followings are internal configuration constants needed.
+ Next_Serial_Number : Task_Serial_Number := 100;
+ pragma Volatile (Next_Serial_Number);
+ -- We start at 100, to reserve some special values for
+ -- using in error checking.
+
+ Linux_Irq_State : Integer := 0;
+
+ type Duration_As_Integer is delta 1.0
+ range -2.0**(Duration'Size - 1) .. 2.0**(Duration'Size - 1) - 1.0;
+ -- used for output RTIME value during debugging
+
+ type Address_Ptr is access all System.Address;
+ pragma Convention (C, Address_Ptr);
+
+ --------------------------------
+ -- Local conversion functions --
+ --------------------------------
+
+ function To_Task_ID is new
+ Ada.Unchecked_Conversion (System.Address, Task_ID);
+
+ function To_Address is new
+ Ada.Unchecked_Conversion (Task_ID, System.Address);
+
+ function RTIME_To_D_Int is new
+ Ada.Unchecked_Conversion (RTIME, Duration_As_Integer);
+
+ function Raw_RTIME is new
+ Ada.Unchecked_Conversion (Duration, RTIME);
+
+ function Raw_Duration is new
+ Ada.Unchecked_Conversion (RTIME, Duration);
+
+ function To_Duration (T : RTIME) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_RTIME (D : Duration) return RTIME;
+ pragma Inline (To_RTIME);
+
+ function To_Integer is new
+ Ada.Unchecked_Conversion (System.Parameters.Size_Type, Integer);
+
+ function To_Address_Ptr is
+ new Ada.Unchecked_Conversion (System.Address, Address_Ptr);
+
+ function To_RTS_Lock_Ptr is new
+ Ada.Unchecked_Conversion (Lock_Ptr, RTS_Lock_Ptr);
+
+ -----------------------------------
+ -- Local Subprogram Declarations --
+ -----------------------------------
+
+ procedure Rt_Switch_To (Tsk : Task_ID);
+ pragma Inline (Rt_Switch_To);
+ -- switch from the 'current_task' to 'Tsk'
+ -- and 'Tsk' then becomes 'current_task'
+
+ procedure R_Save_Flags (F : out Integer);
+ pragma Inline (R_Save_Flags);
+ -- save EFLAGS register to 'F'
+
+ procedure R_Restore_Flags (F : Integer);
+ pragma Inline (R_Restore_Flags);
+ -- restore EFLAGS register from 'F'
+
+ procedure R_Cli;
+ pragma Inline (R_Cli);
+ -- disable interrupts
+
+ procedure R_Sti;
+ pragma Inline (R_Sti);
+ -- enable interrupts
+
+ procedure Timer_Wrapper;
+ -- the timer handler. It sets Timer_Expired flag to True and
+ -- then calls Rt_Schedule
+
+ procedure Rt_Schedule;
+ -- the scheduler
+
+ procedure Insert_R (T : Task_ID);
+ pragma Inline (Insert_R);
+ -- insert 'T' into the tail of the ready queue for its active
+ -- priority
+ -- if original queue is 6 5 4 4 3 2 and T has priority of 4
+ -- then after T is inserted the queue becomes 6 5 4 4 T 3 2
+
+ procedure Insert_RF (T : Task_ID);
+ pragma Inline (Insert_RF);
+ -- insert 'T' into the front of the ready queue for its active
+ -- priority
+ -- if original queue is 6 5 4 4 3 2 and T has priority of 4
+ -- then after T is inserted the queue becomes 6 5 T 4 4 3 2
+
+ procedure Delete_R (T : Task_ID);
+ pragma Inline (Delete_R);
+ -- delete 'T' from the ready queue. If 'T' is not in any queue
+ -- the operation has no effect
+
+ procedure Insert_T (T : Task_ID);
+ pragma Inline (Insert_T);
+ -- insert 'T' into the waiting queue according to its Resume_Time.
+ -- If there are tasks in the waiting queue that have the same
+ -- Resume_Time as 'T', 'T' is then inserted into the queue for
+ -- its active priority
+
+ procedure Delete_T (T : Task_ID);
+ pragma Inline (Delete_T);
+ -- delete 'T' from the waiting queue.
+
+ procedure Move_Top_Task_From_Timer_Queue_To_Ready_Queue;
+ pragma Inline (Move_Top_Task_From_Timer_Queue_To_Ready_Queue);
+ -- remove the task in the front of the waiting queue and insert it
+ -- into the tail of the ready queue for its active priority
+
+ -------------------------
+ -- Local Subprograms --
+ -------------------------
+
+ procedure Rt_Switch_To (Tsk : Task_ID) is
+ begin
+ pragma Debug (Printk ("procedure Rt_Switch_To called" & LF));
+
+ Asm (
+ "pushl %%eax" & LFHT &
+ "pushl %%ebp" & LFHT &
+ "pushl %%edi" & LFHT &
+ "pushl %%esi" & LFHT &
+ "pushl %%edx" & LFHT &
+ "pushl %%ecx" & LFHT &
+ "pushl %%ebx" & LFHT &
+
+ "movl current_task, %%edx" & LFHT &
+ "cmpl $0, 36(%%edx)" & LFHT &
+ -- 36 is hard-coded, 36(%%edx) is actually
+ -- Current_Task.Common.LL.Uses_Fp
+
+ "jz 25f" & LFHT &
+ "sub $108,%%esp" & LFHT &
+ "fsave (%%esp)" & LFHT &
+ "25: pushl $1f" & LFHT &
+ "movl %%esp, 32(%%edx)" & LFHT &
+ -- 32 is hard-coded, 32(%%edx) is actually
+ -- Current_Task.Common.LL.Stack
+
+ "movl 32(%%ecx), %%esp" & LFHT &
+ -- 32 is hard-coded, 32(%%ecx) is actually Tsk.Common.LL.Stack.
+ -- Tsk is the task to be switched to
+
+ "movl %%ecx, current_task" & LFHT &
+ "ret" & LFHT &
+ "1: cmpl $0, 36(%%ecx)" & LFHT &
+ -- 36(%%exc) is Tsk.Common.LL.Stack (hard coded)
+ "jz 26f" & LFHT &
+ "frstor (%%esp)" & LFHT &
+ "add $108,%%esp" & LFHT &
+ "26: popl %%ebx" & LFHT &
+ "popl %%ecx" & LFHT &
+ "popl %%edx" & LFHT &
+ "popl %%esi" & LFHT &
+ "popl %%edi" & LFHT &
+ "popl %%ebp" & LFHT &
+ "popl %%eax",
+ Outputs => No_Output_Operands,
+ Inputs => Task_ID'Asm_Input ("c", Tsk),
+ Clobber => "cx",
+ Volatile => True);
+ end Rt_Switch_To;
+
+ procedure R_Save_Flags (F : out Integer) is
+ begin
+ Asm (
+ "pushfl" & LFHT &
+ "popl %0",
+ Outputs => Integer'Asm_Output ("=g", F),
+ Inputs => No_Input_Operands,
+ Clobber => "memory",
+ Volatile => True);
+ end R_Save_Flags;
+
+ procedure R_Restore_Flags (F : Integer) is
+ begin
+ Asm (
+ "pushl %0" & LFHT &
+ "popfl",
+ Outputs => No_Output_Operands,
+ Inputs => Integer'Asm_Input ("g", F),
+ Clobber => "memory",
+ Volatile => True);
+ end R_Restore_Flags;
+
+ procedure R_Sti is
+ begin
+ Asm (
+ "sti",
+ Outputs => No_Output_Operands,
+ Inputs => No_Input_Operands,
+ Clobber => "memory",
+ Volatile => True);
+ end R_Sti;
+
+ procedure R_Cli is
+ begin
+ Asm (
+ "cli",
+ Outputs => No_Output_Operands,
+ Inputs => No_Input_Operands,
+ Clobber => "memory",
+ Volatile => True);
+ end R_Cli;
+
+ -- A wrapper for Rt_Schedule, works as the timer handler
+
+ procedure Timer_Wrapper is
+ begin
+ pragma Debug (Printk ("procedure Timer_Wrapper called" & LF));
+
+ Timer_Expired := True;
+ Rt_Schedule;
+ end Timer_Wrapper;
+
+ procedure Rt_Schedule is
+ Now : RTIME;
+ Top_Task : Task_ID;
+ Flags : Integer;
+
+ procedure Debug_Timer_Queue;
+ -- Check the state of the Timer Queue.
+
+ procedure Debug_Timer_Queue is
+ begin
+ if Timer_Queue.Common.LL.Succ /= Timer_Queue'Address then
+ Printk ("Timer_Queue not empty" & LF);
+ end if;
+
+ if To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time <
+ Now + Guess
+ then
+ Printk ("and need to move top task to ready queue" & LF);
+ end if;
+ end Debug_Timer_Queue;
+
+ begin
+ pragma Debug (Printk ("procedure Rt_Schedule called" & LF));
+
+ -- Scheduler_Idle means that this call comes from an interrupt
+ -- handler (e.g timer) that interrupted the idle loop below.
+
+ if Scheduler_Idle then
+ return;
+ end if;
+
+ <<Idle>>
+ R_Save_Flags (Flags);
+ R_Cli;
+
+ Scheduler_Idle := False;
+
+ if Timer_Expired then
+ pragma Debug (Printk ("Timer expired" & LF));
+ Timer_Expired := False;
+
+ -- Check for expired time delays.
+ Now := Rt_Get_Time;
+
+ -- Need another (circular) queue for delayed tasks, this one ordered
+ -- by wakeup time, so the one at the front has the earliest resume
+ -- time. Wake up all the tasks sleeping on time delays that should
+ -- be awakened at this time.
+
+ -- ??? This is not very good, since we may waste time here waking
+ -- up a bunch of lower priority tasks, adding to the blocking time
+ -- of higher priority ready tasks, but we don't see how to get
+ -- around this without adding more wasted time elsewhere.
+
+ pragma Debug (Debug_Timer_Queue);
+
+ while Timer_Queue.Common.LL.Succ /= Timer_Queue'Address and then
+ To_Task_ID
+ (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time < Now + Guess
+ loop
+ To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.State :=
+ RT_TASK_READY;
+ Move_Top_Task_From_Timer_Queue_To_Ready_Queue;
+ end loop;
+
+ -- Arm the timer if necessary.
+ -- ??? This may be wasteful, if the tasks on the timer queue are
+ -- of lower priority than the current task's priority. The problem
+ -- is that we can't tell this without scanning the whole timer
+ -- queue. This scanning takes extra time.
+
+ if Timer_Queue.Common.LL.Succ /= Timer_Queue'Address then
+ -- Timer_Queue is not empty, so set the timer to interrupt at
+ -- the next resume time. The Wakeup procedure must also do this,
+ -- and must do it while interrupts are disabled so that there is
+ -- no danger of interleaving with this code.
+ Rt_Set_Timer
+ (To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time);
+ else
+ Rt_No_Timer;
+ end if;
+ end if;
+
+ Top_Task := To_Task_ID (Idle_Task.Common.LL.Succ);
+
+ -- If the ready queue is empty, the kernel has to wait until the timer
+ -- or another interrupt makes a task ready.
+
+ if Top_Task = To_Task_ID (Idle_Task'Address) then
+ Scheduler_Idle := True;
+ R_Restore_Flags (Flags);
+ pragma Debug (Printk ("!!!kernel idle!!!" & LF));
+ goto Idle;
+ end if;
+
+ if Top_Task = Current_Task then
+ pragma Debug (Printk ("Rt_Schedule: Top_Task = Current_Task" & LF));
+ -- if current task continues, just return.
+
+ R_Restore_Flags (Flags);
+ return;
+ end if;
+
+ if Top_Task = Environment_Task_ID then
+ pragma Debug (Printk
+ ("Rt_Schedule: Top_Task = Environment_Task" & LF));
+ -- If there are no RT tasks ready, we execute the regular
+ -- Linux kernel, and allow the regular Linux interrupt
+ -- handlers to preempt the current task again.
+
+ if not In_Elab_Code then
+ SFIF := Linux_Irq_State;
+ end if;
+
+ elsif Current_Task = Environment_Task_ID then
+ pragma Debug (Printk
+ ("Rt_Schedule: Current_Task = Environment_Task" & LF));
+ -- We are going to preempt the regular Linux kernel to
+ -- execute an RT task, so don't allow the regular Linux
+ -- interrupt handlers to preempt the current task any more.
+
+ Linux_Irq_State := SFIF;
+ SFIF := 0;
+ end if;
+
+ Top_Task.Common.LL.State := RT_TASK_READY;
+ Rt_Switch_To (Top_Task);
+ R_Restore_Flags (Flags);
+ end Rt_Schedule;
+
+ procedure Insert_R (T : Task_ID) is
+ Q : Task_ID := To_Task_ID (Idle_Task.Common.LL.Succ);
+ begin
+ pragma Debug (Printk ("procedure Insert_R called" & LF));
+
+ pragma Assert (T.Common.LL.Succ = To_Address (T));
+ pragma Assert (T.Common.LL.Pred = To_Address (T));
+
+ -- T is inserted in the queue between a task that has higher
+ -- or the same Active_Priority as T and a task that has lower
+ -- Active_Priority than T
+
+ while Q /= To_Task_ID (Idle_Task'Address)
+ and then T.Common.LL.Active_Priority <= Q.Common.LL.Active_Priority
+ loop
+ Q := To_Task_ID (Q.Common.LL.Succ);
+ end loop;
+
+ -- Q is successor of T
+
+ T.Common.LL.Succ := To_Address (Q);
+ T.Common.LL.Pred := Q.Common.LL.Pred;
+ To_Task_ID (T.Common.LL.Pred).Common.LL.Succ := To_Address (T);
+ Q.Common.LL.Pred := To_Address (T);
+ end Insert_R;
+
+ procedure Insert_RF (T : Task_ID) is
+ Q : Task_ID := To_Task_ID (Idle_Task.Common.LL.Succ);
+ begin
+ pragma Debug (Printk ("procedure Insert_RF called" & LF));
+
+ pragma Assert (T.Common.LL.Succ = To_Address (T));
+ pragma Assert (T.Common.LL.Pred = To_Address (T));
+
+ -- T is inserted in the queue between a task that has higher
+ -- Active_Priority as T and a task that has lower or the same
+ -- Active_Priority as T
+
+ while Q /= To_Task_ID (Idle_Task'Address) and then
+ T.Common.LL.Active_Priority < Q.Common.LL.Active_Priority
+ loop
+ Q := To_Task_ID (Q.Common.LL.Succ);
+ end loop;
+
+ -- Q is successor of T
+
+ T.Common.LL.Succ := To_Address (Q);
+ T.Common.LL.Pred := Q.Common.LL.Pred;
+ To_Task_ID (T.Common.LL.Pred).Common.LL.Succ := To_Address (T);
+ Q.Common.LL.Pred := To_Address (T);
+ end Insert_RF;
+
+ procedure Delete_R (T : Task_ID) is
+ Tpred : constant Task_ID := To_Task_ID (T.Common.LL.Pred);
+ Tsucc : constant Task_ID := To_Task_ID (T.Common.LL.Succ);
+
+ begin
+ pragma Debug (Printk ("procedure Delete_R called" & LF));
+
+ -- checking whether T is in the queue is not necessary because
+ -- if T is not in the queue, following statements changes
+ -- nothing. But T cannot be in the Timer_Queue, otherwise
+ -- activate the check below, note that checking whether T is
+ -- in a queue is a relatively expensive operation
+
+ Tpred.Common.LL.Succ := To_Address (Tsucc);
+ Tsucc.Common.LL.Pred := To_Address (Tpred);
+ T.Common.LL.Succ := To_Address (T);
+ T.Common.LL.Pred := To_Address (T);
+ end Delete_R;
+
+ procedure Insert_T (T : Task_ID) is
+ Q : Task_ID := To_Task_ID (Timer_Queue.Common.LL.Succ);
+ begin
+ pragma Debug (Printk ("procedure Insert_T called" & LF));
+
+ pragma Assert (T.Common.LL.Succ = To_Address (T));
+
+ while Q /= To_Task_ID (Timer_Queue'Address) and then
+ T.Common.LL.Resume_Time > Q.Common.LL.Resume_Time
+ loop
+ Q := To_Task_ID (Q.Common.LL.Succ);
+ end loop;
+
+ -- Q is the task that has Resume_Time equal to or greater than that
+ -- of T. If they have the same Resume_Time, continue looking for the
+ -- location T is to be inserted using its Active_Priority
+
+ while Q /= To_Task_ID (Timer_Queue'Address) and then
+ T.Common.LL.Resume_Time = Q.Common.LL.Resume_Time
+ loop
+ exit when T.Common.LL.Active_Priority > Q.Common.LL.Active_Priority;
+ Q := To_Task_ID (Q.Common.LL.Succ);
+ end loop;
+
+ -- Q is successor of T
+
+ T.Common.LL.Succ := To_Address (Q);
+ T.Common.LL.Pred := Q.Common.LL.Pred;
+ To_Task_ID (T.Common.LL.Pred).Common.LL.Succ := To_Address (T);
+ Q.Common.LL.Pred := To_Address (T);
+ end Insert_T;
+
+ procedure Delete_T (T : Task_ID) is
+ Tpred : constant Task_ID := To_Task_ID (T.Common.LL.Pred);
+ Tsucc : constant Task_ID := To_Task_ID (T.Common.LL.Succ);
+
+ begin
+ pragma Debug (Printk ("procedure Delete_T called" & LF));
+
+ pragma Assert (T /= To_Task_ID (Timer_Queue'Address));
+
+ Tpred.Common.LL.Succ := To_Address (Tsucc);
+ Tsucc.Common.LL.Pred := To_Address (Tpred);
+ T.Common.LL.Succ := To_Address (T);
+ T.Common.LL.Pred := To_Address (T);
+ end Delete_T;
+
+ procedure Move_Top_Task_From_Timer_Queue_To_Ready_Queue is
+ Top_Task : Task_ID := To_Task_ID (Timer_Queue.Common.LL.Succ);
+ begin
+ pragma Debug (Printk ("procedure Move_Top_Task called" & LF));
+
+ if Top_Task /= To_Task_ID (Timer_Queue'Address) then
+ Delete_T (Top_Task);
+ Top_Task.Common.LL.State := RT_TASK_READY;
+ Insert_R (Top_Task);
+ end if;
+ end Move_Top_Task_From_Timer_Queue_To_Ready_Queue;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_ID is
+ begin
+ pragma Debug (Printk ("function Self called" & LF));
+
+ return Current_Task;
+ end Self;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is
+ begin
+ pragma Debug (Printk ("procedure Initialize_Lock called" & LF));
+
+ L.Ceiling_Priority := Prio;
+ L.Owner := System.Null_Address;
+ end Initialize_Lock;
+
+ procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
+ begin
+ pragma Debug (Printk ("procedure Initialize_Lock (RTS) called" & LF));
+
+ L.Ceiling_Priority := System.Any_Priority'Last;
+ L.Owner := System.Null_Address;
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : access Lock) is
+ begin
+ pragma Debug (Printk ("procedure Finalize_Lock called" & LF));
+ null;
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : access RTS_Lock) is
+ begin
+ pragma Debug (Printk ("procedure Finalize_Lock (RTS) called" & LF));
+ null;
+ end Finalize_Lock;
+
+ ----------------
+ -- Write_Lock --
+ ----------------
+
+ procedure Write_Lock
+ (L : access Lock;
+ Ceiling_Violation : out Boolean)
+ is
+ Prio : constant System.Any_Priority :=
+ Current_Task.Common.LL.Active_Priority;
+ begin
+ pragma Debug (Printk ("procedure Write_Lock called" & LF));
+
+ Ceiling_Violation := False;
+
+ if Prio > L.Ceiling_Priority then
+ -- Ceiling violation.
+ -- This should never happen, unless something is seriously
+ -- wrong with task T or the entire run-time system.
+ -- ???? extreme error recovery, e.g. shut down the system or task
+
+ Ceiling_Violation := True;
+ pragma Debug (Printk ("Ceiling Violation in Write_Lock" & LF));
+ return;
+ end if;
+
+ L.Pre_Locking_Priority := Prio;
+ L.Owner := To_Address (Current_Task);
+ Current_Task.Common.LL.Active_Priority := L.Ceiling_Priority;
+
+ if Current_Task.Common.LL.Outer_Lock = null then
+ -- If this lock is not nested, record a pointer to it.
+
+ Current_Task.Common.LL.Outer_Lock :=
+ To_RTS_Lock_Ptr (L.all'Unchecked_Access);
+ end if;
+ end Write_Lock;
+
+ procedure Write_Lock (L : access RTS_Lock) is
+ Prio : constant System.Any_Priority :=
+ Current_Task.Common.LL.Active_Priority;
+
+ begin
+ pragma Debug (Printk ("procedure Write_Lock (RTS) called" & LF));
+
+ if Prio > L.Ceiling_Priority then
+ -- Ceiling violation.
+ -- This should never happen, unless something is seriously
+ -- wrong with task T or the entire runtime system.
+ -- ???? extreme error recovery, e.g. shut down the system or task
+
+ Printk ("Ceiling Violation in Write_Lock (RTS)" & LF);
+ return;
+ end if;
+
+ L.Pre_Locking_Priority := Prio;
+ L.Owner := To_Address (Current_Task);
+ Current_Task.Common.LL.Active_Priority := L.Ceiling_Priority;
+
+ if Current_Task.Common.LL.Outer_Lock = null then
+ Current_Task.Common.LL.Outer_Lock := L.all'Unchecked_Access;
+ end if;
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_ID) is
+ Prio : constant System.Any_Priority :=
+ Current_Task.Common.LL.Active_Priority;
+
+ begin
+ pragma Debug (Printk ("procedure Write_Lock (Task_ID) called" & LF));
+
+ if Prio > T.Common.LL.L.Ceiling_Priority then
+ -- Ceiling violation.
+ -- This should never happen, unless something is seriously
+ -- wrong with task T or the entire runtime system.
+ -- ???? extreme error recovery, e.g. shut down the system or task
+
+ Printk ("Ceiling Violation in Write_Lock (Task)" & LF);
+ return;
+ end if;
+
+ T.Common.LL.L.Pre_Locking_Priority := Prio;
+ T.Common.LL.L.Owner := To_Address (Current_Task);
+ Current_Task.Common.LL.Active_Priority := T.Common.LL.L.Ceiling_Priority;
+
+ if Current_Task.Common.LL.Outer_Lock = null then
+ Current_Task.Common.LL.Outer_Lock := T.Common.LL.L'Access;
+ end if;
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ pragma Debug (Printk ("procedure Read_Lock called" & LF));
+ Write_Lock (L, Ceiling_Violation);
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : access Lock) is
+ Flags : Integer;
+ begin
+ pragma Debug (Printk ("procedure Unlock called" & LF));
+
+ if L.Owner /= To_Address (Current_Task) then
+ -- ...error recovery
+
+ null;
+ Printk ("The caller is not the owner of the lock" & LF);
+ return;
+ end if;
+
+ L.Owner := System.Null_Address;
+
+ -- Now that the lock is released, lower own priority,
+
+ if Current_Task.Common.LL.Outer_Lock =
+ To_RTS_Lock_Ptr (L.all'Unchecked_Access)
+ then
+ -- This lock is the outer-most one, reset own priority to
+ -- Current_Priority;
+
+ Current_Task.Common.LL.Active_Priority :=
+ Current_Task.Common.Current_Priority;
+ Current_Task.Common.LL.Outer_Lock := null;
+
+ else
+ -- If this lock is nested, pop the old active priority.
+
+ Current_Task.Common.LL.Active_Priority := L.Pre_Locking_Priority;
+ end if;
+
+ -- Reschedule the task if necessary. Note we only need to reschedule
+ -- the task if its Active_Priority becomes less than the one following
+ -- it. The check depends on the fact that Environment_Task (tail of
+ -- the ready queue) has the lowest Active_Priority
+
+ if Current_Task.Common.LL.Active_Priority
+ < To_Task_ID (Current_Task.Common.LL.Succ).Common.LL.Active_Priority
+ then
+ R_Save_Flags (Flags);
+ R_Cli;
+ Delete_R (Current_Task);
+ Insert_RF (Current_Task);
+ R_Restore_Flags (Flags);
+ Rt_Schedule;
+ end if;
+ end Unlock;
+
+ procedure Unlock (L : access RTS_Lock) is
+ Flags : Integer;
+ begin
+ pragma Debug (Printk ("procedure Unlock (RTS_Lock) called" & LF));
+
+ if L.Owner /= To_Address (Current_Task) then
+ null;
+ Printk ("The caller is not the owner of the lock" & LF);
+ return;
+ end if;
+
+ L.Owner := System.Null_Address;
+
+ if Current_Task.Common.LL.Outer_Lock = L.all'Unchecked_Access then
+ Current_Task.Common.LL.Active_Priority :=
+ Current_Task.Common.Current_Priority;
+ Current_Task.Common.LL.Outer_Lock := null;
+
+ else
+ Current_Task.Common.LL.Active_Priority := L.Pre_Locking_Priority;
+ end if;
+
+ -- Reschedule the task if necessary
+
+ if Current_Task.Common.LL.Active_Priority
+ < To_Task_ID (Current_Task.Common.LL.Succ).Common.LL.Active_Priority
+ then
+ R_Save_Flags (Flags);
+ R_Cli;
+ Delete_R (Current_Task);
+ Insert_RF (Current_Task);
+ R_Restore_Flags (Flags);
+ Rt_Schedule;
+ end if;
+ end Unlock;
+
+ procedure Unlock (T : Task_ID) is
+ begin
+ pragma Debug (Printk ("procedure Unlock (Task_ID) called" & LF));
+ Unlock (T.Common.LL.L'Access);
+ end Unlock;
+
+ -----------
+ -- Sleep --
+ -----------
+
+ -- Unlock Self_ID.Common.LL.L and suspend Self_ID, atomically.
+ -- Before return, lock Self_ID.Common.LL.L again
+ -- Self_ID can only be reactivated by calling Wakeup.
+ -- Unlock code is repeated intentionally.
+
+ procedure Sleep
+ (Self_ID : Task_ID;
+ Reason : ST.Task_States)
+ is
+ Flags : Integer;
+ begin
+ pragma Debug (Printk ("procedure Sleep called" & LF));
+
+ -- Note that Self_ID is actually Current_Task, that is, only the
+ -- task that is running can put itself into sleep. To preserve
+ -- consistency, we use Self_ID throughout the code here
+
+ Self_ID.Common.State := Reason;
+ Self_ID.Common.LL.State := RT_TASK_DORMANT;
+
+ R_Save_Flags (Flags);
+ R_Cli;
+
+ Delete_R (Self_ID);
+
+ -- Arrange to unlock Self_ID's ATCB lock. The following check
+ -- may be unnecessary because the specification of Sleep says
+ -- the caller shoud hold its own ATCB lock before calling Sleep
+
+ if Self_ID.Common.LL.L.Owner = To_Address (Self_ID) then
+ Self_ID.Common.LL.L.Owner := System.Null_Address;
+
+ if Self_ID.Common.LL.Outer_Lock = Self_ID.Common.LL.L'Access then
+ Self_ID.Common.LL.Active_Priority :=
+ Self_ID.Common.Current_Priority;
+ Self_ID.Common.LL.Outer_Lock := null;
+
+ else
+ Self_ID.Common.LL.Active_Priority :=
+ Self_ID.Common.LL.L.Pre_Locking_Priority;
+ end if;
+ end if;
+
+ R_Restore_Flags (Flags);
+ Rt_Schedule;
+
+ -- Before leave, regain the lock
+
+ Write_Lock (Self_ID);
+ end Sleep;
+
+ -----------------
+ -- Timed_Sleep --
+ -----------------
+
+ -- Arrange to be awakened after/at Time (depending on Mode) then Unlock
+ -- Self_ID.Common.LL.L and suspend self. If the timeout expires first,
+ -- that should awaken the task. If it's awakened (by some other task
+ -- calling Wakeup) before the timeout expires, the timeout should be
+ -- cancelled.
+
+ -- 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
+ Flags : Integer;
+ Abs_Time : RTIME;
+
+ begin
+ pragma Debug (Printk ("procedure Timed_Sleep called" & LF));
+
+ Timedout := True;
+ Yielded := False;
+ -- ??? These two boolean seems not relevant here
+
+ if Mode = Relative then
+ Abs_Time := To_RTIME (Time) + Rt_Get_Time;
+ else
+ Abs_Time := To_RTIME (Time);
+ end if;
+
+ Self_ID.Common.LL.Resume_Time := Abs_Time;
+ Self_ID.Common.LL.State := RT_TASK_DELAYED;
+
+ R_Save_Flags (Flags);
+ R_Cli;
+ Delete_R (Self_ID);
+ Insert_T (Self_ID);
+
+ -- Check if the timer needs to be set
+
+ if Timer_Queue.Common.LL.Succ = To_Address (Self_ID) then
+ Rt_Set_Timer (Abs_Time);
+ end if;
+
+ -- Another way to do it
+ --
+ -- if Abs_Time <
+ -- To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time
+ -- then
+ -- Rt_Set_Timer (Abs_Time);
+ -- end if;
+
+ -- Arrange to unlock Self_ID's ATCB lock. see comments in Sleep
+
+ if Self_ID.Common.LL.L.Owner = To_Address (Self_ID) then
+ Self_ID.Common.LL.L.Owner := System.Null_Address;
+
+ if Self_ID.Common.LL.Outer_Lock = Self_ID.Common.LL.L'Access then
+ Self_ID.Common.LL.Active_Priority :=
+ Self_ID.Common.Current_Priority;
+ Self_ID.Common.LL.Outer_Lock := null;
+
+ else
+ Self_ID.Common.LL.Active_Priority :=
+ Self_ID.Common.LL.L.Pre_Locking_Priority;
+ end if;
+ end if;
+
+ R_Restore_Flags (Flags);
+ Rt_Schedule;
+
+ -- Before leaving, regain the lock
+
+ Write_Lock (Self_ID);
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ -- This is for use in implementing delay statements, so we assume
+ -- the caller is not abort-deferred and is holding no locks.
+ -- Self_ID can only be awakened after the timeout, no Wakeup on it.
+
+ procedure Timed_Delay
+ (Self_ID : Task_ID;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ Flags : Integer;
+ Abs_Time : RTIME;
+
+ begin
+ pragma Debug (Printk ("procedure Timed_Delay called" & LF));
+
+ -- Only the little window between deferring abort and
+ -- locking Self_ID is the reason we need to
+ -- check for pending abort and priority change below! :(
+
+ Write_Lock (Self_ID);
+
+ -- Take the lock in case its ATCB needs to be modified
+
+ if Mode = Relative then
+ Abs_Time := To_RTIME (Time) + Rt_Get_Time;
+ else
+ Abs_Time := To_RTIME (Time);
+ end if;
+
+ Self_ID.Common.LL.Resume_Time := Abs_Time;
+ Self_ID.Common.LL.State := RT_TASK_DELAYED;
+
+ R_Save_Flags (Flags);
+ R_Cli;
+ Delete_R (Self_ID);
+ Insert_T (Self_ID);
+
+ -- Check if the timer needs to be set
+
+ if Timer_Queue.Common.LL.Succ = To_Address (Self_ID) then
+ Rt_Set_Timer (Abs_Time);
+ end if;
+
+ -- Arrange to unlock Self_ID's ATCB lock.
+ -- Note that the code below is slightly different from Unlock, so
+ -- it is more than inline it.
+
+ if To_Task_ID (Self_ID.Common.LL.L.Owner) = Self_ID then
+ Self_ID.Common.LL.L.Owner := System.Null_Address;
+
+ if Self_ID.Common.LL.Outer_Lock = Self_ID.Common.LL.L'Access then
+ Self_ID.Common.LL.Active_Priority :=
+ Self_ID.Common.Current_Priority;
+ Self_ID.Common.LL.Outer_Lock := null;
+
+ else
+ Self_ID.Common.LL.Active_Priority :=
+ Self_ID.Common.LL.L.Pre_Locking_Priority;
+ end if;
+ end if;
+
+ R_Restore_Flags (Flags);
+ Rt_Schedule;
+ end Timed_Delay;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ -- RTIME is represented as a 64-bit signed count of ticks,
+ -- where there are 1_193_180 ticks per second.
+
+ -- Let T be a count of ticks and N the corresponding count of nanoseconds.
+ -- From the following relationship
+ -- T / (ticks_per_second) = N / (ns_per_second)
+ -- where ns_per_second is 1_000_000_000 (number of nanoseconds in
+ -- a second), we get
+ -- T * (ns_per_second) = N * (ticks_per_second)
+ -- or
+ -- T * 1_000_000_000 = N * 1_193_180
+ -- which can be reduced to
+ -- T * 50_000_000 = N * 59_659
+ -- Let Nano_Count = 50_000_000 and Tick_Count = 59_659, we then have
+ -- T * Nano_Count = N * Tick_Count
+
+ -- IMPORTANT FACT:
+ -- These numbers are small enough that we can do arithmetic
+ -- on them without overflowing 64 bits. To see this, observe
+
+ -- 10**3 = 1000 < 1024 = 2**10
+ -- Tick_Count < 60 * 1000 < 64 * 1024 < 2**16
+ -- Nano_Count < 50 * 1000 * 1000 < 64 * 1024 * 1024 < 2**26
+
+ -- It follows that if 0 <= R < Tick_Count, we can compute
+ -- R * Nano_Count < 2**42 without overflow in 64 bits.
+ -- Similarly, if 0 <= R < Nano_Count, we can compute
+ -- R * Tick_Count < 2**42 without overflow in 64 bits.
+
+ -- GNAT represents Duration as a count of nanoseconds internally.
+
+ -- To convert T from RTIME to Duration, let
+ -- Q = T / Tick_Count, with truncation
+ -- R = T - Q * Tick_Count, the remainder 0 <= R < Tick_Count
+ -- so
+ -- N * Tick_Count
+ -- = T * Nano_Count - Q * Tick_Count * Nano_Count
+ -- + Q * Tick_Count * Nano_Count
+ -- = (T - Q * Tick_Count) * Nano_Count
+ -- + (Q * Nano_Count) * Tick_Count
+ -- = R * Nano_Count + (Q * Nano_Count) * Tick_Count
+
+ -- Now, let
+ -- Q1 = R * Nano_Count / Tick_Count, with truncation
+ -- R1 = R * Nano_Count - Q1 * Tick_Count, 0 <= R1 <Tick_Count
+ -- R * Nano_Count = Q1 * Tick_Count + R1
+ -- so
+ -- N * Tick_Count
+ -- = R * Nano_Count + (Q * Nano_Count) * Tick_Count
+ -- = Q1 * Tick_Count + R1 + (Q * Nano_Count) * Tick_Count
+ -- = R1 + (Q * Nano_Count + Q1) * Tick_Count
+ -- and
+ -- N = Q * Nano_Count + Q1 + R1 /Tick_Count,
+ -- where 0 <= R1 /Tick_Count < 1
+
+ function To_Duration (T : RTIME) return Duration is
+ Q, Q1, RN : RTIME;
+ begin
+ Q := T / Tick_Count;
+ RN := (T - Q * Tick_Count) * Nano_Count;
+ Q1 := RN / Tick_Count;
+ return Raw_Duration (Q * Nano_Count + Q1);
+ end To_Duration;
+
+ -- To convert D from Duration to RTIME,
+ -- Let D be a Duration value, and N be the representation of D as an
+ -- integer count of nanoseconds. Let
+ -- Q = N / Nano_Count, with truncation
+ -- R = N - Q * Nano_Count, the remainder 0 <= R < Nano_Count
+ -- so
+ -- T * Nano_Count
+ -- = N * Tick_Count - Q * Nano_Count * Tick_Count
+ -- + Q * Nano_Count * Tick_Count
+ -- = (N - Q * Nano_Count) * Tick_Count
+ -- + (Q * Tick_Count) * Nano_Count
+ -- = R * Tick_Count + (Q * Tick_Count) * Nano_Count
+ -- Now, let
+ -- Q1 = R * Tick_Count / Nano_Count, with truncation
+ -- R1 = R * Tick_Count - Q1 * Nano_Count, 0 <= R1 < Nano_Count
+ -- R * Tick_Count = Q1 * Nano_Count + R1
+ -- so
+ -- T * Nano_Count
+ -- = R * Tick_Count + (Q * Tick_Count) * Nano_Count
+ -- = Q1 * Nano_Count + R1 + (Q * Tick_Count) * Nano_Count
+ -- = (Q * Tick_Count + Q1) * Nano_Count + R1
+ -- and
+ -- T = Q * Tick_Count + Q1 + R1 / Nano_Count,
+ -- where 0 <= R1 / Nano_Count < 1
+
+ function To_RTIME (D : Duration) return RTIME is
+ N : RTIME := Raw_RTIME (D);
+ Q, Q1, RT : RTIME;
+
+ begin
+ Q := N / Nano_Count;
+ RT := (N - Q * Nano_Count) * Tick_Count;
+ Q1 := RT / Nano_Count;
+ return Q * Tick_Count + Q1;
+ end To_RTIME;
+
+ function Monotonic_Clock return Duration is
+ begin
+ pragma Debug (Printk ("procedure Clock called" & LF));
+
+ return To_Duration (Rt_Get_Time);
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ begin
+ return 10#1.0#E-6;
+ end RT_Resolution;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_ID; Reason : ST.Task_States) is
+ Flags : Integer;
+ begin
+ pragma Debug (Printk ("procedure Wakeup called" & LF));
+
+ T.Common.State := Reason;
+ T.Common.LL.State := RT_TASK_READY;
+
+ R_Save_Flags (Flags);
+ R_Cli;
+
+ if Timer_Queue.Common.LL.Succ = To_Address (T) then
+ -- T is the first task in Timer_Queue, further check
+
+ if T.Common.LL.Succ = Timer_Queue'Address then
+ -- T is the only task in Timer_Queue, so deactivate timer
+
+ Rt_No_Timer;
+
+ else
+ -- T is the first task in Timer_Queue, so set timer to T's
+ -- successor's Resume_Time
+
+ Rt_Set_Timer (To_Task_ID (T.Common.LL.Succ).Common.LL.Resume_Time);
+ end if;
+ end if;
+
+ Delete_T (T);
+
+ -- If T is in Timer_Queue, T is removed. If not, nothing happened
+
+ Insert_R (T);
+ R_Restore_Flags (Flags);
+
+ Rt_Schedule;
+ end Wakeup;
+
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ Flags : Integer;
+ begin
+ pragma Debug (Printk ("procedure Yield called" & LF));
+
+ pragma Assert (Current_Task /= To_Task_ID (Idle_Task'Address));
+
+ R_Save_Flags (Flags);
+ R_Cli;
+ Delete_R (Current_Task);
+ Insert_R (Current_Task);
+
+ -- Remove Current_Task from the top of the Ready_Queue
+ -- and reinsert it back at proper position (the end of
+ -- tasks with the same active priority).
+
+ R_Restore_Flags (Flags);
+ Rt_Schedule;
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ -- This version implicitly assume that T is the Current_Task
+
+ procedure Set_Priority
+ (T : Task_ID;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ Flags : Integer;
+ begin
+ pragma Debug (Printk ("procedure Set_Priority called" & LF));
+ pragma Assert (T = Self);
+
+ T.Common.Current_Priority := Prio;
+
+ if T.Common.LL.Outer_Lock /= null then
+ -- If the task T is holding any lock, defer the priority change
+ -- until the lock is released. That is, T's Active_Priority will
+ -- be set to Prio after it unlocks the outer-most lock. See
+ -- Unlock for detail.
+ -- Nothing needs to be done here for this case
+
+ null;
+ else
+ -- If T is not holding any lock, change the priority right away.
+
+ R_Save_Flags (Flags);
+ R_Cli;
+ T.Common.LL.Active_Priority := Prio;
+ Delete_R (T);
+ Insert_RF (T);
+
+ -- Insert at the front of the queue for its new priority
+
+ R_Restore_Flags (Flags);
+ end if;
+
+ Rt_Schedule;
+ end Set_Priority;
+
+ ------------------
+ -- Get_Priority --
+ ------------------
+
+ function Get_Priority (T : Task_ID) return System.Any_Priority is
+ begin
+ pragma Debug (Printk ("procedure Get_Priority called" & LF));
+
+ return T.Common.Current_Priority;
+ end Get_Priority;
+
+ ----------------
+ -- Enter_Task --
+ ----------------
+
+ -- Do any target-specific initialization that is needed for a new task
+ -- that has to be done by the task itself. This is called from the task
+ -- wrapper, immediately after the task starts execution.
+
+ procedure Enter_Task (Self_ID : Task_ID) is
+ begin
+ -- Use this as "hook" to re-enable interrupts.
+ pragma Debug (Printk ("procedure Enter_Task called" & LF));
+
+ R_Sti;
+ end Enter_Task;
+
+ ----------------
+ -- New_ATCB --
+ ----------------
+
+ function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
+ T : constant Task_ID := Available_TCBs;
+ begin
+ pragma Debug (Printk ("function New_ATCB called" & LF));
+
+ if Entry_Num /= 0 then
+ -- We are preallocating all TCBs, so they must all have the
+ -- same number of entries, which means the value of
+ -- Entry_Num must be bounded. We probably could choose a
+ -- non-zero upper bound here, but the Ravenscar Profile
+ -- specifies that there be no task entries.
+ -- ???
+ -- Later, do something better for recovery from this error.
+
+ null;
+ end if;
+
+ if T /= null then
+ Available_TCBs := To_Task_ID (T.Common.LL.Next);
+ T.Common.LL.Next := System.Null_Address;
+ Known_Tasks (T.Known_Tasks_Index) := T;
+ end if;
+
+ return T;
+ end New_ATCB;
+
+ ----------------------
+ -- Initialize_TCB --
+ ----------------------
+
+ procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
+ begin
+ pragma Debug (Printk ("procedure Initialize_TCB called" & LF));
+
+ -- 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);
+
+ Self_ID.Common.LL.L.Ceiling_Priority := System.Any_Priority'Last;
+ Self_ID.Common.LL.L.Owner := System.Null_Address;
+ Succeeded := True;
+ 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
+ Adjusted_Stack_Size : Integer;
+ Bottom : System.Address;
+ Flags : Integer;
+
+ begin
+ pragma Debug (Printk ("procedure Create_Task called" & LF));
+
+ Succeeded := True;
+
+ if T.Common.LL.Magic = RT_TASK_MAGIC then
+ Succeeded := False;
+ return;
+ end if;
+
+ if Stack_Size = Unspecified_Size then
+ Adjusted_Stack_Size := To_Integer (Default_Stack_Size);
+ elsif Stack_Size < Minimum_Stack_Size then
+ Adjusted_Stack_Size := To_Integer (Minimum_Stack_Size);
+ else
+ Adjusted_Stack_Size := To_Integer (Stack_Size);
+ end if;
+
+ Bottom := Kmalloc (Adjusted_Stack_Size, GFP_KERNEL);
+
+ if Bottom = System.Null_Address then
+ Succeeded := False;
+ return;
+ end if;
+
+ T.Common.LL.Uses_Fp := 1;
+
+ -- This field has to be reset to 1 if T uses FP unit. But, without
+ -- a library-level procedure provided by this package, it cannot
+ -- be set easily. So temporarily, set it to 1 (which means all the
+ -- tasks will use FP unit. ???
+
+ T.Common.LL.Magic := RT_TASK_MAGIC;
+ T.Common.LL.State := RT_TASK_READY;
+ T.Common.LL.Succ := To_Address (T);
+ T.Common.LL.Pred := To_Address (T);
+ T.Common.LL.Active_Priority := Priority;
+ T.Common.Current_Priority := Priority;
+
+ T.Common.LL.Stack_Bottom := Bottom;
+ T.Common.LL.Stack := Bottom + Storage_Offset (Adjusted_Stack_Size);
+
+ -- Store the value T into the stack, so that Task_wrapper (defined
+ -- in System.Tasking.Stages) will find that value for its parameter
+ -- Self_ID, when the scheduler eventually transfers control to the
+ -- new task.
+
+ T.Common.LL.Stack := T.Common.LL.Stack - Addr_Bytes;
+ To_Address_Ptr (T.Common.LL.Stack).all := To_Address (T);
+
+ -- Leave space for the return address, which will not be used,
+ -- since the task wrapper should never return.
+
+ T.Common.LL.Stack := T.Common.LL.Stack - Addr_Bytes;
+ To_Address_Ptr (T.Common.LL.Stack).all := System.Null_Address;
+
+ -- Put the entry point address of the task wrapper
+ -- procedure on the new top of the stack.
+
+ T.Common.LL.Stack := T.Common.LL.Stack - Addr_Bytes;
+ To_Address_Ptr (T.Common.LL.Stack).all := Wrapper;
+
+ R_Save_Flags (Flags);
+ R_Cli;
+ Insert_R (T);
+ R_Restore_Flags (Flags);
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_ID) is
+ begin
+ pragma Debug (Printk ("procedure Finalize_TCB called" & LF));
+
+ pragma Assert (T.Common.LL.Succ = To_Address (T));
+
+ if T.Common.LL.State = RT_TASK_DORMANT then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ T.Common.LL.Next := To_Address (Available_TCBs);
+ Available_TCBs := T;
+ Kfree (T.Common.LL.Stack_Bottom);
+ end if;
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ Flags : Integer;
+ begin
+ pragma Debug (Printk ("procedure Exit_Task called" & LF));
+ pragma Assert (Current_Task /= To_Task_ID (Idle_Task'Address));
+ pragma Assert (Current_Task /= Environment_Task_ID);
+
+ R_Save_Flags (Flags);
+ R_Cli;
+ Current_Task.Common.LL.State := RT_TASK_DORMANT;
+ Current_Task.Common.LL.Magic := 0;
+ Delete_R (Current_Task);
+ R_Restore_Flags (Flags);
+ Rt_Schedule;
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ -- ??? Not implemented for now
+
+ procedure Abort_Task (T : Task_ID) is
+ -- Should cause T to raise Abort_Signal the next time it
+ -- executes.
+ -- ??? Can this ever be called when T = Current_Task?
+ -- To be safe, do nothing in this case.
+ begin
+ pragma Debug (Printk ("procedure Abort_Task called" & LF));
+ null;
+ end Abort_Task;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy versions. The only currently working versions is for solaris
+ -- (native).
+ -- We should probably copy the working versions over from the Solaris
+ -- version of this package, with any appropriate changes, since without
+ -- the checks on it will probably be nearly impossible to debug the
+ -- run-time system.
+
+ -- Not implemented for now
+
+ function Check_Exit (Self_ID : Task_ID) return Boolean is
+ begin
+ pragma Debug (Printk ("function Check_Exit called" & LF));
+
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : Task_ID) return Boolean is
+ begin
+ pragma Debug (Printk ("function Check_No_Locks called" & LF));
+
+ if Self_ID.Common.LL.Outer_Lock = null then
+ return True;
+ else
+ return False;
+ end if;
+ end Check_No_Locks;
+
+ ----------------------
+ -- Environment_Task --
+ ----------------------
+
+ function Environment_Task return Task_ID is
+ begin
+ return Environment_Task_ID;
+ end Environment_Task;
+
+ -------------------------
+ -- Lock_All_Tasks_List --
+ -------------------------
+
+ procedure Lock_All_Tasks_List is
+ begin
+ pragma Debug (Printk ("procedure Lock_All_Tasks_List called" & LF));
+
+ Write_Lock (All_Tasks_L'Access);
+ end Lock_All_Tasks_List;
+
+ ---------------------------
+ -- Unlock_All_Tasks_List --
+ ---------------------------
+
+ procedure Unlock_All_Tasks_List is
+ begin
+ pragma Debug (Printk ("procedure Unlock_All_Tasks_List called" & LF));
+
+ Unlock (All_Tasks_L'Access);
+ end Unlock_All_Tasks_List;
+
+ -----------------
+ -- Stack_Guard --
+ -----------------
+
+ -- Not implemented for now
+
+ procedure Stack_Guard (T : Task_ID; On : Boolean) is
+ begin
+ null;
+ end Stack_Guard;
+
+ --------------------
+ -- Get_Thread_Id --
+ --------------------
+
+ function Get_Thread_Id (T : Task_ID) return OSI.Thread_Id is
+ begin
+ return To_Address (T);
+ end Get_Thread_Id;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : Task_ID;
+ Thread_Self : OSI.Thread_Id) return Boolean is
+ begin
+ return False;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_ID;
+ Thread_Self : OSI.Thread_Id) return Boolean is
+ begin
+ return False;
+ end Resume_Task;
+
+ -----------------
+ -- Init_Module --
+ -----------------
+
+ function Init_Module return Integer is
+ procedure adainit;
+ pragma Import (C, adainit);
+
+ begin
+ adainit;
+ In_Elab_Code := False;
+ Set_Priority (Environment_Task_ID, Any_Priority'First);
+ return 0;
+ end Init_Module;
+
+ --------------------
+ -- Cleanup_Module --
+ --------------------
+
+ procedure Cleanup_Module is
+ procedure adafinal;
+ pragma Import (C, adafinal);
+
+ begin
+ adafinal;
+ end Cleanup_Module;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ -- The environment task is "special". The TCB of the environment task is
+ -- not in the TCB_Array above. Logically, all initialization code for the
+ -- runtime system is executed by the environment task, but until the
+ -- environment task has initialized its own TCB we dare not execute any
+ -- calls that try to access the TCB of Current_Task. It is allocated by
+ -- target-independent runtime system code, in System.Tasking.Initializa-
+ -- tion.Init_RTS, before the call to this procedure Initialize. The
+ -- target-independent runtime system initializes all the components that
+ -- are target-independent, but this package needs to be given a chance to
+ -- initialize the target-dependent data. We do that in this procedure.
+
+ -- In the present implementation, Environment_Task is set to be the
+ -- regular Linux kernel task.
+
+ procedure Initialize (Environment_Task : Task_ID) is
+ begin
+ pragma Debug (Printk ("procedure Initialize called" & LF));
+
+ Environment_Task_ID := Environment_Task;
+
+ -- Build the list of available ATCB's.
+
+ Available_TCBs := To_Task_ID (TCB_Array (1)'Address);
+
+ for J in TCB_Array'First + 1 .. TCB_Array'Last - 1 loop
+ -- Note that the zeroth element in TCB_Array is not used, see
+ -- comments following the declaration of TCB_Array
+
+ TCB_Array (J).Common.LL.Next := TCB_Array (J + 1)'Address;
+ end loop;
+
+ TCB_Array (TCB_Array'Last).Common.LL.Next := System.Null_Address;
+
+ -- Initialize the idle task, which is the head of Ready_Queue.
+
+ Idle_Task.Common.LL.Magic := RT_TASK_MAGIC;
+ Idle_Task.Common.LL.State := RT_TASK_READY;
+ Idle_Task.Common.Current_Priority := System.Any_Priority'First;
+ Idle_Task.Common.LL.Active_Priority := System.Any_Priority'First;
+ Idle_Task.Common.LL.Succ := Idle_Task'Address;
+ Idle_Task.Common.LL.Pred := Idle_Task'Address;
+
+ -- Initialize the regular Linux kernel task.
+
+ Environment_Task.Common.LL.Magic := RT_TASK_MAGIC;
+ Environment_Task.Common.LL.State := RT_TASK_READY;
+ Environment_Task.Common.Current_Priority := System.Any_Priority'First;
+ Environment_Task.Common.LL.Active_Priority := System.Any_Priority'First;
+ Environment_Task.Common.LL.Succ := To_Address (Environment_Task);
+ Environment_Task.Common.LL.Pred := To_Address (Environment_Task);
+
+ -- Initialize the head of Timer_Queue
+
+ Timer_Queue.Common.LL.Succ := Timer_Queue'Address;
+ Timer_Queue.Common.LL.Pred := Timer_Queue'Address;
+ Timer_Queue.Common.LL.Resume_Time := Max_Sensible_Delay;
+
+ -- Set the current task to regular Linux kernel task
+
+ Current_Task := Environment_Task;
+
+ -- Set Timer_Wrapper to be the timer handler
+
+ Rt_Free_Timer;
+ Rt_Request_Timer (Timer_Wrapper'Address);
+
+ -- Initialize the lock used to synchronize chain of all ATCBs.
+
+ Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
+
+ Enter_Task (Environment_Task);
+ end Initialize;
+
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $
+-- --
+-- Copyright (C) 1991-2000, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+-- RT_Linux version.
+
+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 System.OS_Interface;
+
+package System.Task_Primitives is
+
+ type Lock is limited private;
+ -- Used for implementation of protected objects.
+
+ type Lock_Ptr is limited private;
+
+ type RTS_Lock is limited private;
+ -- Used inside the runtime system. The difference between Lock and the
+ -- RTS_Lock is that the later one serves only as a semaphore so that do
+ -- not check for ceiling violations.
+ type RTS_Lock_Ptr is limited private;
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper
+ -- declared local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task
+ -- basis. A component of this type is guaranteed to be included
+ -- in the Ada_Task_Control_Block.
+
+private
+
+ type RT_Linux_Lock is record
+ Ceiling_Priority : System.Any_Priority;
+ Pre_Locking_Priority : System.Any_Priority;
+ -- Used to store the task's active priority before it
+ -- acquires the lock
+
+ Owner : System.Address;
+ -- This is really a Task_ID, but we can't use that type
+ -- here because this System.Tasking is "with"
+ -- the current package -- a circularity.
+ end record;
+
+ type Lock is new RT_Linux_Lock;
+ type RTS_Lock is new RT_Linux_Lock;
+
+ type RTS_Lock_Ptr is access all RTS_Lock;
+ type Lock_Ptr is access all Lock;
+
+ type Private_Data is record
+ Stack : System.Address;
+ -- A stack space needed for the task. the space is allocated
+ -- when the task is being created and is deallocated when
+ -- the TCB for the task is finalized
+
+ Uses_Fp : Integer;
+ -- A flag to indicate whether the task is going to use floating-
+ -- point unit. It's set to 1, indicating FP unit is always going
+ -- to be used. The reason is that it is in this private record and
+ -- necessary operation has to be provided for a user to call so as
+ -- to change its value
+
+ Magic : Integer;
+ -- A special value is going to be stored in it when a task is
+ -- created. The value is RT_TASK_MAGIC (16#754d2774#) as declared
+ -- in System.OS_Interface
+
+ State : System.OS_Interface.Rt_Task_States;
+ -- Shows whether the task is RT_TASK_READY, RT_TASK_DELAYED or
+ -- RT_TASK_DORMANT to support suspend, wait, wakeup.
+
+ Stack_Bottom : System.Address;
+
+ Active_Priority : System.Any_Priority;
+ -- Active priority of the task
+
+ Period : System.OS_Interface.RTIME;
+ -- Intended originally to store the period of the task, but not used
+ -- in the current implementation
+
+ Resume_Time : System.OS_Interface.RTIME;
+ -- Store the time the task has to be awakened
+
+ Next : System.Address;
+ -- This really is a Task_ID, used to link the Available_TCBs.
+
+ Succ : System.Address;
+ pragma Volatile (Succ);
+ Pred : System.Address;
+ pragma Volatile (Pred);
+ -- These really are Task_ID, used to implement a circular doubly
+ -- linked list for task queue
+
+ L : aliased RTS_Lock;
+
+ Outer_Lock : RTS_Lock_Ptr := null;
+ -- Used to track which Lock the task is holding is the outermost
+ -- one in order to implement priority setting and inheritance
+ end record;
+
+ -- ???? May need to use pragma Atomic or Volatile on some
+ -- components; may also need to specify aliased for some.
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 1998 - 2001 Free Software Foundation --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the PPC VxWorks 6.0 version of this package. A different version
+-- is used for VxWorks 5.x
+
+with Interfaces.C;
+
+package System.VxWorks is
+ pragma Preelaborate (System.VxWorks);
+
+ package IC renames Interfaces.C;
+
+ -- Define enough of a Wind Task Control Block in order to
+ -- obtain the inherited priority. When porting this to
+ -- different versions of VxWorks (this is based on 6.0),
+ -- be sure to look at the definition for WIND_TCB located
+ -- in $WIND_BASE/target/h/taskLib.h
+
+ type Wind_Fill_1 is array (0 .. 16#6B#) of IC.unsigned_char;
+ type Wind_Fill_2 is array (16#74# .. 16#10F#) of IC.unsigned_char;
+
+ type Wind_TCB is record
+ Fill_1 : Wind_Fill_1; -- 0x00 - 0x6b
+ Priority : IC.int; -- 0x6c - 0x6f, current (inherited) priority
+ Normal_Priority : IC.int; -- 0x70 - 0x73, base priority
+ Fill_2 : Wind_Fill_2; -- 0x74 - 0x10f
+ spare1 : Address; -- 0x110 - 0x113
+ spare2 : Address; -- 0x114 - 0x117
+ spare3 : Address; -- 0x118 - 0x11b
+ spare4 : Address; -- 0x11c - 0x11f
+ end record;
+ type Wind_TCB_Ptr is access Wind_TCB;
+
+ -- Floating point context record. PPC version
+
+ FP_NUM_DREGS : constant := 32;
+ type Fpr_Array is array (1 .. FP_NUM_DREGS) of IC.double;
+
+ type FP_CONTEXT is record
+ fpr : Fpr_Array;
+ fpcsr : IC.int;
+ pad : IC.int;
+ end record;
+ pragma Convention (C, FP_CONTEXT);
+
+ Num_HW_Interrupts : constant := 256;
+
+ -- For VxWorks 6.0
+ type TASK_DESC is record
+ td_id : IC.int; -- task id
+ td_priority : IC.int; -- task priority
+ td_status : IC.int; -- task status
+ td_options : IC.int; -- task option bits (see below)
+ td_entry : Address; -- original entry point of task
+ td_sp : Address; -- saved stack pointer
+ td_pStackBase : Address; -- the bottom of the stack
+ td_pStackLimit : Address; -- the effective end of the stack
+ td_pStackEnd : Address; -- the actual end of the stack
+ td_stackSize : IC.int; -- size of stack in bytes
+ td_stackCurrent : IC.int; -- current stack usage in bytes
+ td_stackHigh : IC.int; -- maximum stack usage in bytes
+ td_stackMargin : IC.int; -- current stack margin in bytes
+
+ td_PExcStkBase : Address; -- exception stack base
+ td_PExcStkPtr : Address; -- exception stack pointer
+ td_ExcStkHigh : IC.int; -- exception stack max usage
+ td_ExcStkMgn : IC.int; -- exception stack margin
+
+ td_errorStatus : IC.int; -- most recent task error status
+ td_delay : IC.int; -- delay/timeout ticks
+
+ td_PdId : Address; -- task's home protection domain
+ td_name : Address; -- name of task
+ end record;
+
+ pragma Convention (C, TASK_DESC);
+
+end System.VxWorks;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- Copyright (C) 1991-2000 Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+-- The GNARL files that were developed for RTEMS are maintained by On-Line --
+-- Applications Research Corporation (http://www.oarcorp.com) in coopera- --
+-- tion with Ada Core Technologies Inc. and Florida State University. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the RTEMS version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+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 Interfaces.C; use Interfaces.C;
+package body System.OS_Interface is
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+ if F < 0.0 then S := S - 1; F := F + 1.0; end if;
+ return timespec' (tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+
+ function To_Duration (TV : struct_timeval) return Duration is
+ begin
+ return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
+ end To_Duration;
+
+ function To_Timeval (D : Duration) return struct_timeval is
+ S : int;
+ F : Duration;
+ begin
+ S := int (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 struct_timeval' (tv_sec => S,
+ tv_usec => int (Long_Long_Integer (F * 10#1#E6)));
+ end To_Timeval;
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ function Get_Page_Size return size_t is
+ begin
+ return 0;
+ end Get_Page_Size;
+
+ function Get_Page_Size return Address is
+ begin
+ return 0;
+ end Get_Page_Size;
+
+ function mprotect
+ (addr : Address; len : size_t; prot : int) return int is
+ begin
+ return 0;
+ end mprotect;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.22 $
+-- --
+-- Copyright (C) 1997-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+-- The GNARL files that were developed for RTEMS are maintained by On-Line --
+-- Applications Research Corporation (http://www.oarcorp.com) in coopera- --
+-- tion with Ada Core Technologies Inc. and Florida State University. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the RTEMS version of this package
+
+-- These are guesses based on what I think the GNARL team will want to
+-- call the rtems configurations. We use CPU-rtems for the rtems
+-- configurations.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ -- This interface assumes that "unsigned" is a 32-bit entity. This
+ -- will correspond to RTEMS object ids.
+
+ subtype rtems_id is Interfaces.C.unsigned;
+
+ 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 := 116;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 31;
+ type Signal is new int range 0 .. Max_Interrupt;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+
+ SIGADAABORT : constant := SIGABRT;
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set := (SIGTRAP, SIGALRM, SIGEMT);
+ Reserved : constant Signal_Set := (1 .. 1 => SIGKILL);
+
+ 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_flags : int;
+ sa_mask : sigset_t;
+ sa_handler : System.Address;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ 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 wether time slicing is supported (i.e SCHED_RR is supported)
+
+ type timespec is private;
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "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_timeval is private;
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 1;
+ SCHED_RR : constant := 2;
+ SCHED_OTHER : constant := 0;
+
+ -------------
+ -- 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;
+
+ 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 := 0;
+
+ -----------
+ -- Stack --
+ -----------
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates wether the stack base is available on this target.
+ -- This allows us to share s-osinte.adb between all the FSU/RTEMS
+ -- run time.
+ -- Note that this value can only be true if pthread_t has a complete
+ -- definition that corresponds exactly to the C header files.
+
+ 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.
+
+ -- These two functions are only needed to share s-taprop.adb with
+ -- FSU threads.
+
+ function Get_Page_Size return size_t;
+ function Get_Page_Size return Address;
+ -- returns the size of a page, or 0 if this is not relevant on this
+ -- target (which is the case for RTEMS)
+
+ PROT_ON : constant := 0;
+ PROT_OFF : constant := 0;
+
+ function mprotect (addr : Address; len : size_t; prot : int) return int;
+ -- Do nothing on RTEMS.
+
+ -----------------------------------------
+ -- Nonstandard Thread Initialization --
+ -----------------------------------------
+
+ procedure pthread_init;
+ -- FSU_THREADS requires pthread_init, which is nonstandard
+ -- and this should be invoked during the elaboration of s-taprop.adb
+ --
+ -- RTEMS does not require this so we provide an empty Ada body.
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ ----------------------------
+ -- 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_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ 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,
+ "pthread_mutexattr_setprioceiling");
+
+ type struct_sched_param is record
+ sched_priority : int;
+ ss_low_priority : timespec;
+ ss_replenish_period : timespec;
+ ss_initial_budget : timespec;
+ end record;
+ pragma Convention (C, struct_sched_param);
+
+ 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 pthread_attr_setschedparam
+ (attr : access pthread_attr_t;
+ sched_param : int) return int;
+ pragma Import (C, pthread_attr_setschedparam);
+
+ 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, "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 pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+
+ type sigset_t is new int;
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type clockid_t is new rtems_id;
+ CLOCK_REALTIME : constant clockid_t := 1;
+
+ type struct_timeval is record
+ tv_sec : int;
+ tv_usec : int;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type pthread_attr_t is record
+ is_initialized : int;
+ stackaddr : System.Address;
+ stacksize : int;
+ contentionscope : int;
+ inheritsched : int;
+ schedpolicy : int;
+ schedparam : struct_sched_param;
+ cputime_clocked_allowed : int;
+ deatchstate : int;
+ end record;
+ pragma Convention (C, pthread_attr_t);
+
+ type pthread_condattr_t is record
+ flags : int;
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_mutexattr_t is record
+ is_initialized : int;
+ process_shared : int;
+ prio_ceiling : int;
+ protocol : int;
+ recursive : int;
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type pthread_t is new rtems_id;
+
+ type pthread_mutex_t is new rtems_id;
+
+ type pthread_cond_t is new rtems_id;
+
+ type pthread_key_t is new rtems_id;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1997-1998 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the RTEMS specific version
+
+with Interfaces.C;
+
+package body System.Parameters is
+
+ function ada_pthread_minimum_stack_size return Interfaces.C.size_t;
+ pragma Import (C, ada_pthread_minimum_stack_size,
+ "_ada_pthread_minimum_stack_size");
+
+ ------------------------
+ -- Default_Stack_Size --
+ ------------------------
+
+ function Default_Stack_Size return Size_Type is
+ begin
+ return Size_Type (ada_pthread_minimum_stack_size);
+ end Default_Stack_Size;
+
+ ------------------------
+ -- Minimum_Stack_Size --
+ ------------------------
+
+ function Minimum_Stack_Size return Size_Type is
+
+ begin
+ return Size_Type (ada_pthread_minimum_stack_size);
+ end Minimum_Stack_Size;
+
+ -------------------------
+ -- Adjust_Storage_Size --
+ -------------------------
+
+ function Adjust_Storage_Size (Size : Size_Type) return Size_Type is
+ begin
+ if Size = Unspecified_Size then
+ return Default_Stack_Size;
+
+ elsif Size < Minimum_Stack_Size then
+ return Minimum_Stack_Size;
+
+ else
+ return Size;
+ end if;
+ end Adjust_Storage_Size;
+
+end System.Parameters;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.21 $ --
+-- --
+-- Copyright (C) 1992-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Solaris version of this package.
+
+-- PLEASE DO NOT add any dependences on other packages.
+-- This package is designed to work with or without tasking support.
+
+-- Make a careful study of all signals available under the OS,
+-- to see which need to be reserved, kept always unmasked,
+-- or kept always unmasked.
+
+-- Be on the lookout for special signals that
+-- may be used by the thread library.
+
+with Interfaces.C;
+-- used for int
+
+with System.OS_Interface;
+-- used for various Constants, Signal and types
+
+package body System.Interrupt_Management is
+
+ use Interfaces.C;
+ use System.OS_Interface;
+
+ type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
+
+ Exception_Interrupts : constant Interrupt_List :=
+ (SIGFPE, SIGILL, SIGSEGV, SIGBUS);
+
+ Unreserve_All_Interrupts : Interfaces.C.int;
+ pragma Import
+ (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
+
+ ----------------------
+ -- Notify_Exception --
+ ----------------------
+
+ -- This function identifies the Ada exception to be raised using
+ -- the information when the system received a synchronous signal.
+ -- Since this function is machine and OS dependent, different code
+ -- has to be provided for different target.
+
+ procedure Notify_Exception
+ (signo : Signal;
+ info : access siginfo_t;
+ context : access ucontext_t);
+
+ procedure Notify_Exception
+ (signo : Signal;
+ info : access siginfo_t;
+ context : access ucontext_t) is
+ begin
+ -- Check that treatment of exception propagation here
+ -- is consistent with treatment of the abort signal in
+ -- System.Task_Primitives.Operations.
+
+ case signo is
+ when SIGFPE =>
+ case info.si_code is
+ when FPE_INTDIV |
+ FPE_INTOVF |
+ FPE_FLTDIV |
+ FPE_FLTOVF |
+ FPE_FLTUND |
+ FPE_FLTRES |
+ FPE_FLTINV |
+ FPE_FLTSUB =>
+
+ raise Constraint_Error;
+
+ when others =>
+ pragma Assert (False);
+ null;
+ end case;
+
+ when SIGILL | SIGSEGV | SIGBUS =>
+ raise Storage_Error;
+
+ when others =>
+ pragma Assert (False);
+ null;
+ end case;
+ end Notify_Exception;
+
+ ---------------------------
+ -- Initialize_Interrupts --
+ ---------------------------
+
+ -- Nothing needs to be done on this platform.
+
+ procedure Initialize_Interrupts is
+ begin
+ null;
+ end Initialize_Interrupts;
+
+----------------------------
+-- Package Initialization --
+----------------------------
+
+begin
+ declare
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ mask : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ begin
+ -- Need to call pthread_init very early because it is doing signal
+ -- initializations.
+
+ pthread_init;
+
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ Abort_Task_Interrupt := SIGABRT;
+
+ act.sa_handler := Notify_Exception'Address;
+
+ -- Set sa_flags to SA_NODEFER so that during the handler execution
+ -- we do not change the Signal_Mask to be masked for the Signal.
+ -- This is a temporary fix to the problem that the Signal_Mask is
+ -- not restored after the exception (longjmp) from the handler.
+ -- The right fix should be made in sigsetjmp so that we save
+ -- the Signal_Set and restore it after a longjmp.
+
+ -- In that case, this field should be changed back to 0. ??? (Dong-Ik)
+
+ act.sa_flags := 16;
+
+ Result := sigemptyset (mask'Access);
+ pragma Assert (Result = 0);
+
+ -- ??? For the same reason explained above, we can't mask these
+ -- signals because otherwise we won't be able to catch more than
+ -- one signal.
+
+ act.sa_mask := mask;
+
+ Keep_Unmasked (Abort_Task_Interrupt) := True;
+ Keep_Unmasked (SIGXCPU) := True;
+ Keep_Unmasked (SIGFPE) := True;
+ Result :=
+ sigaction
+ (Signal (SIGFPE), act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ -- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but in the
+ -- same time, disable the ability of handling this signal
+ -- via Ada.Interrupts.
+ -- The pragma Unreserve_All_Interrupts let the user the ability to
+ -- change this behavior.
+
+ if Unreserve_All_Interrupts = 0 then
+ Keep_Unmasked (SIGINT) := True;
+ end if;
+
+ for J in
+ Exception_Interrupts'First + 1 .. Exception_Interrupts'Last loop
+ Keep_Unmasked (Exception_Interrupts (J)) := True;
+
+ if Unreserve_All_Interrupts = 0 then
+ Result :=
+ sigaction
+ (Signal (Exception_Interrupts (J)), act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
+
+ for J in Unmasked'Range loop
+ Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
+ end loop;
+
+ Reserve := Keep_Unmasked or Keep_Masked;
+
+ for J in Reserved'Range loop
+ Reserve (Interrupt_ID (Reserved (J))) := True;
+ end loop;
+
+ -- We do not have Signal 0 in reality. We just use this value
+ -- to identify not existing signals (see s-intnam.ads). Therefore,
+ -- Signal 0 should not be used in all signal related operations hence
+ -- mark it as reserved.
+
+ Reserve (0) := True;
+ end;
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- SYSTEM.MACHINE_STATE_OPERATIONS --
+-- --
+-- B o d y --
+-- (Version using the GCC stack unwinding mechanism) --
+-- --
+-- $Revision: 1.3 $
+-- --
+-- Copyright (C) 1999-2001 Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This version of System.Machine_State_Operations is for use on
+-- systems where the GCC stack unwinding mechanism is supported.
+-- It is currently only used on Solaris
+
+package body System.Machine_State_Operations is
+
+ use System.Storage_Elements;
+ use System.Exceptions;
+
+ ----------------------------
+ -- Allocate_Machine_State --
+ ----------------------------
+
+ function Allocate_Machine_State return Machine_State is
+ function Machine_State_Length return Storage_Offset;
+ pragma Import (C, Machine_State_Length, "__gnat_machine_state_length");
+
+ function Gnat_Malloc (Size : Storage_Offset) return Machine_State;
+ pragma Import (C, Gnat_Malloc, "__gnat_malloc");
+
+ begin
+ return Gnat_Malloc (Machine_State_Length);
+ end Allocate_Machine_State;
+
+ -------------------
+ -- Enter_Handler --
+ -------------------
+
+ procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
+ procedure c_enter_handler (m : Machine_State; handler : Handler_Loc);
+ pragma Import (C, c_enter_handler, "__gnat_enter_handler");
+
+ begin
+ c_enter_handler (M, Handler);
+ end Enter_Handler;
+
+ ----------------
+ -- Fetch_Code --
+ ----------------
+
+ function Fetch_Code (Loc : Code_Loc) return Code_Loc is
+ begin
+ return Loc;
+ end Fetch_Code;
+
+ ------------------------
+ -- Free_Machine_State --
+ ------------------------
+
+ procedure Free_Machine_State (M : in out Machine_State) is
+ procedure Gnat_Free (M : in Machine_State);
+ pragma Import (C, Gnat_Free, "__gnat_free");
+
+ begin
+ Gnat_Free (M);
+ M := Machine_State (Null_Address);
+ end Free_Machine_State;
+
+ ------------------
+ -- Get_Code_Loc --
+ ------------------
+
+ function Get_Code_Loc (M : Machine_State) return Code_Loc is
+ function c_get_code_loc (m : Machine_State) return Code_Loc;
+ pragma Import (C, c_get_code_loc, "__gnat_get_code_loc");
+
+ begin
+ return c_get_code_loc (M);
+ end Get_Code_Loc;
+
+ --------------------------
+ -- Machine_State_Length --
+ --------------------------
+
+ function Machine_State_Length return Storage_Offset is
+
+ function c_machine_state_length return Storage_Offset;
+ pragma Import (C, c_machine_state_length, "__gnat_machine_state_length");
+
+ begin
+ return c_machine_state_length;
+ end Machine_State_Length;
+
+ ---------------
+ -- Pop_Frame --
+ ---------------
+
+ procedure Pop_Frame
+ (M : Machine_State;
+ Info : Subprogram_Info_Type)
+ is
+ procedure c_pop_frame (m : Machine_State);
+ pragma Import (C, c_pop_frame, "__gnat_pop_frame");
+
+ begin
+ c_pop_frame (M);
+ end Pop_Frame;
+
+ -----------------------
+ -- Set_Machine_State --
+ -----------------------
+
+ procedure Set_Machine_State (M : Machine_State) is
+ procedure c_set_machine_state (m : Machine_State);
+ pragma Import (C, c_set_machine_state, "__gnat_set_machine_state");
+
+ begin
+ c_set_machine_state (M);
+ Pop_Frame (M, System.Null_Address);
+ end Set_Machine_State;
+
+ ------------------------------
+ -- Set_Signal_Machine_State --
+ ------------------------------
+
+ procedure Set_Signal_Machine_State
+ (M : Machine_State;
+ Context : System.Address) is
+ begin
+ null;
+ end Set_Signal_Machine_State;
+
+end System.Machine_State_Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.9 $
+-- --
+-- Copyright (C) 1991-2001 Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Solaris version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+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 Interfaces.C; use Interfaces.C;
+package body System.OS_Interface is
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+ if F < 0.0 then S := S - 1; F := F + 1.0; end if;
+ return timespec' (tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ function To_Duration (TV : struct_timeval) return Duration is
+ begin
+ return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
+ end To_Duration;
+
+ function To_Timeval (D : Duration) return struct_timeval is
+ S : long;
+ F : Duration;
+ begin
+ S := long (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 struct_timeval' (tv_sec => S,
+ tv_usec => long (Long_Long_Integer (F * 10#1#E6)));
+ end To_Timeval;
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.30 $
+-- --
+-- Copyright (C) 1997-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Solaris (native) version of this package
+
+-- This package includes all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lposix4");
+ pragma Linker_Options ("-lthread");
+
+ subtype int is Interfaces.C.int;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ ETIME : constant := 62;
+ ETIMEDOUT : constant := 145;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 45;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ SIGWINCH : constant := 20; -- window size change
+ SIGURG : constant := 21; -- urgent condition on IO channel
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias)
+ SIGSTOP : constant := 23; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 24; -- user stop requested from tty
+ SIGCONT : constant := 25; -- stopped process has been continued
+ SIGTTIN : constant := 26; -- background tty read attempted
+ SIGTTOU : constant := 27; -- background tty write attempted
+ SIGVTALRM : constant := 28; -- virtual timer expired
+ SIGPROF : constant := 29; -- profiling timer expired
+ SIGXCPU : constant := 30; -- CPU time limit exceeded
+ SIGXFSZ : constant := 31; -- filesize limit exceeded
+ SIGWAITING : constant := 32; -- process's lwps blocked (Solaris)
+ SIGLWP : constant := 33; -- used by thread library (Solaris)
+ SIGFREEZE : constant := 34; -- used by CPR (Solaris)
+ SIGTHAW : constant := 35; -- used by CPR (Solaris)
+ SIGCANCEL : constant := 36; -- thread cancellation signal (libthread)
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set := (SIGTRAP, SIGLWP, SIGPROF);
+
+ -- Following signals should not be disturbed.
+ -- See c-posix-signals.c in FLORIST
+
+ Reserved : constant Signal_Set := (SIGKILL, SIGSTOP, SIGWAITING, SIGCANCEL);
+
+ 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 union_type_3 is new String (1 .. 116);
+ type siginfo_t is record
+ si_signo : int;
+ si_code : int;
+ si_errno : int;
+ X_data : union_type_3;
+ end record;
+ pragma Convention (C, siginfo_t);
+
+ -- The types mcontext_t and gregset_t are part of the ucontext_t
+ -- information, which is specific to Solaris2.4 for SPARC
+ -- The ucontext_t info seems to be used by the handler
+ -- for SIGSEGV to decide whether it is a Storage_Error (stack overflow) or
+ -- a Constraint_Error (bad pointer). The original code that did this
+ -- is suspect, so it is not clear whether we really need this part of
+ -- the signal context information, or perhaps something else.
+ -- More analysis is needed, after which these declarations may need to
+ -- be changed.
+
+ FPE_INTDIV : constant := 1; -- integer divide by zero
+ FPE_INTOVF : constant := 2; -- integer overflow
+ FPE_FLTDIV : constant := 3; -- floating point divide by zero
+ FPE_FLTOVF : constant := 4; -- floating point overflow
+ FPE_FLTUND : constant := 5; -- floating point underflow
+ FPE_FLTRES : constant := 6; -- floating point inexact result
+ FPE_FLTINV : constant := 7; -- invalid floating point operation
+ FPE_FLTSUB : constant := 8; -- subscript out of range
+
+ type greg_t is new int;
+
+ type gregset_t is array (0 .. 18) of greg_t;
+
+ type union_type_2 is new String (1 .. 128);
+ type record_type_1 is record
+ fpu_fr : union_type_2;
+ fpu_q : System.Address;
+ fpu_fsr : unsigned;
+ fpu_qcnt : unsigned_char;
+ fpu_q_entrysize : unsigned_char;
+ fpu_en : unsigned_char;
+ end record;
+ pragma Convention (C, record_type_1);
+
+ type array_type_7 is array (Integer range 0 .. 20) of long;
+ type mcontext_t is record
+ gregs : gregset_t;
+ gwins : System.Address;
+ fpregs : record_type_1;
+ filler : array_type_7;
+ end record;
+ pragma Convention (C, mcontext_t);
+
+ type record_type_2 is record
+ ss_sp : System.Address;
+ ss_size : int;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, record_type_2);
+
+ type array_type_8 is array (Integer range 0 .. 22) of long;
+ type ucontext_t is record
+ uc_flags : unsigned_long;
+ uc_link : System.Address;
+ uc_sigmask : sigset_t;
+ uc_stack : record_type_2;
+ uc_mcontext : mcontext_t;
+ uc_filler : array_type_8;
+ end record;
+ pragma Convention (C, ucontext_t);
+
+ type Signal_Handler is access procedure
+ (signo : Signal;
+ info : access siginfo_t;
+ context : access ucontext_t);
+
+ type union_type_1 is new plain_char;
+ type array_type_2 is array (Integer range 0 .. 1) of int;
+ type struct_sigaction is record
+ sa_flags : int;
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_resv : array_type_2;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ 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 --
+ ----------
+
+ type timespec is private;
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+
+ function clock_gettime
+ (clock_id : clockid_t; tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "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_timeval is private;
+ -- This is needed on systems that do not have clock_gettime()
+ -- but do have gettimeofday().
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+
+ THR_DETACHED : constant := 64;
+ THR_BOUND : constant := 1;
+ THR_NEW_LWP : constant := 2;
+ USYNC_THREAD : constant := 0;
+
+ type thread_t is private;
+ subtype Thread_Id is thread_t;
+
+ type mutex_t is limited private;
+
+ type cond_t is limited private;
+
+ type thread_key_t is private;
+
+ function thr_create
+ (stack_base : System.Address;
+ stack_size : size_t;
+ start_routine : Thread_Body;
+ arg : System.Address;
+ flags : int;
+ new_thread : access thread_t) return int;
+ pragma Import (C, thr_create, "thr_create");
+
+ function thr_min_stack return size_t;
+ pragma Import (C, thr_min_stack, "thr_min_stack");
+
+ function thr_self return thread_t;
+ pragma Import (C, thr_self, "thr_self");
+
+ function mutex_init
+ (mutex : access mutex_t;
+ mtype : int;
+ arg : System.Address) return int;
+ pragma Import (C, mutex_init, "mutex_init");
+
+ function mutex_destroy (mutex : access mutex_t) return int;
+ pragma Import (C, mutex_destroy, "mutex_destroy");
+
+ function mutex_lock (mutex : access mutex_t) return int;
+ pragma Import (C, mutex_lock, "mutex_lock");
+
+ function mutex_unlock (mutex : access mutex_t) return int;
+ pragma Import (C, mutex_unlock, "mutex_unlock");
+
+ function cond_init
+ (cond : access cond_t;
+ ctype : int;
+ arg : int) return int;
+ pragma Import (C, cond_init, "cond_init");
+
+ function cond_wait
+ (cond : access cond_t; mutex : access mutex_t) return int;
+ pragma Import (C, cond_wait, "cond_wait");
+
+ function cond_timedwait
+ (cond : access cond_t;
+ mutex : access mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, cond_timedwait, "cond_timedwait");
+
+ function cond_signal (cond : access cond_t) return int;
+ pragma Import (C, cond_signal, "cond_signal");
+
+ function cond_destroy (cond : access cond_t) return int;
+ pragma Import (C, cond_destroy, "cond_destroy");
+
+ function thr_setspecific
+ (key : thread_key_t; value : System.Address) return int;
+ pragma Import (C, thr_setspecific, "thr_setspecific");
+
+ function thr_getspecific
+ (key : thread_key_t;
+ value : access System.Address) return int;
+ pragma Import (C, thr_getspecific, "thr_getspecific");
+
+ function thr_keycreate
+ (key : access thread_key_t; destructor : System.Address) return int;
+ pragma Import (C, thr_keycreate, "thr_keycreate");
+
+ function thr_setprio (thread : thread_t; priority : int) return int;
+ pragma Import (C, thr_setprio, "thr_setprio");
+
+ procedure thr_exit (status : System.Address);
+ pragma Import (C, thr_exit, "thr_exit");
+
+ function thr_setconcurrency (new_level : int) return int;
+ pragma Import (C, thr_setconcurrency, "thr_setconcurrency");
+
+ function sigwait (set : access sigset_t; sig : access Signal) return int;
+ pragma Import (C, sigwait, "__posix_sigwait");
+
+ function thr_kill (thread : thread_t; sig : Signal) return int;
+ pragma Import (C, thr_kill, "thr_kill");
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function thr_sigsetmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, thr_sigsetmask, "thr_sigsetmask");
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "thr_sigsetmask");
+
+ function thr_suspend (target_thread : thread_t) return int;
+ pragma Import (C, thr_suspend, "thr_suspend");
+
+ function thr_continue (target_thread : thread_t) return int;
+ pragma Import (C, thr_continue, "thr_continue");
+
+ procedure thr_yield;
+ pragma Import (C, thr_yield, "thr_yield");
+
+ ---------
+ -- LWP --
+ ---------
+
+ P_PID : constant := 0;
+ P_LWPID : constant := 8;
+
+ PC_GETCID : constant := 0;
+ PC_GETCLINFO : constant := 1;
+ PC_SETPARMS : constant := 2;
+ PC_GETPARMS : constant := 3;
+ PC_ADMIN : constant := 4;
+
+ PC_CLNULL : constant := -1;
+
+ RT_NOCHANGE : constant := -1;
+ RT_TQINF : constant := -2;
+ RT_TQDEF : constant := -3;
+
+ PC_CLNMSZ : constant := 16;
+
+ PC_VERSION : constant := 1;
+
+ type lwpid_t is new int;
+
+ type pri_t is new short;
+
+ type id_t is new long;
+
+ P_MYID : constant := -1;
+ -- the specified LWP or process is the current one.
+
+ type struct_pcinfo is record
+ pc_cid : id_t;
+ pc_clname : String (1 .. PC_CLNMSZ);
+ rt_maxpri : short;
+ end record;
+ pragma Convention (C, struct_pcinfo);
+
+ type struct_pcparms is record
+ pc_cid : id_t;
+ rt_pri : pri_t;
+ rt_tqsecs : long;
+ rt_tqnsecs : long;
+ end record;
+ pragma Convention (C, struct_pcparms);
+
+ function priocntl
+ (ver : int;
+ id_type : int;
+ id : lwpid_t;
+ cmd : int;
+ arg : System.Address) return Interfaces.C.long;
+ pragma Import (C, priocntl, "__priocntl");
+
+ function lwp_self return lwpid_t;
+ pragma Import (C, lwp_self, "_lwp_self");
+
+ type processorid_t is new int;
+ type processorid_t_ptr is access all processorid_t;
+
+ -- Constants for function processor_bind
+
+ PBIND_QUERY : constant processorid_t := -2;
+ -- the processor bindings are not changed.
+
+ PBIND_NONE : constant processorid_t := -1;
+ -- the processor bindings of the specified LWPs are cleared.
+
+ -- Flags for function p_online
+
+ PR_OFFLINE : constant int := 1;
+ -- processor is offline, as quiet as possible
+
+ PR_ONLINE : constant int := 2;
+ -- processor online
+
+ PR_STATUS : constant int := 3;
+ -- value passed to p_online to request status
+
+ function p_online (processorid : processorid_t; flag : int) return int;
+ pragma Import (C, p_online, "p_online");
+
+ function processor_bind
+ (id_type : int;
+ id : id_t;
+ proc_id : processorid_t;
+ obind : processorid_t_ptr) return int;
+ pragma Import (C, processor_bind, "processor_bind");
+
+ procedure pthread_init;
+ -- dummy procedure to share s-intman.adb with other Solaris targets.
+
+private
+
+ type array_type_1 is array (0 .. 3) of unsigned_long;
+ type sigset_t is record
+ X_X_sigbits : array_type_1;
+ end record;
+ pragma Convention (C, sigset_t);
+
+ type pid_t is new 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 clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 0;
+
+ type struct_timeval is record
+ tv_sec : long;
+ tv_usec : long;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type thread_t is new unsigned;
+
+ type array_type_9 is array (0 .. 3) of unsigned_char;
+ type record_type_3 is record
+ flag : array_type_9;
+ Xtype : unsigned_long;
+ end record;
+ pragma Convention (C, record_type_3);
+
+ type mutex_t is record
+ flags : record_type_3;
+ lock : String (1 .. 8);
+ data : String (1 .. 8);
+ end record;
+ pragma Convention (C, mutex_t);
+
+ type cond_t is record
+ flag : array_type_9;
+ Xtype : unsigned_long;
+ data : String (1 .. 8);
+ end record;
+ pragma Convention (C, cond_t);
+
+ type thread_key_t is new unsigned;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.3 $
+-- --
+-- Copyright (C) 1998-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Solaris (native) specific version
+
+package body System.Parameters is
+
+ ------------------------
+ -- Default_Stack_Size --
+ ------------------------
+
+ function Default_Stack_Size return Size_Type is
+ begin
+ return 100_000;
+ end Default_Stack_Size;
+
+ ------------------------
+ -- Minimum_Stack_Size --
+ ------------------------
+
+ function Minimum_Stack_Size return Size_Type is
+
+ thr_min_stack : constant Size_Type := 1160;
+ -- hard coded value for Solaris 8 to avoid adding dependency on
+ -- libthread for every Ada program.
+ -- This value does not really matter anyway, since this is checked
+ -- and adjusted at the library level when creating a thread.
+
+ begin
+ return thr_min_stack;
+ end Minimum_Stack_Size;
+
+ -------------------------
+ -- Adjust_Storage_Size --
+ -------------------------
+
+ function Adjust_Storage_Size (Size : Size_Type) return Size_Type is
+ begin
+ if Size = Unspecified_Size then
+ return Default_Stack_Size;
+
+ elsif Size < Minimum_Stack_Size then
+ return Minimum_Stack_Size;
+
+ else
+ return Size;
+ end if;
+ end Adjust_Storage_Size;
+
+end System.Parameters;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (SUN Solaris Version) --
+-- --
+-- $Revision: 1.14 $
+-- --
+-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ 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 := Integer'Last;
+
+ 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 := Standard'Tick;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := Standard'Storage_Unit;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Standard'Address_Size;
+
+ -- 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;
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer
+ range 0 .. Standard'Max_Interrupt_Priority;
+
+ subtype Priority is Any_Priority
+ range 0 .. Standard'Max_Priority;
+
+ -- Functional notation is needed in the following to avoid visibility
+ -- problems when this package is compiled through rtsfind in the middle
+ -- of another compilation.
+
+ subtype Interrupt_Priority is Any_Priority
+ range
+ Standard."+" (Standard'Max_Priority, 1) ..
+ Standard'Max_Interrupt_Priority;
+
+ Default_Priority : constant Priority :=
+ Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
+
+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.
+
+ AAMP : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Denorm : constant Boolean := True;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+ High_Integrity_Mode : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := True;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+end System;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.92 $
+-- --
+-- Copyright (C) 1991-2001, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Solaris (native) version of this package
+
+-- 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 System.Tasking.Debug;
+-- used for Known_Tasks
+
+with Ada.Exceptions;
+-- used for Raise_Exception
+
+with GNAT.OS_Lib;
+-- used for String_Access, Getenv
+
+with Interfaces.C;
+-- used for int
+-- size_t
+
+with System.Interrupt_Management;
+-- used for Keep_Unmasked
+-- Abort_Task_Interrupt
+-- Interrupt_ID
+
+with System.Interrupt_Management.Operations;
+-- used for Set_Interrupt_Mask
+-- All_Tasks_Mask
+pragma Elaborate_All (System.Interrupt_Management.Operations);
+
+with System.Parameters;
+-- used for Size_Type
+
+with System.Tasking;
+-- used for Ada_Task_Control_Block
+-- Task_ID
+-- ATCB components and types
+
+with System.Task_Info;
+-- to initialize Task_Info for a C thread, in function Self
+
+with System.Soft_Links;
+-- used for Defer/Undefer_Abort
+-- to initialize TSD for a C thread, in function Self
+
+-- Note that we do not use System.Tasking.Initialization directly since
+-- this 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.Initialization
+
+with System.OS_Primitives;
+-- used for Delay_Modes
+
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+package body System.Task_Primitives.Operations is
+
+ use System.Tasking.Debug;
+ use System.Tasking;
+ use Interfaces.C;
+ use System.OS_Interface;
+ use System.Parameters;
+ use Ada.Exceptions;
+ use System.OS_Primitives;
+
+ package SSL renames System.Soft_Links;
+
+ ------------------
+ -- Local Data --
+ ------------------
+
+ ATCB_Magic_Code : constant := 16#ADAADAAD#;
+ -- This is used to allow us to catch attempts to call Self
+ -- from outside an Ada task, with high probability.
+ -- For an Ada task, Task_Wrapper.Magic_Number = ATCB_Magic_Code.
+
+ -- The following are logically constants, but need to be initialized
+ -- at run time.
+
+ Environment_Task_ID : Task_ID;
+ -- A variable to hold Task_ID for the environment task.
+ -- If we use this variable to get the Task_ID, we need the following
+ -- ATCB_Key only for non-Ada threads.
+
+ Unblocked_Signal_Mask : aliased sigset_t;
+ -- The set of signals that should unblocked in all tasks
+
+ ATCB_Key : aliased thread_key_t;
+ -- Key used to find the Ada Task_ID associated with a thread,
+ -- at least for C threads unknown to the Ada run-time system.
+
+ All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
+ -- See comments on locking rules in System.Tasking (spec).
+
+ Next_Serial_Number : Task_Serial_Number := 100;
+ -- We start at 100, to reserve some special values for
+ -- using in error checking.
+ -- The following are internal configuration constants needed.
+
+ ------------------------
+ -- Priority Support --
+ ------------------------
+
+ Dynamic_Priority_Support : constant Boolean := True;
+ -- controls whether we poll for pending priority changes during sleeps
+
+ Priority_Ceiling_Emulation : constant Boolean := True;
+ -- controls whether we emulate priority ceiling locking
+
+ -- To get a scheduling close to annex D requirements, we use the real-time
+ -- class provided for LWP's and map each task/thread to a specific and
+ -- unique LWP (there is 1 thread per LWP, and 1 LWP per thread).
+
+ -- The real time class can only be set when the process has root
+ -- priviledges, so in the other cases, we use the normal thread scheduling
+ -- and priority handling.
+
+ Using_Real_Time_Class : Boolean := False;
+ -- indicates wether the real time class is being used (i.e the process
+ -- has root priviledges).
+
+ Prio_Param : aliased struct_pcparms;
+ -- Hold priority info (Real_Time) initialized during the package
+ -- elaboration.
+
+ -------------------------------------
+ -- External Configuration Values --
+ -------------------------------------
+
+ Time_Slice_Val : Interfaces.C.long;
+ pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
+
+ Locking_Policy : Character;
+ pragma Import (C, Locking_Policy, "__gl_locking_policy");
+
+ Dispatching_Policy : Character;
+ pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
+
+ --------------------------------
+ -- Foreign Threads Detection --
+ --------------------------------
+
+ -- The following are used to allow the Self function to
+ -- automatically generate ATCB's for C threads that happen to call
+ -- Ada procedure, which in turn happen to call the Ada run-time system.
+
+ type Fake_ATCB;
+ type Fake_ATCB_Ptr is access Fake_ATCB;
+ type Fake_ATCB is record
+ Stack_Base : Interfaces.C.unsigned := 0;
+ -- A value of zero indicates the node is not in use.
+ Next : Fake_ATCB_Ptr;
+ Real_ATCB : aliased Ada_Task_Control_Block (0);
+ end record;
+
+ Fake_ATCB_List : Fake_ATCB_Ptr;
+ -- A linear linked list.
+ -- The list is protected by All_Tasks_L;
+ -- Nodes are added to this list from the front.
+ -- Once a node is added to this list, it is never removed.
+
+ Fake_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads).
+
+ Next_Fake_ATCB : Fake_ATCB_Ptr;
+ -- Used to allocate one Fake_ATCB in advance. See comment in New_Fake_ATCB
+
+ ------------
+ -- Checks --
+ ------------
+
+ Check_Count : Integer := 0;
+ Old_Owner : Task_ID;
+ Lock_Count : Integer := 0;
+ Unlock_Count : Integer := 0;
+
+ function To_Lock_Ptr is
+ new Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr);
+ function To_Task_ID is
+ new Unchecked_Conversion (Owner_ID, Task_ID);
+ function To_Owner_ID is
+ new Unchecked_Conversion (Task_ID, Owner_ID);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function sysconf (name : System.OS_Interface.int)
+ return processorid_t;
+ pragma Import (C, sysconf, "sysconf");
+
+ SC_NPROCESSORS_CONF : constant System.OS_Interface.int := 14;
+
+ function Num_Procs (name : System.OS_Interface.int := SC_NPROCESSORS_CONF)
+ return processorid_t renames sysconf;
+
+ procedure Abort_Handler
+ (Sig : Signal;
+ Code : access siginfo_t;
+ Context : access ucontext_t);
+
+ function To_thread_t is new Unchecked_Conversion
+ (Integer, System.OS_Interface.thread_t);
+
+ function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
+
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+
+ type Ptr is access Task_ID;
+ function To_Ptr is new Unchecked_Conversion (Interfaces.C.unsigned, Ptr);
+ function To_Ptr is new Unchecked_Conversion (System.Address, Ptr);
+
+ type Iptr is access Interfaces.C.unsigned;
+ function To_Iptr is new Unchecked_Conversion (Interfaces.C.unsigned, Iptr);
+
+ function Thread_Body_Access is
+ new Unchecked_Conversion (System.Address, Thread_Body);
+
+ function New_Fake_ATCB (Stack_Base : Interfaces.C.unsigned) return Task_ID;
+ -- Allocate and Initialize a new ATCB. This code can safely be called from
+ -- a foreign thread, as it doesn't access implicitely or explicitely
+ -- "self" before having initialized the new ATCB.
+
+ ------------
+ -- Checks --
+ ------------
+
+ function Check_Initialize_Lock (L : Lock_Ptr; Level : Lock_Level)
+ return Boolean;
+ pragma Inline (Check_Initialize_Lock);
+
+ function Check_Lock (L : Lock_Ptr) return Boolean;
+ pragma Inline (Check_Lock);
+
+ function Record_Lock (L : Lock_Ptr) return Boolean;
+ pragma Inline (Record_Lock);
+
+ function Check_Sleep (Reason : Task_States) return Boolean;
+ pragma Inline (Check_Sleep);
+
+ function Record_Wakeup
+ (L : Lock_Ptr;
+ Reason : Task_States) return Boolean;
+ pragma Inline (Record_Wakeup);
+
+ function Check_Wakeup
+ (T : Task_ID;
+ Reason : Task_States) return Boolean;
+ pragma Inline (Check_Wakeup);
+
+ function Check_Unlock (L : Lock_Ptr) return Boolean;
+ pragma Inline (Check_Lock);
+
+ function Check_Finalize_Lock (L : Lock_Ptr) return Boolean;
+ pragma Inline (Check_Finalize_Lock);
+
+ -------------------
+ -- New_Fake_ATCB --
+ -------------------
+
+ function New_Fake_ATCB (Stack_Base : Interfaces.C.unsigned)
+ return Task_ID
+ is
+ Self_ID : Task_ID;
+ P, Q : Fake_ATCB_Ptr;
+ Succeeded : Boolean;
+ Result : Interfaces.C.int;
+
+ begin
+ -- This section is ticklish.
+ -- We dare not call anything that might require an ATCB, until
+ -- we have the new ATCB in place.
+ -- Note: we don't use "Write_Lock (All_Tasks_L'Access);" because
+ -- we don't yet have an ATCB, and so can't pass the safety check.
+
+ Result := mutex_lock (All_Tasks_L.L'Access);
+ Q := null;
+ P := Fake_ATCB_List;
+
+ while P /= null loop
+ if P.Stack_Base = 0 then
+ Q := P;
+ elsif thr_kill (P.Real_ATCB.Common.LL.Thread, 0) /= 0 then
+ -- ????
+ -- If a C thread that has dependent Ada tasks terminates
+ -- abruptly, e.g. as a result of cancellation, any dependent
+ -- tasks are likely to hang up in termination.
+ P.Stack_Base := 0;
+ Q := P;
+ end if;
+
+ P := P.Next;
+ end loop;
+
+ if Q = null then
+
+ -- Create a new ATCB with zero entries.
+
+ Self_ID := Next_Fake_ATCB.Real_ATCB'Access;
+ Next_Fake_ATCB.Stack_Base := Stack_Base;
+ Next_Fake_ATCB.Next := Fake_ATCB_List;
+ Fake_ATCB_List := Next_Fake_ATCB;
+ Next_Fake_ATCB := null;
+
+ else
+
+ -- Reuse an existing fake ATCB.
+
+ Self_ID := Q.Real_ATCB'Access;
+ Q.Stack_Base := Stack_Base;
+ end if;
+
+ -- Do the standard initializations
+
+ System.Tasking.Initialize_ATCB
+ (Self_ID, null, Null_Address, Null_Task, Fake_Task_Elaborated'Access,
+ System.Priority'First, Task_Info.Unspecified_Task_Info, 0, Self_ID,
+ Succeeded);
+ pragma Assert (Succeeded);
+
+ -- Record this as the Task_ID for the current thread.
+
+ Self_ID.Common.LL.Thread := thr_self;
+ Result := thr_setspecific (ATCB_Key, To_Address (Self_ID));
+ pragma Assert (Result = 0);
+
+ -- Finally, it is safe to use an allocator in this thread.
+
+ if Next_Fake_ATCB = null then
+ Next_Fake_ATCB := new Fake_ATCB;
+ end if;
+
+ Self_ID.Master_of_Task := 0;
+ Self_ID.Master_Within := Self_ID.Master_of_Task + 1;
+
+ for L in Self_ID.Entry_Calls'Range loop
+ Self_ID.Entry_Calls (L).Self := Self_ID;
+ Self_ID.Entry_Calls (L).Level := L;
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ Self_ID.Awake_Count := 1;
+
+ -- Since this is not an ordinary Ada task, we will start out undeferred
+
+ Self_ID.Deferral_Level := 0;
+
+ -- 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);
+
+ System.Soft_Links.Create_TSD (Self_ID.Common.Compiler_Data);
+
+ -- ????
+ -- The following call is commented out to avoid dependence on
+ -- the System.Tasking.Initialization package.
+
+ -- It seems that if we want Ada.Task_Attributes to work correctly
+ -- for C threads we will need to raise the visibility of this soft
+ -- link to System.Soft_Links.
+
+ -- We are putting that off until this new functionality is otherwise
+ -- stable.
+
+ -- System.Tasking.Initialization.Initialize_Attributes_Link.all (T);
+
+ -- Must not unlock until Next_ATCB is again allocated.
+
+ 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;
+
+ Result := mutex_unlock (All_Tasks_L.L'Access);
+
+ -- We cannot use "Unlock (All_Tasks_L'Access);" because
+ -- we did not use Write_Lock, and so would not pass the checks.
+
+ return Self_ID;
+ end New_Fake_ATCB;
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ -- Target-dependent binding of inter-thread Abort signal to
+ -- the raising of the Abort_Signal exception.
+
+ -- The technical issues and alternatives here are essentially
+ -- the same as for raising exceptions in response to other
+ -- signals (e.g. Storage_Error). See code and comments in
+ -- the package body System.Interrupt_Management.
+
+ -- Some implementations may not allow an exception to be propagated
+ -- out of a handler, and others might leave the signal or
+ -- interrupt that invoked this handler masked after the exceptional
+ -- return to the application code.
+
+ -- GNAT exceptions are originally implemented using setjmp()/longjmp().
+ -- On most UNIX systems, this will allow transfer out of a signal handler,
+ -- which is usually the only mechanism available for implementing
+ -- asynchronous handlers of this kind. However, some
+ -- systems do not restore the signal mask on longjmp(), leaving the
+ -- abort signal masked.
+
+ -- Alternative solutions include:
+
+ -- 1. Change the PC saved in the system-dependent Context
+ -- parameter to point to code that raises the exception.
+ -- Normal return from this handler will then raise
+ -- the exception after the mask and other system state has
+ -- been restored (see example below).
+ -- 2. Use siglongjmp()/sigsetjmp() to implement exceptions.
+ -- 3. Unmask the signal in the Abortion_Signal exception handler
+ -- (in the RTS).
+
+ -- The following procedure would be needed if we can't longjmp out of
+ -- a signal handler. (See below.)
+
+ -- procedure Raise_Abort_Signal is
+ -- begin
+ -- raise Standard'Abort_Signal;
+ -- end if;
+
+ -- ???
+ -- The comments above need revising. They are partly obsolete.
+
+ procedure Abort_Handler
+ (Sig : Signal;
+ Code : access siginfo_t;
+ Context : access ucontext_t)
+ is
+ Self_ID : Task_ID := Self;
+ Result : Interfaces.C.int;
+ Old_Set : aliased sigset_t;
+
+ begin
+ -- Assuming it is safe to longjmp out of a signal handler, the
+ -- following code can be used:
+
+ if Self_ID.Deferral_Level = 0
+ and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ and then not Self_ID.Aborting
+ then
+ -- You can comment the following out,
+ -- to make all aborts synchronous, for debugging.
+
+ Self_ID.Aborting := True;
+
+ -- Make sure signals used for RTS internal purpose are unmasked
+
+ Result := thr_sigsetmask (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ raise Standard'Abort_Signal;
+
+ -- ?????
+ -- Must be certain that the implementation of "raise"
+ -- does not make any OS/thread calls, or at least that
+ -- if it makes any, they are safe for interruption by
+ -- async. signals.
+ end if;
+
+ -- Otherwise, something like this is required:
+ -- if not Abort_Is_Deferred.all then
+ -- -- Overwrite the return PC address with the address of the
+ -- -- special raise routine, and "return" to that routine's
+ -- -- starting address.
+ -- Context.PC := Raise_Abort_Signal'Address;
+ -- return;
+ -- end if;
+
+ end Abort_Handler;
+
+ -------------------
+ -- Stack_Guard --
+ -------------------
+
+ -- The underlying thread system sets a guard page at the
+ -- bottom of a thread stack, so nothing is needed.
+
+ procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ begin
+ null;
+ end Stack_Guard;
+
+ --------------------
+ -- Get_Thread_Id --
+ --------------------
+
+ function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
+ begin
+ return T.Common.LL.Thread;
+ end Get_Thread_Id;
+
+ -----------
+ -- Self --
+ -----------
+
+ function Self return Task_ID is separate;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ -- Note: mutexes and cond_variables needed per-task basis are
+ -- initialized in Intialize_TCB and the Storage_Error is
+ -- handled. Other mutexes (such as All_Tasks_L, Memory_Lock...)
+ -- used in RTS is initialized before any status change of RTS.
+ -- Therefore rasing Storage_Error in the following routines
+ -- should be able to be handled safely.
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : access Lock)
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Initialize_Lock (Lock_Ptr (L), PO_Level));
+
+ if Priority_Ceiling_Emulation then
+ L.Ceiling := Prio;
+ end if;
+
+ Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ Raise_Exception (Storage_Error'Identity, "Failed to allocate a lock");
+ end if;
+ end Initialize_Lock;
+
+ procedure Initialize_Lock
+ (L : access RTS_Lock;
+ Level : Lock_Level)
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Initialize_Lock
+ (To_Lock_Ptr (RTS_Lock_Ptr (L)), Level));
+ Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ Raise_Exception (Storage_Error'Identity, "Failed to allocate a lock");
+ end if;
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Finalize_Lock (Lock_Ptr (L)));
+ Result := mutex_destroy (L.L'Access);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Finalize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
+ Result := mutex_destroy (L.L'Access);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ ----------------
+ -- Write_Lock --
+ ----------------
+
+ procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Lock (Lock_Ptr (L)));
+
+ if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then
+ declare
+ Self_Id : constant Task_ID := Self;
+ Saved_Priority : System.Any_Priority;
+
+ begin
+ if Self_Id.Common.LL.Active_Priority > L.Ceiling then
+ Ceiling_Violation := True;
+ return;
+ end if;
+
+ Saved_Priority := Self_Id.Common.LL.Active_Priority;
+
+ if Self_Id.Common.LL.Active_Priority < L.Ceiling then
+ Set_Priority (Self_Id, L.Ceiling);
+ end if;
+
+ Result := mutex_lock (L.L'Access);
+ pragma Assert (Result = 0);
+ Ceiling_Violation := False;
+
+ L.Saved_Priority := Saved_Priority;
+ end;
+
+ else
+ Result := mutex_lock (L.L'Access);
+ pragma Assert (Result = 0);
+ Ceiling_Violation := False;
+ end if;
+
+ pragma Assert (Record_Lock (Lock_Ptr (L)));
+ end Write_Lock;
+
+ procedure Write_Lock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
+ Result := mutex_lock (L.L'Access);
+ pragma Assert (Result = 0);
+ pragma Assert (Record_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
+ Result := mutex_lock (T.Common.LL.L.L'Access);
+ pragma Assert (Result = 0);
+ pragma Assert (Record_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ Write_Lock (L, Ceiling_Violation);
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Unlock (Lock_Ptr (L)));
+
+ if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then
+ declare
+ Self_Id : constant Task_ID := Self;
+
+ begin
+ Result := mutex_unlock (L.L'Access);
+ pragma Assert (Result = 0);
+
+ if Self_Id.Common.LL.Active_Priority > L.Saved_Priority then
+ Set_Priority (Self_Id, L.Saved_Priority);
+ end if;
+ end;
+ else
+ Result := mutex_unlock (L.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+ end Unlock;
+
+ procedure Unlock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
+ Result := mutex_unlock (L.L'Access);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access)));
+ Result := mutex_unlock (T.Common.LL.L.L'Access);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ -- For the time delay implementation, we need to make sure we
+ -- achieve following criteria:
+
+ -- 1) We have to delay at least for the amount requested.
+ -- 2) We have to give up CPU even though the actual delay does not
+ -- result in blocking.
+ -- 3) Except for restricted run-time systems that do not support
+ -- ATC or task abort, the delay must be interrupted by the
+ -- abort_task operation.
+ -- 4) The implementation has to be efficient so that the delay overhead
+ -- is relatively cheap.
+ -- (1)-(3) are Ada requirements. Even though (2) is an Annex-D
+ -- requirement we still want to provide the effect in all cases.
+ -- The reason is that users may want to use short delays to implement
+ -- their own scheduling effect in the absence of language provided
+ -- scheduling policies.
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ TS : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+ return To_Duration (TS);
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ begin
+ return 10#1.0#E-6;
+ end RT_Resolution;
+
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ begin
+ if Do_Yield then
+ System.OS_Interface.thr_yield;
+ end if;
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_Priority
+ (T : Task_ID;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ Result : Interfaces.C.int;
+ Param : aliased struct_pcparms;
+
+ use Task_Info;
+
+ begin
+ T.Common.Current_Priority := Prio;
+
+ if Priority_Ceiling_Emulation then
+ T.Common.LL.Active_Priority := Prio;
+ end if;
+
+ if Using_Real_Time_Class then
+ Param.pc_cid := Prio_Param.pc_cid;
+ Param.rt_pri := pri_t (Prio);
+ Param.rt_tqsecs := Prio_Param.rt_tqsecs;
+ Param.rt_tqnsecs := Prio_Param.rt_tqnsecs;
+
+ Result := Interfaces.C.int (
+ priocntl (PC_VERSION, P_LWPID, T.Common.LL.LWP, PC_SETPARMS,
+ Param'Address));
+
+ else
+ if T.Common.Task_Info /= null
+ and then not T.Common.Task_Info.Bound_To_LWP
+ then
+ -- The task is not bound to a LWP, so use thr_setprio
+
+ Result :=
+ thr_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio));
+
+ else
+
+ -- The task is bound to a LWP, use priocntl
+ -- ??? TBD
+
+ null;
+ end if;
+ end if;
+ 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
+ Result : Interfaces.C.int;
+ Proc : processorid_t; -- User processor #
+ Last_Proc : processorid_t; -- Last processor #
+
+ use System.Task_Info;
+ begin
+ Self_ID.Common.LL.Thread := thr_self;
+
+ Self_ID.Common.LL.LWP := lwp_self;
+
+ if Self_ID.Common.Task_Info /= null then
+ if Self_ID.Common.Task_Info.New_LWP
+ and then Self_ID.Common.Task_Info.CPU /= CPU_UNCHANGED
+ then
+ Last_Proc := Num_Procs - 1;
+
+ if Self_ID.Common.Task_Info.CPU = ANY_CPU then
+ Result := 0;
+ Proc := 0;
+
+ while Proc < Last_Proc loop
+ Result := p_online (Proc, PR_STATUS);
+ exit when Result = PR_ONLINE;
+ Proc := Proc + 1;
+ end loop;
+
+ Result := processor_bind (P_LWPID, P_MYID, Proc, null);
+ pragma Assert (Result = 0);
+
+ else
+ -- Use specified processor
+
+ if Self_ID.Common.Task_Info.CPU < 0
+ or else Self_ID.Common.Task_Info.CPU > Last_Proc
+ then
+ raise Invalid_CPU_Number;
+ end if;
+
+ Result := processor_bind
+ (P_LWPID, P_MYID, Self_ID.Common.Task_Info.CPU, null);
+ pragma Assert (Result = 0);
+ end if;
+ end if;
+ end if;
+
+ Result := thr_setspecific (ATCB_Key, To_Address (Self_ID));
+ pragma Assert (Result = 0);
+
+ -- We need the above code even if we do direct fetch of Task_ID in Self
+ -- for the main task on Sun, x86 Solaris and for gcc 2.7.2.
+
+ Lock_All_Tasks_List;
+
+ for I in Known_Tasks'Range loop
+ if Known_Tasks (I) = null then
+ Known_Tasks (I) := Self_ID;
+ Self_ID.Known_Tasks_Index := I;
+ exit;
+ end if;
+ end loop;
+ Unlock_All_Tasks_List;
+ 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;
+
+ ----------------------
+ -- Initialize_TCB --
+ ----------------------
+
+ procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
+ Result : Interfaces.C.int;
+
+ 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);
+
+ Self_ID.Common.LL.Thread := To_thread_t (-1);
+ Result := mutex_init
+ (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address);
+ Self_ID.Common.LL.L.Level :=
+ Private_Task_Serial_Number (Self_ID.Serial_Number);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = 0 then
+ Result := cond_init (Self_ID.Common.LL.CV'Access, USYNC_THREAD, 0);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Result := mutex_destroy (Self_ID.Common.LL.L.L'Access);
+ pragma Assert (Result = 0);
+ Succeeded := False;
+ else
+ Succeeded := True;
+ end if;
+
+ else
+ Succeeded := False;
+ end if;
+ 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
+ Result : Interfaces.C.int;
+ Adjusted_Stack_Size : Interfaces.C.size_t;
+ Opts : Interfaces.C.int := THR_DETACHED;
+
+ Page_Size : constant System.Parameters.Size_Type := 4096;
+ -- This constant is for reserving extra space at the
+ -- end of the stack, which can be used by the stack
+ -- checking as guard page. The idea is that we need
+ -- to have at least Stack_Size bytes available for
+ -- actual use.
+
+ use System.Task_Info;
+ begin
+ if Stack_Size = System.Parameters.Unspecified_Size then
+ Adjusted_Stack_Size :=
+ Interfaces.C.size_t (Default_Stack_Size + Page_Size);
+
+ elsif Stack_Size < Minimum_Stack_Size then
+ Adjusted_Stack_Size :=
+ Interfaces.C.size_t (Minimum_Stack_Size + Page_Size);
+
+ else
+ Adjusted_Stack_Size :=
+ Interfaces.C.size_t (Stack_Size + Page_Size);
+ 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.
+
+ if T.Common.Task_Info /= null then
+
+ if T.Common.Task_Info.New_LWP then
+ Opts := Opts + THR_NEW_LWP;
+ end if;
+
+ if T.Common.Task_Info.Bound_To_LWP then
+ Opts := Opts + THR_BOUND;
+ end if;
+
+ else
+ Opts := THR_DETACHED + THR_BOUND;
+ end if;
+
+ Result := thr_create
+ (System.Null_Address,
+ Adjusted_Stack_Size,
+ Thread_Body_Access (Wrapper),
+ To_Address (T),
+ Opts,
+ T.Common.LL.Thread'Access);
+
+ Succeeded := Result = 0;
+ pragma Assert
+ (Result = 0
+ or else Result = ENOMEM
+ or else Result = EAGAIN);
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_ID) is
+ Result : Interfaces.C.int;
+ Tmp : Task_ID := T;
+
+ procedure Free is new
+ Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
+
+ begin
+ T.Common.LL.Thread := To_thread_t (0);
+ Result := mutex_destroy (T.Common.LL.L.L'Access);
+ pragma Assert (Result = 0);
+ Result := 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);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ -- This procedure must be called with abort deferred.
+ -- It can no longer call Self or access
+ -- the current task's ATCB, since the ATCB has been deallocated.
+
+ procedure Exit_Task is
+ begin
+ thr_exit (System.Null_Address);
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_ID) is
+ Result : Interfaces.C.int;
+ begin
+ pragma Assert (T /= Self);
+
+ Result := thr_kill (T.Common.LL.Thread,
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+ null;
+
+ pragma Assert (Result = 0);
+ end Abort_Task;
+
+ -------------
+ -- Sleep --
+ -------------
+
+ procedure Sleep
+ (Self_ID : Task_ID;
+ Reason : Task_States)
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Sleep (Reason));
+
+ if Dynamic_Priority_Support
+ and then Self_ID.Pending_Priority_Change
+ then
+ Self_ID.Pending_Priority_Change := False;
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
+ end if;
+
+ Result := cond_wait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access);
+ pragma Assert (Result = 0 or else Result = EINTR);
+ pragma Assert (Record_Wakeup
+ (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
+ end Sleep;
+
+ -- Note that we are relying heaviliy here on the GNAT feature
+ -- that Calendar.Time, System.Real_Time.Time, Duration, and
+ -- System.Real_Time.Time_Span are all represented in the same
+ -- way, i.e., as a 64-bit count of nanoseconds.
+
+ -- This allows us to always pass the timeout value as a Duration.
+
+ -- ???
+ -- We are taking liberties here with the semantics of the delays.
+ -- That is, we make no distinction between delays on the Calendar clock
+ -- and delays on the Real_Time clock. That is technically incorrect, if
+ -- the Calendar clock happens to be reset or adjusted.
+ -- To solve this defect will require modification to the compiler
+ -- interface, so that it can pass through more information, to tell
+ -- us here which clock to use!
+
+ -- cond_timedwait will return if any of the following happens:
+ -- 1) some other task did cond_signal on this condition variable
+ -- In this case, the return value is 0
+ -- 2) the call just returned, for no good reason
+ -- This is called a "spurious wakeup".
+ -- In this case, the return value may also be 0.
+ -- 3) the time delay expires
+ -- In this case, the return value is ETIME
+ -- 4) this task received a signal, which was handled by some
+ -- handler procedure, and now the thread is resuming execution
+ -- UNIX calls this an "interrupted" system call.
+ -- In this case, the return value is EINTR
+
+ -- If the cond_timedwait returns 0 or EINTR, it is still
+ -- possible that the time has actually expired, and by chance
+ -- a signal or cond_signal occurred at around the same time.
+
+ -- We have also observed that on some OS's the value ETIME
+ -- will be returned, but the clock will show that the full delay
+ -- has not yet expired.
+
+ -- For these reasons, we need to check the clock after return
+ -- from cond_timedwait. If the time has expired, we will set
+ -- Timedout = True.
+
+ -- This check might be omitted for systems on which the
+ -- cond_timedwait() never returns early or wakes up spuriously.
+
+ -- Annex D requires that completion of a delay cause the task
+ -- to go to the end of its priority queue, regardless of whether
+ -- the task actually was suspended by the delay. Since
+ -- cond_timedwait does not do this on Solaris, we add a call
+ -- to thr_yield at the end. We might do this at the beginning,
+ -- instead, but then the round-robin effect would not be the
+ -- same; the delayed task would be ahead of other tasks of the
+ -- same priority that awoke while it was sleeping.
+
+ -- For Timed_Sleep, we are expecting possible cond_signals
+ -- to indicate other events (e.g., completion of a RV or
+ -- completion of the abortable part of an async. select),
+ -- we want to always return if interrupted. The caller will
+ -- be responsible for checking the task state to see whether
+ -- the wakeup was spurious, and to go back to sleep again
+ -- in that case. We don't need to check for pending abort
+ -- or priority change on the way in our out; that is the
+ -- caller's responsibility.
+
+ -- For Timed_Delay, we are not expecting any cond_signals or
+ -- other interruptions, except for priority changes and aborts.
+ -- Therefore, we don't want to return unless the delay has
+ -- actually expired, or the call has been aborted. In this
+ -- case, since we want to implement the entire delay statement
+ -- semantics, we do need to check for pending abort and priority
+ -- changes. We can quietly handle priority changes inside the
+ -- procedure, since there is no entry-queue reordering involved.
+
+ -----------------
+ -- 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.
+
+ -- Yielded should be False unles we know for certain that the
+ -- operation resulted in the calling task going to the end of
+ -- the dispatching queue for its priority.
+
+ -- ???
+ -- This version presumes the worst, so Yielded is always False.
+ -- On some targets, if cond_timedwait always yields, we could
+ -- set Yielded to True just before the cond_timedwait call.
+
+ procedure Timed_Sleep
+ (Self_ID : Task_ID;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ Check_Time : constant Duration := Monotonic_Clock;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Sleep (Reason));
+ Timedout := True;
+ Yielded := False;
+
+ if Mode = Relative then
+ Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
+ else
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+ end if;
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ or else (Dynamic_Priority_Support and then
+ Self_ID.Pending_Priority_Change);
+
+ Result := cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L.L'Access, Request'Access);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ if Result = 0 or Result = EINTR then
+ -- somebody may have called Wakeup for us
+ Timedout := False;
+ exit;
+ end if;
+
+ pragma Assert (Result = ETIME);
+ end loop;
+ end if;
+
+ pragma Assert (Record_Wakeup
+ (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
+ 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
+ Check_Time : constant Duration := Monotonic_Clock;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ -- Only the little window between deferring abort and
+ -- locking Self_ID is the reason we need to
+ -- check for pending abort and priority change below!
+
+ SSL.Abort_Defer.all;
+ Write_Lock (Self_ID);
+
+ if Mode = Relative then
+ Abs_Time := Time + Check_Time;
+ else
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+ end if;
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+ Self_ID.Common.State := Delay_Sleep;
+
+ pragma Assert (Check_Sleep (Delay_Sleep));
+
+ loop
+ if Dynamic_Priority_Support and then
+ Self_ID.Pending_Priority_Change then
+ Self_ID.Pending_Priority_Change := False;
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
+ end if;
+
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Result := cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L.L'Access, Request'Access);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ pragma Assert (Result = 0 or else
+ Result = ETIME or else
+ Result = EINTR);
+ end loop;
+
+ pragma Assert (Record_Wakeup
+ (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Delay_Sleep));
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+ thr_yield;
+ SSL.Abort_Undefer.all;
+ end Timed_Delay;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup
+ (T : Task_ID;
+ Reason : Task_States)
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Wakeup (T, Reason));
+ Result := cond_signal (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+ end Wakeup;
+
+ ---------------------------
+ -- Check_Initialize_Lock --
+ ---------------------------
+
+ -- The following code is intended to check some of the invariant
+ -- assertions related to lock usage, on which we depend.
+
+ function Check_Initialize_Lock
+ (L : Lock_Ptr;
+ Level : Lock_Level)
+ return Boolean
+ is
+ Self_ID : constant Task_ID := Self;
+
+ begin
+ -- Check that caller is abort-deferred
+
+ if Self_ID.Deferral_Level <= 0 then
+ return False;
+ end if;
+
+ -- Check that the lock is not yet initialized
+
+ if L.Level /= 0 then
+ return False;
+ end if;
+
+ L.Level := Lock_Level'Pos (Level) + 1;
+ return True;
+ end Check_Initialize_Lock;
+
+ ----------------
+ -- Check_Lock --
+ ----------------
+
+ function Check_Lock (L : Lock_Ptr) return Boolean is
+ Self_ID : Task_ID := Self;
+ P : Lock_Ptr;
+
+ begin
+ -- Check that the argument is not null
+
+ if L = null then
+ return False;
+ end if;
+
+ -- Check that L is not frozen
+
+ if L.Frozen then
+ return False;
+ end if;
+
+ -- Check that caller is abort-deferred
+
+ if Self_ID.Deferral_Level <= 0 then
+ return False;
+ end if;
+
+ -- Check that caller is not holding this lock already
+
+ if L.Owner = To_Owner_ID (Self_ID) then
+ return False;
+ end if;
+
+ -- Check that TCB lock order rules are satisfied
+
+ P := Self_ID.Common.LL.Locks;
+ if P /= null then
+ if P.Level >= L.Level
+ and then (P.Level > 2 or else L.Level > 2)
+ then
+ return False;
+ end if;
+ end if;
+
+ return True;
+ end Check_Lock;
+
+ -----------------
+ -- Record_Lock --
+ -----------------
+
+ function Record_Lock (L : Lock_Ptr) return Boolean is
+ Self_ID : Task_ID := Self;
+ P : Lock_Ptr;
+
+ begin
+ Lock_Count := Lock_Count + 1;
+
+ -- There should be no owner for this lock at this point
+
+ if L.Owner /= null then
+ return False;
+ end if;
+
+ -- Record new owner
+
+ L.Owner := To_Owner_ID (Self_ID);
+
+ -- Check that TCB lock order rules are satisfied
+
+ P := Self_ID.Common.LL.Locks;
+
+ if P /= null then
+ L.Next := P;
+ end if;
+
+ Self_ID.Common.LL.Locking := null;
+ Self_ID.Common.LL.Locks := L;
+ return True;
+ end Record_Lock;
+
+ -----------------
+ -- Check_Sleep --
+ -----------------
+
+ function Check_Sleep (Reason : Task_States) return Boolean is
+ Self_ID : Task_ID := Self;
+ P : Lock_Ptr;
+
+ begin
+ -- Check that caller is abort-deferred
+
+ if Self_ID.Deferral_Level <= 0 then
+ return False;
+ end if;
+
+ -- Check that caller is holding own lock, on top of list
+
+ if Self_ID.Common.LL.Locks /=
+ To_Lock_Ptr (Self_ID.Common.LL.L'Access)
+ then
+ return False;
+ end if;
+
+ -- Check that TCB lock order rules are satisfied
+
+ if Self_ID.Common.LL.Locks.Next /= null then
+ return False;
+ end if;
+
+ Self_ID.Common.LL.L.Owner := null;
+ P := Self_ID.Common.LL.Locks;
+ Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next;
+ P.Next := null;
+ return True;
+ end Check_Sleep;
+
+ -------------------
+ -- Record_Wakeup --
+ -------------------
+
+ function Record_Wakeup
+ (L : Lock_Ptr;
+ Reason : Task_States)
+ return Boolean
+ is
+ Self_ID : Task_ID := Self;
+ P : Lock_Ptr;
+
+ begin
+ -- Record new owner
+
+ L.Owner := To_Owner_ID (Self_ID);
+
+ -- Check that TCB lock order rules are satisfied
+
+ P := Self_ID.Common.LL.Locks;
+
+ if P /= null then
+ L.Next := P;
+ end if;
+
+ Self_ID.Common.LL.Locking := null;
+ Self_ID.Common.LL.Locks := L;
+ return True;
+ end Record_Wakeup;
+
+ ------------------
+ -- Check_Wakeup --
+ ------------------
+
+ function Check_Wakeup
+ (T : Task_ID;
+ Reason : Task_States)
+ return Boolean
+ is
+ Self_ID : Task_ID := Self;
+
+ begin
+ -- Is caller holding T's lock?
+
+ if T.Common.LL.L.Owner /= To_Owner_ID (Self_ID) then
+ return False;
+ end if;
+
+ -- Are reasons for wakeup and sleep consistent?
+
+ if T.Common.State /= Reason then
+ return False;
+ end if;
+
+ return True;
+ end Check_Wakeup;
+
+ ------------------
+ -- Check_Unlock --
+ ------------------
+
+ function Check_Unlock (L : Lock_Ptr) return Boolean is
+ Self_ID : Task_ID := Self;
+ P : Lock_Ptr;
+
+ begin
+ Unlock_Count := Unlock_Count + 1;
+
+ if L = null then
+ return False;
+ end if;
+
+ if L.Buddy /= null then
+ return False;
+ end if;
+
+ if L.Level = 4 then
+ Check_Count := Unlock_Count;
+ end if;
+
+ if Unlock_Count - Check_Count > 1000 then
+ Check_Count := Unlock_Count;
+ Old_Owner := To_Task_ID (All_Tasks_L.Owner);
+ end if;
+
+ -- Check that caller is abort-deferred
+
+ if Self_ID.Deferral_Level <= 0 then
+ return False;
+ end if;
+
+ -- Check that caller is holding this lock, on top of list
+
+ if Self_ID.Common.LL.Locks /= L then
+ return False;
+ end if;
+
+ -- Record there is no owner now
+
+ L.Owner := null;
+ P := Self_ID.Common.LL.Locks;
+ Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next;
+ P.Next := null;
+ return True;
+ end Check_Unlock;
+
+ --------------------
+ -- Check_Finalize --
+ --------------------
+
+ function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is
+ Self_ID : Task_ID := Self;
+
+ begin
+ -- Check that caller is abort-deferred
+
+ if Self_ID.Deferral_Level <= 0 then
+ return False;
+ end if;
+
+ -- Check that no one is holding this lock
+
+ if L.Owner /= null then
+ return False;
+ end if;
+
+ L.Frozen := True;
+ return True;
+ end Check_Finalize_Lock;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ function Check_Exit (Self_ID : Task_ID) return Boolean is
+ begin
+ -- Check that caller is just holding Global_Task_Lock
+ -- and no other locks
+
+ if Self_ID.Common.LL.Locks = null then
+ return False;
+ end if;
+
+ -- 2 = Global_Task_Level
+
+ if Self_ID.Common.LL.Locks.Level /= 2 then
+ return False;
+ end if;
+
+ if Self_ID.Common.LL.Locks.Next /= null then
+ return False;
+ end if;
+
+ -- Check that caller is abort-deferred
+
+ if Self_ID.Deferral_Level <= 0 then
+ return False;
+ end if;
+
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : Task_ID) return Boolean is
+ begin
+ return Self_ID.Common.LL.Locks = null;
+ end Check_No_Locks;
+
+ ----------------------
+ -- Environment_Task --
+ ----------------------
+
+ function Environment_Task return Task_ID is
+ begin
+ return Environment_Task_ID;
+ end Environment_Task;
+
+ -------------------------
+ -- Lock_All_Tasks_List --
+ -------------------------
+
+ procedure Lock_All_Tasks_List is
+ begin
+ Write_Lock (All_Tasks_L'Access);
+ end Lock_All_Tasks_List;
+
+ ---------------------------
+ -- Unlock_All_Tasks_List --
+ ---------------------------
+
+ procedure Unlock_All_Tasks_List is
+ begin
+ Unlock (All_Tasks_L'Access);
+ end Unlock_All_Tasks_List;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ if T.Common.LL.Thread /= Thread_Self then
+ return thr_suspend (T.Common.LL.Thread) = 0;
+ else
+ return True;
+ end if;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ if T.Common.LL.Thread /= Thread_Self then
+ return thr_continue (T.Common.LL.Thread) = 0;
+ else
+ return True;
+ end if;
+ end Resume_Task;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : ST.Task_ID) is
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Tmp_Set : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ procedure Configure_Processors;
+ -- Processors configuration
+ -- The user can specify a processor which the program should run
+ -- on to emulate a single-processor system. This can be easily
+ -- done by setting environment variable GNAT_PROCESSOR to one of
+ -- the following :
+ --
+ -- -2 : use the default configuration (run the program on all
+ -- available processors) - this is the same as having
+ -- GNAT_PROCESSOR unset
+ -- -1 : let the RTS choose one processor and run the program on
+ -- that processor
+ -- 0 .. Last_Proc : run the program on the specified processor
+ --
+ -- Last_Proc is equal to the value of the system variable
+ -- _SC_NPROCESSORS_CONF, minus one.
+
+ procedure Configure_Processors is
+
+ Proc_Acc : constant GNAT.OS_Lib.String_Access :=
+ GNAT.OS_Lib.Getenv ("GNAT_PROCESSOR");
+ begin
+ if Proc_Acc.all'Length /= 0 then
+
+ -- Environment variable is defined
+
+ declare
+ Proc : aliased processorid_t; -- User processor #
+ Last_Proc : processorid_t; -- Last processor #
+
+ begin
+ Last_Proc := Num_Procs - 1;
+
+ if Last_Proc = -1 then
+
+ -- Unable to read system variable _SC_NPROCESSORS_CONF
+ -- Ignore environment variable GNAT_PROCESSOR
+
+ null;
+
+ else
+ Proc := processorid_t'Value (Proc_Acc.all);
+
+ if Proc < -2 or Proc > Last_Proc then
+ raise Constraint_Error;
+
+ elsif Proc = -2 then
+
+ -- Use the default configuration
+
+ null;
+
+ elsif Proc = -1 then
+
+ -- Choose a processor
+
+ Result := 0;
+ while Proc < Last_Proc loop
+ Proc := Proc + 1;
+ Result := p_online (Proc, PR_STATUS);
+ exit when Result = PR_ONLINE;
+ end loop;
+
+ pragma Assert (Result = PR_ONLINE);
+ Result := processor_bind (P_PID, P_MYID, Proc, null);
+ pragma Assert (Result = 0);
+
+ else
+ -- Use user processor
+
+ Result := processor_bind (P_PID, P_MYID, Proc, null);
+ pragma Assert (Result = 0);
+ end if;
+ end if;
+
+ exception
+ when Constraint_Error =>
+
+ -- Illegal environment variable GNAT_PROCESSOR - ignored
+
+ null;
+ end;
+ end if;
+ end Configure_Processors;
+
+ -- Start of processing for Initialize
+
+ begin
+ Environment_Task_ID := Environment_Task;
+
+ -- This is done in Enter_Task, but this is too late for the
+ -- Environment Task, since we need to call Self in Check_Locks when
+ -- the run time is compiled with assertions on.
+
+ Result := thr_setspecific (ATCB_Key, To_Address (Environment_Task));
+ pragma Assert (Result = 0);
+
+ -- Initialize the lock used to synchronize chain of all ATCBs.
+
+ Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
+
+ Enter_Task (Environment_Task);
+
+ -- Install the abort-signal handler
+
+ -- Set sa_flags to SA_NODEFER so that during the handler execution
+ -- we do not change the Signal_Mask to be masked for the Abort_Signal.
+ -- This is a temporary fix to the problem that the Signal_Mask is
+ -- not restored after the exception (longjmp) from the handler.
+ -- The right fix should be made in sigsetjmp so that we save
+ -- the Signal_Set and restore it after a longjmp.
+ -- In that case, this field should be changed back to 0. ???
+
+ act.sa_flags := 16;
+
+ 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);
+
+ Configure_Processors;
+
+ -- Create a free ATCB for use on the Fake_ATCB_List.
+
+ Next_Fake_ATCB := new Fake_ATCB;
+ end Initialize;
+
+-- Package elaboration
+
+begin
+ declare
+ Result : Interfaces.C.int;
+
+ begin
+ -- Mask Environment task for all signals. The original mask of the
+ -- Environment task will be recovered by Interrupt_Server task
+ -- during the elaboration of s-interr.adb.
+
+ System.Interrupt_Management.Operations.Set_Interrupt_Mask
+ (System.Interrupt_Management.Operations.All_Tasks_Mask'Access);
+
+ -- 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;
+
+ -- We need the following code to support automatic creation of fake
+ -- ATCB's for C threads that call the Ada run-time system, even if
+ -- we use a faster way of getting Self for real Ada tasks.
+
+ Result := thr_keycreate (ATCB_Key'Access, System.Null_Address);
+ pragma Assert (Result = 0);
+ end;
+
+ if Dispatching_Policy = 'F' then
+ declare
+ Result : Interfaces.C.long;
+ Class_Info : aliased struct_pcinfo;
+ Secs, Nsecs : Interfaces.C.long;
+
+ begin
+
+ -- If a pragma Time_Slice is specified, takes the value in account.
+
+ if Time_Slice_Val > 0 then
+ -- Convert Time_Slice_Val (microseconds) into seconds and
+ -- nanoseconds
+
+ Secs := Time_Slice_Val / 1_000_000;
+ Nsecs := (Time_Slice_Val rem 1_000_000) * 1_000;
+
+ -- Otherwise, default to no time slicing (i.e run until blocked)
+
+ else
+ Secs := RT_TQINF;
+ Nsecs := RT_TQINF;
+ end if;
+
+ -- Get the real time class id.
+
+ Class_Info.pc_clname (1) := 'R';
+ Class_Info.pc_clname (2) := 'T';
+ Class_Info.pc_clname (3) := ASCII.Nul;
+
+ Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_GETCID,
+ Class_Info'Address);
+
+ -- Request the real time class
+
+ Prio_Param.pc_cid := Class_Info.pc_cid;
+ Prio_Param.rt_pri := pri_t (Class_Info.rt_maxpri);
+ Prio_Param.rt_tqsecs := Secs;
+ Prio_Param.rt_tqnsecs := Nsecs;
+
+ Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_SETPARMS,
+ Prio_Param'Address);
+
+ Using_Real_Time_Class := Result /= -1;
+ end;
+ end if;
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 1992-1998 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package body contains the routines associated with the implementation
+-- of the Task_Info pragma.
+
+-- This is the Solaris (native) version of this module.
+
+package body System.Task_Info is
+
+ function Unbound_Thread_Attributes return Thread_Attributes is
+ begin
+ return (False, False);
+ end Unbound_Thread_Attributes;
+
+ function Bound_Thread_Attributes return Thread_Attributes is
+ begin
+ return (False, True);
+ end Bound_Thread_Attributes;
+
+ function Bound_Thread_Attributes (CPU : CPU_Number)
+ return Thread_Attributes is
+ begin
+ return (True, True, CPU);
+ end Bound_Thread_Attributes;
+
+ function New_Unbound_Thread_Attributes return Task_Info_Type is
+ begin
+ return new Thread_Attributes' (False, False);
+ end New_Unbound_Thread_Attributes;
+
+ function New_Bound_Thread_Attributes return Task_Info_Type is
+ begin
+ return new Thread_Attributes' (False, True);
+ end New_Bound_Thread_Attributes;
+
+ function New_Bound_Thread_Attributes (CPU : CPU_Number)
+ return Task_Info_Type is
+ begin
+ return new Thread_Attributes' (True, True, CPU);
+ end New_Bound_Thread_Attributes;
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $
+-- --
+-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the definitions and routines associated with the
+-- implementation of the Task_Info pragma.
+
+-- This is the Solaris (native) version of this module.
+
+with System.OS_Interface;
+with Unchecked_Deallocation;
+package System.Task_Info is
+pragma Elaborate_Body;
+-- To ensure that a body is allowed
+
+ -----------------------------------------------------
+ -- Binding of Tasks to LWPs and LWPs to processors --
+ -----------------------------------------------------
+
+ -- The Solaris implementation of the GNU Low-Level Interface (GNULLI)
+ -- implements each Ada task as a Solaris thread. The Solaris thread
+ -- library distributes threads across one or more LWPs (Light Weight
+ -- Process) that are members of the same process. Solaris distributes
+ -- processes and LWPs across the available CPUs on a given machine. The
+ -- pragma Task_Info provides the mechanism to control the distribution
+ -- of tasks to LWPs, and LWPs to processors.
+
+ -- Each thread has a number of attributes that dictate it's scheduling.
+ -- These attributes are:
+ --
+ -- New_LWP: whether a new LWP is created for this thread.
+ --
+ -- Bound_To_LWP: whether the thread is bound to a specific LWP
+ -- for its entire lifetime.
+ --
+ -- CPU: the CPU number associated to the LWP
+ --
+
+ -- The Task_Info pragma:
+
+ -- pragma Task_Info (EXPRESSION);
+
+ -- allows the specification on a task by task basis of a value of type
+ -- System.Task_Info.Task_Info_Type to be passed to a task when it is
+ -- created. The specification of this type, and the effect on the task
+ -- that is created is target dependent.
+
+ -- The Task_Info pragma appears within a task definition (compare the
+ -- definition and implementation of pragma Priority). If no such pragma
+ -- appears, then the value Task_Info_Unspecified is passed. If a pragma
+ -- is present, then it supplies an alternative value. If the argument of
+ -- the pragma is a discriminant reference, then the value can be set on
+ -- a task by task basis by supplying the appropriate discriminant value.
+
+ -- Note that this means that the type used for Task_Info_Type must be
+ -- suitable for use as a discriminant (i.e. a scalar or access type).
+
+ -----------------------
+ -- Thread Attributes --
+ -----------------------
+
+ subtype CPU_Number is System.OS_Interface.processorid_t;
+
+ CPU_UNCHANGED : constant CPU_Number := System.OS_Interface.PBIND_QUERY;
+ -- Do not bind the LWP to a specific processor
+
+ ANY_CPU : constant CPU_Number := System.OS_Interface.PBIND_NONE;
+ -- Bind the LWP to any processor
+
+ Invalid_CPU_Number : exception;
+
+ type Thread_Attributes (New_LWP : Boolean) is record
+ Bound_To_LWP : Boolean := True;
+ case New_LWP is
+ when False =>
+ null;
+ when True =>
+ CPU : CPU_Number := CPU_UNCHANGED;
+ end case;
+ end record;
+
+ Default_Thread_Attributes : constant Thread_Attributes := (False, True);
+
+ function Unbound_Thread_Attributes
+ return Thread_Attributes;
+
+ function Bound_Thread_Attributes
+ return Thread_Attributes;
+
+ function Bound_Thread_Attributes (CPU : CPU_Number)
+ return Thread_Attributes;
+
+ type Task_Info_Type is access all Thread_Attributes;
+
+ function New_Unbound_Thread_Attributes
+ return Task_Info_Type;
+
+ function New_Bound_Thread_Attributes
+ return Task_Info_Type;
+
+ function New_Bound_Thread_Attributes (CPU : CPU_Number)
+ return Task_Info_Type;
+
+ type Task_Image_Type is access String;
+ -- Used to generate a meaningful identifier for tasks that are variables
+ -- and components of variables.
+
+ procedure Free_Task_Image is new
+ Unchecked_Deallocation (String, Task_Image_Type);
+
+ Unspecified_Task_Info : constant Task_Info_Type := null;
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.14 $
+-- --
+-- Copyright (C) 1992-2000, 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Solaris version of this package.
+-- It was created by hand for use with new "checked"
+-- GNULLI primitives.
+
+-- This package provides low-level support for most tasking features.
+
+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 System.OS_Interface;
+-- used for mutex_t
+-- cond_t
+-- thread_t
+
+package System.Task_Primitives is
+ pragma Preelaborate;
+
+ type Lock is limited private;
+ type Lock_Ptr is access all Lock;
+ -- Should be used for implementation of protected objects.
+
+ type RTS_Lock is limited private;
+ type RTS_Lock_Ptr is access all RTS_Lock;
+ -- Should be used inside the runtime system.
+ -- The difference between Lock and the RTS_Lock is that the later
+ -- one serves only as a semaphore so that do not check for
+ -- ceiling violations.
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper
+ -- declared local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task
+ -- basis. A component of this type is guaranteed to be included
+ -- in the Ada_Task_Control_Block.
+
+private
+
+ type Private_Task_Serial_Number is mod 2 ** 64;
+ -- Used to give each task a unique serial number.
+
+ type Base_Lock is new System.OS_Interface.mutex_t;
+
+ type Owner_Int is new Integer;
+ for Owner_Int'Alignment use Standard'Maximum_Alignment;
+
+ type Owner_ID is access all Owner_Int;
+
+ type Lock is record
+ L : aliased Base_Lock;
+ Ceiling : System.Any_Priority := System.Any_Priority'First;
+ Saved_Priority : System.Any_Priority := System.Any_Priority'First;
+ Owner : Owner_ID;
+ Next : Lock_Ptr;
+ Level : Private_Task_Serial_Number := 0;
+ Buddy : Owner_ID;
+ Frozen : Boolean := False;
+ end record;
+
+ type RTS_Lock is new Lock;
+
+ -- Note that task support on gdb relies on the fact that the first
+ -- 2 fields of Private_Data are Thread and LWP.
+
+ type Private_Data is record
+ Thread : aliased System.OS_Interface.thread_t;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb).
+ -- They put the same value (thr_self value). We do not want to
+ -- use lock on those operations and the only thing we have to
+ -- make sure is that they are updated in atomic fashion.
+
+ LWP : System.OS_Interface.lwpid_t;
+ -- The LWP id of the thread. Set by self in Enter_Task.
+
+ CV : aliased System.OS_Interface.cond_t;
+ L : aliased RTS_Lock;
+ -- protection for all components is lock L
+
+ Active_Priority : System.Any_Priority := System.Any_Priority'First;
+ -- Simulated active priority,
+ -- used only if Priority_Ceiling_Support is True.
+
+ Locking : Lock_Ptr;
+ Locks : Lock_Ptr;
+ Wakeups : Natural := 0;
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SELF --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1991-1998, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Solaris Sparc (native) version of this package.
+
+with System.Machine_Code;
+-- used for Asm
+
+separate (System.Task_Primitives.Operations)
+
+----------
+-- Self --
+----------
+
+-- For Solaris version of RTS, we use a short cut to get the self
+-- information faster:
+
+-- We have noticed that on Sparc Solaris, the register g7 always
+-- contains the address near the frame pointer (fp) of the active
+-- thread (fixed offset). This means, if we declare a variable near
+-- the top of the stack for each threads (in our case in the task wrapper)
+-- and let the variable hold the Task_ID information, we can get the
+-- value without going through the thr_getspecific kernel call.
+--
+-- There are two things to take care in this trick.
+--
+-- 1) We need to calculate the offset between the g7 value and the
+-- local variable address.
+-- Possible Solutions :
+-- a) Use gdb to figure out the offset.
+-- b) Figure it out during the elaboration of RTS by, say,
+-- creating a dummy task.
+-- We used solution a) mainly because it is more efficient and keeps
+-- the RTS from being cluttered with stuff that we won't be used
+-- for all environments (i.e., we would have to at least introduce
+-- new interfaces).
+--
+-- On Sparc Solaris the offset was #10#108# (= #16#6b#) with gcc 2.7.2.
+-- With gcc 2.8.0, the offset is #10#116# (= #16#74#).
+--
+-- 2) We can not use the same offset business for the main thread
+-- because we do not use a wrapper for the main thread.
+-- Previousely, we used the difference between g7 and fp to determine
+-- wether a task was the main task or not. But this was obviousely
+-- wrong since it worked only for tasks that use small amount of
+-- stack.
+-- So, we now take advantage of the code that recognizes foreign
+-- threads (see below) for the main task.
+--
+-- NOTE: What we are doing here is ABSOLUTELY for Solaris 2.4, 2.5 and 2.6
+-- on Sun.
+
+-- We need to make sure this is OK when we move to other versions
+-- of the same OS.
+
+-- We always can go back to the old way of doing this and we include
+-- the code which use thr_getspecifics. Also, look for %%%%%
+-- in comments for other necessary modifications.
+
+-- This code happens to work with Solaris 2.5.1 too, but with gcc
+-- 2.8.0, this offset is different.
+
+-- ??? Try to rethink the approach here to get a more flexible
+-- solution at run time ?
+
+-- One other solution (close to 1-b) would be to add some scanning
+-- routine in Enter_Task to compute the offset since now we have
+-- a magic number at the beginning of the task code.
+
+-- function Self return Task_ID is
+-- Temp : aliased System.Address;
+-- Result : Interfaces.C.int;
+--
+-- begin
+-- Result := thr_getspecific (ATCB_Key, Temp'Unchecked_Access);
+-- pragma Assert (Result = 0);
+-- return To_Task_ID (Temp);
+-- end 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 run-time 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.
+
+-- (The entire Ada run-time system may not have been elaborated,
+-- either, but that is a different problem, that we will need to
+-- solve another way.)
+
+-- 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.
+
+-- We will also use such points to poll for disappearance of the
+-- threads associated with any implicit ATCBs that we created
+-- earlier, and take the opportunity to recover them.
+
+-- A nasty problem here is the limitations of the compilation
+-- order dependency, and in particular the GNARL/GNULLI layering.
+-- To initialize an ATCB we need to assume System.Tasking has
+-- been elaborated.
+
+function Self return Task_ID is
+ X : Ptr;
+ Result : Interfaces.C.int;
+
+ function Get_G7 return Interfaces.C.unsigned;
+ pragma Inline (Get_G7);
+
+ use System.Machine_Code;
+
+ ------------
+ -- Get_G7 --
+ ------------
+
+ function Get_G7 return Interfaces.C.unsigned is
+ Result : Interfaces.C.unsigned;
+
+ begin
+ Asm ("mov %%g7,%0", Interfaces.C.unsigned'Asm_Output ("=r", Result));
+ return Result;
+ end Get_G7;
+
+-- Start of processing for Self
+
+begin
+ if To_Iptr (Get_G7 - 120).all /=
+ Interfaces.C.unsigned (ATCB_Magic_Code)
+ then
+ -- Check whether this is a thread we have seen before (e.g the
+ -- main task).
+ -- 120 = 116 + Magic_Type'Size/System.Storage_Unit
+
+ declare
+ Unknown_Task : aliased System.Address;
+
+ begin
+ Result :=
+ thr_getspecific (ATCB_Key, Unknown_Task'Unchecked_Access);
+
+ pragma Assert (Result = 0);
+
+ if Unknown_Task = System.Null_Address then
+
+ -- We are seeing this thread for the first time.
+
+ return New_Fake_ATCB (Get_G7);
+
+ else
+ return To_Task_ID (Unknown_Task);
+ end if;
+ end;
+ end if;
+
+ X := To_Ptr (Get_G7 - 116);
+ return X.all;
+
+end Self;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 1998-2001 Free Software Foundation --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the SPARC64 VxWorks version of this package.
+
+with Interfaces.C;
+
+package System.VxWorks is
+ pragma Preelaborate (System.VxWorks);
+
+ package IC renames Interfaces.C;
+
+ -- Define enough of a Wind Task Control Block in order to
+ -- obtain the inherited priority. When porting this to
+ -- different versions of VxWorks (this is based on 5.3[.1]),
+ -- be sure to look at the definition for WIND_TCB located
+ -- in $WIND_BASE/target/h/taskLib.h
+
+ type Wind_Fill_1 is array (0 .. 16#3F#) of IC.unsigned_char;
+ type Wind_Fill_2 is array (16#48# .. 16#107#) of IC.unsigned_char;
+
+ type Wind_TCB is record
+ Fill_1 : Wind_Fill_1; -- 0x00 - 0x3f
+ Priority : IC.int; -- 0x40 - 0x43, current (inherited) priority
+ Normal_Priority : IC.int; -- 0x44 - 0x47, base priority
+ Fill_2 : Wind_Fill_2; -- 0x48 - 0x107
+ spare1 : Address; -- 0x108 - 0x10b
+ spare2 : Address; -- 0x10c - 0x10f
+ spare3 : Address; -- 0x110 - 0x113
+ spare4 : Address; -- 0x114 - 0x117
+ end record;
+ type Wind_TCB_Ptr is access Wind_TCB;
+
+ -- Floating point context record. SPARCV9 version
+
+ FP_NUM_DREGS : constant := 32;
+
+ type RType is new Interfaces.Unsigned_64;
+ for RType'Alignment use 8;
+
+ type Fpd_Array is array (1 .. FP_NUM_DREGS) of RType;
+ for Fpd_Array'Alignment use 8;
+
+ type FP_CONTEXT is record
+ fpd : Fpd_Array;
+ fsr : RType;
+ end record;
+
+ for FP_CONTEXT'Alignment use 8;
+ pragma Convention (C, FP_CONTEXT);
+
+ -- Number of entries in hardware interrupt vector table. Value of
+ -- 0 disables hardware interrupt handling until we have time to test it
+ -- on this target.
+ Num_HW_Interrupts : constant := 0;
+
+ -- VxWorks 5.3 and 5.4 version
+ type TASK_DESC is record
+ td_id : IC.int; -- task id
+ td_name : Address; -- name of task
+ td_priority : IC.int; -- task priority
+ td_status : IC.int; -- task status
+ td_options : IC.int; -- task option bits (see below)
+ td_entry : Address; -- original entry point of task
+ td_sp : Address; -- saved stack pointer
+ td_pStackBase : Address; -- the bottom of the stack
+ td_pStackLimit : Address; -- the effective end of the stack
+ td_pStackEnd : Address; -- the actual end of the stack
+ td_stackSize : IC.int; -- size of stack in bytes
+ td_stackCurrent : IC.int; -- current stack usage in bytes
+ td_stackHigh : IC.int; -- maximum stack usage in bytes
+ td_stackMargin : IC.int; -- current stack margin in bytes
+ td_errorStatus : IC.int; -- most recent task error status
+ td_delay : IC.int; -- delay/timeout ticks
+ end record;
+ pragma Convention (C, TASK_DESC);
+
+end System.VxWorks;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.26 $
+-- --
+-- Copyright (C) 1997-2001, 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Solaris (FSU THREADS) version of this package.
+
+-- This package includes all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lgthreads");
+ pragma Linker_Options ("-lmalloc");
+
+ 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 := 145;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 45;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ SIGWINCH : constant := 20; -- window size change
+ SIGURG : constant := 21; -- urgent condition on IO channel
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias)
+ SIGSTOP : constant := 23; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 24; -- user stop requested from tty
+ SIGCONT : constant := 25; -- stopped process has been continued
+ SIGTTIN : constant := 26; -- background tty read attempted
+ SIGTTOU : constant := 27; -- background tty write attempted
+ SIGVTALRM : constant := 28; -- virtual timer expired
+ SIGPROF : constant := 29; -- profiling timer expired
+ SIGXCPU : constant := 30; -- CPU time limit exceeded
+ SIGXFSZ : constant := 31; -- filesize limit exceeded
+ SIGWAITING : constant := 32; -- process's lwps blocked (Solaris)
+ SIGLWP : constant := 33; -- used by thread library (Solaris)
+ SIGFREEZE : constant := 34; -- used by CPR (Solaris)
+ SIGTHAW : constant := 35; -- used by CPR (Solaris)
+ SIGCANCEL : constant := 36; -- used for thread cancel (Solaris)
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set :=
+ (SIGTRAP, SIGLWP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF);
+
+ Reserved : constant Signal_Set :=
+ (SIGKILL, SIGSTOP, SIGALRM, SIGVTALRM, SIGWAITING);
+
+ 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 union_type_3 is new String (1 .. 116);
+ type siginfo_t is record
+ si_signo : int;
+ si_code : int;
+ si_errno : int;
+ X_data : union_type_3;
+ end record;
+ pragma Convention (C, siginfo_t);
+
+ -- The types mcontext_t and gregset_t are part of the ucontext_t
+ -- information, which is specific to Solaris2.4 for SPARC
+ -- The ucontext_t info seems to be used by the handler
+ -- for SIGSEGV to decide whether it is a Storage_Error (stack overflow) or
+ -- a Constraint_Error (bad pointer). The original code that did this
+ -- is suspect, so it is not clear whether we really need this part of
+ -- the signal context information, or perhaps something else.
+ -- More analysis is needed, after which these declarations may need to
+ -- be changed.
+
+ EMT_TAGOVF : constant := 1; -- tag overflow
+ FPE_INTDIV : constant := 1; -- integer divide by zero
+ FPE_INTOVF : constant := 2; -- integer overflow
+ FPE_FLTDIV : constant := 3; -- floating point divide by zero
+ FPE_FLTOVF : constant := 4; -- floating point overflow
+ FPE_FLTUND : constant := 5; -- floating point underflow
+ FPE_FLTRES : constant := 6; -- floating point inexact result
+ FPE_FLTINV : constant := 7; -- invalid floating point operation
+ FPE_FLTSUB : constant := 8; -- subscript out of range
+
+ SEGV_MAPERR : constant := 1; -- address not mapped to object
+ SEGV_ACCERR : constant := 2; -- invalid permissions
+
+ BUS_ADRALN : constant := 1; -- invalid address alignment
+ BUS_ADRERR : constant := 2; -- non-existent physical address
+ BUS_OBJERR : constant := 3; -- object specific hardware error
+
+ ILL_ILLOPC : constant := 1; -- illegal opcode
+ ILL_ILLOPN : constant := 2; -- illegal operand
+ ILL_ILLADR : constant := 3; -- illegal addressing mode
+ ILL_ILLTRP : constant := 4; -- illegal trap
+ ILL_PRVOPC : constant := 5; -- privileged opcode
+ ILL_PRVREG : constant := 6; -- privileged register
+ ILL_COPROC : constant := 7; -- co-processor
+ ILL_BADSTK : constant := 8; -- bad stack
+
+ type greg_t is new int;
+
+ type gregset_t is array (Integer range 0 .. 18) of greg_t;
+
+ REG_O0 : constant := 11;
+ -- index of saved register O0 in ucontext.uc_mcontext.gregs array
+
+ type union_type_2 is new String (1 .. 128);
+ type record_type_1 is record
+ fpu_fr : union_type_2;
+ fpu_q : System.Address;
+ fpu_fsr : unsigned;
+ fpu_qcnt : unsigned_char;
+ fpu_q_entrysize : unsigned_char;
+ fpu_en : unsigned_char;
+ end record;
+ pragma Convention (C, record_type_1);
+ type array_type_7 is array (Integer range 0 .. 20) of long;
+ type mcontext_t is record
+ gregs : gregset_t;
+ gwins : System.Address;
+ fpregs : record_type_1;
+ filler : array_type_7;
+ end record;
+ pragma Convention (C, mcontext_t);
+
+ type record_type_2 is record
+ ss_sp : System.Address;
+ ss_size : int;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, record_type_2);
+ type array_type_8 is array (Integer range 0 .. 22) of long;
+ type ucontext_t is record
+ uc_flags : unsigned_long;
+ uc_link : System.Address;
+ uc_sigmask : sigset_t;
+ uc_stack : record_type_2;
+ uc_mcontext : mcontext_t;
+ uc_filler : array_type_8;
+ end record;
+ pragma Convention (C, ucontext_t);
+
+ type Signal_Handler is access procedure
+ (signo : Signal;
+ info : access siginfo_t;
+ context : access ucontext_t);
+
+ type union_type_1 is new plain_char;
+ type array_type_2 is array (Integer range 0 .. 1) of int;
+ type struct_sigaction is record
+ sa_flags : int;
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_resv : array_type_2;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ 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 := False;
+ -- Indicates wether time slicing is supported (i.e FSU threads have been
+ -- compiled with DEF_RR)
+
+ type timespec is private;
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "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_timeval is private;
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 0;
+ SCHED_RR : constant := 1;
+ SCHED_OTHER : constant := 2;
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- 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;
+ 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;
+
+ -----------
+ -- Stack --
+ -----------
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates wether the stack base is available on this target.
+ -- This allows us to share s-osinte.adb between all the FSU run time.
+ -- Note that this value can only be true if pthread_t has a complete
+ -- definition that corresponds exactly to the C header files.
+
+ 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_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
+
+ PROT_ON : constant := PROT_NONE;
+ 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;
+ -- FSU_THREADS requires pthread_init, which is nonstandard
+ -- and this should be invoked during the elaboration of s-taprop.adb
+ pragma Import (C, pthread_init, "pthread_init");
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait (set : access sigset_t; sig : access Signal) return int;
+ -- FSU_THREADS has a nonstandard sigwait
+
+ function pthread_kill (thread : pthread_t; sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "sigprocmask");
+
+ --------------------------
+ -- 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;
+ -- FSU_THREADS has nonstandard pthread_mutex_lock
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ -- FSU_THREADS has nonstandard pthread_mutex_lock
+
+ 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;
+ -- FSU_THREADS has a nonstandard pthread_cond_wait
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ -- FSU_THREADS has a nonstandard 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_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ 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,
+ "pthread_mutexattr_setprio_ceiling");
+
+ 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;
+ -- FSU_THREADS does not have 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, "pthread_attr_setsched");
+
+ function sched_yield return int;
+ -- FSU_THREADS does not have 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;
+ -- FSU_THREADS has a nonstandard 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 pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ -- FSU_THREADS has a nonstandard pthread_getspecific
+
+ type destructor_pointer is access procedure (arg : System.Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+
+ type array_type_1 is array (Integer range 0 .. 3) of unsigned_long;
+ type sigset_t is record
+ X_X_sigbits : array_type_1;
+ end record;
+ pragma Convention (C, sigset_t);
+
+ type pid_t is new 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 clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 0;
+
+ type struct_timeval is record
+ tv_sec : long;
+ tv_usec : long;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type pthread_attr_t is record
+ flags : int;
+ stacksize : int;
+ contentionscope : int;
+ inheritsched : int;
+ detachstate : int;
+ sched : int;
+ prio : int;
+ starttime : timespec;
+ deadline : timespec;
+ period : timespec;
+ end record;
+ pragma Convention (C, pthread_attr_t);
+
+ type pthread_condattr_t is record
+ flags : int;
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_mutexattr_t is record
+ flags : int;
+ prio_ceiling : int;
+ protocol : int;
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type sigjmp_buf is array (Integer range 0 .. 18) of int;
+
+ type pthread_t_struct is record
+ context : sigjmp_buf;
+ pbody : sigjmp_buf;
+ errno : int;
+ ret : int;
+ stack_base : System.Address;
+ end record;
+ pragma Convention (C, pthread_t_struct);
+
+ type pthread_t is access all pthread_t_struct;
+
+ type queue_t is record
+ head : System.Address;
+ tail : System.Address;
+ end record;
+ pragma Convention (C, queue_t);
+
+ type pthread_mutex_t is record
+ queue : queue_t;
+ lock : plain_char;
+ owner : System.Address;
+ flags : int;
+ prio_ceiling : int;
+ protocol : int;
+ prev_max_ceiling_prio : int;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_cond_t is record
+ queue : queue_t;
+ flags : int;
+ waiters : int;
+ mutex : System.Address;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.15 $ --
+-- --
+-- Copyright (C) 1991-2001 Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Sun OS (FSU THREADS) version of this package
+
+-- PLEASE DO NOT add any dependences on other packages. ??? why not ???
+-- This package is designed to work with or without tasking support.
+
+-- Make a careful study of all signals available under the OS, to see which
+-- need to be reserved, kept always unmasked, or kept always unmasked. Be on
+-- the lookout for special signals that may be used by the thread library.
+
+with Interfaces.C;
+-- used for int
+
+with System.Error_Reporting;
+-- used for Shutdown
+
+with System.OS_Interface;
+-- used for various Constants, Signal and types
+
+package body System.Interrupt_Management is
+
+ use Interfaces.C;
+ use System.Error_Reporting;
+ use System.OS_Interface;
+
+ type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
+ Exception_Interrupts : constant Interrupt_List :=
+ (SIGFPE, SIGILL, SIGSEGV);
+
+ Unreserve_All_Interrupts : Interfaces.C.int;
+ pragma Import
+ (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Notify_Exception
+ (signo : Signal;
+ info : access siginfo_t;
+ context : access struct_sigcontext);
+ -- This function identifies the Ada exception to be raised using
+ -- the information when the system received a synchronous signal.
+ -- Since this function is machine and OS dependent, different code
+ -- has to be provided for different target.
+
+ ----------------------
+ -- Notify_Exception --
+ ----------------------
+
+ -- The following code is intended for SunOS on Sparcstation.
+
+ procedure Notify_Exception
+ (signo : Signal;
+ info : access siginfo_t;
+ context : access struct_sigcontext)
+ is
+ begin
+ -- As long as we are using a longjmp to return control to the
+ -- exception handler on the runtime stack, we are safe. The original
+ -- signal mask (the one we had before coming into this signal catching
+ -- function) will be restored by the longjmp. Therefore, raising
+ -- an exception in this handler should be a safe operation.
+
+ -- Check that treatment of exception propagation here
+ -- is consistent with treatment of the abort signal in
+ -- System.Task_Primitives.Operations.
+
+ case signo is
+ when SIGFPE =>
+ case info.si_code is
+ when FPE_INTOVF_TRAP |
+ FPE_STARTSIG_TRAP |
+ FPE_INTDIV_TRAP |
+ FPE_FLTDIV_TRAP |
+ FPE_FLTUND_TRAP |
+ FPE_FLTOPERR_TRAP |
+ FPE_FLTOVF_TRAP =>
+ raise Constraint_Error;
+
+ when others =>
+ pragma Assert (Shutdown ("Unexpected SIGFPE signal"));
+ null;
+ end case;
+
+ when SIGILL =>
+ case info.si_code is
+ when ILL_STACK |
+ ILL_ILLINSTR_FAULT |
+ ILL_PRIVINSTR_FAULT =>
+ raise Constraint_Error;
+
+ when others =>
+ pragma Assert (Shutdown ("Unexpected SIGILL signal"));
+ null;
+ end case;
+
+ when SIGSEGV =>
+
+ -- was caused by accessing a null pointer.
+
+-- ???? Origin of this code is unclear, may be broken ???
+
+ if context.sc_o0 in 0 .. 16#2000# then
+ raise Constraint_Error;
+ else
+ raise Storage_Error;
+ end if;
+
+ when others =>
+ pragma Assert (Shutdown ("Unexpected signal"));
+ null;
+ end case;
+ end Notify_Exception;
+
+ ---------------------------
+ -- Initialize_Interrupts --
+ ---------------------------
+
+ -- Nothing needs to be done on this platform
+
+ procedure Initialize_Interrupts is
+ begin
+ null;
+ end Initialize_Interrupts;
+
+-------------------------
+-- Package Elaboration --
+-------------------------
+
+begin
+ declare
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ mask : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ begin
+ -- Need to call pthread_init very early because it is doing signal
+ -- initializations.
+
+ pthread_init;
+
+ -- Change the following assignment to use another signal for task abort.
+ -- For example, SIGTERM might be a good one if SIGABRT is required for
+ -- use elsewhere.
+
+ Abort_Task_Interrupt := SIGABRT;
+
+ act.sa_handler := Notify_Exception'Address;
+
+ -- Set sa_flags to SA_NODEFER so that during the handler execution
+ -- we do not change the Signal_Mask to be masked for the Signal.
+ -- This is a temporary fix to the problem that the Signal_Mask is
+ -- not restored after the exception (longjmp) from the handler.
+ -- The right fix should be made in sigsetjmp so that we save
+ -- the Signal_Set and restore it after a longjmp.
+
+ -- In that case, this field should be changed back to 0. ???
+
+ act.sa_flags := 16;
+
+ Result := sigemptyset (mask'Access);
+ pragma Assert (Result = 0);
+
+ for J in Exception_Interrupts'Range loop
+ Result := sigaddset (mask'Access, Signal (Exception_Interrupts (J)));
+ pragma Assert (Result = 0);
+ end loop;
+
+ act.sa_mask := mask;
+
+ for J in Exception_Interrupts'Range loop
+ Keep_Unmasked (Exception_Interrupts (J)) := True;
+
+ if Unreserve_All_Interrupts = 0 then
+ Result :=
+ sigaction
+ (Signal (Exception_Interrupts (J)),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
+
+ Keep_Unmasked (Abort_Task_Interrupt) := True;
+ Keep_Unmasked (SIGBUS) := True;
+ Keep_Unmasked (SIGFPE) := True;
+ Result :=
+ sigaction
+ (Signal (SIGFPE), act'Unchecked_Access,
+ old_act'Unchecked_Access);
+
+ Keep_Unmasked (SIGALRM) := True;
+ Keep_Unmasked (SIGSTOP) := True;
+ Keep_Unmasked (SIGKILL) := True;
+ Keep_Unmasked (SIGXCPU) := True;
+
+ -- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but at
+ -- the same time, disable the ability of handling this signal using
+ -- package Ada.Interrupts.
+
+ -- The pragma Unreserve_All_Interrupts allows the user the ability to
+ -- change this behavior.
+
+ if Unreserve_All_Interrupts = 0 then
+ Keep_Unmasked (SIGINT) := True;
+ end if;
+
+ -- Reserve this not to interfere with thread scheduling
+
+ -- ??? consider adding this to interrupt exceptions
+ -- Keep_Unmasked (SIGALRM) := True;
+
+ -- An earlier version had a comment about SIGALRM needing to be unmasked
+ -- in at least one thread for cond_timedwait to work.
+
+ -- It is unclear whether this is True for Solaris threads, FSU threads,
+ -- both, or maybe just an old version of FSU threads. ????
+
+ -- Following signals should not be disturbed. Found by experiment
+
+ Keep_Unmasked (SIGEMT) := True;
+ Keep_Unmasked (SIGCHLD) := True;
+
+ -- We do not have Signal 0 in reality. We just use this value
+ -- to identify not existing signals (see s-intnam.ads). Therefore,
+ -- Signal 0 should not be used in all signal related operations hence
+ -- mark it as reserved.
+
+ Reserve := Reserve or Keep_Unmasked or Keep_Masked;
+ Reserve (0) := True;
+ end;
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.24 $
+-- --
+-- Copyright (C) 1997-2001, 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Sun OS (FSU THREADS) version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lgthreads");
+ pragma Linker_Options ("-lmalloc");
+
+ 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 := 31;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGWINCH : constant := 28; -- window size change
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGPOLL : constant := 23; -- pollable event occurred
+ SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
+ 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
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+
+ 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;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 4;
+
+ 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 := False;
+ -- Indicates wether time slicing is supported (i.e FSU threads have been
+ -- compiled with DEF_RR)
+
+ type timespec is private;
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "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_timeval is private;
+
+ function To_Duration (TV : struct_timeval) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timeval (D : Duration) return struct_timeval;
+ pragma Inline (To_Timeval);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 0;
+ SCHED_RR : constant := 1;
+ SCHED_OTHER : constant := 2;
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- 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;
+ 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;
+
+ -----------
+ -- Stack --
+ -----------
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates wether the stack base is available on this target.
+ -- This allows us to share s-osinte.adb between all the FSU run time.
+ -- Note that this value can only be true if pthread_t has a complete
+ -- definition that corresponds exactly to the C header files.
+
+ 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_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
+
+ PROT_ON : constant := PROT_NONE;
+ PROT_OFF : constant := PROT_ALL;
+
+ function mprotect (addr : Address; len : size_t; prot : int) return int;
+ pragma Import (C, mprotect);
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+ -- FSU_THREADS requires pthread_init, which is nonstandard
+ -- and this should be invoked during the elaboration of s-taprop.adb
+ procedure pthread_init;
+ pragma Import (C, pthread_init, "pthread_init");
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait (set : access sigset_t; sig : access Signal) return int;
+ -- FSU_THREADS has a nonstandard sigwait
+
+ function pthread_kill (thread : pthread_t; sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ -- FSU threads does not have pthread_sigmask. Instead, it uses
+ -- sigprocmask to do the signal handling when the thread library is
+ -- sucked in.
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "sigprocmask");
+
+ --------------------------
+ -- 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;
+ -- FSU_THREADS has nonstandard pthread_mutex_lock
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ -- FSU_THREADS has nonstandard pthread_mutex_lock
+
+ 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;
+ -- FSU_THREADS has a nonstandard pthread_cond_wait
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ -- FSU_THREADS has a nonstandard 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_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ 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,
+ "pthread_mutexattr_setprio_ceiling");
+
+ 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;
+ -- FSU_THREADS does not have 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, "pthread_attr_setsched");
+
+ function pthread_attr_setschedparam
+ (attr : access pthread_attr_t;
+ sched_param : int) return int;
+ pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam");
+
+ function sched_yield return int;
+ -- FSU_THREADS does not have 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;
+ -- FSU_THREADS has a nonstandard 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 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 pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ -- FSU_THREADS has a nonstandard pthread_getspecific
+
+ type destructor_pointer is access procedure (arg : System.Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer)
+ return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+
+ type sigset_t is new int;
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 0;
+
+ type struct_timeval is record
+ tv_sec : long;
+ tv_usec : long;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type pthread_attr_t is record
+ flags : int;
+ stacksize : int;
+ contentionscope : int;
+ inheritsched : int;
+ detachstate : int;
+ sched : int;
+ prio : int;
+ starttime : timespec;
+ deadline : timespec;
+ period : timespec;
+ end record;
+ pragma Convention (C, pthread_attr_t);
+
+ type pthread_condattr_t is record
+ flags : int;
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_mutexattr_t is record
+ flags : int;
+ prio_ceiling : int;
+ protocol : int;
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type sigjmp_buf is array (Integer range 0 .. 9) of int;
+
+ type pthread_t_struct is record
+ context : sigjmp_buf;
+ pbody : sigjmp_buf;
+ errno : int;
+ ret : int;
+ stack_base : System.Address;
+ end record;
+ pragma Convention (C, pthread_t_struct);
+
+ type pthread_t is access all pthread_t_struct;
+
+ type queue_t is record
+ head : System.Address;
+ tail : System.Address;
+ end record;
+ pragma Convention (C, queue_t);
+
+ type pthread_mutex_t is record
+ queue : queue_t;
+ lock : plain_char;
+ owner : System.Address;
+ flags : int;
+ prio_ceiling : int;
+ protocol : int;
+ prev_max_ceiling_prio : int;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_cond_t is record
+ queue : queue_t;
+ flags : int;
+ waiters : int;
+ mutex : System.Address;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . A S T _ H A N D L I N G --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.18 $
+-- --
+-- Copyright (C) 1996-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the OpenVMS/Alpha version.
+
+with System; use System;
+
+with System.IO;
+
+with System.Machine_Code;
+with System.Storage_Elements;
+
+with System.Tasking;
+with System.Tasking.Rendezvous;
+with System.Tasking.Initialization;
+with System.Tasking.Utilities;
+
+with System.Task_Primitives;
+with System.Task_Primitives.Operations;
+with System.Task_Primitives.Operations.DEC;
+
+-- with Ada.Finalization;
+-- removed, because of problem with controlled attribute ???
+
+with Ada.Task_Attributes;
+with Ada.Task_Identification;
+
+with Ada.Exceptions; use Ada.Exceptions;
+
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+
+package body System.AST_Handling is
+
+ package ATID renames Ada.Task_Identification;
+
+ package ST renames System.Tasking;
+ package STR renames System.Tasking.Rendezvous;
+ package STI renames System.Tasking.Initialization;
+ package STU renames System.Tasking.Utilities;
+
+ package SSE renames System.Storage_Elements;
+ package STPO renames System.Task_Primitives.Operations;
+ package STPOD renames System.Task_Primitives.Operations.DEC;
+
+ AST_Lock : aliased System.Task_Primitives.RTS_Lock;
+ -- This is a global lock; it is used to execute in mutual exclusion
+ -- from all other AST tasks. It is only used by Lock_AST and
+ -- Unlock_AST.
+
+ procedure Lock_AST (Self_ID : ST.Task_ID);
+ -- Locks out other AST tasks. Preceding a section of code by Lock_AST and
+ -- following it by Unlock_AST creates a critical region.
+
+ procedure Unlock_AST (Self_ID : ST.Task_ID);
+ -- Releases lock previously set by call to Lock_AST.
+ -- All nested locks must be released before other tasks competing for the
+ -- tasking lock are released.
+
+ ---------------
+ -- Lock_AST --
+ ---------------
+
+ procedure Lock_AST (Self_ID : ST.Task_ID) is
+ begin
+ STI.Defer_Abort_Nestable (Self_ID);
+ STPO.Write_Lock (AST_Lock'Access);
+ end Lock_AST;
+
+ -----------------
+ -- Unlock_AST --
+ -----------------
+
+ procedure Unlock_AST (Self_ID : ST.Task_ID) is
+ begin
+ STPO.Unlock (AST_Lock'Access);
+ STI.Undefer_Abort_Nestable (Self_ID);
+ end Unlock_AST;
+
+ ---------------------------------
+ -- AST_Handler Data Structures --
+ ---------------------------------
+
+ -- As noted in the private part of the spec of System.Aux_DEC, the
+ -- AST_Handler type is simply a pointer to a procedure that takes
+ -- a single 64bit parameter. The following is a local copy
+ -- of that definition.
+
+ -- We need our own copy because we need to get our hands on this
+ -- and we cannot see the private part of System.Aux_DEC. We don't
+ -- want to be a child of Aux_Dec because of complications resulting
+ -- from the use of pragma Extend_System. We will use unchecked
+ -- conversions between the two versions of the declarations.
+
+ type AST_Handler is access procedure (Param : Long_Integer);
+
+ -- However, this declaration is somewhat misleading, since the values
+ -- referenced by AST_Handler values (all produced in this package by
+ -- calls to Create_AST_Handler) are highly stylized.
+
+ -- The first point is that in VMS/Alpha, procedure pointers do not in
+ -- fact point to code, but rather to a 48-byte procedure descriptor.
+ -- So a value of type AST_Handler is in fact a pointer to one of these
+ -- 48-byte descriptors.
+
+ type Descriptor_Type is new SSE.Storage_Array (1 .. 48);
+ for Descriptor_Type'Alignment use Standard'Maximum_Alignment;
+ type Descriptor_Ref is access all Descriptor_Type;
+
+ -- Normally, there is only one such descriptor for a given procedure, but
+ -- it works fine to make a copy of the single allocated descriptor, and
+ -- use the copy itself, and we take advantage of this in the design here.
+ -- The idea is that AST_Handler values will all point to a record with the
+ -- following structure:
+
+ -- Note: When we say it works fine, there is one delicate point, which
+ -- is that the code for the AST procedure itself requires the original
+ -- descriptor address. We handle this by saving the orignal descriptor
+ -- address in this structure and restoring in Process_AST.
+
+ type AST_Handler_Data is record
+ Descriptor : Descriptor_Type;
+ Original_Descriptor_Ref : Descriptor_Ref;
+ Taskid : ATID.Task_Id;
+ Entryno : Natural;
+ end record;
+
+ type AST_Handler_Data_Ref is access all AST_Handler_Data;
+
+ function To_AST_Handler is new Ada.Unchecked_Conversion
+ (AST_Handler_Data_Ref, System.Aux_DEC.AST_Handler);
+
+ function To_AST_Data_Handler_Ref is new Ada.Unchecked_Conversion
+ (System.Aux_DEC.AST_Handler, AST_Handler_Data_Ref);
+
+ function To_AST_Data_Handler_Ref is new Ada.Unchecked_Conversion
+ (AST_Handler, AST_Handler_Data_Ref);
+
+ -- Each time Create_AST_Handler is called, a new value of this record
+ -- type is created, containing a copy of the procedure descriptor for
+ -- the routine used to handle all AST's (Process_AST), and the Task_Id
+ -- and entry number parameters identifying the task entry involved.
+
+ -- The AST_Handler value returned is a pointer to this record. Since
+ -- the record starts with the procedure descriptor, it can be used
+ -- by the system in the normal way to call the procedure. But now
+ -- when the procedure gets control, it can determine the address of
+ -- the procedure descriptor used to call it (since the ABI specifies
+ -- that this is left sitting in register r27 on entry), and then use
+ -- that address to retrieve the Task_Id and entry number so that it
+ -- knows on which entry to queue the AST request.
+
+ -- The next issue is where are these records placed. Since we intend
+ -- to pass pointers to these records to asynchronous system service
+ -- routines, they have to be on the heap, which means we have to worry
+ -- about when to allocate them and deallocate them.
+
+ -- We solve this problem by introducing a task attribute that points to
+ -- a vector, indexed by the entry number, of AST_Handler_Data records
+ -- for a given task. The pointer itself is a controlled object allowing
+ -- us to write a finalization routine that frees the referenced vector.
+
+ -- An entry in this vector is either initialized (Entryno non-zero) and
+ -- can be used for any subsequent reference to the same entry, or it is
+ -- unused, marked by the Entryno value being zero.
+
+ type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data;
+ type AST_Handler_Vector_Ref is access all AST_Handler_Vector;
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Object => AST_Handler_Vector,
+ Name => AST_Handler_Vector_Ref);
+
+-- type AST_Vector_Ptr is new Ada.Finalization.Controlled with record
+-- removed due to problem with controlled attribute, consequence is that
+-- we have a memory leak if a task that has AST attribute entries is
+-- terminated. ???
+
+ type AST_Vector_Ptr is record
+ Vector : AST_Handler_Vector_Ref;
+ end record;
+
+ procedure Finalize (Object : in out AST_Vector_Ptr);
+ -- Used to get rid of allocated AST_Vector's
+
+ AST_Vector_Init : AST_Vector_Ptr;
+ -- Initial value, treated as constant, Vector will be null.
+
+ package AST_Attribute is new Ada.Task_Attributes
+ (Attribute => AST_Vector_Ptr,
+ Initial_Value => AST_Vector_Init);
+
+ use AST_Attribute;
+
+ -----------------------
+ -- AST Service Queue --
+ -----------------------
+
+ -- The following global data structures are used to queue pending
+ -- AST requests. When an AST is signalled, the AST service routine
+ -- Process_AST is called, and it makes an entry in this structure.
+
+ type AST_Instance is record
+ Taskid : ATID.Task_Id;
+ Entryno : Natural;
+ Param : Long_Integer;
+ end record;
+ -- The Taskid and Entryno indicate the entry on which this AST is to
+ -- be queued, and Param is the parameter provided from the AST itself.
+
+ AST_Service_Queue_Size : constant := 256;
+ AST_Service_Queue_Limit : constant := 250;
+ type AST_Service_Queue_Index is mod AST_Service_Queue_Size;
+ -- Index used to refer to entries in the circular buffer which holds
+ -- active AST_Instance values. The upper bound reflects the maximum
+ -- number of AST instances that can be stored in the buffer. Since
+ -- these entries are immediately serviced by the high priority server
+ -- task that does the actual entry queuing, it is very unusual to have
+ -- any significant number of entries simulaneously queued.
+
+ AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance;
+ pragma Volatile_Components (AST_Service_Queue);
+ -- The circular buffer used to store active AST requests.
+
+ AST_Service_Queue_Put : AST_Service_Queue_Index := 0;
+ AST_Service_Queue_Get : AST_Service_Queue_Index := 0;
+ pragma Atomic (AST_Service_Queue_Put);
+ pragma Atomic (AST_Service_Queue_Get);
+ -- These two variables point to the next slots in the AST_Service_Queue
+ -- to be used for putting a new entry in and taking an entry out. This
+ -- is a circular buffer, so these pointers wrap around. If the two values
+ -- are equal the buffer is currently empty. The pointers are atomic to
+ -- ensure proper synchronization between the single producer (namely the
+ -- Process_AST procedure), and the single consumer (the AST_Service_Task).
+
+ --------------------------------
+ -- AST Server Task Structures --
+ --------------------------------
+
+ -- The basic approach is that when an AST comes in, a call is made to
+ -- the Process_AST procedure. It queues the request in the service queue
+ -- and then wakes up an AST server task to perform the actual call to the
+ -- required entry. We use this intermediate server task, since the AST
+ -- procedure itself cannot wait to return, and we need some caller for
+ -- the rendezvous so that we can use the normal rendezvous mechanism.
+
+ -- It would work to have only one AST server task, but then we would lose
+ -- all overlap in AST processing, and furthermore, we could get priority
+ -- inversion effects resulting in starvation of AST requests.
+
+ -- We therefore maintain a small pool of AST server tasks. We adjust
+ -- the size of the pool dynamically to reflect traffic, so that we have
+ -- a sufficient number of server tasks to avoid starvation.
+
+ Max_AST_Servers : constant Natural := 16;
+ -- Maximum number of AST server tasks that can be allocated
+
+ Num_AST_Servers : Natural := 0;
+ -- Number of AST server tasks currently active
+
+ Num_Waiting_AST_Servers : Natural := 0;
+ -- This is the number of AST server tasks that are either waiting for
+ -- work, or just about to go to sleep and wait for work.
+
+ Is_Waiting : array (1 .. Max_AST_Servers) of Boolean := (others => False);
+ -- An array of flags showing which AST server tasks are currently waiting
+
+ AST_Task_Ids : array (1 .. Max_AST_Servers) of ST.Task_ID;
+ -- Task Id's of allocated AST server tasks
+
+ task type AST_Server_Task (Num : Natural) is
+ pragma Priority (Priority'Last);
+ end AST_Server_Task;
+ -- Declaration for AST server task. This task has no entries, it is
+ -- controlled by sleep and wakeup calls at the task primitives level.
+
+ type AST_Server_Task_Ptr is access all AST_Server_Task;
+ -- Type used to allocate server tasks
+
+ function To_Integer is new Ada.Unchecked_Conversion
+ (ATID.Task_Id, Integer);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Allocate_New_AST_Server;
+ -- Allocate an additional AST server task
+
+ procedure Process_AST (Param : Long_Integer);
+ -- This is the central routine for processing all AST's, it is referenced
+ -- as the code address of all created AST_Handler values. See detailed
+ -- description in body to understand how it works to have a single such
+ -- procedure for all AST's even though it does not get any indication of
+ -- the entry involved passed as an explicit parameter. The single explicit
+ -- parameter Param is the parameter passed by the system with the AST.
+
+ -----------------------------
+ -- Allocate_New_AST_Server --
+ -----------------------------
+
+ procedure Allocate_New_AST_Server is
+ Dummy : AST_Server_Task_Ptr;
+
+ begin
+ if Num_AST_Servers = Max_AST_Servers then
+ return;
+
+ else
+ -- Note: it is safe to increment Num_AST_Servers immediately, since
+ -- no one will try to activate this task until it indicates that it
+ -- is sleeping by setting its entry in Is_Waiting to True.
+
+ Num_AST_Servers := Num_AST_Servers + 1;
+ Dummy := new AST_Server_Task (Num_AST_Servers);
+ end if;
+ end Allocate_New_AST_Server;
+
+ ---------------------
+ -- AST_Server_Task --
+ ---------------------
+
+ task body AST_Server_Task is
+ Taskid : ATID.Task_Id;
+ Entryno : Natural;
+ Param : aliased Long_Integer;
+ Self_Id : constant ST.Task_ID := ST.Self;
+
+ pragma Volatile (Param);
+
+ begin
+ -- By making this task independent of master, when the environment
+ -- task is finalizing, the AST_Server_Task will be notified that it
+ -- should terminate.
+
+ STU.Make_Independent;
+
+ -- Record our task Id for access by Process_AST
+
+ AST_Task_Ids (Num) := Self_Id;
+
+ -- Note: this entire task operates with the main task lock set, except
+ -- when it is sleeping waiting for work, or busy doing a rendezvous
+ -- with an AST server. This lock protects the data structures that
+ -- are shared by multiple instances of the server task.
+
+ Lock_AST (Self_Id);
+
+ -- This is the main infinite loop of the task. We go to sleep and
+ -- wait to be woken up by Process_AST when there is some work to do.
+
+ loop
+ Num_Waiting_AST_Servers := Num_Waiting_AST_Servers + 1;
+
+ Unlock_AST (Self_Id);
+
+ STI.Defer_Abort (Self_Id);
+ STPO.Write_Lock (Self_Id);
+
+ Is_Waiting (Num) := True;
+
+ Self_Id.Common.State := ST.AST_Server_Sleep;
+ STPO.Sleep (Self_Id, ST.AST_Server_Sleep);
+ Self_Id.Common.State := ST.Runnable;
+
+ STPO.Unlock (Self_Id);
+
+ -- If the process is finalizing, Undefer_Abort will simply end
+ -- this task.
+
+ STI.Undefer_Abort (Self_Id);
+
+ -- We are awake, there is something to do!
+
+ Lock_AST (Self_Id);
+ Num_Waiting_AST_Servers := Num_Waiting_AST_Servers - 1;
+
+ -- Loop here to service outstanding requests. We are always
+ -- locked on entry to this loop.
+
+ while AST_Service_Queue_Get /= AST_Service_Queue_Put loop
+ Taskid := AST_Service_Queue (AST_Service_Queue_Get).Taskid;
+ Entryno := AST_Service_Queue (AST_Service_Queue_Get).Entryno;
+ Param := AST_Service_Queue (AST_Service_Queue_Get).Param;
+
+ AST_Service_Queue_Get := AST_Service_Queue_Get + 1;
+
+ -- This is a manual expansion of the normal call simple code
+
+ declare
+ type AA is access all Long_Integer;
+ P : AA := Param'Unrestricted_Access;
+
+ function To_ST_Task_Id is new Ada.Unchecked_Conversion
+ (ATID.Task_Id, ST.Task_ID);
+
+ begin
+ Unlock_AST (Self_Id);
+ STR.Call_Simple
+ (Acceptor => To_ST_Task_Id (Taskid),
+ E => ST.Task_Entry_Index (Entryno),
+ Uninterpreted_Data => P'Address);
+ exception
+ when E : others =>
+ System.IO.Put_Line ("%Debugging event");
+ System.IO.Put_Line (Exception_Name (E) &
+ " raised when trying to deliver an AST.");
+ if Exception_Message (E)'Length /= 0 then
+ System.IO.Put_Line (Exception_Message (E));
+ end if;
+ System.IO.Put_Line ("Task type is " & "Receiver_Type");
+ System.IO.Put_Line ("Task id is " & ATID.Image (Taskid));
+ end;
+ Lock_AST (Self_Id);
+ end loop;
+ end loop;
+
+ end AST_Server_Task;
+
+ ------------------------
+ -- Create_AST_Handler --
+ ------------------------
+
+ function Create_AST_Handler
+ (Taskid : ATID.Task_Id;
+ Entryno : Natural)
+ return System.Aux_DEC.AST_Handler
+ is
+ Attr_Ref : Attribute_Handle;
+
+ Process_AST_Ptr : constant AST_Handler := Process_AST'Access;
+ -- Reference to standard procedure descriptor for Process_AST
+
+ function To_Descriptor_Ref is new Ada.Unchecked_Conversion
+ (AST_Handler, Descriptor_Ref);
+
+ Original_Descriptor_Ref : Descriptor_Ref :=
+ To_Descriptor_Ref (Process_AST_Ptr);
+
+ begin
+ if ATID.Is_Terminated (Taskid) then
+ raise Program_Error;
+ end if;
+
+ Attr_Ref := Reference (Taskid);
+
+ -- Allocate another server if supply is getting low
+
+ if Num_Waiting_AST_Servers < 2 then
+ Allocate_New_AST_Server;
+ end if;
+
+ -- No point in creating more if we have zillions waiting to
+ -- be serviced.
+
+ while AST_Service_Queue_Put - AST_Service_Queue_Get
+ > AST_Service_Queue_Limit
+ loop
+ delay 0.01;
+ end loop;
+
+ -- If no AST vector allocated, or the one we have is too short, then
+ -- allocate one of right size and initialize all entries except the
+ -- one we will use to unused. Note that the assignment automatically
+ -- frees the old allocated table if there is one.
+
+ if Attr_Ref.Vector = null
+ or else Attr_Ref.Vector'Length < Entryno
+ then
+ Attr_Ref.Vector := new AST_Handler_Vector (1 .. Entryno);
+
+ for E in 1 .. Entryno loop
+ Attr_Ref.Vector (E).Descriptor :=
+ Original_Descriptor_Ref.all;
+ Attr_Ref.Vector (E).Original_Descriptor_Ref :=
+ Original_Descriptor_Ref;
+ Attr_Ref.Vector (E).Taskid := Taskid;
+ Attr_Ref.Vector (E).Entryno := E;
+ end loop;
+ end if;
+
+ return To_AST_Handler (Attr_Ref.Vector (Entryno)'Unrestricted_Access);
+ end Create_AST_Handler;
+
+ ----------------------------
+ -- Expand_AST_Packet_Pool --
+ ----------------------------
+
+ procedure Expand_AST_Packet_Pool
+ (Requested_Packets : in Natural;
+ Actual_Number : out Natural;
+ Total_Number : out Natural)
+ is
+ begin
+ -- The AST implementation of GNAT does not permit dynamic expansion
+ -- of the pool, so we simply add no entries and return the total. If
+ -- it is necessary to expand the allocation, then this package body
+ -- must be recompiled with a larger value for AST_Service_Queue_Size.
+
+ Actual_Number := 0;
+ Total_Number := AST_Service_Queue_Size;
+ end Expand_AST_Packet_Pool;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out AST_Vector_Ptr) is
+ begin
+ Free (Object.Vector);
+ end Finalize;
+
+ -----------------
+ -- Process_AST --
+ -----------------
+
+ procedure Process_AST (Param : Long_Integer) is
+
+ Handler_Data_Ptr : AST_Handler_Data_Ref;
+ -- This variable is set to the address of the descriptor through
+ -- which Process_AST is called. Since the descriptor is part of
+ -- an AST_Handler value, this is also the address of this value,
+ -- from which we can obtain the task and entry number information.
+
+ function To_Address is new Ada.Unchecked_Conversion
+ (ST.Task_ID, System.Address);
+
+ begin
+ System.Machine_Code.Asm
+ (Template => "addl $27,0,%0",
+ Outputs => AST_Handler_Data_Ref'Asm_Output ("=r", Handler_Data_Ptr),
+ Volatile => True);
+
+ System.Machine_Code.Asm
+ (Template => "ldl $27,%0",
+ Inputs => Descriptor_Ref'Asm_Input
+ ("m", Handler_Data_Ptr.Original_Descriptor_Ref),
+ Volatile => True);
+
+ AST_Service_Queue (AST_Service_Queue_Put) := AST_Instance'
+ (Taskid => Handler_Data_Ptr.Taskid,
+ Entryno => Handler_Data_Ptr.Entryno,
+ Param => Param);
+
+ -- ??? What is the protection of this variable ?
+ -- It seems that trying to use any lock in this procedure will get
+ -- an ACCVIO.
+
+ AST_Service_Queue_Put := AST_Service_Queue_Put + 1;
+
+ -- Need to wake up processing task. If there is no waiting server
+ -- then we have temporarily run out, but things should still be
+ -- OK, since one of the active ones will eventually pick up the
+ -- service request queued in the AST_Service_Queue.
+
+ for J in 1 .. Num_AST_Servers loop
+ if Is_Waiting (J) then
+ Is_Waiting (J) := False;
+
+ -- Sleeps are handled by ASTs on VMS, so don't call Wakeup.
+ -- ??? We should lock AST_Task_Ids (J) here. What's the story ?
+
+ STPOD.Interrupt_AST_Handler
+ (To_Address (AST_Task_Ids (J)));
+ exit;
+ end if;
+ end loop;
+ end Process_AST;
+
+begin
+ STPO.Initialize_Lock (AST_Lock'Access, STPO.Global_Task_Level);
+end System.AST_Handling;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T . --
+-- O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.8 $ --
+-- --
+-- Copyright (C) 1991-2000 Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a OpenVMS/Alpha version of this package.
+
+with System.OS_Interface;
+-- used for various type, constant, and operations
+
+with System.Tasking;
+
+with System.Tasking.Initialization;
+
+with System.Task_Primitives.Operations;
+
+with System.Task_Primitives.Operations.DEC;
+
+with Unchecked_Conversion;
+
+package body System.Interrupt_Management.Operations is
+
+ use System.OS_Interface;
+ use System.Tasking;
+ use type unsigned_short;
+
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+ function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
+ package POP renames System.Task_Primitives.Operations;
+
+ ----------------------------
+ -- Thread_Block_Interrupt --
+ ----------------------------
+
+ procedure Thread_Block_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ null;
+ end Thread_Block_Interrupt;
+
+ ------------------------------
+ -- Thread_Unblock_Interrupt --
+ ------------------------------
+
+ procedure Thread_Unblock_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ null;
+ end Thread_Unblock_Interrupt;
+
+ ------------------------
+ -- Set_Interrupt_Mask --
+ ------------------------
+
+ procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ begin
+ null;
+ end Set_Interrupt_Mask;
+
+ procedure Set_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ OMask : access Interrupt_Mask) is
+ begin
+ null;
+ end Set_Interrupt_Mask;
+
+ ------------------------
+ -- Get_Interrupt_Mask --
+ ------------------------
+
+ procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ begin
+ null;
+ end Get_Interrupt_Mask;
+
+ --------------------
+ -- Interrupt_Wait --
+ --------------------
+
+ function To_unsigned_long is new
+ Unchecked_Conversion (System.Address, unsigned_long);
+
+ function Interrupt_Wait (Mask : access Interrupt_Mask)
+ return Interrupt_ID
+ is
+ Self_ID : Task_ID := Self;
+ Iosb : IO_Status_Block_Type := (0, 0, 0);
+ Status : Cond_Value_Type;
+
+ begin
+
+ -- A QIO read is registered. The system call returns immediately
+ -- after scheduling an AST to be fired when the operation
+ -- completes.
+
+ Sys_QIO
+ (Status => Status,
+ Chan => Rcv_Interrupt_Chan,
+ Func => IO_READVBLK,
+ Iosb => Iosb,
+ Astadr =>
+ POP.DEC.Interrupt_AST_Handler'Access,
+ Astprm => To_Address (Self_ID),
+ P1 => To_unsigned_long (Interrupt_Mailbox'Address),
+ P2 => Interrupt_ID'Size / 8);
+
+ pragma Assert ((Status and 1) = 1);
+
+ loop
+
+ -- Wait to be woken up. Could be that the AST has fired,
+ -- in which case the Iosb.Status variable will be non-zero,
+ -- or maybe the wait is being aborted.
+
+ POP.Sleep
+ (Self_ID,
+ System.Tasking.Interrupt_Server_Blocked_On_Event_Flag);
+
+ if Iosb.Status /= 0 then
+ if (Iosb.Status and 1) = 1
+ and then Mask (Signal (Interrupt_Mailbox))
+ then
+ return Interrupt_Mailbox;
+ else
+ return 0;
+ end if;
+ else
+ POP.Unlock (Self_ID);
+ System.Tasking.Initialization.Undefer_Abort (Self_ID);
+ System.Tasking.Initialization.Defer_Abort (Self_ID);
+ POP.Write_Lock (Self_ID);
+ end if;
+ end loop;
+ end Interrupt_Wait;
+
+ ----------------------------
+ -- Install_Default_Action --
+ ----------------------------
+
+ procedure Install_Default_Action (Interrupt : Interrupt_ID) is
+ begin
+ null;
+ end Install_Default_Action;
+
+ ---------------------------
+ -- Install_Ignore_Action --
+ ---------------------------
+
+ procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
+ begin
+ null;
+ end Install_Ignore_Action;
+
+ -------------------------
+ -- Fill_Interrupt_Mask --
+ -------------------------
+
+ procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ begin
+ Mask.all := (others => True);
+ end Fill_Interrupt_Mask;
+
+ --------------------------
+ -- Empty_Interrupt_Mask --
+ --------------------------
+
+ procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ begin
+ Mask.all := (others => False);
+ end Empty_Interrupt_Mask;
+
+ ---------------------------
+ -- Add_To_Interrupt_Mask --
+ ---------------------------
+
+ procedure Add_To_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID)
+ is
+ begin
+ Mask (Signal (Interrupt)) := True;
+ end Add_To_Interrupt_Mask;
+
+ --------------------------------
+ -- Delete_From_Interrupt_Mask --
+ --------------------------------
+
+ procedure Delete_From_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID)
+ is
+ begin
+ Mask (Signal (Interrupt)) := False;
+ end Delete_From_Interrupt_Mask;
+
+ ---------------
+ -- Is_Member --
+ ---------------
+
+ function Is_Member
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID) return Boolean
+ is
+ begin
+ return Mask (Signal (Interrupt));
+ end Is_Member;
+
+ -------------------------
+ -- Copy_Interrupt_Mask --
+ -------------------------
+
+ procedure Copy_Interrupt_Mask
+ (X : out Interrupt_Mask;
+ Y : Interrupt_Mask)
+ is
+ begin
+ X := Y;
+ end Copy_Interrupt_Mask;
+
+ -------------------------
+ -- Interrupt_Self_Process --
+ -------------------------
+
+ procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
+ Status : Cond_Value_Type;
+ begin
+ Sys_QIO
+ (Status => Status,
+ Chan => Snd_Interrupt_Chan,
+ Func => IO_WRITEVBLK,
+ P1 => To_unsigned_long (Interrupt'Address),
+ P2 => Interrupt_ID'Size / 8);
+
+ pragma Assert ((Status and 1) = 1);
+
+ end Interrupt_Self_Process;
+
+begin
+
+ Environment_Mask := (others => False);
+ All_Tasks_Mask := (others => True);
+
+ for I in Interrupt_ID loop
+ if Keep_Unmasked (I) then
+ Environment_Mask (Signal (I)) := True;
+ All_Tasks_Mask (Signal (I)) := False;
+ end if;
+ end loop;
+
+end System.Interrupt_Management.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1991-2000 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is an OpenVMS/Alpha version of this package.
+
+-- Invariants:
+
+-- Once we associate a Server_Task with an interrupt, the task never
+-- goes away, and we never remove the association.
+
+-- There is no more than one interrupt per Server_Task and no more than
+-- one Server_Task per interrupt.
+
+-- Within this package, the lock L is used to protect the various status
+-- tables. If there is a Server_Task associated with an interrupt, we use
+-- the per-task lock of the Server_Task instead so that we protect the
+-- status between Interrupt_Manager and Server_Task. Protection among
+-- service requests are done using User Request to Interrupt_Manager
+-- rendezvous.
+
+with Ada.Task_Identification;
+-- used for Task_ID type
+
+with Ada.Exceptions;
+-- used for Raise_Exception
+
+with System.Task_Primitives;
+-- used for RTS_Lock
+-- Self
+
+with System.Interrupt_Management;
+-- used for Reserve
+-- Interrupt_ID
+-- Interrupt_Mask
+-- Abort_Task_Interrupt
+
+with System.Interrupt_Management.Operations;
+-- used for Thread_Block_Interrupt
+-- Thread_Unblock_Interrupt
+-- Install_Default_Action
+-- Install_Ignore_Action
+-- Copy_Interrupt_Mask
+-- Set_Interrupt_Mask
+-- Empty_Interrupt_Mask
+-- Fill_Interrupt_Mask
+-- Add_To_Interrupt_Mask
+-- Delete_From_Interrupt_Mask
+-- Interrupt_Wait
+-- Interrupt_Self_Process
+-- Get_Interrupt_Mask
+-- Set_Interrupt_Mask
+-- IS_Member
+-- Environment_Mask
+-- All_Tasks_Mask
+pragma Elaborate_All (System.Interrupt_Management.Operations);
+
+with System.Error_Reporting;
+pragma Warnings (Off, System.Error_Reporting);
+-- used for Shutdown
+
+with System.Task_Primitives.Operations;
+-- used for Write_Lock
+-- Unlock
+-- Abort
+-- Wakeup_Task
+-- Sleep
+-- Initialize_Lock
+
+with System.Task_Primitives.Interrupt_Operations;
+-- used for Set_Interrupt_ID
+
+with System.Storage_Elements;
+-- used for To_Address
+-- To_Integer
+-- Integer_Address
+
+with System.Tasking;
+-- used for Task_ID
+-- Task_Entry_Index
+-- Null_Task
+-- Self
+-- Interrupt_Manager_ID
+
+with System.Tasking.Utilities;
+-- used for Make_Independent
+
+with System.Tasking.Rendezvous;
+-- used for Call_Simple
+pragma Elaborate_All (System.Tasking.Rendezvous);
+
+with System.Tasking.Initialization;
+-- used for Defer_Abort
+-- Undefer_Abort
+
+with Unchecked_Conversion;
+
+package body System.Interrupts is
+
+ use Tasking;
+ use System.Error_Reporting;
+ use Ada.Exceptions;
+
+ package PRI renames System.Task_Primitives;
+ package POP renames System.Task_Primitives.Operations;
+ package PIO renames System.Task_Primitives.Interrupt_Operations;
+ package IMNG renames System.Interrupt_Management;
+ package IMOP renames System.Interrupt_Management.Operations;
+
+ function To_System is new Unchecked_Conversion
+ (Ada.Task_Identification.Task_Id, Task_ID);
+
+ -----------------
+ -- Local Tasks --
+ -----------------
+
+ -- WARNING: System.Tasking.Utilities performs calls to this task
+ -- with low-level constructs. Do not change this spec without synchro-
+ -- nizing it.
+
+ task Interrupt_Manager is
+ entry Initialize (Mask : IMNG.Interrupt_Mask);
+
+ entry Attach_Handler
+ (New_Handler : in Parameterless_Handler;
+ Interrupt : in Interrupt_ID;
+ Static : in Boolean;
+ Restoration : in Boolean := False);
+
+ entry Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : in Parameterless_Handler;
+ Interrupt : in Interrupt_ID;
+ Static : in Boolean);
+
+ entry Detach_Handler
+ (Interrupt : in Interrupt_ID;
+ Static : in Boolean);
+
+ entry Bind_Interrupt_To_Entry
+ (T : Task_ID;
+ E : Task_Entry_Index;
+ Interrupt : Interrupt_ID);
+
+ entry Detach_Interrupt_Entries (T : Task_ID);
+
+ entry Block_Interrupt (Interrupt : Interrupt_ID);
+
+ entry Unblock_Interrupt (Interrupt : Interrupt_ID);
+
+ entry Ignore_Interrupt (Interrupt : Interrupt_ID);
+
+ entry Unignore_Interrupt (Interrupt : Interrupt_ID);
+
+ pragma Interrupt_Priority (System.Interrupt_Priority'Last);
+ end Interrupt_Manager;
+
+ task type Server_Task (Interrupt : Interrupt_ID) is
+ pragma Priority (System.Interrupt_Priority'Last);
+ end Server_Task;
+
+ type Server_Task_Access is access Server_Task;
+
+ --------------------------------
+ -- Local Types and Variables --
+ --------------------------------
+
+ type Entry_Assoc is record
+ T : Task_ID;
+ E : Task_Entry_Index;
+ end record;
+
+ type Handler_Assoc is record
+ H : Parameterless_Handler;
+ Static : Boolean; -- Indicates static binding;
+ end record;
+
+ User_Handler : array (Interrupt_ID'Range) of Handler_Assoc :=
+ (others => (null, Static => False));
+ pragma Volatile_Components (User_Handler);
+ -- Holds the protected procedure handler (if any) and its Static
+ -- information for each interrupt. A handler is a Static one if
+ -- it is specified through the pragma Attach_Handler.
+ -- Attach_Handler. Otherwise, not static)
+
+ User_Entry : array (Interrupt_ID'Range) of Entry_Assoc :=
+ (others => (T => Null_Task, E => Null_Task_Entry));
+ pragma Volatile_Components (User_Entry);
+ -- Holds the task and entry index (if any) for each interrupt
+
+ Blocked : array (Interrupt_ID'Range) of Boolean := (others => False);
+ pragma Volatile_Components (Blocked);
+ -- True iff the corresponding interrupt is blocked in the process level
+
+ Ignored : array (Interrupt_ID'Range) of Boolean := (others => False);
+ pragma Volatile_Components (Ignored);
+ -- True iff the corresponding interrupt is blocked in the process level
+
+ Last_Unblocker :
+ array (Interrupt_ID'Range) of Task_ID := (others => Null_Task);
+ pragma Volatile_Components (Last_Unblocker);
+ -- Holds the ID of the last Task which Unblocked this Interrupt.
+ -- It contains Null_Task if no tasks have ever requested the
+ -- Unblocking operation or the Interrupt is currently Blocked.
+
+ Server_ID : array (Interrupt_ID'Range) of Task_ID :=
+ (others => Null_Task);
+ pragma Atomic_Components (Server_ID);
+ -- Holds the Task_ID of the Server_Task for each interrupt.
+ -- Task_ID is needed to accomplish locking per Interrupt base. Also
+ -- is needed to decide whether to create a new Server_Task.
+
+ -- Type and Head, Tail of the list containing Registered Interrupt
+ -- Handlers. These definitions are used to register the handlers
+ -- specified by the pragma Interrupt_Handler.
+
+ type Registered_Handler;
+ type R_Link is access all Registered_Handler;
+
+ type Registered_Handler is record
+ H : System.Address := System.Null_Address;
+ Next : R_Link := null;
+ end record;
+
+ Registered_Handler_Head : R_Link := null;
+ Registered_Handler_Tail : R_Link := null;
+
+ Access_Hold : Server_Task_Access;
+ -- variable used to allocate Server_Task using "new".
+
+ L : aliased PRI.RTS_Lock;
+ -- L protects contents in tables above corresponding to interrupts
+ -- for which Server_ID (T) = null.
+ --
+ -- If Server_ID (T) /= null then protection is via
+ -- per-task (TCB) lock of Server_ID (T).
+ --
+ -- For deadlock prevention, L should not be locked after
+ -- any other lock is held.
+
+ Task_Lock : array (Interrupt_ID'Range) of Boolean := (others => False);
+ -- Boolean flags to give matching Locking and Unlocking. See the comments
+ -- in Lock_Interrupt.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Lock_Interrupt
+ (Self_ID : Task_ID;
+ Interrupt : Interrupt_ID);
+ -- protect the tables using L or per-task lock. Set the Boolean
+ -- value Task_Lock if the lock is made using per-task lock.
+ -- This information is needed so that Unlock_Interrupt
+ -- performs unlocking on the same lock. The situation we are preventing
+ -- is, for example, when Attach_Handler is called for the first time
+ -- we lock L and create an Server_Task. For a matching unlocking, if we
+ -- rely on the fact that there is a Server_Task, we will unlock the
+ -- per-task lock.
+
+ procedure Unlock_Interrupt
+ (Self_ID : Task_ID;
+ Interrupt : Interrupt_ID);
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean;
+
+ --------------------
+ -- Lock_Interrupt --
+ --------------------
+
+ -- ?????
+ -- This package has been modified several times.
+ -- Do we still need this fancy locking scheme, now that more operations
+ -- are entries of the interrupt manager task?
+ -- ?????
+ -- More likely, we will need to convert one or more entry calls to
+ -- protected operations, because presently we are violating locking order
+ -- rules by calling a task entry from within the runtime system.
+
+ procedure Lock_Interrupt
+ (Self_ID : Task_ID;
+ Interrupt : Interrupt_ID)
+ is
+ begin
+ Initialization.Defer_Abort (Self_ID);
+
+ POP.Write_Lock (L'Access);
+
+ if Task_Lock (Interrupt) then
+
+ -- We need to use per-task lock.
+
+ POP.Unlock (L'Access);
+ POP.Write_Lock (Server_ID (Interrupt));
+
+ -- Rely on the fact that once Server_ID is set to a non-null
+ -- value it will never be set back to null.
+
+ elsif Server_ID (Interrupt) /= Null_Task then
+
+ -- We need to use per-task lock.
+
+ Task_Lock (Interrupt) := True;
+ POP.Unlock (L'Access);
+ POP.Write_Lock (Server_ID (Interrupt));
+ end if;
+ end Lock_Interrupt;
+
+ ----------------------
+ -- Unlock_Interrupt --
+ ----------------------
+
+ procedure Unlock_Interrupt
+ (Self_ID : Task_ID;
+ Interrupt : Interrupt_ID)
+ is
+ begin
+ if Task_Lock (Interrupt) then
+ POP.Unlock (Server_ID (Interrupt));
+ else
+ POP.Unlock (L'Access);
+ end if;
+
+ Initialization.Undefer_Abort (Self_ID);
+ end Unlock_Interrupt;
+
+ ----------------------------------
+ -- Register_Interrupt_Handler --
+ ----------------------------------
+
+ procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
+ New_Node_Ptr : R_Link;
+
+ begin
+ -- This routine registers the Handler as usable for Dynamic
+ -- Interrupt Handler. Routines attaching and detaching Handler
+ -- dynamically should first consult if the Handler is rgistered.
+ -- A Program Error should be raised if it is not registered.
+
+ -- The pragma Interrupt_Handler can only appear in the library
+ -- level PO definition and instantiation. Therefore, we do not need
+ -- to implement Unregistering operation. Neither we need to
+ -- protect the queue structure using a Lock.
+
+ pragma Assert (Handler_Addr /= System.Null_Address);
+
+ New_Node_Ptr := new Registered_Handler;
+ New_Node_Ptr.H := Handler_Addr;
+
+ if Registered_Handler_Head = null then
+ Registered_Handler_Head := New_Node_Ptr;
+ Registered_Handler_Tail := New_Node_Ptr;
+
+ else
+ Registered_Handler_Tail.Next := New_Node_Ptr;
+ Registered_Handler_Tail := New_Node_Ptr;
+ end if;
+ end Register_Interrupt_Handler;
+
+ -------------------
+ -- Is_Registered --
+ -------------------
+
+ -- See if the Handler has been "pragma"ed using Interrupt_Handler.
+ -- Always consider a null handler as registered.
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean is
+
+ type Fat_Ptr is record
+ Object_Addr : System.Address;
+ Handler_Addr : System.Address;
+ end record;
+
+ function To_Fat_Ptr is new Unchecked_Conversion
+ (Parameterless_Handler, Fat_Ptr);
+
+ Ptr : R_Link;
+ Fat : Fat_Ptr;
+
+ begin
+ if Handler = null then
+ return True;
+ end if;
+
+ Fat := To_Fat_Ptr (Handler);
+
+ Ptr := Registered_Handler_Head;
+
+ while (Ptr /= null) loop
+ if Ptr.H = Fat.Handler_Addr then
+ return True;
+ end if;
+
+ Ptr := Ptr.Next;
+ end loop;
+
+ return False;
+
+ end Is_Registered;
+
+ -----------------
+ -- Is_Reserved --
+ -----------------
+
+ function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt));
+ end Is_Reserved;
+
+ -----------------------
+ -- Is_Entry_Attached --
+ -----------------------
+
+ function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ return User_Entry (Interrupt).T /= Null_Task;
+ end Is_Entry_Attached;
+
+ -------------------------
+ -- Is_Handler_Attached --
+ -------------------------
+
+ function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ return User_Handler (Interrupt).H /= null;
+ end Is_Handler_Attached;
+
+ ----------------
+ -- Is_Blocked --
+ ----------------
+
+ function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ return Blocked (Interrupt);
+ end Is_Blocked;
+
+ ----------------
+ -- Is_Ignored --
+ ----------------
+
+ function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ return Ignored (Interrupt);
+ end Is_Ignored;
+
+ ---------------------
+ -- Current_Handler --
+ ---------------------
+
+ function Current_Handler (Interrupt : Interrupt_ID)
+ return Parameterless_Handler is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ -- ??? Since Parameterless_Handler is not Atomic, the
+ -- current implementation is wrong. We need a new service in
+ -- Interrupt_Manager to ensure atomicity.
+
+ return User_Handler (Interrupt).H;
+ end Current_Handler;
+
+ --------------------
+ -- Attach_Handler --
+ --------------------
+
+ -- Calling this procedure with New_Handler = null and Static = True
+ -- means we want to detach the current handler regardless of the
+ -- previous handler's binding status (ie. do not care if it is a
+ -- dynamic or static handler).
+
+ -- This option is needed so that during the finalization of a PO, we
+ -- can detach handlers attached through pragma Attach_Handler.
+
+ procedure Attach_Handler
+ (New_Handler : in Parameterless_Handler;
+ Interrupt : in Interrupt_ID;
+ Static : in Boolean := False)
+ is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
+
+ end Attach_Handler;
+
+ ----------------------
+ -- Exchange_Handler --
+ ----------------------
+
+ -- Calling this procedure with New_Handler = null and Static = True
+ -- means we want to detach the current handler regardless of the
+ -- previous handler's binding status (ie. do not care if it is a
+ -- dynamic or static handler).
+
+ -- This option is needed so that during the finalization of a PO, we
+ -- can detach handlers attached through pragma Attach_Handler.
+
+ procedure Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : in Parameterless_Handler;
+ Interrupt : in Interrupt_ID;
+ Static : in Boolean := False)
+ is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ Interrupt_Manager.Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static);
+
+ end Exchange_Handler;
+
+ --------------------
+ -- Detach_Handler --
+ --------------------
+
+ -- Calling this procedure with Static = True means we want to Detach the
+ -- current handler regardless of the previous handler's binding status
+ -- (i.e. do not care if it is a dynamic or static handler).
+
+ -- This option is needed so that during the finalization of a PO, we can
+ -- detach handlers attached through pragma Attach_Handler.
+
+ procedure Detach_Handler
+ (Interrupt : in Interrupt_ID;
+ Static : in Boolean := False)
+ is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ Interrupt_Manager.Detach_Handler (Interrupt, Static);
+
+ end Detach_Handler;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference (Interrupt : Interrupt_ID) return System.Address is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ return Storage_Elements.To_Address
+ (Storage_Elements.Integer_Address (Interrupt));
+ end Reference;
+
+ -----------------------------
+ -- Bind_Interrupt_To_Entry --
+ -----------------------------
+
+ -- This procedure raises a Program_Error if it tries to
+ -- bind an interrupt to which an Entry or a Procedure is
+ -- already bound.
+
+ procedure Bind_Interrupt_To_Entry
+ (T : Task_ID;
+ E : Task_Entry_Index;
+ Int_Ref : System.Address)
+ is
+ Interrupt : constant Interrupt_ID :=
+ Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
+
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
+
+ end Bind_Interrupt_To_Entry;
+
+ ------------------------------
+ -- Detach_Interrupt_Entries --
+ ------------------------------
+
+ procedure Detach_Interrupt_Entries (T : Task_ID) is
+ begin
+ Interrupt_Manager.Detach_Interrupt_Entries (T);
+ end Detach_Interrupt_Entries;
+
+ ---------------------
+ -- Block_Interrupt --
+ ---------------------
+
+ procedure Block_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ Interrupt_Manager.Block_Interrupt (Interrupt);
+ end Block_Interrupt;
+
+ -----------------------
+ -- Unblock_Interrupt --
+ -----------------------
+
+ procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ Interrupt_Manager.Unblock_Interrupt (Interrupt);
+ end Unblock_Interrupt;
+
+ ------------------
+ -- Unblocked_By --
+ ------------------
+
+ function Unblocked_By
+ (Interrupt : Interrupt_ID)
+ return System.Tasking.Task_ID
+ is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ return Last_Unblocker (Interrupt);
+ end Unblocked_By;
+
+ ----------------------
+ -- Ignore_Interrupt --
+ ----------------------
+
+ procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ Interrupt_Manager.Ignore_Interrupt (Interrupt);
+ end Ignore_Interrupt;
+
+ ------------------------
+ -- Unignore_Interrupt --
+ ------------------------
+
+ procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ Interrupt_Manager.Unignore_Interrupt (Interrupt);
+ end Unignore_Interrupt;
+
+ -----------------------
+ -- Interrupt_Manager --
+ -----------------------
+
+ task body Interrupt_Manager is
+
+ ----------------------
+ -- Local Variables --
+ ----------------------
+
+ Intwait_Mask : aliased IMNG.Interrupt_Mask;
+ Ret_Interrupt : Interrupt_ID;
+ Old_Mask : aliased IMNG.Interrupt_Mask;
+ Self_ID : Task_ID := POP.Self;
+
+ ---------------------
+ -- Local Routines --
+ ---------------------
+
+ procedure Unprotected_Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : in Parameterless_Handler;
+ Interrupt : in Interrupt_ID;
+ Static : in Boolean;
+ Restoration : in Boolean := False);
+
+ procedure Unprotected_Detach_Handler
+ (Interrupt : in Interrupt_ID;
+ Static : in Boolean);
+
+ ----------------------------------
+ -- Unprotected_Exchange_Handler --
+ ----------------------------------
+
+ procedure Unprotected_Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : in Parameterless_Handler;
+ Interrupt : in Interrupt_ID;
+ Static : in Boolean;
+ Restoration : in Boolean := False)
+ is
+ begin
+ if User_Entry (Interrupt).T /= Null_Task then
+
+ -- In case we have an Interrupt Entry already installed.
+ -- raise a program error. (propagate it to the caller).
+
+ Unlock_Interrupt (Self_ID, Interrupt);
+ Raise_Exception (Program_Error'Identity,
+ "An interrupt is already installed");
+ end if;
+
+ -- Note : A null handler with Static = True will
+ -- pass the following check. That is the case when we want to
+ -- Detach a handler regardless of the Static status
+ -- of the current_Handler.
+ -- We don't check anything if Restoration is True, since we
+ -- may be detaching a static handler to restore a dynamic one.
+
+ if not Restoration and then not Static
+
+ -- Tries to overwrite a static Interrupt Handler with a
+ -- dynamic Handler
+
+ and then (User_Handler (Interrupt).Static
+
+ -- The new handler is not specified as an
+ -- Interrupt Handler by a pragma.
+
+ or else not Is_Registered (New_Handler))
+ then
+ Unlock_Interrupt (Self_ID, Interrupt);
+ Raise_Exception (Program_Error'Identity,
+ "Trying to overwrite a static Interrupt Handler with a " &
+ "dynamic Handler");
+ end if;
+
+ -- The interrupt should no longer be ingnored if
+ -- it was ever ignored.
+
+ Ignored (Interrupt) := False;
+
+ -- Save the old handler
+
+ Old_Handler := User_Handler (Interrupt).H;
+
+ -- The new handler
+
+ User_Handler (Interrupt).H := New_Handler;
+
+ if New_Handler = null then
+
+ -- The null handler means we are detaching the handler.
+
+ User_Handler (Interrupt).Static := False;
+
+ else
+ User_Handler (Interrupt).Static := Static;
+ end if;
+
+ -- Invoke a corresponding Server_Task if not yet created.
+ -- Place Task_ID info in Server_ID array.
+
+ if Server_ID (Interrupt) = Null_Task then
+ Access_Hold := new Server_Task (Interrupt);
+ Server_ID (Interrupt) := To_System (Access_Hold.all'Identity);
+ else
+ POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep);
+ end if;
+
+ end Unprotected_Exchange_Handler;
+
+ --------------------------------
+ -- Unprotected_Detach_Handler --
+ --------------------------------
+
+ procedure Unprotected_Detach_Handler
+ (Interrupt : in Interrupt_ID;
+ Static : in Boolean)
+ is
+ Old_Handler : Parameterless_Handler;
+
+ begin
+ if User_Entry (Interrupt).T /= Null_Task then
+
+ -- In case we have an Interrupt Entry installed.
+ -- raise a program error. (propagate it to the caller).
+
+ Unlock_Interrupt (Self_ID, Interrupt);
+ Raise_Exception (Program_Error'Identity,
+ "An interrupt entry is already installed");
+ end if;
+
+ -- Note : Static = True will pass the following check. That is the
+ -- case when we want to detach a handler regardless of the static
+ -- status of the current_Handler.
+
+ if not Static and then User_Handler (Interrupt).Static then
+
+ -- Tries to detach a static Interrupt Handler.
+ -- raise a program error.
+
+ Unlock_Interrupt (Self_ID, Interrupt);
+ Raise_Exception (Program_Error'Identity,
+ "Trying to detach a static Interrupt Handler");
+ end if;
+
+ -- The interrupt should no longer be ignored if
+ -- it was ever ignored.
+
+ Ignored (Interrupt) := False;
+
+ Old_Handler := User_Handler (Interrupt).H;
+
+ -- The new handler
+
+ User_Handler (Interrupt).H := null;
+ User_Handler (Interrupt).Static := False;
+ IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (Interrupt));
+
+ end Unprotected_Detach_Handler;
+
+ -- Start of processing for Interrupt_Manager
+
+ begin
+ -- By making this task independent of master, when the process
+ -- goes away, the Interrupt_Manager will terminate gracefully.
+
+ System.Tasking.Utilities.Make_Independent;
+
+ -- Environmen task gets its own interrupt mask, saves it,
+ -- and then masks all interrupts except the Keep_Unmasked set.
+
+ -- During rendezvous, the Interrupt_Manager receives the old
+ -- interrupt mask of the environment task, and sets its own
+ -- interrupt mask to that value.
+
+ -- The environment task will call the entry of Interrupt_Manager some
+ -- during elaboration of the body of this package.
+
+ accept Initialize (Mask : IMNG.Interrupt_Mask) do
+ null;
+ end Initialize;
+
+ -- Note: All tasks in RTS will have all the Reserve Interrupts
+ -- being masked (except the Interrupt_Manager) and Keep_Unmasked
+ -- unmasked when created.
+
+ -- Abort_Task_Interrupt is one of the Interrupt unmasked
+ -- in all tasks. We mask the Interrupt in this particular task
+ -- so that "sigwait" is possible to catch an explicitely sent
+ -- Abort_Task_Interrupt from the Server_Tasks.
+
+ -- This sigwaiting is needed so that we make sure a Server_Task is
+ -- out of its own sigwait state. This extra synchronization is
+ -- necessary to prevent following senarios.
+
+ -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the
+ -- Server_Task then changes its own interrupt mask (OS level).
+ -- If an interrupt (corresponding to the Server_Task) arrives
+ -- in the nean time we have the Interrupt_Manager umnasked and
+ -- the Server_Task waiting on sigwait.
+
+ -- 2) For unbinding handler, we install a default action in the
+ -- Interrupt_Manager. POSIX.1c states that the result of using
+ -- "sigwait" and "sigaction" simaltaneously on the same interrupt
+ -- is undefined. Therefore, we need to be informed from the
+ -- Server_Task of the fact that the Server_Task is out of its
+ -- sigwait stage.
+
+ loop
+ -- A block is needed to absorb Program_Error exception
+
+ declare
+ Old_Handler : Parameterless_Handler;
+
+ begin
+ select
+
+ accept Attach_Handler
+ (New_Handler : in Parameterless_Handler;
+ Interrupt : in Interrupt_ID;
+ Static : in Boolean;
+ Restoration : in Boolean := False)
+ do
+ Lock_Interrupt (Self_ID, Interrupt);
+ Unprotected_Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static, Restoration);
+ Unlock_Interrupt (Self_ID, Interrupt);
+ end Attach_Handler;
+
+ or accept Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : in Parameterless_Handler;
+ Interrupt : in Interrupt_ID;
+ Static : in Boolean)
+ do
+ Lock_Interrupt (Self_ID, Interrupt);
+ Unprotected_Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static);
+ Unlock_Interrupt (Self_ID, Interrupt);
+ end Exchange_Handler;
+
+ or accept Detach_Handler
+ (Interrupt : in Interrupt_ID;
+ Static : in Boolean)
+ do
+ Lock_Interrupt (Self_ID, Interrupt);
+ Unprotected_Detach_Handler (Interrupt, Static);
+ Unlock_Interrupt (Self_ID, Interrupt);
+ end Detach_Handler;
+
+ or accept Bind_Interrupt_To_Entry
+ (T : Task_ID;
+ E : Task_Entry_Index;
+ Interrupt : Interrupt_ID)
+ do
+ Lock_Interrupt (Self_ID, Interrupt);
+
+ -- if there is a binding already (either a procedure or an
+ -- entry), raise Program_Error (propagate it to the caller).
+
+ if User_Handler (Interrupt).H /= null
+ or else User_Entry (Interrupt).T /= Null_Task
+ then
+ Unlock_Interrupt (Self_ID, Interrupt);
+ Raise_Exception (Program_Error'Identity,
+ "A binding for this interrupt is already present");
+ end if;
+
+ -- The interrupt should no longer be ingnored if
+ -- it was ever ignored.
+
+ Ignored (Interrupt) := False;
+ User_Entry (Interrupt) := Entry_Assoc' (T => T, E => E);
+
+ -- Indicate the attachment of Interrupt Entry in ATCB.
+ -- This is need so that when an Interrupt Entry task
+ -- terminates the binding can be cleaned.
+ -- The call to unbinding must be
+ -- make by the task before it terminates.
+
+ T.Interrupt_Entry := True;
+
+ -- Invoke a corresponding Server_Task if not yet created.
+ -- Place Task_ID info in Server_ID array.
+
+ if Server_ID (Interrupt) = Null_Task then
+
+ Access_Hold := new Server_Task (Interrupt);
+ Server_ID (Interrupt) :=
+ To_System (Access_Hold.all'Identity);
+ else
+ POP.Wakeup (Server_ID (Interrupt),
+ Interrupt_Server_Idle_Sleep);
+ end if;
+
+ Unlock_Interrupt (Self_ID, Interrupt);
+ end Bind_Interrupt_To_Entry;
+
+ or accept Detach_Interrupt_Entries (T : Task_ID)
+ do
+ for I in Interrupt_ID'Range loop
+ if not Is_Reserved (I) then
+ Lock_Interrupt (Self_ID, I);
+
+ if User_Entry (I).T = T then
+
+ -- The interrupt should no longer be ignored if
+ -- it was ever ignored.
+
+ Ignored (I) := False;
+ User_Entry (I) := Entry_Assoc'
+ (T => Null_Task, E => Null_Task_Entry);
+ IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (I));
+ end if;
+
+ Unlock_Interrupt (Self_ID, I);
+ end if;
+ end loop;
+
+ -- Indicate in ATCB that no Interrupt Entries are attached.
+
+ T.Interrupt_Entry := False;
+ end Detach_Interrupt_Entries;
+
+ or accept Block_Interrupt (Interrupt : Interrupt_ID) do
+ raise Program_Error;
+ end Block_Interrupt;
+
+ or accept Unblock_Interrupt (Interrupt : Interrupt_ID) do
+ raise Program_Error;
+ end Unblock_Interrupt;
+
+ or accept Ignore_Interrupt (Interrupt : Interrupt_ID) do
+ raise Program_Error;
+ end Ignore_Interrupt;
+
+ or accept Unignore_Interrupt (Interrupt : Interrupt_ID) do
+ raise Program_Error;
+ end Unignore_Interrupt;
+
+ end select;
+
+ exception
+
+ -- If there is a program error we just want to propagate it
+ -- to the caller and do not want to stop this task.
+
+ when Program_Error =>
+ null;
+
+ when others =>
+ pragma Assert
+ (Shutdown ("Interrupt_Manager---exception not expected"));
+ null;
+ end;
+
+ end loop;
+
+ pragma Assert (Shutdown ("Interrupt_Manager---should not get here"));
+
+ end Interrupt_Manager;
+
+ -----------------
+ -- Server_Task --
+ -----------------
+
+ task body Server_Task is
+ Self_ID : Task_ID := Self;
+ Tmp_Handler : Parameterless_Handler;
+ Tmp_ID : Task_ID;
+ Tmp_Entry_Index : Task_Entry_Index;
+ Intwait_Mask : aliased IMNG.Interrupt_Mask;
+ Ret_Interrupt : IMNG.Interrupt_ID;
+
+ begin
+ -- By making this task independent of master, when the process
+ -- goes away, the Server_Task will terminate gracefully.
+
+ System.Tasking.Utilities.Make_Independent;
+
+ -- Install default action in system level.
+
+ IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
+
+ -- Set up the mask (also clears the event flag)
+
+ IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access);
+ IMOP.Add_To_Interrupt_Mask
+ (Intwait_Mask'Access, IMNG.Interrupt_ID (Interrupt));
+
+ -- Remember the Interrupt_ID for Abort_Task.
+
+ PIO.Set_Interrupt_ID (IMNG.Interrupt_ID (Interrupt), Self_ID);
+
+ -- Note: All tasks in RTS will have all the Reserve Interrupts
+ -- being masked (except the Interrupt_Manager) and Keep_Unmasked
+ -- unmasked when created.
+
+ loop
+ System.Tasking.Initialization.Defer_Abort (Self_ID);
+
+ -- A Handler or an Entry is installed. At this point all tasks
+ -- mask for the Interrupt is masked. Catch the Interrupt using
+ -- sigwait.
+
+ -- This task may wake up from sigwait by receiving an interrupt
+ -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding
+ -- a Procedure Handler or an Entry. Or it could be a wake up
+ -- from status change (Unblocked -> Blocked). If that is not
+ -- the case, we should exceute the attached Procedure or Entry.
+
+ POP.Write_Lock (Self_ID);
+
+ if User_Handler (Interrupt).H = null
+ and then User_Entry (Interrupt).T = Null_Task
+ then
+ -- No Interrupt binding. If there is an interrupt,
+ -- Interrupt_Manager will take default action.
+
+ Self_ID.Common.State := Interrupt_Server_Idle_Sleep;
+ POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep);
+ Self_ID.Common.State := Runnable;
+
+ else
+
+ Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag;
+ Ret_Interrupt := IMOP.Interrupt_Wait (Intwait_Mask'Access);
+ Self_ID.Common.State := Runnable;
+
+ if not (Self_ID.Deferral_Level = 0
+ and then Self_ID.Pending_ATC_Level
+ < Self_ID.ATC_Nesting_Level)
+ then
+ if User_Handler (Interrupt).H /= null then
+ Tmp_Handler := User_Handler (Interrupt).H;
+
+ -- RTS calls should not be made with self being locked.
+
+ POP.Unlock (Self_ID);
+
+ Tmp_Handler.all;
+ POP.Write_Lock (Self_ID);
+
+ elsif User_Entry (Interrupt).T /= Null_Task then
+ Tmp_ID := User_Entry (Interrupt).T;
+ Tmp_Entry_Index := User_Entry (Interrupt).E;
+
+ -- RTS calls should not be made with self being locked.
+
+ POP.Unlock (Self_ID);
+
+ System.Tasking.Rendezvous.Call_Simple
+ (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
+
+ POP.Write_Lock (Self_ID);
+ end if;
+ end if;
+ end if;
+
+ POP.Unlock (Self_ID);
+ System.Tasking.Initialization.Undefer_Abort (Self_ID);
+
+ -- Undefer abort here to allow a window for this task
+ -- to be aborted at the time of system shutdown.
+ end loop;
+
+ pragma Assert (Shutdown ("Server_Task---should not get here"));
+ end Server_Task;
+
+ -------------------------------------
+ -- Has_Interrupt_Or_Attach_Handler --
+ -------------------------------------
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Dynamic_Interrupt_Protection) return Boolean is
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ ----------------
+ -- Finalize --
+ ----------------
+
+ procedure Finalize (Object : in out Static_Interrupt_Protection) is
+ begin
+ -- ??? loop to be executed only when we're not doing library level
+ -- finalization, since in this case all interrupt tasks are gone.
+ if not Interrupt_Manager'Terminated then
+ for N in reverse Object.Previous_Handlers'Range loop
+ Interrupt_Manager.Attach_Handler
+ (New_Handler => Object.Previous_Handlers (N).Handler,
+ Interrupt => Object.Previous_Handlers (N).Interrupt,
+ Static => Object.Previous_Handlers (N).Static,
+ Restoration => True);
+ end loop;
+ end if;
+
+ Tasking.Protected_Objects.Entries.Finalize
+ (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
+ end Finalize;
+
+ -------------------------------------
+ -- Has_Interrupt_Or_Attach_Handler --
+ -------------------------------------
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Static_Interrupt_Protection)
+ return Boolean
+ is
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ ----------------------
+ -- Install_Handlers --
+ ----------------------
+
+ procedure Install_Handlers
+ (Object : access Static_Interrupt_Protection;
+ New_Handlers : in New_Handler_Array)
+ is
+ begin
+ for N in New_Handlers'Range loop
+
+ -- We need a lock around this ???
+
+ Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
+ Object.Previous_Handlers (N).Static := User_Handler
+ (New_Handlers (N).Interrupt).Static;
+
+ -- We call Exchange_Handler and not directly Interrupt_Manager.
+ -- Exchange_Handler so we get the Is_Reserved check.
+
+ Exchange_Handler
+ (Old_Handler => Object.Previous_Handlers (N).Handler,
+ New_Handler => New_Handlers (N).Handler,
+ Interrupt => New_Handlers (N).Interrupt,
+ Static => True);
+ end loop;
+ end Install_Handlers;
+
+-- Elaboration code for package System.Interrupts
+begin
+
+ -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent.
+
+ Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
+
+ -- Initialize the lock L.
+
+ Initialization.Defer_Abort (Self);
+ POP.Initialize_Lock (L'Access, POP.ATCB_Level);
+ Initialization.Undefer_Abort (Self);
+
+ -- During the elaboration of this package body we want RTS to
+ -- inherit the interrupt mask from the Environment Task.
+
+ -- The Environment Task should have gotten its mask from
+ -- the enclosing process during the RTS start up. (See
+ -- in s-inmaop.adb). Pass the Interrupt_Mask of the Environment
+ -- task to the Interrupt_Manager.
+
+ -- Note : At this point we know that all tasks (including
+ -- RTS internal servers) are masked for non-reserved signals
+ -- (see s-taprop.adb). Only the Interrupt_Manager will have
+ -- masks set up differently inheriting the original Environment
+ -- Task's mask.
+
+ Interrupt_Manager.Initialize (IMOP.Environment_Mask);
+end System.Interrupts;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.6 $ --
+-- --
+-- Copyright (C) 1991-2000, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a OpenVMS/Alpha version of this package.
+
+-- PLEASE DO NOT add any dependences on other packages.
+-- This package is designed to work with or without tasking support.
+
+-- See the other warnings in the package specification before making
+-- any modifications to this file.
+
+with System.OS_Interface;
+-- used for various Constants, Signal and types
+
+package body System.Interrupt_Management is
+
+ use System.OS_Interface;
+ use type unsigned_long;
+
+ type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
+
+ ---------------------------
+ -- Initialize_Interrupts --
+ ---------------------------
+
+ procedure Initialize_Interrupts is
+ Status : Cond_Value_Type;
+ begin
+ Sys_Crembx
+ (Status => Status,
+ Prmflg => False,
+ Chan => Rcv_Interrupt_Chan,
+ Maxmsg => Interrupt_ID'Size,
+ Bufquo => Interrupt_Bufquo,
+ Lognam => "GNAT_Interrupt_Mailbox",
+ Flags => CMB_M_READONLY);
+
+ pragma Assert ((Status and 1) = 1);
+
+ Sys_Assign
+ (Status => Status,
+ Devnam => "GNAT_Interrupt_Mailbox",
+ Chan => Snd_Interrupt_Chan,
+ Flags => AGN_M_WRITEONLY);
+
+ pragma Assert ((Status and 1) = 1);
+
+ end Initialize_Interrupts;
+
+begin
+ -- Unused
+ Abort_Task_Interrupt := Interrupt_ID_0;
+
+ Reserve := Reserve or Keep_Unmasked or Keep_Masked;
+
+ Reserve (Interrupt_ID_0) := True;
+
+ Initialize_Interrupts;
+
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 1991-2000 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+--
+-- This is the Alpha/VMS version of this package.
+--
+-- This package encapsulates and centralizes information about
+-- all uses of interrupts (or signals), including the
+-- target-dependent mapping of interrupts (or signals) to exceptions.
+
+-- PLEASE DO NOT add any with-clauses to this package.
+-- This is designed to work for both tasking and non-tasking systems,
+-- without pulling in any of the tasking support.
+
+-- PLEASE DO NOT remove the Elaborate_Body pragma from this package.
+-- Elaboration of this package should happen early, as most other
+-- initializations depend on it.
+-- Forcing immediate elaboration of the body also helps to enforce
+-- the design assumption that this is a second-level
+-- package, just one level above System.OS_Interface, with no
+-- cross-dependences.
+
+-- PLEASE DO NOT put any subprogram declarations with arguments of
+-- type Interrupt_ID into the visible part of this package.
+-- The type Interrupt_ID is used to derive the type in Ada.Interrupts,
+-- and adding more operations to that type would be illegal according
+-- to the Ada Reference Manual. (This is the reason why the signals sets
+-- below are implemented as visible arrays rather than functions.)
+
+with System.OS_Interface;
+-- used for Signal
+-- sigset_t
+
+package System.Interrupt_Management is
+
+ pragma Elaborate_Body;
+
+ type Interrupt_Mask is limited private;
+
+ type Interrupt_ID is new System.OS_Interface.Signal;
+
+ type Interrupt_Set is array (Interrupt_ID) of Boolean;
+
+ -- The following objects serve as constants, but are initialized
+ -- in the body to aid portability. This permits us
+ -- to use more portable names for interrupts,
+ -- where distinct names may map to the same interrupt ID value.
+ -- For example, suppose SIGRARE is a signal that is not defined on
+ -- all systems, but is always reserved when it is defined.
+ -- If we have the convention that ID zero is not used for any "real"
+ -- signals, and SIGRARE = 0 when SIGRARE is not one of the locally
+ -- supported signals, we can write
+ -- Reserved (SIGRARE) := true;
+ -- and the initialization code will be portable.
+
+ Abort_Task_Interrupt : Interrupt_ID;
+ -- The interrupt that is used to implement task abortion,
+ -- if an interrupt is used for that purpose.
+ -- This is one of the reserved interrupts.
+
+ Keep_Unmasked : Interrupt_Set := (others => False);
+ -- Keep_Unmasked (I) is true iff the interrupt I is
+ -- one that must be kept unmasked at all times,
+ -- except (perhaps) for short critical sections.
+ -- This includes interrupts that are mapped to exceptions
+ -- (see System.Interrupt_Exceptions.Is_Exception), but may also
+ -- include interrupts (e.g. timer) that need to be kept unmasked
+ -- for other reasons.
+ -- Where interrupts are implemented as OS signals, and signal masking
+ -- is per-task, the interrupt should be unmasked in ALL TASKS.
+
+ Reserve : Interrupt_Set := (others => False);
+ -- Reserve (I) is true iff the interrupt I is one that
+ -- cannot be permitted to be attached to a user handler.
+ -- The possible reasons are many. For example,
+ -- it may be mapped to an exception, used to implement task abortion,
+ -- or used to implement time delays.
+
+ Keep_Masked : Interrupt_Set := (others => False);
+ -- Keep_Masked (I) is true iff the interrupt I must always be masked.
+ -- Where interrupts are implemented as OS signals, and signal masking
+ -- is per-task, the interrupt should be masked in ALL TASKS.
+ -- There might not be any interrupts in this class, depending on
+ -- the environment. For example, if interrupts are OS signals
+ -- and signal masking is per-task, use of the sigwait operation
+ -- requires the signal be masked in all tasks.
+
+ procedure Initialize_Interrupts;
+ -- On systems where there is no signal inheritance between tasks (e.g
+ -- VxWorks, LinuxThreads), this procedure is used to initialize interrupts
+ -- handling in each task. Otherwise this function should only be called by
+ -- initialize in this package body.
+
+private
+
+ use type System.OS_Interface.unsigned_long;
+
+ type Interrupt_Mask is new System.OS_Interface.sigset_t;
+
+ -- Interrupts on VMS are implemented with a mailbox. A QIO read is
+ -- registered on the Rcv channel and the interrupt occurs by registering
+ -- a QIO write on the Snd channel. The maximum number of pending
+ -- interrupts is arbitrarily set at 1000. One nice feature of using
+ -- a mailbox is that it is trivially extendable to cross process
+ -- interrupts.
+
+ Rcv_Interrupt_Chan : System.OS_Interface.unsigned_short := 0;
+ Snd_Interrupt_Chan : System.OS_Interface.unsigned_short := 0;
+ Interrupt_Mailbox : Interrupt_ID := 0;
+ Interrupt_Bufquo : System.OS_Interface.unsigned_long
+ := 1000 * (Interrupt_ID'Size / 8);
+
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- SYSTEM.MACHINE_STATE_OPERATIONS --
+-- --
+-- B o d y --
+-- (Version for Alpha/VMS) --
+-- --
+-- $Revision: 1.3 $
+-- --
+-- Copyright (C) 2001 Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This version of System.Machine_State_Operations is for use on
+-- Alpha systems running VMS.
+
+with System.Memory;
+with System.Aux_DEC; use System.Aux_DEC;
+with Unchecked_Conversion;
+
+package body System.Machine_State_Operations is
+
+ use System.Exceptions;
+ subtype Cond_Value_Type is Unsigned_Longword;
+
+ -- Record layouts copied from Starlet.
+
+ type ICB_Fflags_Bits_Type is record
+ Exception_Frame : Boolean;
+ Ast_Frame : Boolean;
+ Bottom_Of_Stack : Boolean;
+ Base_Frame : Boolean;
+ Filler_1 : Unsigned_20;
+ end record;
+
+ for ICB_Fflags_Bits_Type use record
+ Exception_Frame at 0 range 0 .. 0;
+ Ast_Frame at 0 range 1 .. 1;
+ Bottom_Of_Stack at 0 range 2 .. 2;
+ Base_Frame at 0 range 3 .. 3;
+ Filler_1 at 0 range 4 .. 23;
+ end record;
+ for ICB_Fflags_Bits_Type'Size use 24;
+
+ ICB_Fflags_Bits_Type_Init : constant ICB_Fflags_Bits_Type :=
+ (ExceptIon_Frame => False,
+ Ast_Frame => False,
+ Bottom_Of_STACK => False,
+ Base_Frame => False,
+ Filler_1 => 0);
+
+ type ICB_Hdr_Quad_Type is record
+ Context_Length : Unsigned_Longword;
+ Fflags_Bits : ICB_Fflags_Bits_Type;
+ Block_Version : Unsigned_Byte;
+ end record;
+
+ for ICB_Hdr_Quad_Type use record
+ Context_Length at 0 range 0 .. 31;
+ Fflags_Bits at 4 range 0 .. 23;
+ Block_Version at 7 range 0 .. 7;
+ end record;
+ for ICB_Hdr_Quad_Type'Size use 64;
+
+ ICB_Hdr_Quad_Type_Init : constant ICB_Hdr_Quad_Type :=
+ (Context_Length => 0,
+ Fflags_Bits => ICB_Fflags_Bits_Type_Init,
+ Block_Version => 0);
+
+ type Invo_Context_Blk_Type is record
+ --
+ -- The first quadword contains:
+ -- o The length of the structure in bytes (a longword field)
+ -- o The frame flags (a 3 byte field of bits)
+ -- o The version number (a 1 byte field)
+ --
+ Hdr_Quad : ICB_Hdr_Quad_Type;
+ --
+ -- The address of the procedure descriptor for the procedure.
+ --
+ Procedure_Descriptor : Unsigned_Quadword;
+ --
+ -- The current PC of a given procedure invocation.
+ --
+ Program_Counter : Integer_64;
+ --
+ -- The current PS of a given procedure invocation.
+ --
+ Processor_Status : Integer_64;
+ --
+ -- The register contents areas. 31 for scalars, 31 for float.
+ --
+ Ireg : Unsigned_Quadword_Array (0 .. 30);
+ Freg : Unsigned_Quadword_Array (0 .. 30);
+ --
+ -- The following is an "internal" area that's reserved for use by
+ -- the operating system. It's size may vary over time.
+ --
+ System_Defined : Unsigned_Quadword_Array (0 .. 1);
+
+ ----Component(s) below are defined as comments since they
+ ----overlap other fields
+ ----
+ ----Chfctx_Addr : Unsigned_Quadword;
+
+ --
+ -- Align to octaword.
+ --
+ Filler_1 : String (1 .. 0);
+ end record;
+
+ for Invo_Context_Blk_Type use record
+ Hdr_Quad at 0 range 0 .. 63;
+ Procedure_Descriptor at 8 range 0 .. 63;
+ Program_Counter at 16 range 0 .. 63;
+ Processor_Status at 24 range 0 .. 63;
+ Ireg at 32 range 0 .. 1983;
+ Freg at 280 range 0 .. 1983;
+ System_Defined at 528 range 0 .. 127;
+
+ ----Component representation spec(s) below are defined as
+ ----comments since they overlap other fields
+ ----
+ ----Chfctx_Addr at 528 range 0 .. 63;
+
+ Filler_1 at 544 range 0 .. -1;
+ end record;
+ for Invo_Context_Blk_Type'Size use 4352;
+
+ Invo_Context_Blk_Type_Init : constant Invo_Context_Blk_Type :=
+ (Hdr_Quad => ICB_Hdr_Quad_Type_Init,
+ Procedure_Descriptor => (0, 0),
+ Program_Counter => 0,
+ Processor_Status => 0,
+ Ireg => (others => (0, 0)),
+ Freg => (others => (0, 0)),
+ System_Defined => (others => (0, 0)),
+ Filler_1 => (others => ASCII.NUL));
+
+ subtype Invo_Handle_Type is Unsigned_Longword;
+
+ type Invo_Handle_Access_Type is access all Invo_Handle_Type;
+
+ function Fetch is new Fetch_From_Address (Code_Loc);
+
+ function To_Invo_Handle_Access is new Unchecked_Conversion
+ (Machine_State, Invo_Handle_Access_Type);
+
+ function To_Machine_State is new Unchecked_Conversion
+ (System.Address, Machine_State);
+
+ function To_Code_Loc is new Unchecked_Conversion
+ (Unsigned_Longword, Code_Loc);
+
+ ----------------------------
+ -- Allocate_Machine_State --
+ ----------------------------
+
+ function Allocate_Machine_State return Machine_State is
+ begin
+ return To_Machine_State
+ (Memory.Alloc (Invo_Handle_Type'Max_Size_In_Storage_Elements));
+ end Allocate_Machine_State;
+
+ -------------------
+ -- Enter_Handler --
+ -------------------
+
+ procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
+ procedure Get_Invo_Context (
+ Result : out Unsigned_Longword; -- return value
+ Invo_Handle : in Invo_Handle_Type;
+ Invo_Context : out Invo_Context_Blk_Type);
+
+ pragma Interface (External, Get_Invo_Context);
+
+ pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT",
+ (Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type),
+ (Value, Value, Reference));
+
+ ICB : Invo_Context_Blk_Type;
+
+ procedure Goto_Unwind (
+ Status : out Cond_Value_Type; -- return value
+ Target_Invo : in Address := Address_Zero;
+ Target_PC : in Address := Address_Zero;
+ New_R0 : in Unsigned_Quadword
+ := Unsigned_Quadword'Null_Parameter;
+ New_R1 : in Unsigned_Quadword
+ := Unsigned_Quadword'Null_Parameter);
+
+ pragma Interface (External, Goto_Unwind);
+
+ pragma Import_Valued_Procedure
+ (Goto_Unwind, "SYS$GOTO_UNWIND",
+ (Cond_Value_Type, Address, Address,
+ Unsigned_Quadword, Unsigned_Quadword),
+ (Value, Reference, Reference,
+ Reference, Reference));
+
+ Status : Cond_Value_Type;
+
+ begin
+ Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB);
+ Goto_Unwind
+ (Status, System.Address (To_Invo_Handle_Access (M).all), Handler);
+ end Enter_Handler;
+
+ ----------------
+ -- Fetch_Code --
+ ----------------
+
+ function Fetch_Code (Loc : Code_Loc) return Code_Loc is
+ begin
+ -- The starting address is in the second longword pointed to by Loc.
+ return Fetch (System.Aux_DEC."+" (Loc, 8));
+ end Fetch_Code;
+
+ ------------------------
+ -- Free_Machine_State --
+ ------------------------
+
+ procedure Free_Machine_State (M : in out Machine_State) is
+ procedure Gnat_Free (M : in Invo_Handle_Access_Type);
+ pragma Import (C, Gnat_Free, "__gnat_free");
+
+ begin
+ Gnat_Free (To_Invo_Handle_Access (M));
+ M := Machine_State (Null_Address);
+ end Free_Machine_State;
+
+ ------------------
+ -- Get_Code_Loc --
+ ------------------
+
+ function Get_Code_Loc (M : Machine_State) return Code_Loc is
+ procedure Get_Invo_Context (
+ Result : out Unsigned_Longword; -- return value
+ Invo_Handle : in Invo_Handle_Type;
+ Invo_Context : out Invo_Context_Blk_Type);
+
+ pragma Interface (External, Get_Invo_Context);
+
+ pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT",
+ (Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type),
+ (Value, Value, Reference));
+
+ Asm_Call_Size : constant := 4;
+ -- Under VMS a call
+ -- asm instruction takes 4 bytes. So we must remove this amount.
+
+ ICB : Invo_Context_Blk_Type;
+ Status : Cond_Value_Type;
+
+ begin
+ Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB);
+ if (Status and 1) /= 1 then
+ return Code_Loc (System.Null_Address);
+ end if;
+ return Code_Loc (ICB.Program_Counter - Asm_Call_Size);
+ end Get_Code_Loc;
+
+ --------------------------
+ -- Machine_State_Length --
+ --------------------------
+
+ function Machine_State_Length
+ return System.Storage_Elements.Storage_Offset
+ is
+ use System.Storage_Elements;
+
+ begin
+ return Invo_Handle_Type'Size / 8;
+ end Machine_State_Length;
+
+ ---------------
+ -- Pop_Frame --
+ ---------------
+
+ procedure Pop_Frame
+ (M : Machine_State;
+ Info : Subprogram_Info_Type)
+ is
+
+ procedure Get_Prev_Invo_Handle (
+ Result : out Invo_Handle_Type; -- return value
+ ICB : in Invo_Handle_Type);
+
+ pragma Interface (External, Get_Prev_Invo_Handle);
+
+ pragma Import_Valued_Procedure
+ (Get_Prev_Invo_Handle, "LIB$GET_PREV_INVO_HANDLE",
+ (Invo_Handle_Type, Invo_Handle_Type),
+ (Value, Value));
+
+ Prev_Handle : aliased Invo_Handle_Type;
+
+ begin
+ Get_Prev_Invo_Handle (Prev_Handle, To_Invo_Handle_Access (M).all);
+ To_Invo_Handle_Access (M).all := Prev_Handle;
+ end Pop_Frame;
+
+ -----------------------
+ -- Set_Machine_State --
+ -----------------------
+
+ procedure Set_Machine_State (M : Machine_State) is
+
+ procedure Get_Curr_Invo_Context
+ (Invo_Context : out Invo_Context_Blk_Type);
+
+ pragma Interface (External, Get_Curr_Invo_Context);
+
+ pragma Import_Valued_Procedure
+ (Get_Curr_Invo_Context, "LIB$GET_CURR_INVO_CONTEXT",
+ (Invo_Context_Blk_Type),
+ (Reference));
+
+ procedure Get_Invo_Handle (
+ Result : out Invo_Handle_Type; -- return value
+ Invo_Context : in Invo_Context_Blk_Type);
+
+ pragma Interface (External, Get_Invo_Handle);
+
+ pragma Import_Valued_Procedure (Get_Invo_Handle, "LIB$GET_INVO_HANDLE",
+ (Invo_Handle_Type, Invo_Context_Blk_Type),
+ (Value, Reference));
+
+ ICB : Invo_Context_Blk_Type;
+ Invo_Handle : aliased Invo_Handle_Type;
+
+ begin
+ Get_Curr_Invo_Context (ICB);
+ Get_Invo_Handle (Invo_Handle, ICB);
+ To_Invo_Handle_Access (M).all := Invo_Handle;
+ Pop_Frame (M, System.Null_Address);
+ end Set_Machine_State;
+
+ ------------------------------
+ -- Set_Signal_Machine_State --
+ ------------------------------
+
+ procedure Set_Signal_Machine_State
+ (M : Machine_State;
+ Context : System.Address) is
+ begin
+ null;
+ end Set_Signal_Machine_State;
+
+end System.Machine_State_Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.6 $
+-- --
+-- Copyright (C) 1991-2000 Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a OpenVMS/Alpha version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+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 Interfaces.C; use Interfaces.C;
+package body System.OS_Interface is
+
+ function sched_yield return int is
+ procedure sched_yield_base;
+ pragma Import (C, sched_yield_base, "PTHREAD_YIELD_NP");
+ begin
+ sched_yield_base;
+ return 0;
+ end sched_yield;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.17 $
+-- --
+-- Copyright (C) 1991-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a OpenVMS/Alpha version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("--for-linker=sys$library:pthread$rtl.exe");
+ -- Link in the DEC threads library.
+
+ -- pragma Linker_Options ("--for-linker=/threads_enable");
+ -- Enable upcalls and multiple kernel threads.
+
+ 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;
+
+ -----------------------------
+ -- Signals (Interrupt IDs) --
+ -----------------------------
+
+ -- Type signal has an arbitrary limit of 31
+
+ Max_Interrupt : constant := 31;
+ type Signal is new unsigned range 0 .. Max_Interrupt;
+ for Signal'Size use unsigned'Size;
+
+ type sigset_t is array (Signal) of Boolean;
+ pragma Pack (sigset_t);
+
+ -- Interrupt_Number_Type
+ -- Unsigned long integer denoting the number of an interrupt
+
+ subtype Interrupt_Number_Type is unsigned_long;
+
+ -- OpenVMS system services return values of type Cond_Value_Type.
+
+ subtype Cond_Value_Type is unsigned_long;
+ subtype Short_Cond_Value_Type is unsigned_short;
+
+ type IO_Status_Block_Type is record
+ Status : Short_Cond_Value_Type;
+ Count : unsigned_short;
+ Dev_Info : unsigned_long;
+ end record;
+
+ type AST_Handler is access procedure (Param : Address);
+ No_AST_Handler : constant AST_Handler := null;
+
+ CMB_M_READONLY : constant := 16#00000001#;
+ CMB_M_WRITEONLY : constant := 16#00000002#;
+ AGN_M_READONLY : constant := 16#00000001#;
+ AGN_M_WRITEONLY : constant := 16#00000002#;
+
+ IO_WRITEVBLK : constant := 48; -- WRITE VIRTUAL BLOCK
+ IO_READVBLK : constant := 49; -- READ VIRTUAL BLOCK
+
+ ----------------
+ -- Sys_Assign --
+ ----------------
+ --
+ -- Assign I/O Channel
+ --
+ -- Status = returned status
+ -- Devnam = address of device name or logical name string
+ -- descriptor
+ -- Chan = address of word to receive channel number assigned
+ -- Acmode = access mode associated with channel
+ -- Mbxnam = address of mailbox logical name string descriptor, if
+ -- mailbox associated with device
+ -- Flags = optional channel flags longword for specifying options
+ -- for the $ASSIGN operation
+ --
+
+ procedure Sys_Assign
+ (Status : out Cond_Value_Type;
+ Devnam : in String;
+ Chan : out unsigned_short;
+ Acmode : in unsigned_short := 0;
+ Mbxnam : in String := String'Null_Parameter;
+ Flags : in unsigned_long := 0);
+ pragma Interface (External, Sys_Assign);
+ pragma Import_Valued_Procedure
+ (Sys_Assign, "SYS$ASSIGN",
+ (Cond_Value_Type, String, unsigned_short,
+ unsigned_short, String, unsigned_long),
+ (Value, Descriptor (s), Reference,
+ Value, Descriptor (s), Value),
+ Flags);
+
+ ----------------
+ -- Sys_Cantim --
+ ----------------
+ --
+ -- Cancel Timer
+ --
+ -- Status = returned status
+ -- Reqidt = ID of timer to be cancelled
+ -- Acmode = Access mode
+ --
+ procedure Sys_Cantim
+ (Status : out Cond_Value_Type;
+ Reqidt : in Address;
+ Acmode : in unsigned);
+ pragma Interface (External, Sys_Cantim);
+ pragma Import_Valued_Procedure
+ (Sys_Cantim, "SYS$CANTIM",
+ (Cond_Value_Type, Address, unsigned),
+ (Value, Value, Value));
+
+ ----------------
+ -- Sys_Crembx --
+ ----------------
+ --
+ -- Create mailbox
+ --
+ -- Status = returned status
+ -- Prmflg = permanent flag
+ -- Chan = channel
+ -- Maxmsg = maximum message
+ -- Bufquo = buufer quote
+ -- Promsk = protection mast
+ -- Acmode = access mode
+ -- Lognam = logical name
+ -- Flags = flags
+ --
+ procedure Sys_Crembx
+ (Status : out Cond_Value_Type;
+ Prmflg : in Boolean;
+ Chan : out unsigned_short;
+ Maxmsg : in unsigned_long := 0;
+ Bufquo : in unsigned_long := 0;
+ Promsk : in unsigned_short := 0;
+ Acmode : in unsigned_short := 0;
+ Lognam : in String;
+ Flags : in unsigned_long := 0);
+ pragma Interface (External, Sys_Crembx);
+ pragma Import_Valued_Procedure
+ (Sys_Crembx, "SYS$CREMBX",
+ (Cond_Value_Type, Boolean, unsigned_short,
+ unsigned_long, unsigned_long, unsigned_short,
+ unsigned_short, String, unsigned_long),
+ (Value, Value, Reference,
+ Value, Value, Value,
+ Value, Descriptor (s), Value));
+
+ -------------
+ -- Sys_QIO --
+ -------------
+ --
+ -- Queue I/O
+ --
+ -- Status = Returned status of call
+ -- EFN = event flag to be set when I/O completes
+ -- Chan = channel
+ -- Func = function
+ -- Iosb = I/O status block
+ -- Astadr = system trap to be generated when I/O completes
+ -- Astprm = AST parameter
+ -- P1-6 = optional parameters
+
+ procedure Sys_QIO
+ (Status : out Cond_Value_Type;
+ EFN : in unsigned_long := 0;
+ Chan : in unsigned_short;
+ Func : in unsigned_long := 0;
+ Iosb : out IO_Status_Block_Type;
+ Astadr : in AST_Handler := No_AST_Handler;
+ Astprm : in Address := Null_Address;
+ P1 : in unsigned_long := 0;
+ P2 : in unsigned_long := 0;
+ P3 : in unsigned_long := 0;
+ P4 : in unsigned_long := 0;
+ P5 : in unsigned_long := 0;
+ P6 : in unsigned_long := 0);
+
+ procedure Sys_QIO
+ (Status : out Cond_Value_Type;
+ EFN : in unsigned_long := 0;
+ Chan : in unsigned_short;
+ Func : in unsigned_long := 0;
+ Iosb : in Address := Null_Address;
+ Astadr : in AST_Handler := No_AST_Handler;
+ Astprm : in Address := Null_Address;
+ P1 : in unsigned_long := 0;
+ P2 : in unsigned_long := 0;
+ P3 : in unsigned_long := 0;
+ P4 : in unsigned_long := 0;
+ P5 : in unsigned_long := 0;
+ P6 : in unsigned_long := 0);
+
+ pragma Interface (External, Sys_QIO);
+ pragma Import_Valued_Procedure
+ (Sys_QIO, "SYS$QIO",
+ (Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long,
+ IO_Status_Block_Type, AST_Handler, Address,
+ unsigned_long, unsigned_long, unsigned_long,
+ unsigned_long, unsigned_long, unsigned_long),
+ (Value, Value, Value, Value,
+ Reference, Value, Value,
+ Value, Value, Value,
+ Value, Value, Value));
+
+ pragma Import_Valued_Procedure
+ (Sys_QIO, "SYS$QIO",
+ (Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long,
+ Address, AST_Handler, Address,
+ unsigned_long, unsigned_long, unsigned_long,
+ unsigned_long, unsigned_long, unsigned_long),
+ (Value, Value, Value, Value,
+ Value, Value, Value,
+ Value, Value, Value,
+ Value, Value, Value));
+
+ ----------------
+ -- Sys_Setimr --
+ ----------------
+ --
+ -- Set Timer
+ --
+ -- Status = Returned status of call
+ -- EFN = event flag to be set when timer expires
+ -- Tim = expiration time
+ -- AST = system trap to be generated when timer expires
+ -- Redidt = returned ID of timer (e.g. to cancel timer)
+ -- Flags = flags
+ --
+ procedure Sys_Setimr
+ (Status : out Cond_Value_Type;
+ EFN : in unsigned_long;
+ Tim : in Long_Integer;
+ AST : in AST_Handler;
+ Reqidt : in Address;
+ Flags : in unsigned_long);
+ pragma Interface (External, Sys_Setimr);
+ pragma Import_Valued_Procedure
+ (Sys_Setimr, "SYS$SETIMR",
+ (Cond_Value_Type, unsigned_long, Long_Integer,
+ AST_Handler, Address, unsigned_long),
+ (Value, Value, Reference,
+ Value, Value, Value));
+
+ Interrupt_ID_0 : constant := 0;
+ Interrupt_ID_1 : constant := 1;
+ Interrupt_ID_2 : constant := 2;
+ Interrupt_ID_3 : constant := 3;
+ Interrupt_ID_4 : constant := 4;
+ Interrupt_ID_5 : constant := 5;
+ Interrupt_ID_6 : constant := 6;
+ Interrupt_ID_7 : constant := 7;
+ Interrupt_ID_8 : constant := 8;
+ Interrupt_ID_9 : constant := 9;
+ Interrupt_ID_10 : constant := 10;
+ Interrupt_ID_11 : constant := 11;
+ Interrupt_ID_12 : constant := 12;
+ Interrupt_ID_13 : constant := 13;
+ Interrupt_ID_14 : constant := 14;
+ Interrupt_ID_15 : constant := 15;
+ Interrupt_ID_16 : constant := 16;
+ Interrupt_ID_17 : constant := 17;
+ Interrupt_ID_18 : constant := 18;
+ Interrupt_ID_19 : constant := 19;
+ Interrupt_ID_20 : constant := 20;
+ Interrupt_ID_21 : constant := 21;
+ Interrupt_ID_22 : constant := 22;
+ Interrupt_ID_23 : constant := 23;
+ Interrupt_ID_24 : constant := 24;
+ Interrupt_ID_25 : constant := 25;
+ Interrupt_ID_26 : constant := 26;
+ Interrupt_ID_27 : constant := 27;
+ Interrupt_ID_28 : constant := 28;
+ Interrupt_ID_29 : constant := 29;
+ Interrupt_ID_30 : constant := 30;
+ Interrupt_ID_31 : constant := 31;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EINTR : constant := 4; -- Interrupted system call
+ EAGAIN : constant := 11; -- No more processes
+ ENOMEM : constant := 12; -- Not enough core
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 1;
+ SCHED_RR : constant := 2;
+ SCHED_OTHER : constant := 3;
+ SCHED_BG : constant := 4;
+ SCHED_LFI : constant := 5;
+ SCHED_LRR : constant := 6;
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill);
+
+ function getpid return pid_t;
+ pragma Import (C, getpid);
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ 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_JOINABLE : constant := 0;
+ PTHREAD_CREATE_DETACHED : constant := 1;
+
+ PTHREAD_CANCEL_DISABLE : constant := 0;
+ PTHREAD_CANCEL_ENABLE : constant := 1;
+
+ PTHREAD_CANCEL_DEFERRED : constant := 0;
+ PTHREAD_CANCEL_ASYNCHRONOUS : constant := 1;
+
+ -- Don't use ERRORCHECK mutexes, they don't work when a thread is not
+ -- the owner. AST's, at least, unlock others threads mutexes. Even
+ -- if the error is ignored, they don't work.
+ PTHREAD_MUTEX_NORMAL_NP : constant := 0;
+ PTHREAD_MUTEX_RECURSIVE_NP : constant := 1;
+ PTHREAD_MUTEX_ERRORCHECK_NP : constant := 2;
+
+ PTHREAD_INHERIT_SCHED : constant := 0;
+ PTHREAD_EXPLICIT_SCHED : constant := 1;
+
+ function pthread_cancel (thread : pthread_t) return int;
+ pragma Import (C, pthread_cancel, "PTHREAD_CANCEL");
+
+ procedure pthread_testcancel;
+ pragma Import (C, pthread_testcancel, "PTHREAD_TESTCANCEL");
+
+ function pthread_setcancelstate
+ (newstate : int; oldstate : access int) return int;
+ pragma Import (C, pthread_setcancelstate, "PTHREAD_SETCANCELSTATE");
+
+ function pthread_setcanceltype
+ (newtype : int; oldtype : access int) return int;
+ pragma Import (C, pthread_setcanceltype, "PTHREAD_SETCANCELTYPE");
+
+ ---------------------------
+ -- POSIX.1c Section 3 --
+ ---------------------------
+
+ function pthread_lock_global_np return int;
+ pragma Import (C, pthread_lock_global_np, "PTHREAD_LOCK_GLOBAL_NP");
+
+ function pthread_unlock_global_np return int;
+ pragma Import (C, pthread_unlock_global_np, "PTHREAD_UNLOCK_GLOBAL_NP");
+
+ ----------------------------
+ -- 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_mutexattr_settype_np
+ (attr : access pthread_mutexattr_t;
+ mutextype : int) return int;
+ pragma Import (C, pthread_mutexattr_settype_np,
+ "PTHREAD_MUTEXATTR_SETTYPE_NP");
+
+ 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_signal_int_np
+ (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal_int_np,
+ "PTHREAD_COND_SIGNAL_INT_NP");
+
+ 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");
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t; protocol : int) return int;
+ pragma Import (C, pthread_mutexattr_setprotocol,
+ "PTHREAD_MUTEXATTR_SETPROTOCOL");
+
+ type struct_sched_param is record
+ sched_priority : int; -- scheduling priority
+ end record;
+ for struct_sched_param'Size use 8*4;
+ pragma Convention (C, struct_sched_param);
+
+ 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,
+ "PTHREAD_ATTR_SETINHERITSCHED");
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t; policy : int) return int;
+ pragma Import (C, pthread_attr_setschedpolicy,
+ "PTHREAD_ATTR_SETSCHEDPOLICY");
+
+ function pthread_attr_setschedparam
+ (attr : access pthread_attr_t;
+ sched_param : int) return int;
+ pragma Import (C, pthread_attr_setschedparam, "PTHREAD_ATTR_SETSCHEDPARAM");
+
+ function sched_yield return int;
+
+ -----------------------------
+ -- 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,
+ "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 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 pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "PTHREAD_SETSPECIFIC");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "PTHREAD_GETSPECIFIC");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "PTHREAD_KEY_CREATE");
+
+private
+
+ type pid_t is new int;
+
+ type pthreadLongAddr_p is mod 2 ** Long_Integer'Size;
+
+ type pthreadLongAddr_t is mod 2 ** Long_Integer'Size;
+ type pthreadLongAddr_t_ptr is mod 2 ** Long_Integer'Size;
+
+ type pthreadLongString_t is mod 2 ** Long_Integer'Size;
+
+ type pthreadLongUint_t is mod 2 ** Long_Integer'Size;
+ type pthreadLongUint_array is array (Natural range <>)
+ of pthreadLongUint_t;
+
+ type pthread_t is mod 2 ** Long_Integer'Size;
+
+ type pthread_cond_t is record
+ state : unsigned;
+ valid : unsigned;
+ name : pthreadLongString_t;
+ arg : unsigned;
+ sequence : unsigned;
+ block : pthreadLongAddr_t_ptr;
+ end record;
+ for pthread_cond_t'Size use 8*32;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_attr_t is record
+ valid : long;
+ name : pthreadLongString_t;
+ arg : pthreadLongUint_t;
+ reserved : pthreadLongUint_array (0 .. 18);
+ end record;
+ for pthread_attr_t'Size use 8*176;
+ pragma Convention (C, pthread_attr_t);
+
+ type pthread_mutex_t is record
+ lock : unsigned;
+ valid : unsigned;
+ name : pthreadLongString_t;
+ arg : unsigned;
+ sequence : unsigned;
+ block : pthreadLongAddr_p;
+ owner : unsigned;
+ depth : unsigned;
+ end record;
+ for pthread_mutex_t'Size use 8*40;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_mutexattr_t is record
+ valid : long;
+ reserved : pthreadLongUint_array (0 .. 14);
+ end record;
+ for pthread_mutexattr_t'Size use 8*128;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type pthread_condattr_t is record
+ valid : long;
+ reserved : pthreadLongUint_array (0 .. 12);
+ end record;
+ for pthread_condattr_t'Size use 8*112;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_key_t is new unsigned;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ P R I M I T I V E S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1998-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the OpenVMS/Alpha version of this file
+
+with System.Aux_DEC;
+
+package body System.OS_Primitives is
+
+ --------------------------------------
+ -- Local functions and declarations --
+ --------------------------------------
+
+ function Get_GMToff return Integer;
+ pragma Import (C, Get_GMToff, "get_gmtoff");
+ -- Get the offset from GMT for this timezone
+
+ VMS_Epoch_Offset : constant Long_Integer :=
+ 10_000_000 *
+ (3_506_716_800 + Long_Integer (Get_GMToff));
+ -- The offset between the Unix Epoch and the VMS Epoch
+
+ subtype Cond_Value_Type is System.Aux_DEC.Unsigned_Longword;
+ -- Condition Value return type
+
+ ----------------
+ -- Sys_Schdwk --
+ ----------------
+ --
+ -- Schedule Wakeup
+ --
+ -- status = returned status
+ -- pidadr = address of process id to be woken up
+ -- prcnam = name of process to be woken up
+ -- daytim = time to wake up
+ -- reptim = repitition interval of wakeup calls
+ --
+
+ procedure Sys_Schdwk
+ (
+ Status : out Cond_Value_Type;
+ Pidadr : in Address := Null_Address;
+ Prcnam : in String := String'Null_Parameter;
+ Daytim : in Long_Integer;
+ Reptim : in Long_Integer := Long_Integer'Null_Parameter
+ );
+
+ pragma Interface (External, Sys_Schdwk);
+ -- VMS system call to schedule a wakeup event
+ pragma Import_Valued_Procedure
+ (Sys_Schdwk, "SYS$SCHDWK",
+ (Cond_Value_Type, Address, String, Long_Integer, Long_Integer),
+ (Value, Value, Descriptor (S), Reference, Reference)
+ );
+
+ ----------------
+ -- Sys_Gettim --
+ ----------------
+ --
+ -- Get System Time
+ --
+ -- status = returned status
+ -- tim = current system time
+ --
+
+ procedure Sys_Gettim
+ (
+ Status : out Cond_Value_Type;
+ Tim : out OS_Time
+ );
+ -- VMS system call to get the current system time
+ pragma Interface (External, Sys_Gettim);
+ pragma Import_Valued_Procedure
+ (Sys_Gettim, "SYS$GETTIM",
+ (Cond_Value_Type, OS_Time),
+ (Value, Reference)
+ );
+
+ ---------------
+ -- Sys_Hiber --
+ ---------------
+ --
+ -- Hibernate (until woken up)
+ --
+ -- status = returned status
+ --
+
+ procedure Sys_Hiber (Status : out Cond_Value_Type);
+ -- VMS system call to hibernate the current process
+ pragma Interface (External, Sys_Hiber);
+ pragma Import_Valued_Procedure
+ (Sys_Hiber, "SYS$HIBER",
+ (Cond_Value_Type),
+ (Value)
+ );
+
+ -----------
+ -- Clock --
+ -----------
+
+ function OS_Clock return OS_Time is
+ Status : Cond_Value_Type;
+ T : OS_Time;
+ begin
+ Sys_Gettim (Status, T);
+ return (T);
+ end OS_Clock;
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock return Duration is
+ begin
+ return To_Duration (OS_Clock, Absolute_Calendar);
+ end Clock;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration renames Clock;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Time : Duration;
+ Mode : Integer)
+ is
+ Sleep_Time : OS_Time;
+ Status : Cond_Value_Type;
+
+ begin
+ Sleep_Time := To_OS_Time (Time, Mode);
+ Sys_Schdwk (Status => Status, Daytim => Sleep_Time);
+ Sys_Hiber (Status);
+ end Timed_Delay;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (T : OS_Time; Mode : Integer) return Duration is
+ begin
+ return Duration'Fixed_Value (T - VMS_Epoch_Offset) * 100;
+ end To_Duration;
+
+ ----------------
+ -- To_OS_Time --
+ ----------------
+
+ function To_OS_Time (D : Duration; Mode : Integer) return OS_Time is
+ begin
+ if Mode = Relative then
+ return -(Long_Integer'Integer_Value (D) / 100);
+ else
+ return Long_Integer'Integer_Value (D) / 100 + VMS_Epoch_Offset;
+ end if;
+ end To_OS_Time;
+
+end System.OS_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1998-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides low level primitives used to implement clock and
+-- delays in non tasking applications on Alpha/VMS
+
+-- The choice of the real clock/delay implementation (depending on whether
+-- tasking is involved or not) is done via soft links (see s-tasoli.ads)
+
+-- NEVER add any dependency to tasking packages here
+
+package System.OS_Primitives is
+
+ subtype OS_Time is Long_Integer;
+ -- System time on VMS is used for performance reasons.
+ -- Note that OS_Time is *not* the same as Ada.Calendar.Time, the
+ -- difference being that relative OS_Time is negative, but relative
+ -- Calendar.Time is positive.
+ -- See Ada.Calendar.Delays for more information on VMS Time.
+
+ Max_Sensible_Delay : constant Duration := 183 * 24 * 60 * 60.0;
+ -- Max of half a year delay, needed to prevent exceptions for large
+ -- delay values. It seems unlikely that any test will notice this
+ -- restriction, except in the case of applications setting the clock at
+ -- at run time (see s-tastim.adb). Also note that a larger value might
+ -- cause problems (e.g overflow, or more likely OS limitation in the
+ -- primitives used).
+
+ function OS_Clock return OS_Time;
+ -- Returns "absolute" time, represented as an offset
+ -- relative to "the Epoch", which is Nov 17, 1858 on VMS.
+
+ function Clock return Duration;
+ pragma Inline (Clock);
+ -- Returns "absolute" time, represented as an offset
+ -- relative to "the Epoch", which is Jan 1, 1970 on unixes.
+ -- This implementation is affected by system's clock changes.
+
+ function Monotonic_Clock return Duration;
+ pragma Inline (Monotonic_Clock);
+ -- Returns "absolute" time, represented as an offset
+ -- relative to "the Epoch", which is Jan 1, 1970.
+ -- This clock implementation is immune to the system's clock changes.
+
+ Relative : constant := 0;
+ Absolute_Calendar : constant := 1;
+ Absolute_RT : constant := 2;
+ -- Values for Mode call below. Note that the compiler (exp_ch9.adb)
+ -- relies on these values. So any change here must be reflected in
+ -- corresponding changes in the compiler.
+
+ procedure Timed_Delay (Time : Duration; Mode : Integer);
+ -- Implements the semantics of the delay statement when no tasking is
+ -- used in the application.
+ --
+ -- Mode is one of the three values above
+ --
+ -- Time is a relative or absolute duration value, depending on Mode.
+ --
+ -- Note that currently Ada.Real_Time always uses the tasking run time, so
+ -- this procedure should never be called with Mode set to Absolute_RT.
+ -- This may change in future or bare board implementations.
+
+ function To_Duration (T : OS_Time; Mode : Integer) return Duration;
+ -- Convert VMS system time to Duration
+ -- Mode is one of the three values above
+
+ function To_OS_Time (D : Duration; Mode : Integer) return OS_Time;
+ -- Convert Duration to VMS system time
+ -- Mode is one of the three values above
+
+end System.OS_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.23 $
+-- --
+-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the OpenVMS version.
+-- Blank line intentional so that it lines up exactly with default.
+
+-- This package defines some system dependent parameters for GNAT. These
+-- are values that are referenced by the runtime library and are therefore
+-- relevant to the target machine.
+
+-- The parameters whose value is defined in the spec are not generally
+-- expected to be changed. If they are changed, it will be necessary to
+-- recompile the run-time library.
+
+-- The parameters which are defined by functions can be changed by modifying
+-- the body of System.Parameters in file s-parame.adb. A change to this body
+-- requires only rebinding and relinking of the application.
+
+-- Note: do not introduce any pragma Inline statements into this unit, since
+-- otherwise the relinking and rebinding capability would be deactivated.
+
+package System.Parameters is
+pragma Pure (Parameters);
+
+ ---------------------------------------
+ -- Task And Stack Allocation Control --
+ ---------------------------------------
+
+ type Task_Storage_Size is new Integer;
+ -- Type used in tasking units for task storage size
+
+ type Size_Type is new Task_Storage_Size;
+ -- Type used to provide task storage size to runtime
+
+ Unspecified_Size : constant Size_Type := Size_Type'First;
+ -- Value used to indicate that no size type is set
+
+ subtype Ratio is Size_Type range -1 .. 100;
+ Dynamic : constant Size_Type := -1;
+ -- The secondary stack ratio is a constant between 0 and 100 which
+ -- determines the percentage of the allocated task stack that is
+ -- used by the secondary stack (the rest being the primary stack).
+ -- The special value of minus one indicates that the secondary
+ -- stack is to be allocated from the heap instead.
+
+ Sec_Stack_Ratio : constant Ratio := Dynamic;
+ -- This constant defines the handling of the secondary stack
+
+ Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic;
+ -- Convenient Boolean for testing for dynamic secondary stack
+
+ function Default_Stack_Size return Size_Type;
+ -- Default task stack size used if none is specified
+
+ function Minimum_Stack_Size return Size_Type;
+ -- Minimum task stack size permitted
+
+ function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
+ -- Given the storage size stored in the TCB, return the Storage_Size
+ -- value required by the RM for the Storage_Size attribute. The
+ -- required adjustment is as follows:
+ --
+ -- when Size = Unspecified_Size, return Default_Stack_Size
+ -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
+ -- otherwise return given Size
+
+ Stack_Grows_Down : constant Boolean := True;
+ -- This constant indicates whether the stack grows up (False) or
+ -- down (True) in memory as functions are called. It is used for
+ -- proper implementation of the stack overflow check.
+
+ ----------------------------------------------
+ -- Characteristics of types in Interfaces.C --
+ ----------------------------------------------
+
+ long_bits : constant := 32;
+ -- Number of bits in type long and unsigned_long. The normal convention
+ -- is that this is the same as type Long_Integer, but this is not true
+ -- of all targets. For example, in OpenVMS long /= Long_Integer.
+
+ ----------------------------------------------
+ -- Behavior of Pragma Finalize_Storage_Only --
+ ----------------------------------------------
+
+ -- Garbage_Collected is a Boolean constant whose value indicates the
+ -- effect of the pragma Finalize_Storage_Entry on a controlled type.
+
+ -- Garbage_Collected = False
+
+ -- The system releases all storage on program termination only,
+ -- but not other garbage collection occurs, so finalization calls
+ -- are ommitted only for outer level onjects can be omitted if
+ -- pragma Finalize_Storage_Only is used.
+
+ -- Garbage_Collected = True
+
+ -- The system provides full garbage collection, so it is never
+ -- necessary to release storage for controlled objects for which
+ -- a pragma Finalize_Storage_Only is used.
+
+ Garbage_Collected : constant Boolean := False;
+ -- The storage mode for this system (release on program exit)
+
+end System.Parameters;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (OpenVMS DEC Threads Version) --
+-- --
+-- $Revision: 1.25 $
+-- --
+-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ 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 := Integer'Last;
+
+ 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 := Standard'Tick;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := Standard'Storage_Unit;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Standard'Address_Size;
+
+ -- 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;
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer
+ range 0 .. Standard'Max_Interrupt_Priority;
+
+ subtype Priority is Any_Priority
+ range 0 .. Standard'Max_Priority;
+
+ -- Functional notation is needed in the following to avoid visibility
+ -- problems when this package is compiled through rtsfind in the middle
+ -- of another compilation.
+
+ subtype Interrupt_Priority is Any_Priority
+ range
+ Standard."+" (Standard'Max_Priority, 1) ..
+ Standard'Max_Interrupt_Priority;
+
+ Default_Priority : constant Priority :=
+ Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
+
+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.
+
+ AAMP : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Denorm : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+ High_Integrity_Mode : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := True;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := True;
+ Stack_Check_Probes : constant Boolean := True;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := True;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := True;
+
+ --------------------------
+ -- Underlying Priorities --
+ ---------------------------
+
+ -- Important note: this section of the file must come AFTER the
+ -- definition of the system implementation parameters to ensure
+ -- that the value of these parameters is available for analysis
+ -- of the declarations here (using Rtsfind at compile time).
+
+ -- The underlying priorities table provides a generalized mechanism
+ -- for mapping from Ada priorities to system priorities. In some
+ -- cases a 1-1 mapping is not the convenient or optimal choice.
+
+ -- For DEC Threads OpenVMS, we use the full range of 31 priorities
+ -- in the Ada model, but map them by compression onto the more limited
+ -- range of priorities available in OpenVMS.
+
+ -- To replace the default values of the Underlying_Priorities mapping,
+ -- copy this source file into your build directory, edit the file to
+ -- reflect your desired behavior, and recompile with the command:
+
+ -- $ gcc -c -O3 -gnatpgn system.ads
+
+ -- then recompile the run-time parts that depend on this package:
+
+ -- $ gnatmake -a -gnatn -O3 <your application>
+
+ -- then force rebuilding your application if you need different options:
+
+ -- $ gnatmake -f <your options> <your application>
+
+ type Priorities_Mapping is array (Any_Priority) of Integer;
+ pragma Suppress_Initialization (Priorities_Mapping);
+ -- Suppress initialization in case gnat.adc specifies Normalize_Scalars
+
+ Underlying_Priorities : constant Priorities_Mapping :=
+
+ (Priority'First => 16,
+
+ 1 => 17,
+ 2 => 18,
+ 3 => 18,
+ 4 => 18,
+ 5 => 18,
+ 6 => 19,
+ 7 => 19,
+ 8 => 19,
+ 9 => 20,
+ 10 => 20,
+ 11 => 21,
+ 12 => 21,
+ 13 => 22,
+ 14 => 23,
+
+ Default_Priority => 24,
+
+ 16 => 25,
+ 17 => 25,
+ 18 => 25,
+ 19 => 26,
+ 20 => 26,
+ 21 => 26,
+ 22 => 27,
+ 23 => 27,
+ 24 => 27,
+ 25 => 28,
+ 26 => 28,
+ 27 => 29,
+ 28 => 29,
+ 29 => 30,
+
+ Priority'Last => 30,
+
+ Interrupt_Priority => 31);
+
+ ----------------------------
+ -- Special VMS Interfaces --
+ ----------------------------
+
+ procedure Lib_Stop (I : in Integer);
+ pragma Interface (C, Lib_Stop);
+ pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value));
+ -- Interface to VMS condition handling. Used by RTSfind and pragma
+ -- {Import,Export}_Exception. Put here because this is the only
+ -- VMS specific package that doesn't drag in tasking.
+
+end System;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.60 $
+-- --
+-- Copyright (C) 1991-2001, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a OpenVMS/Alpha version of this package
+
+-- 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 System.Tasking.Debug;
+-- used for Known_Tasks
+
+with Interfaces.C;
+-- used for int
+-- size_t
+
+with System.Parameters;
+-- used for Size_Type
+
+with System.Tasking;
+-- used for Ada_Task_Control_Block
+-- Task_ID
+
+with System.Soft_Links;
+-- used for Defer/Undefer_Abort
+-- Set_Exc_Stack_Addr
+
+-- Note that we do not use System.Tasking.Initialization directly since
+-- this 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.Initialization
+
+with System.OS_Primitives;
+-- used for Delay_Modes
+
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+package body System.Task_Primitives.Operations is
+
+ use System.Tasking.Debug;
+ use System.Tasking;
+ use Interfaces.C;
+ use System.OS_Interface;
+ use System.Parameters;
+ use System.OS_Primitives;
+ use type System.OS_Primitives.OS_Time;
+
+ package SSL renames System.Soft_Links;
+
+ ------------------
+ -- Local Data --
+ ------------------
+
+ -- The followings are logically constants, but need to be initialized
+ -- at run time.
+
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_ID associated with a thread
+
+ All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
+ -- See comments on locking rules in System.Tasking (spec).
+
+ Environment_Task_ID : Task_ID;
+ -- A variable to hold Task_ID for the environment task.
+
+ 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");
+
+ FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
+ -- Indicates whether FIFO_Within_Priorities is set.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
+
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+
+ procedure Timer_Sleep_AST (ID : Address);
+ -- Signal the condition variable when AST fires.
+
+ procedure Timer_Sleep_AST (ID : Address) is
+ Result : Interfaces.C.int;
+ Self_ID : Task_ID := To_Task_ID (ID);
+
+ begin
+ Self_ID.Common.LL.AST_Pending := False;
+ Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access);
+ end Timer_Sleep_AST;
+
+ -------------------
+ -- Stack_Guard --
+ -------------------
+
+ -- The underlying thread system sets a guard page at the
+ -- bottom of a thread stack, so nothing is needed.
+ -- ??? Check the comment above
+
+ procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ begin
+ null;
+ end Stack_Guard;
+
+ --------------------
+ -- Get_Thread_Id --
+ --------------------
+
+ function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
+ begin
+ return T.Common.LL.Thread;
+ end Get_Thread_Id;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_ID is
+ Result : System.Address;
+
+ begin
+ Result := pthread_getspecific (ATCB_Key);
+ pragma Assert (Result /= System.Null_Address);
+ return To_Task_ID (Result);
+ end Self;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ -- Note: mutexes and cond_variables needed per-task basis are
+ -- initialized in Intialize_TCB and the Storage_Error is
+ -- handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...)
+ -- used in RTS is initialized before any status change of RTS.
+ -- Therefore rasing Storage_Error in the following routines
+ -- should be able to be handled safely.
+
+ procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is
+ Attributes : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutexattr_init (Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ L.Prio_Save := 0;
+ L.Prio := Interfaces.C.int (Prio);
+
+ Result := pthread_mutex_init (L.L'Access, Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+ end Initialize_Lock;
+
+ procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) 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;
+
+-- Don't use, see comment in s-osinte.ads about ERRORCHECK mutexes.
+-- Result := pthread_mutexattr_settype_np
+-- (Attributes'Access, PTHREAD_MUTEX_ERRORCHECK_NP);
+-- pragma Assert (Result = 0);
+
+-- Result := pthread_mutexattr_setprotocol
+-- (Attributes'Access, PTHREAD_PRIO_PROTECT);
+-- pragma Assert (Result = 0);
+
+-- Result := pthread_mutexattr_setprioceiling
+-- (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
+-- pragma Assert (Result = 0);
+
+ Result := pthread_mutex_init (L, Attributes'Access);
+
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_destroy (L.L'Access);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : 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 : access Lock; Ceiling_Violation : out Boolean) is
+ Self_ID : constant Task_ID := Self;
+ All_Tasks_Link : constant Task_ID := Self.Common.All_Tasks_Link;
+ Current_Prio : System.Any_Priority;
+ Result : Interfaces.C.int;
+
+ begin
+ Current_Prio := Get_Priority (Self_ID);
+
+ -- If there is no other tasks, no need to check priorities.
+
+ if All_Tasks_Link /= Null_Task
+ and then L.Prio < Interfaces.C.int (Current_Prio)
+ then
+ Ceiling_Violation := True;
+ return;
+ end if;
+
+ Result := pthread_mutex_lock (L.L'Access);
+ pragma Assert (Result = 0);
+
+ Ceiling_Violation := False;
+-- Why is this commented out ???
+-- L.Prio_Save := Interfaces.C.int (Current_Prio);
+-- Set_Priority (Self_ID, System.Any_Priority (L.Prio));
+ end Write_Lock;
+
+ procedure Write_Lock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ Write_Lock (L, Ceiling_Violation);
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (L.L'Access);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ -------------
+ -- Sleep --
+ -------------
+
+ procedure Sleep (Self_ID : Task_ID;
+ Reason : System.Tasking.Task_States) is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Self_ID = Self);
+ Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access);
+ -- EINTR is not considered a failure.
+ pragma Assert (Result = 0 or else Result = EINTR);
+
+ if Self_ID.Deferral_Level = 0
+ and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ then
+ Unlock (Self_ID);
+ raise Standard'Abort_Signal;
+ end if;
+ 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 : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ Sleep_Time : OS_Time;
+ Result : Interfaces.C.int;
+ Status : Cond_Value_Type;
+
+ begin
+ Timedout := False;
+ Yielded := False;
+
+ Sleep_Time := To_OS_Time (Time, Mode);
+
+ if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ or else Self_ID.Pending_Priority_Change
+ then
+ return;
+ end if;
+
+ Self_ID.Common.LL.AST_Pending := True;
+
+ Sys_Setimr
+ (Status, 0, Sleep_Time,
+ Timer_Sleep_AST'Access, To_Address (Self_ID), 0);
+
+ if (Status and 1) /= 1 then
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access);
+
+ if not Self_ID.Common.LL.AST_Pending then
+ Timedout := True;
+ else
+ Sys_Cantim (Status, To_Address (Self_ID), 0);
+ pragma Assert ((Status and 1) = 1);
+ 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
+ Sleep_Time : OS_Time;
+ Result : Interfaces.C.int;
+ Status : Cond_Value_Type;
+
+ begin
+
+ -- Only the little window between deferring abort and
+ -- locking Self_ID is the reason we need to
+ -- check for pending abort and priority change below! :(
+
+ SSL.Abort_Defer.all;
+ Write_Lock (Self_ID);
+
+ if not (Time = 0.0 and then Mode = Relative) then
+
+ Sleep_Time := To_OS_Time (Time, Mode);
+
+ if Mode = Relative or else OS_Clock < Sleep_Time then
+
+ Self_ID.Common.State := Delay_Sleep;
+ Self_ID.Common.LL.AST_Pending := True;
+
+ Sys_Setimr
+ (Status, 0, Sleep_Time,
+ Timer_Sleep_AST'Access, To_Address (Self_ID), 0);
+
+ if (Status and 1) /= 1 then
+ raise Storage_Error;
+ end if;
+
+ loop
+ if Self_ID.Pending_Priority_Change then
+ Self_ID.Pending_Priority_Change := False;
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
+ end if;
+
+ if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then
+ Sys_Cantim (Status, To_Address (Self_ID), 0);
+ pragma Assert ((Status and 1) = 1);
+ exit;
+ end if;
+
+ Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access);
+
+ exit when not Self_ID.Common.LL.AST_Pending;
+
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+
+ end if;
+ end if;
+
+ Unlock (Self_ID);
+ Result := sched_yield;
+ SSL.Abort_Undefer.all;
+ end Timed_Delay;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration
+ renames System.OS_Primitives.Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ begin
+ return 10#1.0#E-3;
+ end RT_Resolution;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
+ 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;
+
+ begin
+ if Do_Yield then
+ Result := sched_yield;
+ end if;
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_Priority
+ (T : Task_ID;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ Result : Interfaces.C.int;
+ Param : aliased struct_sched_param;
+ begin
+ T.Common.Current_Priority := Prio;
+ Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
+
+ if Time_Slice_Val > 0 then
+ Result := pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_RR, Param'Access);
+
+ elsif FIFO_Within_Priorities 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_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
+ Result : Interfaces.C.int;
+
+ begin
+ Self_ID.Common.LL.Thread := pthread_self;
+
+ -- It is not safe for the new task accept signals until it
+ -- has bound its TCB pointer to the thread with pthread_setspecific (),
+ -- since the handler wrappers use the TCB pointer
+ -- to restore the stack limit.
+
+ Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID));
+ pragma Assert (Result = 0);
+
+ Lock_All_Tasks_List;
+ for I in Known_Tasks'Range loop
+ if Known_Tasks (I) = null then
+ Known_Tasks (I) := Self_ID;
+ Self_ID.Known_Tasks_Index := I;
+ exit;
+ end if;
+ end loop;
+ Unlock_All_Tasks_List;
+ 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;
+
+ ----------------------
+ -- Initialize_TCB --
+ ----------------------
+
+ procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
+ Mutex_Attr : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+ Cond_Attr : aliased pthread_condattr_t;
+
+ begin
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+-- Don't use, see comment in s-osinte.ads about ERRORCHECK mutexes.
+-- Result := pthread_mutexattr_settype_np
+-- (Mutex_Attr'Access, PTHREAD_MUTEX_ERRORCHECK_NP);
+-- pragma Assert (Result = 0);
+
+-- Result := pthread_mutexattr_setprotocol
+-- (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT);
+-- pragma Assert (Result = 0);
+
+-- Result := pthread_mutexattr_setprioceiling
+-- (Mutex_Attr'Access, Interfaces.C.int (System.Any_Priority'Last));
+-- pragma Assert (Result = 0);
+
+ Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
+ Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
+ Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = 0 then
+ Succeeded := True;
+ Self_ID.Common.LL.Exc_Stack_Ptr := new Exc_Stack_T;
+ SSL.Set_Exc_Stack_Addr
+ (To_Address (Self_ID),
+ Self_ID.Common.LL.Exc_Stack_Ptr (Exc_Stack_T'Last)'Address);
+
+ else
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Succeeded := False;
+ end if;
+
+ Result := pthread_condattr_destroy (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+ end Initialize_TCB;
+
+ -----------------
+ -- Create_Task --
+ -----------------
+
+ procedure Create_Task
+ (T : Task_ID;
+ Wrapper : System.Address;
+ Stack_Size : System.Parameters.Size_Type;
+ Priority : System.Any_Priority;
+ Succeeded : out Boolean)
+ is
+ Attributes : aliased pthread_attr_t;
+ Adjusted_Stack_Size : Interfaces.C.size_t;
+ Result : Interfaces.C.int;
+
+ function Thread_Body_Access is new
+ Unchecked_Conversion (System.Address, Thread_Body);
+
+ begin
+ if Stack_Size = Unspecified_Size then
+ Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size);
+
+ elsif Stack_Size < Minimum_Stack_Size then
+ Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
+
+ else
+ Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
+ end if;
+
+ -- Since the initial signal mask of a thread is inherited from the
+ -- creator, we need to set our local signal mask mask all signals
+ -- during the creation operation, to make sure the new thread is
+ -- not disturbed by signals before it has set its own Task_ID.
+
+ 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);
+
+ -- This call may be unnecessary, not sure. ???
+
+ Result := pthread_attr_setinheritsched
+ (Attributes'Access, PTHREAD_EXPLICIT_SCHED);
+ pragma Assert (Result = 0);
+
+ Result := pthread_create
+ (T.Common.LL.Thread'Access,
+ Attributes'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
+
+ -- ENOMEM is a valid run-time error. Don't shut down.
+
+ pragma Assert (Result = 0
+ or else Result = EAGAIN or else Result = ENOMEM);
+
+ 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;
+
+ procedure Free is new
+ Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
+
+ procedure Free is new Unchecked_Deallocation
+ (Exc_Stack_T, Exc_Stack_Ptr_T);
+
+ begin
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Result := pthread_cond_destroy (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+ if T.Known_Tasks_Index /= -1 then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ end if;
+ Free (T.Common.LL.Exc_Stack_Ptr);
+ Free (Tmp);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ pthread_exit (System.Null_Address);
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_ID) is
+
+ begin
+
+ -- Why is this commented out ???
+-- if T = Self and then T.Deferral_Level = 0
+-- and then T.Pending_ATC_Level < T.ATC_Nesting_Level
+-- then
+-- raise Standard'Abort_Signal;
+-- end if;
+
+ --
+ -- Interrupt Server_Tasks may be waiting on an event flag
+ --
+ if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then
+ Wakeup (T, Interrupt_Server_Blocked_On_Event_Flag);
+ end if;
+
+ end Abort_Task;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy versions. The only currently working versions is for solaris
+ -- (native).
+
+ function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ 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_All_Tasks_List --
+ -------------------------
+
+ procedure Lock_All_Tasks_List is
+ begin
+ Write_Lock (All_Tasks_L'Access);
+ end Lock_All_Tasks_List;
+
+ ---------------------------
+ -- Unlock_All_Tasks_List --
+ ---------------------------
+
+ procedure Unlock_All_Tasks_List is
+ begin
+ Unlock (All_Tasks_L'Access);
+ end Unlock_All_Tasks_List;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ return False;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ return False;
+ end Resume_Task;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_ID) is
+ begin
+ Environment_Task_ID := Environment_Task;
+
+ Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
+ -- Initialize the lock used to synchronize chain of all ATCBs.
+
+ Enter_Task (Environment_Task);
+ end Initialize;
+
+begin
+ declare
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_key_create (ATCB_Key'Access, null);
+ pragma Assert (Result = 0);
+ end;
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $
+-- --
+-- Copyright (C) 1991-2000 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a OpenVMS/Alpha version of this package.
+
+-- This package provides low-level support for most tasking features.
+
+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 Interfaces.C;
+-- used for int
+-- size_t
+
+with System.OS_Interface;
+-- used for pthread_mutex_t
+-- pthread_cond_t
+-- pthread_t
+
+package System.Task_Primitives is
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects.
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system.
+ -- The difference between Lock and the RTS_Lock is that the later
+ -- one serves only as a semaphore so that do not check for
+ -- ceiling violations.
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper
+ -- declared local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task
+ -- basis. A component of this type is guaranteed to be included
+ -- in the Ada_Task_Control_Block.
+
+private
+
+ type Exc_Stack_T is array (0 .. 8192) of aliased Character;
+ for Exc_Stack_T'Alignment use Standard'Maximum_Alignment;
+ type Exc_Stack_Ptr_T is access all Exc_Stack_T;
+
+ type Lock is record
+ L : aliased System.OS_Interface.pthread_mutex_t;
+ Prio : Interfaces.C.int;
+ Prio_Save : Interfaces.C.int;
+ end record;
+
+ type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
+ type Private_Data is record
+ Thread : aliased System.OS_Interface.pthread_t;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb).
+ -- They put the same value (thr_self value). We do not want to
+ -- use lock on those operations and the only thing we have to
+ -- make sure is that they are updated in atomic fashion.
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+ L : aliased RTS_Lock;
+ -- protection for all components is lock L
+
+ Exc_Stack_Ptr : Exc_Stack_Ptr_T;
+ -- ??? This needs comments.
+
+ AST_Pending : Boolean;
+ -- Used to detect delay and sleep timeouts
+
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- . D E C --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 2000 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+-- This package is for OpenVMS/Alpha
+--
+with System.OS_Interface;
+with System.Tasking;
+with Unchecked_Conversion;
+package body System.Task_Primitives.Operations.DEC is
+
+ use System.OS_Interface;
+ use System.Tasking;
+ use System.Aux_DEC;
+ use type Interfaces.C.int;
+
+ -- The FAB_RAB_Type specifieds where the context field (the calling
+ -- task) is stored. Other fields defined for FAB_RAB arent' need and
+ -- so are ignored.
+ type FAB_RAB_Type is
+ record
+ CTX : Unsigned_Longword;
+ end record;
+
+ for FAB_RAB_Type use
+ record
+ CTX at 24 range 0 .. 31;
+ end record;
+
+ for FAB_RAB_Type'Size use 224;
+
+ type FAB_RAB_Access_Type is access all FAB_RAB_Type;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function To_Unsigned_Longword is new
+ Unchecked_Conversion (Task_ID, Unsigned_Longword);
+
+ function To_Task_Id is new
+ Unchecked_Conversion (Unsigned_Longword, Task_ID);
+
+ function To_FAB_RAB is new
+ Unchecked_Conversion (Address, FAB_RAB_Access_Type);
+
+ ---------------------------
+ -- Interrupt_AST_Handler --
+ ---------------------------
+
+ procedure Interrupt_AST_Handler (ID : Address) is
+ Result : Interfaces.C.int;
+ AST_Self_ID : Task_ID := To_Task_Id (ID);
+ begin
+ Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+ end Interrupt_AST_Handler;
+
+ ---------------------
+ -- RMS_AST_Handler --
+ ---------------------
+
+ procedure RMS_AST_Handler (ID : Address) is
+ AST_Self_ID : Task_ID := To_Task_Id (To_FAB_RAB (ID).CTX);
+ Result : Interfaces.C.int;
+ begin
+ AST_Self_ID.Common.LL.AST_Pending := False;
+ Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+ end RMS_AST_Handler;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Unsigned_Longword is
+ Self_ID : Task_ID := Self;
+ begin
+ Self_ID.Common.LL.AST_Pending := True;
+ return To_Unsigned_Longword (Self);
+ end Self;
+
+ -------------------------
+ -- Starlet_AST_Handler --
+ -------------------------
+
+ procedure Starlet_AST_Handler (ID : Address) is
+ Result : Interfaces.C.int;
+ AST_Self_ID : Task_ID := To_Task_Id (ID);
+ begin
+ AST_Self_ID.Common.LL.AST_Pending := False;
+ Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+ end Starlet_AST_Handler;
+
+ ----------------
+ -- Task_Synch --
+ ----------------
+
+ procedure Task_Synch is
+ Synch_Self_ID : Task_ID := Self;
+ begin
+ Write_Lock (Synch_Self_ID);
+ Synch_Self_ID.Common.State := AST_Server_Sleep;
+ while Synch_Self_ID.Common.LL.AST_Pending loop
+ Sleep (Synch_Self_ID, AST_Server_Sleep);
+ end loop;
+ Synch_Self_ID.Common.State := Runnable;
+ Unlock (Synch_Self_ID);
+ end Task_Synch;
+
+end System.Task_Primitives.Operations.DEC;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- . D E C --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 2000 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+--
+-- This package is for OpenVMS/Alpha.
+--
+with System.Aux_DEC;
+package System.Task_Primitives.Operations.DEC is
+
+ procedure Interrupt_AST_Handler (ID : Address);
+ -- Handles the AST for Ada95 Interrupts.
+
+ procedure RMS_AST_Handler (ID : Address);
+ -- Handles the AST for RMS_Asynch_Operations.
+
+ function Self return System.Aux_DEC.Unsigned_Longword;
+ -- Returns the task identification for the AST.
+
+ procedure Starlet_AST_Handler (ID : Address);
+ -- Handles the AST for Starlet Tasking_Services.
+
+ procedure Task_Synch;
+ -- Synchronizes the task after the system service completes.
+
+end System.Task_Primitives.Operations.DEC;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.15 $
+-- --
+-- Copyright (C) 1997-2000 Free Software Foundation, Inc. --
+-- (Version for Alpha OpenVMS) --
+-- --
+-- 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.IO; use System.IO;
+with System.Machine_Code; use System.Machine_Code;
+
+package body System.Vax_Float_Operations is
+
+ -- Ensure this gets compiled with -O to avoid extra (and possibly
+ -- improper) memory stores.
+
+ pragma Optimize (Time);
+
+ -- Declare the functions that do the conversions between floating-point
+ -- formats. Call the operands IEEE float so they get passed in
+ -- FP registers.
+
+ function Cvt_G_T (X : T) return T;
+ function Cvt_T_G (X : T) return T;
+ function Cvt_T_F (X : T) return S;
+
+ pragma Import (C, Cvt_G_T, "OTS$CVT_FLOAT_G_T");
+ pragma Import (C, Cvt_T_G, "OTS$CVT_FLOAT_T_G");
+ pragma Import (C, Cvt_T_F, "OTS$CVT_FLOAT_T_F");
+
+ -- In each of the conversion routines that are done with OTS calls,
+ -- we define variables of the corresponding IEEE type so that they are
+ -- passed and kept in the proper register class.
+
+ ------------
+ -- D_To_G --
+ ------------
+
+ function D_To_G (X : D) return G is
+ A, B : T;
+ C : G;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", A), D'Asm_Input ("m", X));
+ Asm ("cvtdg %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
+ Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B));
+ return C;
+ end D_To_G;
+
+ ------------
+ -- F_To_G --
+ ------------
+
+ function F_To_G (X : F) return G is
+ A : T;
+ B : G;
+
+ begin
+ Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X));
+ Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A));
+ return B;
+ end F_To_G;
+
+ ------------
+ -- F_To_S --
+ ------------
+
+ function F_To_S (X : F) return S is
+ A : T;
+ B : S;
+
+ begin
+ -- Because converting to a wider FP format is a no-op, we say
+ -- A is 64-bit even though we are loading 32 bits into it.
+ Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X));
+
+ B := S (Cvt_G_T (A));
+ return B;
+ end F_To_S;
+
+ ------------
+ -- G_To_D --
+ ------------
+
+ function G_To_D (X : G) return D is
+ A, B : T;
+ C : D;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
+ Asm ("cvtgd %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
+ Asm ("stg %1,%0", D'Asm_Output ("=m", C), T'Asm_Input ("f", B));
+ return C;
+ end G_To_D;
+
+ ------------
+ -- G_To_F --
+ ------------
+
+ function G_To_F (X : G) return F is
+ A : T;
+ B : S;
+ C : F;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
+ Asm ("cvtgf %1,%0", S'Asm_Output ("=f", B), T'Asm_Input ("f", A));
+ Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B));
+ return C;
+ end G_To_F;
+
+ ------------
+ -- G_To_Q --
+ ------------
+
+ function G_To_Q (X : G) return Q is
+ A : T;
+ B : Q;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
+ Asm ("cvtgq %1,%0", Q'Asm_Output ("=f", B), T'Asm_Input ("f", A));
+ return B;
+ end G_To_Q;
+
+ ------------
+ -- G_To_T --
+ ------------
+
+ function G_To_T (X : G) return T is
+ A, B : T;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
+ B := Cvt_G_T (A);
+ return B;
+ end G_To_T;
+
+ ------------
+ -- F_To_Q --
+ ------------
+
+ function F_To_Q (X : F) return Q is
+ begin
+ return G_To_Q (F_To_G (X));
+ end F_To_Q;
+
+ ------------
+ -- Q_To_F --
+ ------------
+
+ function Q_To_F (X : Q) return F is
+ A : S;
+ B : F;
+
+ begin
+ Asm ("cvtqf %1,%0", S'Asm_Output ("=f", A), Q'Asm_Input ("f", X));
+ Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A));
+ return B;
+ end Q_To_F;
+
+ ------------
+ -- Q_To_G --
+ ------------
+
+ function Q_To_G (X : Q) return G is
+ A : T;
+ B : G;
+
+ begin
+ Asm ("cvtqg %1,%0", T'Asm_Output ("=f", A), Q'Asm_Input ("f", X));
+ Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A));
+ return B;
+ end Q_To_G;
+
+ ------------
+ -- S_To_F --
+ ------------
+
+ function S_To_F (X : S) return F is
+ A : S;
+ B : F;
+
+ begin
+ A := Cvt_T_F (T (X));
+ Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A));
+ return B;
+ end S_To_F;
+
+ ------------
+ -- T_To_D --
+ ------------
+
+ function T_To_D (X : T) return D is
+ begin
+ return G_To_D (T_To_G (X));
+ end T_To_D;
+
+ ------------
+ -- T_To_G --
+ ------------
+
+ function T_To_G (X : T) return G is
+ A : T;
+ B : G;
+
+ begin
+ A := Cvt_T_G (X);
+ Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A));
+ return B;
+ end T_To_G;
+
+ -----------
+ -- Abs_F --
+ -----------
+
+ function Abs_F (X : F) return F is
+ A, B : S;
+ C : F;
+
+ begin
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X));
+ Asm ("cpys $f31,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A));
+ Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B));
+ return C;
+ end Abs_F;
+
+ -----------
+ -- Abs_G --
+ -----------
+
+ function Abs_G (X : G) return G is
+ A, B : T;
+ C : G;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
+ Asm ("cpys $f31,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
+ Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B));
+ return C;
+ end Abs_G;
+
+ -----------
+ -- Add_F --
+ -----------
+
+ function Add_F (X, Y : F) return F is
+ X1, Y1, R : S;
+ R1 : F;
+
+ begin
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
+ Asm ("addf %1,%2,%0", S'Asm_Output ("=f", R),
+ (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
+ Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
+ return R1;
+ end Add_F;
+
+ -----------
+ -- Add_G --
+ -----------
+
+ function Add_G (X, Y : G) return G is
+ X1, Y1, R : T;
+ R1 : G;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
+ Asm ("addg %1,%2,%0", T'Asm_Output ("=f", R),
+ (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
+ Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
+ return R1;
+ end Add_G;
+
+ --------------------
+ -- Debug_Output_D --
+ --------------------
+
+ procedure Debug_Output_D (Arg : D) is
+ begin
+ Put (D'Image (Arg));
+ end Debug_Output_D;
+
+ --------------------
+ -- Debug_Output_F --
+ --------------------
+
+ procedure Debug_Output_F (Arg : F) is
+ begin
+ Put (F'Image (Arg));
+ end Debug_Output_F;
+
+ --------------------
+ -- Debug_Output_G --
+ --------------------
+
+ procedure Debug_Output_G (Arg : G) is
+ begin
+ Put (G'Image (Arg));
+ end Debug_Output_G;
+
+ --------------------
+ -- Debug_String_D --
+ --------------------
+
+ Debug_String_Buffer : String (1 .. 32);
+ -- Buffer used by all Debug_String_x routines for returning result
+
+ function Debug_String_D (Arg : D) return System.Address is
+ Image_String : constant String := D'Image (Arg) & ASCII.NUL;
+ Image_Size : constant Integer := Image_String'Length;
+
+ begin
+ Debug_String_Buffer (1 .. Image_Size) := Image_String;
+ return Debug_String_Buffer (1)'Address;
+ end Debug_String_D;
+
+ --------------------
+ -- Debug_String_F --
+ --------------------
+
+ function Debug_String_F (Arg : F) return System.Address is
+ Image_String : constant String := F'Image (Arg) & ASCII.NUL;
+ Image_Size : constant Integer := Image_String'Length;
+
+ begin
+ Debug_String_Buffer (1 .. Image_Size) := Image_String;
+ return Debug_String_Buffer (1)'Address;
+ end Debug_String_F;
+
+ --------------------
+ -- Debug_String_G --
+ --------------------
+
+ function Debug_String_G (Arg : G) return System.Address is
+ Image_String : constant String := G'Image (Arg) & ASCII.NUL;
+ Image_Size : constant Integer := Image_String'Length;
+
+ begin
+ Debug_String_Buffer (1 .. Image_Size) := Image_String;
+ return Debug_String_Buffer (1)'Address;
+ end Debug_String_G;
+
+ -----------
+ -- Div_F --
+ -----------
+
+ function Div_F (X, Y : F) return F is
+ X1, Y1, R : S;
+
+ R1 : F;
+ begin
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
+ Asm ("divf %1,%2,%0", S'Asm_Output ("=f", R),
+ (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
+ Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
+ return R1;
+ end Div_F;
+
+ -----------
+ -- Div_G --
+ -----------
+
+ function Div_G (X, Y : G) return G is
+ X1, Y1, R : T;
+ R1 : G;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
+ Asm ("divg %1,%2,%0", T'Asm_Output ("=f", R),
+ (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
+ Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
+ return R1;
+ end Div_G;
+
+ ----------
+ -- Eq_F --
+ ----------
+
+ function Eq_F (X, Y : F) return Boolean is
+ X1, Y1, R : S;
+
+ begin
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
+ Asm ("cmpgeq %1,%2,%0", S'Asm_Output ("=f", R),
+ (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
+ return R /= 0.0;
+ end Eq_F;
+
+ ----------
+ -- Eq_G --
+ ----------
+
+ function Eq_G (X, Y : G) return Boolean is
+ X1, Y1, R : T;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
+ Asm ("cmpgeq %1,%2,%0", T'Asm_Output ("=f", R),
+ (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
+ return R /= 0.0;
+ end Eq_G;
+
+ ----------
+ -- Le_F --
+ ----------
+
+ function Le_F (X, Y : F) return Boolean is
+ X1, Y1, R : S;
+
+ begin
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
+ Asm ("cmpgle %1,%2,%0", S'Asm_Output ("=f", R),
+ (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
+ return R /= 0.0;
+ end Le_F;
+
+ ----------
+ -- Le_G --
+ ----------
+
+ function Le_G (X, Y : G) return Boolean is
+ X1, Y1, R : T;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
+ Asm ("cmpgle %1,%2,%0", T'Asm_Output ("=f", R),
+ (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
+ return R /= 0.0;
+ end Le_G;
+
+ ----------
+ -- Lt_F --
+ ----------
+
+ function Lt_F (X, Y : F) return Boolean is
+ X1, Y1, R : S;
+
+ begin
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
+ Asm ("cmpglt %1,%2,%0", S'Asm_Output ("=f", R),
+ (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
+ return R /= 0.0;
+ end Lt_F;
+
+ ----------
+ -- Lt_G --
+ ----------
+
+ function Lt_G (X, Y : G) return Boolean is
+ X1, Y1, R : T;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
+ Asm ("cmpglt %1,%2,%0", T'Asm_Output ("=f", R),
+ (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
+ return R /= 0.0;
+ end Lt_G;
+
+ -----------
+ -- Mul_F --
+ -----------
+
+ function Mul_F (X, Y : F) return F is
+ X1, Y1, R : S;
+ R1 : F;
+
+ begin
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
+ Asm ("mulf %1,%2,%0", S'Asm_Output ("=f", R),
+ (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
+ Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
+ return R1;
+ end Mul_F;
+
+ -----------
+ -- Mul_G --
+ -----------
+
+ function Mul_G (X, Y : G) return G is
+ X1, Y1, R : T;
+ R1 : G;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
+ Asm ("mulg %1,%2,%0", T'Asm_Output ("=f", R),
+ (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
+ Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
+ return R1;
+ end Mul_G;
+
+ -----------
+ -- Neg_F --
+ -----------
+
+ function Neg_F (X : F) return F is
+ A, B : S;
+ C : F;
+
+ begin
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X));
+ Asm ("cpysn %1,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A));
+ Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B));
+ return C;
+ end Neg_F;
+
+ -----------
+ -- Neg_G --
+ -----------
+
+ function Neg_G (X : G) return G is
+ A, B : T;
+ C : G;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
+ Asm ("cpysn %1,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
+ Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B));
+ return C;
+ end Neg_G;
+
+ --------
+ -- pd --
+ --------
+
+ procedure pd (Arg : D) is
+ begin
+ Put_Line (D'Image (Arg));
+ end pd;
+
+ --------
+ -- pf --
+ --------
+
+ procedure pf (Arg : F) is
+ begin
+ Put_Line (F'Image (Arg));
+ end pf;
+
+ --------
+ -- pg --
+ --------
+
+ procedure pg (Arg : G) is
+ begin
+ Put_Line (G'Image (Arg));
+ end pg;
+
+ -----------
+ -- Sub_F --
+ -----------
+
+ function Sub_F (X, Y : F) return F is
+ X1, Y1, R : S;
+ R1 : F;
+
+ begin
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
+ Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
+ Asm ("subf %1,%2,%0", S'Asm_Output ("=f", R),
+ (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
+ Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
+ return R1;
+ end Sub_F;
+
+ -----------
+ -- Sub_G --
+ -----------
+
+ function Sub_G (X, Y : G) return G is
+ X1, Y1, R : T;
+ R1 : G;
+
+ begin
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
+ Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
+ Asm ("subg %1,%2,%0", T'Asm_Output ("=f", R),
+ (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
+ Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
+ return R1;
+ end Sub_G;
+
+end System.Vax_Float_Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . G L O B A L _ L O C K S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1999-2001 Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This implementation is specific to NT.
+
+with GNAT.Task_Lock;
+
+with Interfaces.C.Strings;
+with System.OS_Interface;
+
+package body System.Global_Locks is
+
+ package TSL renames GNAT.Task_Lock;
+ package OSI renames System.OS_Interface;
+ package ICS renames Interfaces.C.Strings;
+
+ subtype Lock_File_Entry is OSI.HANDLE;
+
+ Last_Lock : Lock_Type := Null_Lock;
+ Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry;
+
+ -----------------
+ -- Create_Lock --
+ -----------------
+
+ procedure Create_Lock
+ (Lock : out Lock_Type;
+ Name : in String)
+ is
+ L : Lock_Type;
+
+ begin
+ TSL.Lock;
+ Last_Lock := Last_Lock + 1;
+ L := Last_Lock;
+ TSL.Unlock;
+
+ if L > Lock_Table'Last then
+ raise Lock_Error;
+ end if;
+
+ Lock_Table (L) :=
+ OSI.CreateMutex (null, OSI.BOOL (False), ICS.New_String (Name));
+ Lock := L;
+ end Create_Lock;
+
+ ------------------
+ -- Acquire_Lock --
+ ------------------
+
+ procedure Acquire_Lock
+ (Lock : in out Lock_Type)
+ is
+ use type OSI.DWORD;
+
+ Res : OSI.DWORD;
+ begin
+ Res := OSI.WaitForSingleObject (Lock_Table (Lock), OSI.Wait_Infinite);
+
+ if Res = OSI.WAIT_FAILED then
+ raise Lock_Error;
+ end if;
+ end Acquire_Lock;
+
+ ------------------
+ -- Release_Lock --
+ ------------------
+
+ procedure Release_Lock
+ (Lock : in out Lock_Type)
+ is
+ use type OSI.BOOL;
+
+ Res : OSI.BOOL;
+ begin
+ Res := OSI.ReleaseMutex (Lock_Table (Lock));
+
+ if Res = OSI.False then
+ raise Lock_Error;
+ end if;
+ end Release_Lock;
+
+end System.Global_Locks;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1991-2000 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the NT version of this package
+
+-- This file performs the system-dependent translation between machine
+-- exceptions and the Ada exceptions, if any, that should be raised when they
+-- occur.
+
+-- PLEASE DO NOT add any dependences on other packages.
+-- This package is designed to work with or without tasking support.
+
+-- See the other warnings in the package specification before making any
+-- modifications to this file.
+
+-- Make a careful study of all signals available under the OS, to see which
+-- need to be reserved, kept always unmasked, or kept always unmasked. Be on
+-- the lookout for special signals that may be used by the thread library.
+
+with System.OS_Interface; use System.OS_Interface;
+
+package body System.Interrupt_Management is
+
+ ---------------------------
+ -- Initialize_Interrupts --
+ ---------------------------
+
+ -- Nothing needs to be done on this platform.
+
+ procedure Initialize_Interrupts is
+ begin
+ null;
+ end Initialize_Interrupts;
+
+begin
+ -- "Reserve" all the interrupts, except those that are explicitely defined
+
+ for J in Interrupt_ID'Range loop
+ Reserve (J) := True;
+ end loop;
+
+ Reserve (SIGINT) := False;
+ Reserve (SIGILL) := False;
+ Reserve (SIGABRT) := False;
+ Reserve (SIGFPE) := False;
+ Reserve (SIGSEGV) := False;
+ Reserve (SIGTERM) := False;
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M E M O R Y --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This version provides ways to limit the amount of used memory for systems
+-- that do not have OS support for that.
+
+-- The amount of available memory available for dynamic allocation is limited
+-- by setting the environment variable GNAT_MEMORY_LIMIT to the number of
+-- kilobytes that can be used.
+--
+-- Windows is currently using this version.
+
+with Ada.Exceptions;
+with System.Soft_Links;
+
+package body System.Memory is
+
+ use Ada.Exceptions;
+ use System.Soft_Links;
+
+ function c_malloc (Size : size_t) return System.Address;
+ pragma Import (C, c_malloc, "malloc");
+
+ procedure c_free (Ptr : System.Address);
+ pragma Import (C, c_free, "free");
+
+ function c_realloc
+ (Ptr : System.Address; Size : size_t) return System.Address;
+ pragma Import (C, c_realloc, "realloc");
+
+ function msize (Ptr : System.Address) return size_t;
+ pragma Import (C, msize, "_msize");
+
+ function getenv (Str : String) return System.Address;
+ pragma Import (C, getenv);
+
+ function atoi (Str : System.Address) return Integer;
+ pragma Import (C, atoi);
+
+ Available_Memory : size_t := 0;
+ -- Amount of memory that is available for heap allocations.
+ -- A value of 0 means that the amount is not yet initialized.
+
+ Msize_Accuracy : constant := 4096;
+ -- Defines the amount of memory to add to requested allocation sizes,
+ -- because malloc may return a bigger block than requested. As msize
+ -- is used when by Free, it must be used on allocation as well. To
+ -- prevent underflow of available_memory we need to use a reserve.
+
+ procedure Check_Available_Memory (Size : size_t);
+ -- This routine must be called while holding the task lock. When the
+ -- memory limit is not yet initialized, it will be set to the value of
+ -- the GNAT_MEMORY_LIMIT environment variable or to unlimited if that
+ -- does not exist. If the size is larger than the amount of available
+ -- memory, the task lock will be freed and a storage_error exception
+ -- will be raised.
+
+ -----------
+ -- Alloc --
+ -----------
+
+ function Alloc (Size : size_t) return System.Address is
+ Result : System.Address;
+ Actual_Size : size_t := Size;
+
+ begin
+ if Size = size_t'Last then
+ Raise_Exception (Storage_Error'Identity, "object too large");
+ end if;
+
+ -- Change size from zero to non-zero. We still want a proper pointer
+ -- for the zero case because pointers to zero length objects have to
+ -- be distinct, but we can't just go ahead and allocate zero bytes,
+ -- since some malloc's return zero for a zero argument.
+
+ if Size = 0 then
+ Actual_Size := 1;
+ end if;
+
+ Lock_Task.all;
+
+ if Actual_Size + Msize_Accuracy >= Available_Memory then
+ Check_Available_Memory (Size + Msize_Accuracy);
+ end if;
+
+ Result := c_malloc (Actual_Size);
+
+ if Result /= System.Null_Address then
+ Available_Memory := Available_Memory - msize (Result);
+ end if;
+
+ Unlock_Task.all;
+
+ if Result = System.Null_Address then
+ Raise_Exception (Storage_Error'Identity, "heap exhausted");
+ end if;
+
+ return Result;
+ end Alloc;
+
+ ----------------------------
+ -- Check_Available_Memory --
+ ----------------------------
+
+ procedure Check_Available_Memory (Size : size_t) is
+ Gnat_Memory_Limit : System.Address;
+
+ begin
+ if Available_Memory = 0 then
+
+ -- The amount of available memory hasn't been initialized yet
+
+ Gnat_Memory_Limit := getenv ("GNAT_MEMORY_LIMIT" & ASCII.NUL);
+
+ if Gnat_Memory_Limit /= System.Null_Address then
+ Available_Memory :=
+ size_t (atoi (Gnat_Memory_Limit)) * 1024 + Msize_Accuracy;
+ else
+ Available_Memory := size_t'Last;
+ end if;
+ end if;
+
+ if Size >= Available_Memory then
+
+ -- There is a memory overflow
+
+ Unlock_Task.all;
+ Raise_Exception
+ (Storage_Error'Identity, "heap memory limit exceeded");
+ end if;
+ end Check_Available_Memory;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (Ptr : System.Address) is
+ begin
+ Lock_Task.all;
+
+ if Ptr /= System.Null_Address then
+ Available_Memory := Available_Memory + msize (Ptr);
+ end if;
+
+ c_free (Ptr);
+
+ Unlock_Task.all;
+ end Free;
+
+ -------------
+ -- Realloc --
+ -------------
+
+ function Realloc
+ (Ptr : System.Address;
+ Size : size_t)
+ return System.Address
+ is
+ Result : System.Address;
+ Actual_Size : size_t := Size;
+ Old_Size : size_t;
+
+ begin
+ if Size = size_t'Last then
+ Raise_Exception (Storage_Error'Identity, "object too large");
+ end if;
+
+ Lock_Task.all;
+
+ Old_Size := msize (Ptr);
+
+ -- Conservative check - no need to try to be precise here
+
+ if Size + Msize_Accuracy >= Available_Memory then
+ Check_Available_Memory (Size + Msize_Accuracy);
+ end if;
+
+ Result := c_realloc (Ptr, Actual_Size);
+
+ if Result /= System.Null_Address then
+ Available_Memory := Available_Memory + Old_Size - msize (Ptr);
+ end if;
+
+ Unlock_Task.all;
+
+ if Result = System.Null_Address then
+ Raise_Exception (Storage_Error'Identity, "heap exhausted");
+ end if;
+
+ return Result;
+ end Realloc;
+
+end System.Memory;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.20 $
+-- --
+-- Copyright (C) 1997-2001, 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a NT (native) version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+with Interfaces.C.Strings;
+
+package System.OS_Interface is
+pragma Preelaborate;
+
+ subtype int is Interfaces.C.int;
+ subtype long is Interfaces.C.long;
+
+ -------------------
+ -- General Types --
+ -------------------
+
+ type DWORD is new Interfaces.C.unsigned_long;
+ type WORD is new Interfaces.C.unsigned_short;
+
+ -- The LARGE_INTEGER type is actually a fixed point type
+ -- that only can represent integers. The reason for this is
+ -- easier conversion to Duration or other fixed point types.
+ -- (See Operations.Clock)
+
+ type LARGE_INTEGER is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0;
+ for LARGE_INTEGER'Alignment use 4;
+
+ subtype PSZ is Interfaces.C.Strings.chars_ptr;
+ subtype PCHAR is Interfaces.C.Strings.chars_ptr;
+ subtype PVOID is System.Address;
+ Null_Void : constant PVOID := System.Null_Address;
+
+ type PLONG is access all Interfaces.C.long;
+ type PDWORD is access all DWORD;
+
+ type BOOL is new Boolean;
+ for BOOL'Size use Interfaces.C.unsigned_long'Size;
+
+ -------------------------
+ -- Handles for objects --
+ -------------------------
+
+ type HANDLE is new Interfaces.C.long;
+ type PHANDLE is access all HANDLE;
+
+ subtype Thread_Id is HANDLE;
+
+ -----------
+ -- Errno --
+ -----------
+
+ NO_ERROR : constant := 0;
+ FUNC_ERR : constant := -1;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 31;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGINT : constant := 2; -- interrupt (Ctrl-C)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGFPE : constant := 8; -- floating point exception
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGBREAK : constant := 21; -- break (Ctrl-Break)
+ SIGABRT : constant := 22; -- used by abort, replace SIGIOT in the future
+
+ type sigset_t is private;
+
+ type isr_address is access procedure (sig : int);
+
+ function intr_attach (sig : int; handler : isr_address) return long;
+ pragma Import (C, intr_attach, "signal");
+
+ Intr_Attach_Reset : constant Boolean := True;
+ -- True if intr_attach is reset after an interrupt handler is called
+
+ procedure kill (sig : Signal);
+ pragma Import (C, kill, "raise");
+
+ ---------------------
+ -- Time Management --
+ ---------------------
+
+ procedure Sleep (dwMilliseconds : DWORD);
+ pragma Import (Stdcall, Sleep, External_Name => "Sleep");
+
+ type SYSTEMTIME is record
+ wYear : WORD;
+ wMonth : WORD;
+ wDayOfWeek : WORD;
+ wDay : WORD;
+ wHour : WORD;
+ wMinute : WORD;
+ wSecond : WORD;
+ wMilliseconds : WORD;
+ end record;
+
+ procedure GetSystemTime (pSystemTime : access SYSTEMTIME);
+ pragma Import (Stdcall, GetSystemTime, "GetSystemTime");
+
+ procedure GetSystemTimeAsFileTime (lpFileTime : access Long_Long_Integer);
+ pragma Import (Stdcall, GetSystemTimeAsFileTime, "GetSystemTimeAsFileTime");
+
+ function SetSystemTime (pSystemTime : access SYSTEMTIME) return BOOL;
+ pragma Import (Stdcall, SetSystemTime, "SetSystemTime");
+
+ function FileTimeToSystemTime
+ (lpFileTime : access Long_Long_Integer;
+ lpSystemTime : access SYSTEMTIME) return BOOL;
+ pragma Import (Stdcall, FileTimeToSystemTime, "FileTimeToSystemTime");
+
+ function SystemTimeToFileTime
+ (lpSystemTime : access SYSTEMTIME;
+ lpFileTime : access Long_Long_Integer) return BOOL;
+ pragma Import (Stdcall, SystemTimeToFileTime, "SystemTimeToFileTime");
+
+ function FileTimeToLocalFileTime
+ (lpFileTime : access Long_Long_Integer;
+ lpLocalFileTime : access Long_Long_Integer) return BOOL;
+ pragma Import (Stdcall, FileTimeToLocalFileTime, "FileTimeToLocalFileTime");
+
+ function LocalFileTimeToFileTime
+ (lpFileTime : access Long_Long_Integer;
+ lpLocalFileTime : access Long_Long_Integer) return BOOL;
+ pragma Import (Stdcall, LocalFileTimeToFileTime, "LocalFileTimeToFileTime");
+
+ function QueryPerformanceCounter
+ (lpPerformanceCount : access LARGE_INTEGER) return BOOL;
+ pragma Import
+ (Stdcall, QueryPerformanceCounter, "QueryPerformanceCounter");
+
+ function QueryPerformanceFrequency
+ (lpFrequency : access LARGE_INTEGER) return BOOL;
+ pragma Import
+ (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+
+ -----------------------
+ -- Critical sections --
+ -----------------------
+
+ type CRITICAL_SECTION is private;
+ type PCRITICAL_SECTION is access all CRITICAL_SECTION;
+
+ procedure InitializeCriticalSection (pCriticalSection : PCRITICAL_SECTION);
+ pragma Import
+ (Stdcall, InitializeCriticalSection, "InitializeCriticalSection");
+
+ procedure EnterCriticalSection (pCriticalSection : PCRITICAL_SECTION);
+ pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection");
+
+ procedure LeaveCriticalSection (pCriticalSection : PCRITICAL_SECTION);
+ pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection");
+
+ procedure DeleteCriticalSection (pCriticalSection : PCRITICAL_SECTION);
+ pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection");
+
+ -------------------------------------------------------------
+ -- Thread Creation, Activation, Suspension And Termination --
+ -------------------------------------------------------------
+
+ type PTHREAD_START_ROUTINE is access function
+ (pThreadParameter : PVOID) return DWORD;
+ pragma Convention (Stdcall, PTHREAD_START_ROUTINE);
+
+ type SECURITY_ATTRIBUTES is record
+ nLength : DWORD;
+ pSecurityDescriptor : PVOID;
+ bInheritHandle : BOOL;
+ end record;
+
+ type PSECURITY_ATTRIBUTES is access all SECURITY_ATTRIBUTES;
+
+ function CreateThread
+ (pThreadAttributes : PSECURITY_ATTRIBUTES;
+ dwStackSize : DWORD;
+ pStartAddress : PTHREAD_START_ROUTINE;
+ pParameter : PVOID;
+ dwCreationFlags : DWORD;
+ pThreadId : PDWORD) return HANDLE;
+ pragma Import (Stdcall, CreateThread, "CreateThread");
+
+ function BeginThreadEx
+ (pThreadAttributes : PSECURITY_ATTRIBUTES;
+ dwStackSize : DWORD;
+ pStartAddress : PTHREAD_START_ROUTINE;
+ pParameter : PVOID;
+ dwCreationFlags : DWORD;
+ pThreadId : PDWORD) return HANDLE;
+ pragma Import (C, BeginThreadEx, "_beginthreadex");
+
+ Debug_Process : constant := 16#00000001#;
+ Debug_Only_This_Process : constant := 16#00000002#;
+ Create_Suspended : constant := 16#00000004#;
+ Detached_Process : constant := 16#00000008#;
+ Create_New_Console : constant := 16#00000010#;
+
+ Create_New_Process_Group : constant := 16#00000200#;
+
+ Create_No_window : constant := 16#08000000#;
+
+ Profile_User : constant := 16#10000000#;
+ Profile_Kernel : constant := 16#20000000#;
+ Profile_Server : constant := 16#40000000#;
+
+ function GetExitCodeThread
+ (hThread : HANDLE;
+ pExitCode : PDWORD) return BOOL;
+ pragma Import (Stdcall, GetExitCodeThread, "GetExitCodeThread");
+
+ function ResumeThread (hThread : HANDLE) return DWORD;
+ pragma Import (Stdcall, ResumeThread, "ResumeThread");
+
+ function SuspendThread (hThread : HANDLE) return DWORD;
+ pragma Import (Stdcall, SuspendThread, "SuspendThread");
+
+ procedure ExitThread (dwExitCode : DWORD);
+ pragma Import (Stdcall, ExitThread, "ExitThread");
+
+ procedure EndThreadEx (dwExitCode : DWORD);
+ pragma Import (C, EndThreadEx, "_endthreadex");
+
+ function TerminateThread
+ (hThread : HANDLE;
+ dwExitCode : DWORD) return BOOL;
+ pragma Import (Stdcall, TerminateThread, "TerminateThread");
+
+ function GetCurrentThread return HANDLE;
+ pragma Import (Stdcall, GetCurrentThread, "GetCurrentThread");
+
+ function GetCurrentProcess return HANDLE;
+ pragma Import (Stdcall, GetCurrentProcess, "GetCurrentProcess");
+
+ function GetCurrentThreadId return DWORD;
+ pragma Import (Stdcall, GetCurrentThreadId, "GetCurrentThreadId");
+
+ function TlsAlloc return DWORD;
+ pragma Import (Stdcall, TlsAlloc, "TlsAlloc");
+
+ function TlsGetValue (dwTlsIndex : DWORD) return PVOID;
+ pragma Import (Stdcall, TlsGetValue, "TlsGetValue");
+
+ function TlsSetValue (dwTlsIndex : DWORD; pTlsValue : PVOID) return BOOL;
+ pragma Import (Stdcall, TlsSetValue, "TlsSetValue");
+
+ function TlsFree (dwTlsIndex : DWORD) return BOOL;
+ pragma Import (Stdcall, TlsFree, "TlsFree");
+
+ TLS_Nothing : constant := DWORD'Last;
+
+ procedure ExitProcess (uExitCode : Interfaces.C.unsigned);
+ pragma Import (Stdcall, ExitProcess, "ExitProcess");
+
+ function WaitForSingleObject
+ (hHandle : HANDLE;
+ dwMilliseconds : DWORD) return DWORD;
+ pragma Import (Stdcall, WaitForSingleObject, "WaitForSingleObject");
+
+ function WaitForSingleObjectEx
+ (hHandle : HANDLE;
+ dwMilliseconds : DWORD;
+ fAlertable : BOOL) return DWORD;
+ pragma Import (Stdcall, WaitForSingleObjectEx, "WaitForSingleObjectEx");
+
+ Wait_Infinite : constant := DWORD'Last;
+ WAIT_TIMEOUT : constant := 16#0000_0102#;
+ WAIT_FAILED : constant := 16#FFFF_FFFF#;
+
+ ------------------------------------
+ -- Semaphores, Events and Mutexes --
+ ------------------------------------
+
+ function CloseHandle (hObject : HANDLE) return BOOL;
+ pragma Import (Stdcall, CloseHandle, "CloseHandle");
+
+ function CreateSemaphore
+ (pSemaphoreAttributes : PSECURITY_ATTRIBUTES;
+ lInitialCount : Interfaces.C.long;
+ lMaximumCount : Interfaces.C.long;
+ pName : PSZ) return HANDLE;
+ pragma Import (Stdcall, CreateSemaphore, "CreateSemaphoreA");
+
+ function OpenSemaphore
+ (dwDesiredAccess : DWORD;
+ bInheritHandle : BOOL;
+ pName : PSZ) return HANDLE;
+ pragma Import (Stdcall, OpenSemaphore, "OpenSemaphoreA");
+
+ function ReleaseSemaphore
+ (hSemaphore : HANDLE;
+ lReleaseCount : Interfaces.C.long;
+ pPreviousCount : PLONG) return BOOL;
+ pragma Import (Stdcall, ReleaseSemaphore, "ReleaseSemaphore");
+
+ function CreateEvent
+ (pEventAttributes : PSECURITY_ATTRIBUTES;
+ bManualReset : BOOL;
+ bInitialState : BOOL;
+ pName : PSZ) return HANDLE;
+ pragma Import (Stdcall, CreateEvent, "CreateEventA");
+
+ function OpenEvent
+ (dwDesiredAccess : DWORD;
+ bInheritHandle : BOOL;
+ pName : PSZ) return HANDLE;
+ pragma Import (Stdcall, OpenEvent, "OpenEventA");
+
+ function SetEvent (hEvent : HANDLE) return BOOL;
+ pragma Import (Stdcall, SetEvent, "SetEvent");
+
+ function ResetEvent (hEvent : HANDLE) return BOOL;
+ pragma Import (Stdcall, ResetEvent, "ResetEvent");
+
+ function PulseEvent (hEvent : HANDLE) return BOOL;
+ pragma Import (Stdcall, PulseEvent, "PulseEvent");
+
+ function CreateMutex
+ (pMutexAttributes : PSECURITY_ATTRIBUTES;
+ bInitialOwner : BOOL;
+ pName : PSZ) return HANDLE;
+ pragma Import (Stdcall, CreateMutex, "CreateMutexA");
+
+ function OpenMutex
+ (dwDesiredAccess : DWORD;
+ bInheritHandle : BOOL;
+ pName : PSZ) return HANDLE;
+ pragma Import (Stdcall, OpenMutex, "OpenMutexA");
+
+ function ReleaseMutex (hMutex : HANDLE) return BOOL;
+ pragma Import (Stdcall, ReleaseMutex, "ReleaseMutex");
+
+ ---------------------------------------------------
+ -- Accessing properties of Threads and Processes --
+ ---------------------------------------------------
+
+ -----------------
+ -- Priorities --
+ -----------------
+
+ function SetThreadPriority
+ (hThread : HANDLE;
+ nPriority : Interfaces.C.int) return BOOL;
+ pragma Import (Stdcall, SetThreadPriority, "SetThreadPriority");
+
+ function GetThreadPriority (hThread : HANDLE) return Interfaces.C.int;
+ pragma Import (Stdcall, GetThreadPriority, "GetThreadPriority");
+
+ function SetPriorityClass
+ (hProcess : HANDLE;
+ dwPriorityClass : DWORD) return BOOL;
+ pragma Import (Stdcall, SetPriorityClass, "SetPriorityClass");
+
+ Normal_Priority_Class : constant := 16#00000020#;
+ Idle_Priority_Class : constant := 16#00000040#;
+ High_Priority_Class : constant := 16#00000080#;
+ Realtime_Priority_Class : constant := 16#00000100#;
+
+ Thread_Priority_Idle : constant := -15;
+ Thread_Priority_Lowest : constant := -2;
+ Thread_Priority_Below_Normal : constant := -1;
+ Thread_Priority_Normal : constant := 0;
+ Thread_Priority_Above_Normal : constant := 1;
+ Thread_Priority_Highest : constant := 2;
+ Thread_Priority_Time_Critical : constant := 15;
+ Thread_Priority_Error_Return : constant := Interfaces.C.long'Last;
+
+ function GetLastError return DWORD;
+ pragma Import (Stdcall, GetLastError, "GetLastError");
+
+private
+
+ type sigset_t is new Interfaces.C.unsigned_long;
+
+ type CRITICAL_SECTION is record
+ DebugInfo : System.Address;
+ -- The following three fields control entering and
+ -- exiting the critical section for the resource
+ LockCount : Long_Integer;
+ RecursionCount : Long_Integer;
+ OwningThread : HANDLE;
+ LockSemaphore : HANDLE;
+ Reserved : DWORD;
+ end record;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ P R I M I T I V E S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.13 $ --
+-- --
+-- Copyright (C) 1998-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the NT version of this package
+
+with Ada.Exceptions;
+with System.OS_Interface;
+
+package body System.OS_Primitives is
+
+ use System.OS_Interface;
+
+ ---------------------------------------
+ -- Data for the high resolution clock --
+ ---------------------------------------
+
+ Tick_Frequency : aliased LARGE_INTEGER;
+ -- Holds frequency of high-performance counter used by Clock
+ -- Windows NT uses a 1_193_182 Hz counter on PCs.
+
+ Base_Ticks : aliased LARGE_INTEGER;
+ -- Holds the Tick count for the base time.
+
+ Base_Clock : Duration;
+ -- Holds the current clock for the standard clock's base time
+
+ Base_Monotonic_Clock : Duration;
+ -- Holds the current clock for monotonic clock's base time
+
+ Base_Time : aliased Long_Long_Integer;
+ -- Holds the base time used to check for system time change, used with
+ -- the standard clock.
+
+ procedure Get_Base_Time;
+ -- Retrieve the base time. This base time will be used by clock to
+ -- compute the current time by adding to it a fraction of the
+ -- performance counter. This is for the implementation of a
+ -- high-resolution clock.
+
+ -----------
+ -- Clock --
+ -----------
+
+ -- This implementation of clock provides high resolution timer values
+ -- using QueryPerformanceCounter. This call return a 64 bits values (based
+ -- on the 8253 16 bits counter). This counter is updated every 1/1_193_182
+ -- times per seconds. The call to QueryPerformanceCounter takes 6
+ -- microsecs to complete.
+
+ function Clock return Duration is
+ Max_Shift : constant Duration := 2.0;
+ Hundreds_Nano_In_Sec : constant := 1E7;
+ Current_Ticks : aliased LARGE_INTEGER;
+ Elap_Secs_Tick : Duration;
+ Elap_Secs_Sys : Duration;
+ Now : aliased Long_Long_Integer;
+
+ begin
+ if not QueryPerformanceCounter (Current_Ticks'Access) then
+ return 0.0;
+ end if;
+
+ GetSystemTimeAsFileTime (Now'Access);
+
+ Elap_Secs_Sys :=
+ Duration (abs (Now - Base_Time) / Hundreds_Nano_In_Sec);
+
+ Elap_Secs_Tick :=
+ Duration (Long_Long_Float (Current_Ticks - Base_Ticks) /
+ Long_Long_Float (Tick_Frequency));
+
+ -- If we have a shift of more than Max_Shift seconds we resynchonize the
+ -- Clock. This is probably due to a manual Clock adjustment, an DST
+ -- adjustment or an NNTP synchronisation. And we want to adjust the
+ -- time for this system (non-monotonic) clock.
+
+ if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then
+ Get_Base_Time;
+
+ Elap_Secs_Tick :=
+ Duration (Long_Long_Float (Current_Ticks - Base_Ticks) /
+ Long_Long_Float (Tick_Frequency));
+ end if;
+
+ return Base_Clock + Elap_Secs_Tick;
+ end Clock;
+
+ -------------------
+ -- Get_Base_Time --
+ -------------------
+
+ procedure Get_Base_Time is
+ use System.OS_Interface;
+
+ -- The resolution for GetSystemTime is 1 millisecond.
+
+ -- The time to get both base times should take less than 1 millisecond.
+ -- Therefore, the elapsed time reported by GetSystemTime between both
+ -- actions should be null.
+
+ Max_Elapsed : constant := 0;
+
+ Test_Now : aliased Long_Long_Integer;
+
+ epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch
+ system_time_ns : constant := 100; -- 100 ns per tick
+ Sec_Unit : constant := 10#1#E9;
+
+ begin
+ -- Here we must be sure that both of these calls are done in a short
+ -- amount of time. Both are base time and should in theory be taken
+ -- at the very same time.
+
+ loop
+ GetSystemTimeAsFileTime (Base_Time'Access);
+
+ if not QueryPerformanceCounter (Base_Ticks'Access) then
+ pragma Assert
+ (Standard.False,
+ "Could not query high performance counter in Clock");
+ null;
+ end if;
+
+ GetSystemTimeAsFileTime (Test_Now'Access);
+
+ exit when Test_Now - Base_Time = Max_Elapsed;
+ end loop;
+
+ Base_Clock := Duration
+ (Long_Long_Float ((Base_Time - epoch_1970) * system_time_ns) /
+ Long_Long_Float (Sec_Unit));
+ end Get_Base_Time;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ Current_Ticks : aliased LARGE_INTEGER;
+ Elap_Secs_Tick : Duration;
+ begin
+ if not QueryPerformanceCounter (Current_Ticks'Access) then
+ return 0.0;
+ end if;
+
+ Elap_Secs_Tick :=
+ Duration (Long_Long_Float (Current_Ticks - Base_Ticks) /
+ Long_Long_Float (Tick_Frequency));
+
+ return Base_Monotonic_Clock + Elap_Secs_Tick;
+ end Monotonic_Clock;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay (Time : Duration; Mode : Integer) is
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Check_Time : Duration := Monotonic_Clock;
+
+ begin
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Time + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ loop
+ Sleep (DWORD (Rel_Time * 1000.0));
+ Check_Time := Monotonic_Clock;
+
+ exit when Abs_Time <= Check_Time;
+
+ Rel_Time := Abs_Time - Check_Time;
+ end loop;
+ end if;
+ end Timed_Delay;
+
+-- Package elaboration, get starting time as base
+
+begin
+ if not QueryPerformanceFrequency (Tick_Frequency'Access) then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity,
+ "cannot get high performance counter frequency");
+ end if;
+
+ Get_Base_Time;
+
+ Base_Monotonic_Clock := Base_Clock;
+end System.OS_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (NT Version) --
+-- --
+-- $Revision: 1.19 $
+-- --
+-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ 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 := Integer'Last;
+
+ 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 := Standard'Tick;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := Standard'Storage_Unit;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Standard'Address_Size;
+
+ -- 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;
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer
+ range 0 .. Standard'Max_Interrupt_Priority;
+
+ subtype Priority is Any_Priority
+ range 0 .. Standard'Max_Priority;
+
+ -- Functional notation is needed in the following to avoid visibility
+ -- problems when this package is compiled through rtsfind in the middle
+ -- of another compilation.
+
+ subtype Interrupt_Priority is Any_Priority
+ range
+ Standard."+" (Standard'Max_Priority, 1) ..
+ Standard'Max_Interrupt_Priority;
+
+ Default_Priority : constant Priority :=
+ Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
+
+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.
+
+ AAMP : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Denorm : constant Boolean := True;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+ High_Integrity_Mode : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := True;
+
+ ---------------------------
+ -- Underlying Priorities --
+ ---------------------------
+
+ -- Important note: this section of the file must come AFTER the
+ -- definition of the system implementation parameters to ensure
+ -- that the value of these parameters is available for analysis
+ -- of the declarations here (using Rtsfind at compile time).
+
+ -- The underlying priorities table provides a generalized mechanism
+ -- for mapping from Ada priorities to system priorities. In some
+ -- cases a 1-1 mapping is not the convenient or optimal choice.
+
+ type Priorities_Mapping is array (Any_Priority) of Integer;
+ pragma Suppress_Initialization (Priorities_Mapping);
+ -- Suppress initialization in case gnat.adc specifies Normalize_Scalars
+
+ -- On NT, the default mapping preserves the standard 31 priorities
+ -- of the Ada model, but maps them using compression onto the 7
+ -- priority levels available in NT.
+
+ -- To replace the default values of the Underlying_Priorities mapping,
+ -- copy this source file into your build directory, edit the file to
+ -- reflect your desired behavior, and recompile with the command:
+
+ -- $ gcc -c -O3 -gnatpgn system.ads
+
+ -- then recompile the run-time parts that depend on this package:
+
+ -- $ gnatmake -a -gnatn -O3 <your application>
+
+ -- then force rebuilding your application if you need different options:
+
+ -- $ gnatmake -f <your options> <your application>
+
+ Underlying_Priorities : constant Priorities_Mapping :=
+
+ (Priority'First .. 1 => -15,
+
+ 2 .. Default_Priority - 2 => -2,
+
+ Default_Priority - 1 => -1,
+
+ Default_Priority => 0,
+
+ Default_Priority + 1 .. 19 => 1,
+
+ 20 .. Priority'Last => 2,
+
+ Interrupt_Priority => 15);
+
+end System;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.66 $
+-- --
+-- Copyright (C) 1992-2001, 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a NT (native) version of this package.
+
+-- 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 System.Tasking.Debug;
+-- used for Known_Tasks
+
+with Interfaces.C;
+-- used for int
+-- size_t
+
+with Interfaces.C.Strings;
+-- used for Null_Ptr
+
+with System.OS_Interface;
+-- used for various type, constant, and operations
+
+with System.Parameters;
+-- used for Size_Type
+
+with System.Tasking;
+-- used for Ada_Task_Control_Block
+-- Task_ID
+
+with System.Soft_Links;
+-- used for Defer/Undefer_Abort
+-- to initialize TSD for a C thread, in function Self
+
+-- Note that we do not use System.Tasking.Initialization directly since
+-- this 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.Initialization
+
+with System.OS_Primitives;
+-- used for Delay_Modes
+
+with System.Task_Info;
+-- used for Unspecified_Task_Info
+
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+package body System.Task_Primitives.Operations is
+
+ use System.Tasking.Debug;
+ use System.Tasking;
+ use Interfaces.C;
+ use Interfaces.C.Strings;
+ use System.OS_Interface;
+ use System.Parameters;
+ use System.OS_Primitives;
+
+ pragma Linker_Options ("-Xlinker --stack=0x800000,0x1000");
+
+ package SSL renames System.Soft_Links;
+
+ ------------------
+ -- Local Data --
+ ------------------
+
+ Environment_Task_ID : Task_ID;
+ -- A variable to hold Task_ID for the environment task.
+
+ All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
+ -- See comments on locking rules in System.Tasking (spec).
+
+ 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");
+
+ FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
+ -- Indicates whether FIFO_Within_Priorities is set.
+
+ ---------------------------------
+ -- Foreign Threads Detection --
+ ---------------------------------
+
+ -- The following are used to allow the Self function to
+ -- automatically generate ATCB's for C threads that happen to call
+ -- Ada procedure, which in turn happen to call the Ada run-time system.
+
+ type Fake_ATCB;
+ type Fake_ATCB_Ptr is access Fake_ATCB;
+ type Fake_ATCB is record
+ Stack_Base : Interfaces.C.unsigned := 0;
+ -- A value of zero indicates the node is not in use.
+ Next : Fake_ATCB_Ptr;
+ Real_ATCB : aliased Ada_Task_Control_Block (0);
+ end record;
+
+ Fake_ATCB_List : Fake_ATCB_Ptr;
+ -- A linear linked list.
+ -- The list is protected by All_Tasks_L;
+ -- Nodes are added to this list from the front.
+ -- Once a node is added to this list, it is never removed.
+
+ Fake_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads).
+
+ Next_Fake_ATCB : Fake_ATCB_Ptr;
+ -- Used to allocate one Fake_ATCB in advance. See comment in New_Fake_ATCB
+
+ ---------------------------------
+ -- Support for New_Fake_ATCB --
+ ---------------------------------
+
+ function New_Fake_ATCB return Task_ID;
+ -- Allocate and Initialize a new ATCB. This code can safely be called from
+ -- a foreign thread, as it doesn't access implicitely or explicitely
+ -- "self" before having initialized the new ATCB.
+
+ ------------------------------------
+ -- The thread local storage index --
+ ------------------------------------
+
+ TlsIndex : DWORD;
+ pragma Export (Ada, TlsIndex);
+ -- To ensure that this variable won't be local to this package, since
+ -- in some cases, inlining forces this variable to be global anyway.
+
+ ----------------------------------
+ -- Utility Conversion Functions --
+ ----------------------------------
+
+ function To_Task_Id is new Unchecked_Conversion (System.Address, Task_ID);
+
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+
+ -------------------
+ -- New_Fake_ATCB --
+ -------------------
+
+ function New_Fake_ATCB return Task_ID is
+ Self_ID : Task_ID;
+ P, Q : Fake_ATCB_Ptr;
+ Succeeded : Boolean;
+ Res : BOOL;
+
+ begin
+ -- This section is ticklish.
+ -- We dare not call anything that might require an ATCB, until
+ -- we have the new ATCB in place.
+
+ Write_Lock (All_Tasks_L'Access);
+ Q := null;
+ P := Fake_ATCB_List;
+
+ while P /= null loop
+ if P.Stack_Base = 0 then
+ Q := P;
+ end if;
+
+ P := P.Next;
+ end loop;
+
+ if Q = null then
+
+ -- Create a new ATCB with zero entries.
+
+ Self_ID := Next_Fake_ATCB.Real_ATCB'Access;
+ Next_Fake_ATCB.Stack_Base := 1;
+ Next_Fake_ATCB.Next := Fake_ATCB_List;
+ Fake_ATCB_List := Next_Fake_ATCB;
+ Next_Fake_ATCB := null;
+
+ else
+ -- Reuse an existing fake ATCB.
+
+ Self_ID := Q.Real_ATCB'Access;
+ Q.Stack_Base := 1;
+ end if;
+
+ -- Record this as the Task_ID for the current thread.
+
+ Self_ID.Common.LL.Thread := GetCurrentThread;
+
+ Res := TlsSetValue (TlsIndex, To_Address (Self_ID));
+ pragma Assert (Res = True);
+
+ -- Do the standard initializations
+
+ System.Tasking.Initialize_ATCB
+ (Self_ID, null, Null_Address, Null_Task, Fake_Task_Elaborated'Access,
+ System.Priority'First, Task_Info.Unspecified_Task_Info, 0, Self_ID,
+ Succeeded);
+ pragma Assert (Succeeded);
+
+ -- Finally, it is safe to use an allocator in this thread.
+
+ if Next_Fake_ATCB = null then
+ Next_Fake_ATCB := new Fake_ATCB;
+ end if;
+
+ Self_ID.Master_of_Task := 0;
+ Self_ID.Master_Within := Self_ID.Master_of_Task + 1;
+
+ for L in Self_ID.Entry_Calls'Range loop
+ Self_ID.Entry_Calls (L).Self := Self_ID;
+ Self_ID.Entry_Calls (L).Level := L;
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ Self_ID.Awake_Count := 1;
+
+ -- Since this is not an ordinary Ada task, we will start out undeferred
+
+ Self_ID.Deferral_Level := 0;
+
+ System.Soft_Links.Create_TSD (Self_ID.Common.Compiler_Data);
+
+ -- ????
+ -- The following call is commented out to avoid dependence on
+ -- the System.Tasking.Initialization package.
+ -- It seems that if we want Ada.Task_Attributes to work correctly
+ -- for C threads we will need to raise the visibility of this soft
+ -- link to System.Soft_Links.
+ -- We are putting that off until this new functionality is otherwise
+ -- stable.
+ -- System.Tasking.Initialization.Initialize_Attributes_Link.all (T);
+
+ -- Must not unlock until Next_ATCB is again allocated.
+
+ Unlock (All_Tasks_L'Access);
+ return Self_ID;
+ end New_Fake_ATCB;
+
+ ----------------------------------
+ -- Condition Variable Functions --
+ ----------------------------------
+
+ procedure Initialize_Cond (Cond : access Condition_Variable);
+ -- Initialize given condition variable Cond
+
+ procedure Finalize_Cond (Cond : access Condition_Variable);
+ -- Finalize given condition variable Cond.
+
+ procedure Cond_Signal (Cond : access Condition_Variable);
+ -- Signal condition variable Cond
+
+ procedure Cond_Wait
+ (Cond : access Condition_Variable;
+ L : access RTS_Lock);
+ -- Wait on conditional variable Cond, using lock L
+
+ procedure Cond_Timed_Wait
+ (Cond : access Condition_Variable;
+ L : access RTS_Lock;
+ Rel_Time : Duration;
+ Timed_Out : out Boolean;
+ Status : out Integer);
+ -- Do timed wait on condition variable Cond using lock L. The duration
+ -- of the timed wait is given by Rel_Time. When the condition is
+ -- signalled, Timed_Out shows whether or not a time out occurred.
+ -- Status shows whether Cond_Timed_Wait completed successfully.
+
+ ---------------------
+ -- Initialize_Cond --
+ ---------------------
+
+ procedure Initialize_Cond (Cond : access Condition_Variable) is
+ hEvent : HANDLE;
+
+ begin
+ hEvent := CreateEvent (null, True, False, Null_Ptr);
+ pragma Assert (hEvent /= 0);
+ Cond.all := Condition_Variable (hEvent);
+ end Initialize_Cond;
+
+ -------------------
+ -- Finalize_Cond --
+ -------------------
+
+ -- No such problem here, DosCloseEventSem has been derived.
+ -- What does such refer to in above comment???
+
+ procedure Finalize_Cond (Cond : access Condition_Variable) is
+ Result : BOOL;
+
+ begin
+ Result := CloseHandle (HANDLE (Cond.all));
+ pragma Assert (Result = True);
+ end Finalize_Cond;
+
+ -----------------
+ -- Cond_Signal --
+ -----------------
+
+ procedure Cond_Signal (Cond : access Condition_Variable) is
+ Result : BOOL;
+
+ begin
+ Result := SetEvent (HANDLE (Cond.all));
+ pragma Assert (Result = True);
+ end Cond_Signal;
+
+ ---------------
+ -- Cond_Wait --
+ ---------------
+
+ -- Pre-assertion: Cond is posted
+ -- L is locked.
+
+ -- Post-assertion: Cond is posted
+ -- L is locked.
+
+ procedure Cond_Wait
+ (Cond : access Condition_Variable;
+ L : access RTS_Lock)
+ is
+ Result : DWORD;
+ Result_Bool : BOOL;
+
+ begin
+ -- Must reset Cond BEFORE L is unlocked.
+
+ Result_Bool := ResetEvent (HANDLE (Cond.all));
+ pragma Assert (Result_Bool = True);
+ Unlock (L);
+
+ -- No problem if we are interrupted here: if the condition is signaled,
+ -- WaitForSingleObject will simply not block
+
+ Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite);
+ pragma Assert (Result = 0);
+
+ Write_Lock (L);
+ end Cond_Wait;
+
+ ---------------------
+ -- Cond_Timed_Wait --
+ ---------------------
+
+ -- Pre-assertion: Cond is posted
+ -- L is locked.
+
+ -- Post-assertion: Cond is posted
+ -- L is locked.
+
+ procedure Cond_Timed_Wait
+ (Cond : access Condition_Variable;
+ L : access RTS_Lock;
+ Rel_Time : Duration;
+ Timed_Out : out Boolean;
+ Status : out Integer)
+ is
+ Time_Out : DWORD;
+ Result : BOOL;
+
+ Int_Rel_Time : DWORD;
+ Wait_Result : DWORD;
+
+ begin
+ -- Must reset Cond BEFORE L is unlocked.
+
+ Result := ResetEvent (HANDLE (Cond.all));
+ pragma Assert (Result = True);
+ Unlock (L);
+
+ -- No problem if we are interrupted here: if the condition is signaled,
+ -- WaitForSingleObject will simply not block
+
+ if Rel_Time <= 0.0 then
+ Timed_Out := True;
+ else
+ Int_Rel_Time := DWORD (Rel_Time);
+ Time_Out := Int_Rel_Time * 1000 +
+ DWORD ((Rel_Time - Duration (Int_Rel_Time)) * 1000.0);
+ Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out);
+
+ if Wait_Result = WAIT_TIMEOUT then
+ Timed_Out := True;
+ Wait_Result := 0;
+ else
+ Timed_Out := False;
+ end if;
+ end if;
+
+ Write_Lock (L);
+
+ -- Ensure post-condition
+
+ if Timed_Out then
+ Result := SetEvent (HANDLE (Cond.all));
+ pragma Assert (Result = True);
+ end if;
+
+ Status := Integer (Wait_Result);
+ end Cond_Timed_Wait;
+
+ ------------------
+ -- Stack_Guard --
+ ------------------
+
+ -- The underlying thread system sets a guard page at the
+ -- bottom of a thread stack, so nothing is needed.
+ -- ??? Check the comment above
+
+ procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ begin
+ null;
+ end Stack_Guard;
+
+ --------------------
+ -- Get_Thread_Id --
+ --------------------
+
+ function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
+ begin
+ return T.Common.LL.Thread;
+ end Get_Thread_Id;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_ID is
+ Self_Id : Task_ID;
+
+ begin
+ Self_Id := To_Task_Id (TlsGetValue (TlsIndex));
+
+ if Self_Id = null then
+ return New_Fake_ATCB;
+ end if;
+
+ return Self_Id;
+ end Self;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ -- Note: mutexes and cond_variables needed per-task basis are
+ -- initialized in Intialize_TCB and the Storage_Error is handled.
+ -- Other mutexes (such as All_Tasks_Lock, Memory_Lock...) used in
+ -- the RTS is initialized before any status change of RTS.
+ -- Therefore raising Storage_Error in the following routines
+ -- should be able to be handled safely.
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : access Lock) is
+ begin
+ InitializeCriticalSection (L.Mutex'Access);
+ L.Owner_Priority := 0;
+ L.Priority := Prio;
+ end Initialize_Lock;
+
+ procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
+ begin
+ InitializeCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : access Lock) is
+ begin
+ DeleteCriticalSection (L.Mutex'Access);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : access RTS_Lock) is
+ begin
+ DeleteCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ end Finalize_Lock;
+
+ ----------------
+ -- Write_Lock --
+ ----------------
+
+ procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ L.Owner_Priority := Get_Priority (Self);
+
+ if L.Priority < L.Owner_Priority then
+ Ceiling_Violation := True;
+ return;
+ end if;
+
+ EnterCriticalSection (L.Mutex'Access);
+
+ Ceiling_Violation := False;
+ end Write_Lock;
+
+ procedure Write_Lock (L : access RTS_Lock) is
+ begin
+ EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_ID) is
+ begin
+ EnterCriticalSection
+ (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ Write_Lock (L, Ceiling_Violation);
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : access Lock) is
+ begin
+ LeaveCriticalSection (L.Mutex'Access);
+ end Unlock;
+
+ procedure Unlock (L : access RTS_Lock) is
+ begin
+ LeaveCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ end Unlock;
+
+ procedure Unlock (T : Task_ID) is
+ begin
+ LeaveCriticalSection
+ (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
+ end Unlock;
+
+ -----------
+ -- Sleep --
+ -----------
+
+ procedure Sleep
+ (Self_ID : Task_ID;
+ Reason : System.Tasking.Task_States) is
+ begin
+ pragma Assert (Self_ID = Self);
+
+ Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+
+ if Self_ID.Deferral_Level = 0
+ and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ then
+ Unlock (Self_ID);
+ raise Standard'Abort_Signal;
+ end if;
+ 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 : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ Check_Time : constant Duration := Monotonic_Clock;
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Result : Integer;
+
+ Local_Timedout : Boolean;
+
+ begin
+ Timedout := True;
+ Yielded := False;
+
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ or else Self_ID.Pending_Priority_Change;
+
+ Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ if not Local_Timedout then
+ -- somebody may have called Wakeup for us
+ Timedout := False;
+ exit;
+ end if;
+
+ Rel_Time := Abs_Time - Monotonic_Clock;
+ end loop;
+ end if;
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Self_ID : Task_ID;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ Check_Time : constant Duration := Monotonic_Clock;
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Result : Integer;
+ Timedout : Boolean;
+
+ begin
+ -- Only the little window between deferring abort and
+ -- locking Self_ID is the reason we need to
+ -- check for pending abort and priority change below! :(
+
+ SSL.Abort_Defer.all;
+ Write_Lock (Self_ID);
+
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Time + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ Self_ID.Common.State := Delay_Sleep;
+
+ loop
+ if Self_ID.Pending_Priority_Change then
+ Self_ID.Pending_Priority_Change := False;
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
+ end if;
+
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access, Rel_Time, Timedout, Result);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ Rel_Time := Abs_Time - Monotonic_Clock;
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+ Yield;
+ SSL.Abort_Undefer.all;
+ end Timed_Delay;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
+ begin
+ Cond_Signal (T.Common.LL.CV'Access);
+ end Wakeup;
+
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ begin
+ if Do_Yield then
+ Sleep (0);
+ end if;
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ type Prio_Array_Type is array (System.Any_Priority) of Integer;
+ pragma Atomic_Components (Prio_Array_Type);
+
+ Prio_Array : Prio_Array_Type;
+ -- Global array containing the id of the currently running task for
+ -- each priority.
+ --
+ -- Note: we assume that we are on a single processor with run-til-blocked
+ -- scheduling.
+
+ procedure Set_Priority
+ (T : Task_ID;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ Res : BOOL;
+ Array_Item : Integer;
+
+ begin
+ Res := SetThreadPriority
+ (T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio)));
+ pragma Assert (Res = True);
+
+ -- ??? Work around a bug in NT 4.0 SP3 scheduler
+ -- It looks like when a task with Thread_Priority_Idle (using RT class)
+ -- never reaches its time slice (e.g by doing multiple and simple RV,
+ -- see CXD8002), the scheduler never gives higher priority task a
+ -- chance to run.
+ -- Note that this works fine on NT 4.0 SP1
+
+ if Time_Slice_Val = 0
+ and then Underlying_Priorities (Prio) = Thread_Priority_Idle
+ and then Loss_Of_Inheritance
+ then
+ Sleep (20);
+ end if;
+
+ if FIFO_Within_Priorities then
+
+ -- Annex D requirement [RM D.2.2 par. 9]:
+ -- If the task drops its priority due to the loss of inherited
+ -- priority, it is added at the head of the ready queue for its
+ -- new active priority.
+
+ if Loss_Of_Inheritance
+ and then Prio < T.Common.Current_Priority
+ then
+ Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
+ Prio_Array (T.Common.Base_Priority) := Array_Item;
+
+ loop
+ -- Let some processes a chance to arrive
+
+ Yield;
+
+ -- Then wait for our turn to proceed
+
+ exit when Array_Item = Prio_Array (T.Common.Base_Priority)
+ or else Prio_Array (T.Common.Base_Priority) = 1;
+ end loop;
+
+ Prio_Array (T.Common.Base_Priority) :=
+ Prio_Array (T.Common.Base_Priority) - 1;
+ end if;
+ end if;
+
+ T.Common.Current_Priority := Prio;
+ end Set_Priority;
+
+ ------------------
+ -- Get_Priority --
+ ------------------
+
+ function Get_Priority (T : Task_ID) return System.Any_Priority is
+ begin
+ return T.Common.Current_Priority;
+ end Get_Priority;
+
+ ----------------
+ -- Enter_Task --
+ ----------------
+
+ -- There were two paths were we needed to call Enter_Task :
+ -- 1) from System.Task_Primitives.Operations.Initialize
+ -- 2) from System.Tasking.Stages.Task_Wrapper
+ --
+ -- The thread initialisation has to be done only for the first case.
+ --
+ -- This is because the GetCurrentThread NT call does not return the
+ -- real thread handler but only a "pseudo" one. It is not possible to
+ -- release the thread handle and free the system ressources from this
+ -- "pseudo" handle. So we really want to keep the real thread handle
+ -- set in System.Task_Primitives.Operations.Create_Task during the
+ -- thread creation.
+
+ procedure Enter_Task (Self_ID : Task_ID) is
+ procedure Init_Float;
+ pragma Import (C, Init_Float, "__gnat_init_float");
+ -- Properly initializes the FPU for x86 systems.
+
+ Succeeded : BOOL;
+
+ begin
+ Succeeded := TlsSetValue (TlsIndex, To_Address (Self_ID));
+ pragma Assert (Succeeded = True);
+ Init_Float;
+
+ Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
+
+ Lock_All_Tasks_List;
+
+ 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_All_Tasks_List;
+ 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;
+
+ ----------------------
+ -- Initialize_TCB --
+ ----------------------
+
+ procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
+ begin
+ Initialize_Cond (Self_ID.Common.LL.CV'Access);
+ Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
+ Succeeded := True;
+ 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
+ hTask : HANDLE;
+ TaskId : aliased DWORD;
+
+ -- ??? The fact that we can't use PVOID because the compiler
+ -- gives a "PVOID is not visible" error is a GNAT bug.
+ -- The strange thing is that the file compiles fine during a regular
+ -- build.
+
+ pTaskParameter : System.OS_Interface.PVOID;
+ dwStackSize : DWORD;
+ Result : DWORD;
+ Entry_Point : PTHREAD_START_ROUTINE;
+
+ function To_PTHREAD_START_ROUTINE is new
+ Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE);
+
+ begin
+ pTaskParameter := To_Address (T);
+
+ if Stack_Size = Unspecified_Size then
+ dwStackSize := DWORD (Default_Stack_Size);
+
+ elsif Stack_Size < Minimum_Stack_Size then
+ dwStackSize := DWORD (Minimum_Stack_Size);
+
+ else
+ dwStackSize := DWORD (Stack_Size);
+ end if;
+
+ Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper);
+
+ hTask := CreateThread
+ (null,
+ dwStackSize,
+ Entry_Point,
+ pTaskParameter,
+ DWORD (Create_Suspended),
+ TaskId'Unchecked_Access);
+
+ -- Step 1: Create the thread in blocked mode
+
+ if hTask = 0 then
+ raise Storage_Error;
+ end if;
+
+ -- Step 2: set its TCB
+
+ T.Common.LL.Thread := hTask;
+
+ -- Step 3: set its priority (child has inherited priority from parent)
+
+ Set_Priority (T, Priority);
+
+ -- Step 4: Now, start it for good:
+
+ Result := ResumeThread (hTask);
+ pragma Assert (Result = 1);
+
+ Succeeded := Result = 1;
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_ID) is
+ Self_ID : Task_ID := T;
+ Result : DWORD;
+ Succeeded : BOOL;
+
+ procedure Free is new
+ Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
+
+ begin
+ Finalize_Lock (T.Common.LL.L'Access);
+ Finalize_Cond (T.Common.LL.CV'Access);
+
+ if T.Known_Tasks_Index /= -1 then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ end if;
+
+ -- Wait for the thread to terminate then close it. this is needed
+ -- to release system ressources.
+
+ Result := WaitForSingleObject (T.Common.LL.Thread, Wait_Infinite);
+ pragma Assert (Result /= WAIT_FAILED);
+ Succeeded := CloseHandle (T.Common.LL.Thread);
+ pragma Assert (Succeeded = True);
+
+ Free (Self_ID);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ ExitThread (0);
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_ID) is
+ begin
+ null;
+ end Abort_Task;
+
+ ----------------------
+ -- Environment_Task --
+ ----------------------
+
+ function Environment_Task return Task_ID is
+ begin
+ return Environment_Task_ID;
+ end Environment_Task;
+
+ -------------------------
+ -- Lock_All_Tasks_List --
+ -------------------------
+
+ procedure Lock_All_Tasks_List is
+ begin
+ Write_Lock (All_Tasks_L'Access);
+ end Lock_All_Tasks_List;
+
+ ---------------------------
+ -- Unlock_All_Tasks_List --
+ ---------------------------
+
+ procedure Unlock_All_Tasks_List is
+ begin
+ Unlock (All_Tasks_L'Access);
+ end Unlock_All_Tasks_List;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_ID) is
+ Res : BOOL;
+ begin
+ Environment_Task_ID := Environment_Task;
+
+ if Time_Slice_Val = 0 or else FIFO_Within_Priorities then
+ Res := OS_Interface.SetPriorityClass
+ (GetCurrentProcess, Realtime_Priority_Class);
+ end if;
+
+ TlsIndex := TlsAlloc;
+
+ -- Initialize the lock used to synchronize chain of all ATCBs.
+
+ Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
+
+ Environment_Task.Common.LL.Thread := GetCurrentThread;
+ Enter_Task (Environment_Task);
+
+ -- Create a free ATCB for use on the Fake_ATCB_List
+
+ Next_Fake_ATCB := new Fake_ATCB;
+ end Initialize;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration
+ renames System.OS_Primitives.Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ begin
+ return 0.000_001; -- 1 micro-second
+ end RT_Resolution;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy versions. The only currently working versions is for solaris
+ -- (native).
+
+ function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ begin
+ return True;
+ end Check_No_Locks;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ if T.Common.LL.Thread /= Thread_Self then
+ return SuspendThread (T.Common.LL.Thread) = NO_ERROR;
+ else
+ return True;
+ end if;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ if T.Common.LL.Thread /= Thread_Self then
+ return ResumeThread (T.Common.LL.Thread) = NO_ERROR;
+ else
+ return True;
+ end if;
+ end Resume_Task;
+
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.12 $
+-- --
+-- Copyright (C) 1991-2000 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a NT (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.
+
+with System.OS_Interface;
+-- used for pthread_mutex_t
+-- pthread_cond_t
+-- pthread_t
+
+package System.Task_Primitives is
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects.
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system.
+ -- The difference between Lock and the RTS_Lock is that the later
+ -- one serves only as a semaphore so that do not check for
+ -- ceiling violations.
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper
+ -- declared local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task
+ -- basis. A component of this type is guaranteed to be included
+ -- in the Ada_Task_Control_Block.
+
+private
+
+ type Lock is record
+ Mutex : aliased System.OS_Interface.CRITICAL_SECTION;
+ Priority : Integer;
+ Owner_Priority : Integer;
+ end record;
+
+ type Condition_Variable is new System.OS_Interface.HANDLE;
+
+ type RTS_Lock is new System.OS_Interface.CRITICAL_SECTION;
+
+ type Private_Data is record
+ Thread : aliased System.OS_Interface.HANDLE;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb).
+ -- They put the same value (thr_self value). We do not want to
+ -- use lock on those operations and the only thing we have to
+ -- make sure is that they are updated in atomic fashion.
+
+ Thread_Id : aliased System.OS_Interface.DWORD;
+ -- The purpose of this field is to provide a better
+ -- tasking support on gdb. The order of the two first fields (Thread
+ -- and LWP) is important.
+
+ CV : aliased Condition_Variable;
+ -- Condition Variable used to implement Sleep/Wakeup
+
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (VXWORKS Version PPC, Sparc64) --
+-- --
+-- $Revision: 1.6 $
+-- --
+-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ 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 := Integer'Last;
+
+ 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 := Standard'Tick;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := Standard'Storage_Unit;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Standard'Address_Size;
+
+ -- 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 :=
+ Bit_Order'Val (Standard'Default_Bit_Order);
+
+ -- Priority-related Declarations (RM D.1)
+
+ -- 256 is reserved for the VxWorks kernel
+ -- 248 - 255 correspond to hardware interrupt levels 0 .. 7
+ -- 247 is a catchall default "interrupt" priority for signals, allowing
+ -- higher priority than normal tasks, but lower than hardware
+ -- priority levels. Protected Object ceilings can override
+ -- these values
+ -- 246 is used by the Interrupt_Manager task
+
+ Max_Interrupt_Priority : constant Positive := 255;
+
+ Max_Priority : constant Positive := 245;
+
+ subtype Any_Priority is Integer
+ range 0 .. Standard'Max_Interrupt_Priority;
+
+ subtype Priority is Any_Priority
+ range 0 .. Standard'Max_Priority;
+
+ -- Functional notation is needed in the following to avoid visibility
+ -- problems when this package is compiled through rtsfind in the middle
+ -- of another compilation.
+
+ subtype Interrupt_Priority is Any_Priority
+ range
+ Standard."+" (Standard'Max_Priority, 1) ..
+ Standard'Max_Interrupt_Priority;
+
+ Default_Priority : constant Priority :=
+ Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
+
+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.
+
+ AAMP : constant Boolean := False;
+ Command_Line_Args : constant Boolean := False;
+ Denorm : constant Boolean := True;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := False;
+ High_Integrity_Mode : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := True;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+end System;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- Copyright (C) 1991-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Invariants:
+
+-- All user-handleable signals are masked at all times in all
+-- tasks/threads except possibly for the Interrupt_Manager task.
+
+-- When a user task wants to have the effect of masking/unmasking an
+-- signal, it must call Block_Interrupt/Unblock_Interrupt, which
+-- will have the effect of unmasking/masking the signal in the
+-- Interrupt_Manager task. These comments do not apply to vectored
+-- hardware interrupts, which may be masked or unmasked using routined
+-- interfaced to the relevant VxWorks system calls.
+
+-- Note : Direct calls to sigaction, sigprocmask, pthread_sigsetmask or any
+-- other low-level interface that changes the signal action or
+-- signal mask needs careful consideration.
+-- One may achieve the effect of system calls first masking RTS blocked
+-- (by calling Block_Interrupt) for the signal under consideration.
+-- This will make all the tasks in RTS blocked for the signal.
+
+-- Once we associate a Signal_Server_Task with an signal, the task never
+-- goes away, and we never remove the association. On the other hand, it
+-- is more convenient to terminate an associated Interrupt_Server_Task
+-- for a vectored hardware interrupt (since we use a binary semaphore
+-- for synchronization with the umbrella handler).
+
+-- There is no more than one signal per Signal_Server_Task and no more than
+-- one Signal_Server_Task per signal. The same relation holds for hardware
+-- interrupts and Interrupt_Server_Task's at any given time. That is,
+-- only one non-terminated Interrupt_Server_Task exists for a give
+-- interrupt at any time.
+
+-- Within this package, the lock L is used to protect the various status
+-- tables. If there is a Server_Task associated with a signal or interrupt,
+-- we use the per-task lock of the Server_Task instead so that we protect the
+-- status between Interrupt_Manager and Server_Task. Protection among
+-- service requests are ensured via user calls to the Interrupt_Manager
+-- entries.
+
+-- This is the VxWorks version of this package, supporting both signals
+-- and vectored hardware interrupts.
+
+with Unchecked_Conversion;
+
+with System.OS_Interface; use System.OS_Interface;
+
+with System.VxWorks;
+
+with Interfaces.VxWorks;
+
+with Ada.Task_Identification;
+-- used for Task_ID type
+
+with Ada.Exceptions;
+-- used for Raise_Exception
+
+with System.Task_Primitives;
+-- used for RTS_Lock
+-- Self
+
+with System.Interrupt_Management;
+-- used for Reserve
+-- Interrupt_ID
+-- Interrupt_Mask
+-- Abort_Task_Interrupt
+
+with System.Interrupt_Management.Operations;
+-- used for Thread_Block_Interrupt
+-- Thread_Unblock_Interrupt
+-- Install_Default_Action
+-- Install_Ignore_Action
+-- Copy_Interrupt_Mask
+-- Set_Interrupt_Mask
+-- Empty_Interrupt_Mask
+-- Fill_Interrupt_Mask
+-- Add_To_Interrupt_Mask
+-- Delete_From_Interrupt_Mask
+-- Interrupt_Wait
+-- Interrupt_Self_Process
+-- Get_Interrupt_Mask
+-- Set_Interrupt_Mask
+-- IS_Member
+-- Environment_Mask
+-- All_Tasks_Mask
+pragma Elaborate_All (System.Interrupt_Management.Operations);
+
+with System.Error_Reporting;
+-- used for Shutdown
+
+with System.Task_Primitives.Operations;
+-- used for Write_Lock
+-- Unlock
+-- Abort
+-- Wakeup_Task
+-- Sleep
+-- Initialize_Lock
+
+with System.Task_Primitives.Interrupt_Operations;
+-- used for Set_Interrupt_ID
+
+with System.Storage_Elements;
+-- used for To_Address
+-- To_Integer
+-- Integer_Address
+
+with System.Tasking;
+-- used for Task_ID
+-- Task_Entry_Index
+-- Null_Task
+-- Self
+-- Interrupt_Manager_ID
+
+with System.Tasking.Utilities;
+-- used for Make_Independent
+
+with System.Tasking.Rendezvous;
+-- used for Call_Simple
+pragma Elaborate_All (System.Tasking.Rendezvous);
+
+with System.Tasking.Initialization;
+-- used for Defer_Abort
+-- Undefer_Abort
+
+package body System.Interrupts is
+
+ use Tasking;
+ use System.Error_Reporting;
+ use Ada.Exceptions;
+
+ package PRI renames System.Task_Primitives;
+ package POP renames System.Task_Primitives.Operations;
+ package PIO renames System.Task_Primitives.Interrupt_Operations;
+ package IMNG renames System.Interrupt_Management;
+ package IMOP renames System.Interrupt_Management.Operations;
+
+ function To_Ada is new Unchecked_Conversion
+ (System.Tasking.Task_ID, Ada.Task_Identification.Task_Id);
+
+ function To_System is new Unchecked_Conversion
+ (Ada.Task_Identification.Task_Id, Task_ID);
+
+ -----------------
+ -- Local Tasks --
+ -----------------
+
+ -- WARNING: System.Tasking.Utilities performs calls to this task
+ -- with low-level constructs. Do not change this spec without synchro-
+ -- nizing it.
+
+ task Interrupt_Manager is
+ entry Initialize (Mask : IMNG.Interrupt_Mask);
+
+ entry Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False);
+
+ entry Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean);
+
+ entry Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean);
+
+ entry Bind_Interrupt_To_Entry
+ (T : Task_ID;
+ E : Task_Entry_Index;
+ Interrupt : Interrupt_ID);
+
+ entry Detach_Interrupt_Entries (T : Task_ID);
+
+ pragma Interrupt_Priority (System.Interrupt_Priority'First);
+ end Interrupt_Manager;
+
+ task type Signal_Server_Task (Interrupt : Interrupt_ID) is
+ pragma Interrupt_Priority (System.Interrupt_Priority'First + 1);
+ end Signal_Server_Task;
+ -- Server task for signal handling
+
+ type Signal_Task_Access is access Signal_Server_Task;
+
+ task type Interrupt_Server_Task
+ (Interrupt : Interrupt_ID; Int_Sema : SEM_ID) is
+ -- Server task for vectored hardware interrupt handling
+ pragma Interrupt_Priority (System.Interrupt_Priority'First + 2);
+ end Interrupt_Server_Task;
+
+ type Interrupt_Task_Access is access Interrupt_Server_Task;
+
+ -------------------------------
+ -- Local Types and Variables --
+ -------------------------------
+
+ type Entry_Assoc is record
+ T : Task_ID;
+ E : Task_Entry_Index;
+ end record;
+
+ type Handler_Assoc is record
+ H : Parameterless_Handler;
+ Static : Boolean; -- Indicates static binding;
+ end record;
+
+ User_Handler : array (Interrupt_ID) of Handler_Assoc :=
+ (others => (null, Static => False));
+ pragma Volatile_Components (User_Handler);
+ -- Holds the protected procedure handler (if any) and its Static
+ -- information for each interrupt or signal. A handler is static
+ -- iff it is specified through the pragma Attach_Handler.
+
+ User_Entry : array (Interrupt_ID) of Entry_Assoc :=
+ (others => (T => Null_Task, E => Null_Task_Entry));
+ pragma Volatile_Components (User_Entry);
+ -- Holds the task and entry index (if any) for each interrupt / signal
+
+ -- Type and Head, Tail of the list containing Registered Interrupt
+ -- Handlers. These definitions are used to register the handlers
+ -- specified by the pragma Interrupt_Handler.
+
+ type Registered_Handler;
+ type R_Link is access all Registered_Handler;
+
+ type Registered_Handler is record
+ H : System.Address := System.Null_Address;
+ Next : R_Link := null;
+ end record;
+
+ Registered_Handler_Head : R_Link := null;
+ Registered_Handler_Tail : R_Link := null;
+
+ Server_ID : array (Interrupt_ID) of System.Tasking.Task_ID :=
+ (others => System.Tasking.Null_Task);
+ pragma Atomic_Components (Server_ID);
+ -- Holds the Task_ID of the Server_Task for each interrupt / signal.
+ -- Task_ID is needed to accomplish locking per interrupt base. Also
+ -- is needed to determine whether to create a new Server_Task.
+
+ Semaphore_ID_Map : array
+ (Interrupt_ID range 0 .. System.VxWorks.Num_HW_Interrupts) of SEM_ID :=
+ (others => 0);
+ -- Array of binary semaphores associated with vectored interrupts
+ -- Note that the last bound should be Max_HW_Interrupt, but this will raise
+ -- Storage_Error if Num_HW_Interrupts is null, so use an extra 4 bytes
+ -- instead.
+
+ Signal_Access_Hold : Signal_Task_Access;
+ -- Variable for allocating a Signal_Server_Task
+
+ Interrupt_Access_Hold : Interrupt_Task_Access;
+ -- Variable for allocating an Interrupt_Server_Task
+
+ L : aliased PRI.RTS_Lock;
+ -- L protects the contents of the above tables for interrupts / signals
+ -- for which Server_ID (I) = Null_Task.
+ --
+ -- If Server_ID (I) /= Null_Task then protection is via the
+ -- per-task (TCB) lock of Server_ID (I).
+ --
+ -- For deadlock prevention, L should not be locked after
+ -- any other lock is held, hence we use PO_Level which is the highest
+ -- lock level for error checking.
+
+ Task_Lock : array (Interrupt_ID) of Boolean := (others => False);
+ -- Booleans indicating whether the per task lock is used
+
+ Default_Handler : array (HW_Interrupt) of Interfaces.VxWorks.VOIDFUNCPTR;
+ -- Vectored interrupt handlers installed prior to program startup.
+ -- These are saved only when the umbrella handler is installed for
+ -- a given interrupt number.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID);
+ -- Check if Id is a reserved interrupt, and if so raise Program_Error
+ -- with an appropriate message, otherwise return.
+
+ procedure Finalize_Interrupt_Servers;
+ -- Unbind the handlers for hardware interrupt server tasks at program
+ -- termination.
+
+ procedure Lock_Interrupt
+ (Self_ID : Task_ID;
+ Interrupt : Interrupt_ID);
+ -- Protect the tables using L or the per-task lock. Set the Boolean
+ -- value Task_Lock if the lock is made using per-task lock.
+ -- This information is needed so that Unlock_Interrupt
+ -- performs unlocking on the same lock. The situation we are preventing
+ -- is, for example, when Attach_Handler is called for the first time
+ -- we lock L and create an Server_Task. For a matching unlocking, if we
+ -- rely on the fact that there is a Server_Task, we will unlock the
+ -- per-task lock.
+
+ procedure Unlock_Interrupt
+ (Self_ID : Task_ID;
+ Interrupt : Interrupt_ID);
+ -- Unlock interrupt previously locked by Lock_Interrupt
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean;
+ -- Needs comment ???
+
+ procedure Notify_Interrupt (Param : System.Address);
+ -- Umbrella handler for vectored interrupts (not signals)
+
+ procedure Install_Default_Action (Interrupt : HW_Interrupt);
+ -- Restore a handler that was in place prior to program execution
+
+ procedure Install_Umbrella_Handler
+ (Interrupt : HW_Interrupt;
+ Handler : Interfaces.VxWorks.VOIDFUNCPTR);
+ -- Install the runtime umbrella handler for a vectored hardware
+ -- interrupt
+
+ function To_Signal (S : Interrupt_ID) return IMNG.Interrupt_ID;
+ -- Convert interrupt ID to signal number.
+
+ procedure Unimplemented (Feature : String);
+ pragma No_Return (Unimplemented);
+ -- Used to mark a call to an unimplemented function. Raises Program_Error
+ -- with an appropriate message noting that Feature is unimplemented.
+
+ --------------------
+ -- Attach_Handler --
+ --------------------
+
+ -- Calling this procedure with New_Handler = null and Static = True
+ -- means we want to detach the current handler regardless of the
+ -- previous handler's binding status (ie. do not care if it is a
+ -- dynamic or static handler).
+
+ -- This option is needed so that during the finalization of a PO, we
+ -- can detach handlers attached through pragma Attach_Handler.
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
+ end Attach_Handler;
+
+ -----------------------------
+ -- Bind_Interrupt_To_Entry --
+ -----------------------------
+
+ -- This procedure raises a Program_Error if it tries to
+ -- bind an interrupt to which an Entry or a Procedure is
+ -- already bound.
+
+ procedure Bind_Interrupt_To_Entry
+ (T : Task_ID;
+ E : Task_Entry_Index;
+ Int_Ref : System.Address)
+ is
+ Interrupt : constant Interrupt_ID :=
+ Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
+
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
+ end Bind_Interrupt_To_Entry;
+
+ ---------------------
+ -- Block_Interrupt --
+ ---------------------
+
+ procedure Block_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Block_Interrupt");
+ end Block_Interrupt;
+
+ ------------------------------
+ -- Check_Reserved_Interrupt --
+ ------------------------------
+
+ procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception
+ (Program_Error'Identity,
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved");
+ else
+ return;
+ end if;
+ end Check_Reserved_Interrupt;
+
+ ---------------------
+ -- Current_Handler --
+ ---------------------
+
+ function Current_Handler
+ (Interrupt : Interrupt_ID)
+ return Parameterless_Handler
+ is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+
+ -- ??? Since Parameterless_Handler is not Atomic, the
+ -- current implementation is wrong. We need a new service in
+ -- Interrupt_Manager to ensure atomicity.
+
+ return User_Handler (Interrupt).H;
+ end Current_Handler;
+
+ --------------------
+ -- Detach_Handler --
+ --------------------
+
+ -- Calling this procedure with Static = True means we want to Detach the
+ -- current handler regardless of the previous handler's binding status
+ -- (i.e. do not care if it is a dynamic or static handler).
+
+ -- This option is needed so that during the finalization of a PO, we can
+ -- detach handlers attached through pragma Attach_Handler.
+
+ procedure Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Detach_Handler (Interrupt, Static);
+ end Detach_Handler;
+
+ ------------------------------
+ -- Detach_Interrupt_Entries --
+ ------------------------------
+
+ procedure Detach_Interrupt_Entries (T : Task_ID) is
+ begin
+ Interrupt_Manager.Detach_Interrupt_Entries (T);
+ end Detach_Interrupt_Entries;
+
+ ----------------------
+ -- Exchange_Handler --
+ ----------------------
+
+ -- Calling this procedure with New_Handler = null and Static = True
+ -- means we want to detach the current handler regardless of the
+ -- previous handler's binding status (ie. do not care if it is a
+ -- dynamic or static handler).
+
+ -- This option is needed so that during the finalization of a PO, we
+ -- can detach handlers attached through pragma Attach_Handler.
+
+ procedure Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static);
+ end Exchange_Handler;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Static_Interrupt_Protection) is
+ begin
+ -- ??? loop to be executed only when we're not doing library level
+ -- finalization, since in this case all interrupt / signal tasks are
+ -- gone.
+
+ if not Interrupt_Manager'Terminated then
+ for N in reverse Object.Previous_Handlers'Range loop
+ Interrupt_Manager.Attach_Handler
+ (New_Handler => Object.Previous_Handlers (N).Handler,
+ Interrupt => Object.Previous_Handlers (N).Interrupt,
+ Static => Object.Previous_Handlers (N).Static,
+ Restoration => True);
+ end loop;
+ end if;
+
+ Tasking.Protected_Objects.Entries.Finalize
+ (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
+ end Finalize;
+
+ --------------------------------
+ -- Finalize_Interrupt_Servers --
+ --------------------------------
+
+ -- Restore default handlers for interrupt servers. Signal servers
+ -- restore the default handlers when they're aborted. This is called
+ -- by the Interrupt_Manager task when it receives the abort signal
+ -- during program finalization.
+
+ procedure Finalize_Interrupt_Servers is
+ begin
+ if HW_Interrupt'Last >= 0 then
+ for Int in HW_Interrupt loop
+ if Server_ID (Interrupt_ID (Int)) /= null
+ and then
+ not Ada.Task_Identification.Is_Terminated
+ (To_Ada (Server_ID (Interrupt_ID (Int))))
+ then
+ Interrupt_Manager.Attach_Handler
+ (New_Handler => null,
+ Interrupt => Interrupt_ID (Int),
+ Static => True,
+ Restoration => True);
+ end if;
+ end loop;
+ end if;
+ end Finalize_Interrupt_Servers;
+
+ -------------------------------------
+ -- Has_Interrupt_Or_Attach_Handler --
+ -------------------------------------
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Dynamic_Interrupt_Protection)
+ return Boolean
+ is
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Static_Interrupt_Protection)
+ return Boolean
+ is
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ ----------------------
+ -- Ignore_Interrupt --
+ ----------------------
+
+ procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Ignore_Interrupt");
+ end Ignore_Interrupt;
+
+ ----------------------------
+ -- Install_Default_Action --
+ ----------------------------
+
+ procedure Install_Default_Action (Interrupt : HW_Interrupt) is
+ begin
+ -- Restore original interrupt handler
+
+ Interfaces.VxWorks.intVecSet
+ (Interfaces.VxWorks.INUM_TO_IVEC (Integer (Interrupt)),
+ Default_Handler (Interrupt));
+ Default_Handler (Interrupt) := null;
+ end Install_Default_Action;
+
+ ----------------------
+ -- Install_Handlers --
+ ----------------------
+
+ procedure Install_Handlers
+ (Object : access Static_Interrupt_Protection;
+ New_Handlers : New_Handler_Array) is
+ begin
+ for N in New_Handlers'Range loop
+ -- We need a lock around this ???
+
+ Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
+ Object.Previous_Handlers (N).Static := User_Handler
+ (New_Handlers (N).Interrupt).Static;
+
+ -- We call Exchange_Handler and not directly Interrupt_Manager.
+ -- Exchange_Handler so we get the Is_Reserved check.
+
+ Exchange_Handler
+ (Old_Handler => Object.Previous_Handlers (N).Handler,
+ New_Handler => New_Handlers (N).Handler,
+ Interrupt => New_Handlers (N).Interrupt,
+ Static => True);
+ end loop;
+ end Install_Handlers;
+
+ ------------------------------
+ -- Install_Umbrella_Handler --
+ ------------------------------
+
+ procedure Install_Umbrella_Handler
+ (Interrupt : HW_Interrupt;
+ Handler : Interfaces.VxWorks.VOIDFUNCPTR)
+ is
+ use Interfaces.VxWorks;
+
+ Vec : constant Interrupt_Vector :=
+ INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt));
+ Old_Handler : constant VOIDFUNCPTR :=
+ intVecGet
+ (INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt)));
+ Stat : Interfaces.VxWorks.STATUS;
+
+ begin
+ -- Only install umbrella handler when no Ada handler has already been
+ -- installed. Note that the interrupt number is passed as a parameter
+ -- when an interrupt occurs, so the umbrella handler has a different
+ -- wrapper generated by intConnect for each interrupt number.
+
+ if Default_Handler (Interrupt) = null then
+ Stat :=
+ intConnect (Vec, VOIDFUNCPTR (Handler), System.Address (Interrupt));
+ Default_Handler (Interrupt) := Old_Handler;
+ end if;
+ end Install_Umbrella_Handler;
+
+ ----------------
+ -- Is_Blocked --
+ ----------------
+
+ function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented ("Is_Blocked");
+ return False;
+ end Is_Blocked;
+
+ -----------------------
+ -- Is_Entry_Attached --
+ -----------------------
+
+ function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ return User_Entry (Interrupt).T /= Null_Task;
+ end Is_Entry_Attached;
+
+ -------------------------
+ -- Is_Handler_Attached --
+ -------------------------
+
+ function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ return User_Handler (Interrupt).H /= null;
+ end Is_Handler_Attached;
+
+ ----------------
+ -- Is_Ignored --
+ ----------------
+
+ function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented ("Is_Ignored");
+ return False;
+ end Is_Ignored;
+
+ -------------------
+ -- Is_Registered --
+ -------------------
+
+ -- See if Handler has been "pragma"ed using Interrupt_Handler.
+ -- Always consider a null handler as registered.
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean is
+ type Fat_Ptr is record
+ Object_Addr : System.Address;
+ Handler_Addr : System.Address;
+ end record;
+
+ function To_Fat_Ptr is new Unchecked_Conversion
+ (Parameterless_Handler, Fat_Ptr);
+
+ Ptr : R_Link;
+ Fat : Fat_Ptr;
+
+ begin
+ if Handler = null then
+ return True;
+ end if;
+
+ Fat := To_Fat_Ptr (Handler);
+
+ Ptr := Registered_Handler_Head;
+
+ while (Ptr /= null) loop
+ if Ptr.H = Fat.Handler_Addr then
+ return True;
+ end if;
+
+ Ptr := Ptr.Next;
+ end loop;
+
+ return False;
+
+ end Is_Registered;
+
+ -----------------
+ -- Is_Reserved --
+ -----------------
+
+ function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ if Interrupt < System.VxWorks.Num_HW_Interrupts then
+ return False;
+ else
+ return IMNG.Reserve (To_Signal (Interrupt));
+ end if;
+ end Is_Reserved;
+
+ --------------------
+ -- Lock_Interrupt --
+ --------------------
+
+ -- ?????
+ -- This package has been modified several times.
+ -- Do we still need this fancy locking scheme, now that more operations
+ -- are entries of the interrupt manager task?
+ -- ?????
+ -- More likely, we will need to convert one or more entry calls to
+ -- protected operations, because presently we are violating locking order
+ -- rules by calling a task entry from within the runtime system.
+
+ procedure Lock_Interrupt
+ (Self_ID : Task_ID;
+ Interrupt : Interrupt_ID) is
+ begin
+ Initialization.Defer_Abort (Self_ID);
+
+ POP.Write_Lock (L'Access);
+
+ if Task_Lock (Interrupt) then
+ pragma Assert (Server_ID (Interrupt) /= null,
+ "Task_Lock is true for null server task");
+ pragma Assert
+ (not Ada.Task_Identification.Is_Terminated
+ (To_Ada (Server_ID (Interrupt))),
+ "Attempt to lock per task lock of terminated server: " &
+ "Task_Lock => True");
+
+ POP.Unlock (L'Access);
+ POP.Write_Lock (Server_ID (Interrupt));
+
+ elsif Server_ID (Interrupt) /= Null_Task then
+ pragma Assert
+ (not Ada.Task_Identification.Is_Terminated
+ (To_Ada (Server_ID (Interrupt))),
+ "Attempt to lock per task lock of terminated server: " &
+ "Task_Lock => False");
+
+ Task_Lock (Interrupt) := True;
+ POP.Unlock (L'Access);
+ POP.Write_Lock (Server_ID (Interrupt));
+ end if;
+
+ end Lock_Interrupt;
+
+ ------------------------
+ -- Notify_Interrupt --
+ ------------------------
+
+ -- Umbrella handler for vectored hardware interrupts (as opposed to
+ -- signals and exceptions). As opposed to the signal implementation,
+ -- this handler is only installed in the vector table while there is
+ -- an active association of an Ada handler to the interrupt.
+
+ -- Otherwise, the handler that existed prior to program startup is
+ -- in the vector table. This ensures that handlers installed by
+ -- the BSP are active unless explicitly replaced in the program text.
+
+ -- Each Interrupt_Server_Task has an associated binary semaphore
+ -- on which it pends once it's been started. This routine determines
+ -- The appropriate semaphore and and issues a semGive call, waking
+ -- the server task. When a handler is unbound,
+ -- System.Interrupts.Unbind_Handler issues a semFlush, and the
+ -- server task deletes its semaphore and terminates.
+
+ procedure Notify_Interrupt (Param : System.Address) is
+ Interrupt : Interrupt_ID := Interrupt_ID (Param);
+ Discard_Result : STATUS;
+
+ begin
+ Discard_Result := semGive (Semaphore_ID_Map (Interrupt));
+ end Notify_Interrupt;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference (Interrupt : Interrupt_ID) return System.Address is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ return Storage_Elements.To_Address
+ (Storage_Elements.Integer_Address (Interrupt));
+ end Reference;
+
+ --------------------------------
+ -- Register_Interrupt_Handler --
+ --------------------------------
+
+ procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
+ New_Node_Ptr : R_Link;
+ begin
+ -- This routine registers a handler as usable for dynamic
+ -- interrupt handler association. Routines attaching and detaching
+ -- handlers dynamically should determine whether the handler is
+ -- registered. Program_Error should be raised if it is not registered.
+
+ -- Pragma Interrupt_Handler can only appear in a library
+ -- level PO definition and instantiation. Therefore, we do not need
+ -- to implement an unregister operation. Nor do we need to
+ -- protect the queue structure with a lock.
+
+ pragma Assert (Handler_Addr /= System.Null_Address);
+
+ New_Node_Ptr := new Registered_Handler;
+ New_Node_Ptr.H := Handler_Addr;
+
+ if Registered_Handler_Head = null then
+ Registered_Handler_Head := New_Node_Ptr;
+ Registered_Handler_Tail := New_Node_Ptr;
+
+ else
+ Registered_Handler_Tail.Next := New_Node_Ptr;
+ Registered_Handler_Tail := New_Node_Ptr;
+ end if;
+ end Register_Interrupt_Handler;
+
+ ---------------
+ -- To_Signal --
+ ---------------
+
+ function To_Signal (S : Interrupt_ID) return IMNG.Interrupt_ID is
+ begin
+ return IMNG.Interrupt_ID (S - System.VxWorks.Num_HW_Interrupts);
+ end To_Signal;
+
+ -----------------------
+ -- Unblock_Interrupt --
+ -----------------------
+
+ procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Unblock_Interrupt");
+ end Unblock_Interrupt;
+
+ ------------------
+ -- Unblocked_By --
+ ------------------
+
+ function Unblocked_By
+ (Interrupt : Interrupt_ID) return System.Tasking.Task_ID is
+ begin
+ Unimplemented ("Unblocked_By");
+ return Null_Task;
+ end Unblocked_By;
+
+ ------------------------
+ -- Unignore_Interrupt --
+ ------------------------
+
+ procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Unignore_Interrupt");
+ end Unignore_Interrupt;
+
+ -------------------
+ -- Unimplemented --
+ -------------------
+
+ procedure Unimplemented (Feature : String) is
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ Feature & " not implemented on VxWorks");
+ end Unimplemented;
+
+ ----------------------
+ -- Unlock_Interrupt --
+ ----------------------
+
+ procedure Unlock_Interrupt
+ (Self_ID : Task_ID;
+ Interrupt : Interrupt_ID) is
+ begin
+ if Task_Lock (Interrupt) then
+ pragma Assert
+ (not Ada.Task_Identification.Is_Terminated
+ (To_Ada (Server_ID (Interrupt))),
+ "Attempt to unlock per task lock of terminated server");
+
+ POP.Unlock (Server_ID (Interrupt));
+ else
+ POP.Unlock (L'Access);
+ end if;
+
+ Initialization.Undefer_Abort (Self_ID);
+ end Unlock_Interrupt;
+
+ -----------------------
+ -- Interrupt_Manager --
+ -----------------------
+
+ task body Interrupt_Manager is
+ ---------------------
+ -- Local Variables --
+ ---------------------
+
+ Intwait_Mask : aliased IMNG.Interrupt_Mask;
+ Old_Mask : aliased IMNG.Interrupt_Mask;
+ Self_ID : Task_ID := POP.Self;
+
+ --------------------
+ -- Local Routines --
+ --------------------
+
+ procedure Bind_Handler (Interrupt : Interrupt_ID);
+ -- This procedure does not do anything if a signal is blocked.
+ -- Otherwise, we have to interrupt Server_Task for status change through
+ -- a wakeup signal.
+
+ procedure Unbind_Handler (Interrupt : Interrupt_ID);
+ -- This procedure does not do anything if a signal is blocked.
+ -- Otherwise, we have to interrupt Server_Task for status change
+ -- through an abort signal.
+
+ -- The following two procedures are labelled Unprotected... in order to
+ -- indicate that Lock/Unlock_Interrupt operations are needed around
+ -- around calls to them.
+
+ procedure Unprotected_Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False);
+
+ procedure Unprotected_Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean);
+
+ ------------------
+ -- Bind_Handler --
+ ------------------
+
+ procedure Bind_Handler (Interrupt : Interrupt_ID) is
+ begin
+ if Interrupt < System.VxWorks.Num_HW_Interrupts then
+ Install_Umbrella_Handler
+ (HW_Interrupt (Interrupt), Notify_Interrupt'Access);
+
+ else
+ -- Mask this task for the given signal so that all tasks
+ -- are masked for the signal and the actual delivery of the
+ -- signal will be caught using "sigwait" by the
+ -- corresponding Server_Task.
+
+ IMOP.Thread_Block_Interrupt (To_Signal (Interrupt));
+ -- We have installed a handler or an entry before we called
+ -- this procedure. If the handler task is waiting to be
+ -- awakened, do it here. Otherwise, the signal will be
+ -- discarded.
+
+ POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep);
+ end if;
+ end Bind_Handler;
+
+ --------------------
+ -- Unbind_Handler --
+ --------------------
+
+ procedure Unbind_Handler (Interrupt : Interrupt_ID) is
+ S : STATUS;
+ Ret_Interrupt : IMNG.Interrupt_ID;
+
+ use type IMNG.Interrupt_ID;
+ use type STATUS;
+
+ begin
+ if Interrupt < System.VxWorks.Num_HW_Interrupts then
+
+ -- Hardware interrupt
+
+ Install_Default_Action (HW_Interrupt (Interrupt));
+
+ -- Flush server task off semaphore, allowing it to terminate
+
+ S := semFlush (Semaphore_ID_Map (Interrupt));
+ pragma Assert (S = 0);
+
+ else
+ -- Currently, there is a handler or an entry attached and
+ -- the corresponding Server_Task is waiting on "sigwait."
+ -- We have to wake up the Server_Task and make it
+ -- wait on a condition variable by sending an
+ -- Abort_Task_Interrupt
+
+ -- Make sure corresponding Server_Task is out of its own
+ -- sigwait state.
+
+ POP.Abort_Task (Server_ID (Interrupt));
+ Ret_Interrupt := IMOP.Interrupt_Wait (Intwait_Mask'Access);
+ pragma Assert (Ret_Interrupt = IMNG.Abort_Task_Interrupt);
+
+ IMOP.Install_Default_Action (To_Signal (Interrupt));
+
+ -- Unmake the Interrupt for this task in order to allow default
+ -- action again.
+
+ IMOP.Thread_Unblock_Interrupt (To_Signal (Interrupt));
+ end if;
+ end Unbind_Handler;
+
+ --------------------------------
+ -- Unprotected_Detach_Handler --
+ --------------------------------
+
+ procedure Unprotected_Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean)
+ is
+ Old_Handler : Parameterless_Handler;
+ begin
+ if User_Entry (Interrupt).T /= Null_Task then
+
+ -- If an interrupt entry is installed raise
+ -- Program_Error. (propagate it to the caller).
+
+ Unlock_Interrupt (Self_ID, Interrupt);
+ Raise_Exception (Program_Error'Identity,
+ "An interrupt entry is already installed");
+ end if;
+
+ -- Note : Static = True will pass the following check. This is the
+ -- case when we want to detach a handler regardless of the static
+ -- status of the Current_Handler.
+
+ if not Static and then User_Handler (Interrupt).Static then
+
+ -- Trying to detach a static Interrupt Handler.
+ -- raise Program_Error.
+
+ Unlock_Interrupt (Self_ID, Interrupt);
+ Raise_Exception (Program_Error'Identity,
+ "Trying to detach a static Interrupt Handler");
+ end if;
+
+ Old_Handler := User_Handler (Interrupt).H;
+
+ -- The new handler
+
+ User_Handler (Interrupt).H := null;
+ User_Handler (Interrupt).Static := False;
+
+ if Old_Handler /= null then
+ Unbind_Handler (Interrupt);
+ end if;
+
+ end Unprotected_Detach_Handler;
+
+ ----------------------------------
+ -- Unprotected_Exchange_Handler --
+ ----------------------------------
+
+ procedure Unprotected_Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False) is
+ begin
+ if User_Entry (Interrupt).T /= Null_Task then
+
+ -- If an interrupt entry is already installed, raise
+ -- Program_Error. (propagate it to the caller).
+
+ Unlock_Interrupt (Self_ID, Interrupt);
+ Raise_Exception (Program_Error'Identity,
+ "An interrupt is already installed");
+ end if;
+
+ -- Note : A null handler with Static = True will
+ -- pass the following check. This is the case when we want to
+ -- detach a handler regardless of the Static status
+ -- of Current_Handler.
+ -- We don't check anything if Restoration is True, since we
+ -- may be detaching a static handler to restore a dynamic one.
+
+ if not Restoration and then not Static
+ and then (User_Handler (Interrupt).Static
+
+ -- Trying to overwrite a static Interrupt Handler with a
+ -- dynamic Handler
+
+ -- The new handler is not specified as an
+ -- Interrupt Handler by a pragma.
+
+ or else not Is_Registered (New_Handler))
+ then
+ Unlock_Interrupt (Self_ID, Interrupt);
+ Raise_Exception
+ (Program_Error'Identity,
+ "Trying to overwrite a static Interrupt Handler with a " &
+ "dynamic Handler");
+ end if;
+
+ -- Save the old handler
+
+ Old_Handler := User_Handler (Interrupt).H;
+
+ -- The new handler
+
+ User_Handler (Interrupt).H := New_Handler;
+
+ if New_Handler = null then
+
+ -- The null handler means we are detaching the handler.
+
+ User_Handler (Interrupt).Static := False;
+
+ else
+ User_Handler (Interrupt).Static := Static;
+ end if;
+
+ -- Invoke a corresponding Server_Task if not yet created.
+ -- Place Task_ID info in Server_ID array.
+
+ if New_Handler /= null
+ and then
+ (Server_ID (Interrupt) = Null_Task
+ or else
+ Ada.Task_Identification.Is_Terminated
+ (To_Ada (Server_ID (Interrupt))))
+ then
+ -- When a new Server_Task is created, it should have its
+ -- signal mask set to the All_Tasks_Mask.
+
+ IMOP.Set_Interrupt_Mask
+ (IMOP.All_Tasks_Mask'Access, Old_Mask'Access);
+
+ if Interrupt < System.VxWorks.Num_HW_Interrupts then
+
+ -- Vectored hardware interrupt
+
+ Interrupt_Access_Hold :=
+ new Interrupt_Server_Task
+ (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY));
+ Server_ID (Interrupt) :=
+ To_System (Interrupt_Access_Hold.all'Identity);
+
+ else
+ -- Signal
+
+ Signal_Access_Hold := new Signal_Server_Task (Interrupt);
+ Server_ID (Interrupt) :=
+ To_System (Signal_Access_Hold.all'Identity);
+ end if;
+
+ IMOP.Set_Interrupt_Mask (Old_Mask'Access);
+ end if;
+
+ if (New_Handler = null) and then Old_Handler /= null then
+
+ -- Restore default handler
+
+ Unbind_Handler (Interrupt);
+
+ elsif Old_Handler = null then
+
+ -- Save default handler
+
+ Bind_Handler (Interrupt);
+ end if;
+
+ end Unprotected_Exchange_Handler;
+
+ -- Start of processing for Interrupt_Manager
+
+ begin
+ -- By making this task independent of any master, when the process
+ -- goes away, the Interrupt_Manager will terminate gracefully.
+
+ System.Tasking.Utilities.Make_Independent;
+
+ -- Environment task gets its own interrupt mask, saves it,
+ -- and then masks all signals except the Keep_Unmasked set.
+
+ -- During rendezvous, the Interrupt_Manager receives the old
+ -- signal mask of the environment task, and sets its own
+ -- signal mask to that value.
+
+ -- The environment task will call this entry of Interrupt_Manager
+ -- during elaboration of the body of this package.
+
+ accept Initialize (Mask : IMNG.Interrupt_Mask) do
+ declare
+ The_Mask : aliased IMNG.Interrupt_Mask;
+
+ begin
+ IMOP.Copy_Interrupt_Mask (The_Mask, Mask);
+ IMOP.Set_Interrupt_Mask (The_Mask'Access);
+ end;
+ end Initialize;
+
+ -- Note: All tasks in RTS will have all reserved signals
+ -- being masked (except the Interrupt_Manager) and Keep_Unmasked
+ -- signals unmasked when created.
+
+ -- Abort_Task_Interrupt is one of the signals unmasked
+ -- in all tasks. We mask the signal in this particular task
+ -- so that "sigwait" is can catch an explicit
+ -- Abort_Task_Interrupt from a Server_Task.
+
+ -- This sigwaiting is needed to ensure that a Signal_Server_Task is
+ -- out of its own sigwait state. This extra synchronization is
+ -- necessary to prevent following scenarios:
+
+ -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to a
+ -- Signal_Server_Task then changes its own signal mask (OS level).
+ -- If a signal (corresponding to the Signal_Server_Task) arrives
+ -- in the meantime, we have the Interrupt_Manager umnasked and
+ -- the Signal_Server_Task waiting on sigwait.
+
+ -- 2) For unbinding a handler, we install a default action in the
+ -- Interrupt_Manager. POSIX.1c states that the result of using
+ -- "sigwait" and "sigaction" simultaneously on the same signal
+ -- is undefined. Therefore, we need to be informed from the
+ -- Signal_Server_Task that it is out of its sigwait stage.
+
+ IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access);
+ IMOP.Add_To_Interrupt_Mask
+ (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt);
+ IMOP.Thread_Block_Interrupt (IMNG.Abort_Task_Interrupt);
+
+ loop
+ -- A block is needed to absorb Program_Error exception
+
+ declare
+ Old_Handler : Parameterless_Handler;
+
+ begin
+ select
+
+ accept Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False)
+ do
+ Lock_Interrupt (Self_ID, Interrupt);
+ Unprotected_Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static, Restoration);
+ Unlock_Interrupt (Self_ID, Interrupt);
+ end Attach_Handler;
+
+ or accept Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean)
+ do
+ Lock_Interrupt (Self_ID, Interrupt);
+ Unprotected_Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static);
+ Unlock_Interrupt (Self_ID, Interrupt);
+ end Exchange_Handler;
+
+ or accept Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean)
+ do
+ Lock_Interrupt (Self_ID, Interrupt);
+ Unprotected_Detach_Handler (Interrupt, Static);
+ Unlock_Interrupt (Self_ID, Interrupt);
+ end Detach_Handler;
+
+ or accept Bind_Interrupt_To_Entry
+ (T : Task_ID;
+ E : Task_Entry_Index;
+ Interrupt : Interrupt_ID)
+ do
+ Lock_Interrupt (Self_ID, Interrupt);
+
+ -- If there is a binding already (either a procedure or an
+ -- entry), raise Program_Error (propagate it to the caller).
+
+ if User_Handler (Interrupt).H /= null
+ or else User_Entry (Interrupt).T /= Null_Task
+ then
+ Unlock_Interrupt (Self_ID, Interrupt);
+ Raise_Exception
+ (Program_Error'Identity,
+ "A binding for this interrupt is already present");
+ end if;
+
+ User_Entry (Interrupt) := Entry_Assoc' (T => T, E => E);
+
+ -- Indicate the attachment of interrupt entry in the ATCB.
+ -- This is needed so when an interrupt entry task terminates
+ -- the binding can be cleaned. The call to unbinding must be
+ -- make by the task before it terminates.
+
+ T.Interrupt_Entry := True;
+
+ -- Invoke a corresponding Server_Task if not yet created.
+ -- Place Task_ID info in Server_ID array.
+
+ if Server_ID (Interrupt) = Null_Task or else
+ Ada.Task_Identification.Is_Terminated
+ (To_Ada (Server_ID (Interrupt))) then
+
+ -- When a new Server_Task is created, it should have its
+ -- signal mask set to the All_Tasks_Mask.
+
+ IMOP.Set_Interrupt_Mask
+ (IMOP.All_Tasks_Mask'Access, Old_Mask'Access);
+
+ if Interrupt < System.VxWorks.Num_HW_Interrupts then
+ Interrupt_Access_Hold := new Interrupt_Server_Task
+ (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY));
+ Server_ID (Interrupt) :=
+ To_System (Interrupt_Access_Hold.all'Identity);
+
+ else
+ Signal_Access_Hold := new Signal_Server_Task (Interrupt);
+ Server_ID (Interrupt) :=
+ To_System (Signal_Access_Hold.all'Identity);
+ end if;
+
+ IMOP.Set_Interrupt_Mask (Old_Mask'Access);
+ end if;
+
+ Bind_Handler (Interrupt);
+ Unlock_Interrupt (Self_ID, Interrupt);
+ end Bind_Interrupt_To_Entry;
+
+ or accept Detach_Interrupt_Entries (T : Task_ID)
+ do
+ for Int in Interrupt_ID'Range loop
+ if not Is_Reserved (Int) then
+ Lock_Interrupt (Self_ID, Int);
+
+ if User_Entry (Int).T = T then
+
+ User_Entry (Int) := Entry_Assoc'
+ (T => Null_Task, E => Null_Task_Entry);
+ Unbind_Handler (Int);
+ end if;
+
+ Unlock_Interrupt (Self_ID, Int);
+ end if;
+ end loop;
+
+ -- Indicate in ATCB that no interrupt entries are attached.
+
+ T.Interrupt_Entry := False;
+ end Detach_Interrupt_Entries;
+
+ end select;
+
+ exception
+
+ -- If there is a Program_Error we just want to propagate it to
+ -- the caller and do not want to stop this task.
+
+ when Program_Error =>
+ null;
+
+ when E : others =>
+ pragma Assert
+ (Shutdown ("Interrupt_Manager---exception not expected" &
+ ASCII.LF &
+ Exception_Information (E)));
+ null;
+ end;
+ end loop;
+
+ pragma Assert (Shutdown ("Interrupt_Manager---should not get here"));
+ exception
+ when Standard'Abort_Signal =>
+ -- Flush interrupt server semaphores, so they can terminate
+ Finalize_Interrupt_Servers;
+ raise;
+ end Interrupt_Manager;
+
+ ------------------------
+ -- Signal_Server_Task --
+ ------------------------
+
+ task body Signal_Server_Task is
+ Intwait_Mask : aliased IMNG.Interrupt_Mask;
+ Ret_Interrupt : IMNG.Interrupt_ID;
+ Self_ID : Task_ID := Self;
+ Tmp_Handler : Parameterless_Handler;
+ Tmp_ID : Task_ID;
+ Tmp_Entry_Index : Task_Entry_Index;
+
+ use type IMNG.Interrupt_ID;
+
+ begin
+ -- By making this task independent of master, when the process
+ -- goes away, the Server_Task will terminate gracefully.
+
+ System.Tasking.Utilities.Make_Independent;
+
+ -- Install default action in system level.
+
+ IMOP.Install_Default_Action (To_Signal (Interrupt));
+
+ -- Note: All tasks in RTS will have all reserved signals
+ -- masked (except the Interrupt_Manager) and Keep_Unmasked
+ -- unmasked when created.
+
+ -- Abort_Task_Interrupt is one of the signals unmasked
+ -- in all tasks. We mask it in this particular task
+ -- so that "sigwait" can catch an explicit
+ -- Abort_Task_Interrupt from the Interrupt_Manager.
+
+ -- There are two signals that this task catches through
+ -- "sigwait." One is the signal it is designated to catch
+ -- in order to execute an user handler or entry. The other is
+ -- Abort_Task_Interrupt. This signal is sent from the
+ -- Interrupt_Manager to inform of status changes (e.g: become Blocked,
+ -- or a handler or entry is to be detached).
+
+ -- Prepare the mask to be used for sigwait.
+
+ IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access);
+
+ IMOP.Add_To_Interrupt_Mask
+ (Intwait_Mask'Access, To_Signal (Interrupt));
+
+ IMOP.Add_To_Interrupt_Mask
+ (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt);
+
+ IMOP.Thread_Block_Interrupt (IMNG.Abort_Task_Interrupt);
+
+ PIO.Set_Interrupt_ID (To_Signal (Interrupt), Self_ID);
+
+ loop
+ System.Tasking.Initialization.Defer_Abort (Self_ID);
+ POP.Write_Lock (Self_ID);
+
+ if User_Handler (Interrupt).H = null
+ and then User_Entry (Interrupt).T = Null_Task
+ then
+
+ -- No signal binding. If a signal is received,
+ -- Interrupt_Manager will take the default action.
+
+ Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep;
+ POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep);
+ Self_ID.Common.State := Runnable;
+
+ else
+ -- A handler or an entry is installed. At this point all tasks
+ -- mask for the signal is masked. Catch it using
+ -- sigwait.
+
+ -- This task may wake up from sigwait by receiving a signal
+ -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding
+ -- a procedure handler or an entry. Or it could be a wake up
+ -- from status change (Unblocked -> Blocked). If that is not
+ -- the case, we should excecute the attached procedure or entry.
+
+ POP.Unlock (Self_ID);
+
+ Ret_Interrupt := IMOP.Interrupt_Wait (Intwait_Mask'Access);
+
+ if Ret_Interrupt = IMNG.Abort_Task_Interrupt then
+ -- Inform the Interrupt_Manager of wakeup from above sigwait.
+
+ POP.Abort_Task (Interrupt_Manager_ID);
+ POP.Write_Lock (Self_ID);
+
+ else
+ POP.Write_Lock (Self_ID);
+
+ -- Even though we have received a signal, the status may
+ -- have changed before we got the Self_ID lock above.
+ -- Therefore we make sure a handler or an entry is still
+ -- bound and make appropriate call.
+ -- If there is no call to make we need to regenerate the
+ -- signal in order not to lose it.
+
+ if User_Handler (Interrupt).H /= null then
+
+ Tmp_Handler := User_Handler (Interrupt).H;
+
+ -- RTS calls should not be made with self being locked.
+
+ POP.Unlock (Self_ID);
+
+ Tmp_Handler.all;
+ POP.Write_Lock (Self_ID);
+
+ elsif User_Entry (Interrupt).T /= Null_Task then
+
+ Tmp_ID := User_Entry (Interrupt).T;
+ Tmp_Entry_Index := User_Entry (Interrupt).E;
+
+ -- RTS calls should not be made with self being locked.
+
+ POP.Unlock (Self_ID);
+
+ System.Tasking.Rendezvous.Call_Simple
+ (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
+
+ POP.Write_Lock (Self_ID);
+ else
+ -- This is a situation where this task woke up receiving a
+ -- signal and before it got the lock the signal was blocked.
+ -- We do not want to lose the signal so we regenerate it at
+ -- the process level.
+
+ IMOP.Interrupt_Self_Process (Ret_Interrupt);
+ end if;
+ end if;
+ end if;
+
+ POP.Unlock (Self_ID);
+ System.Tasking.Initialization.Undefer_Abort (Self_ID);
+
+ -- Undefer abort here to allow a window for this task
+ -- to be aborted at the time of system shutdown.
+ end loop;
+ end Signal_Server_Task;
+
+ ---------------------------
+ -- Interrupt_Server_Task --
+ ---------------------------
+
+ -- Server task for vectored hardware interrupt handling
+
+ task body Interrupt_Server_Task is
+ Self_ID : Task_ID := Self;
+ Tmp_Handler : Parameterless_Handler;
+ Tmp_ID : Task_ID;
+ Tmp_Entry_Index : Task_Entry_Index;
+ S : STATUS;
+
+ use type STATUS;
+
+ begin
+ System.Tasking.Utilities.Make_Independent;
+ Semaphore_ID_Map (Interrupt) := Int_Sema;
+
+ loop
+ -- Pend on semaphore that will be triggered by the
+ -- umbrella handler when the associated interrupt comes in
+
+ S := semTake (Int_Sema, WAIT_FOREVER);
+ pragma Assert (S = 0);
+
+ if User_Handler (Interrupt).H /= null then
+
+ -- Protected procedure handler
+
+ Tmp_Handler := User_Handler (Interrupt).H;
+ Tmp_Handler.all;
+
+ elsif User_Entry (Interrupt).T /= Null_Task then
+
+ -- Interrupt entry handler
+
+ Tmp_ID := User_Entry (Interrupt).T;
+ Tmp_Entry_Index := User_Entry (Interrupt).E;
+ System.Tasking.Rendezvous.Call_Simple
+ (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
+
+ else
+ -- Semaphore has been flushed by an unbind operation in
+ -- the Interrupt_Manager. Terminate the server task.
+
+ -- Wait for the Interrupt_Manager to complete its work
+
+ POP.Write_Lock (Self_ID);
+
+ -- Delete the associated semaphore
+
+ S := semDelete (Int_Sema);
+
+ pragma Assert (S = 0);
+
+ -- Set status for the Interrupt_Manager
+
+ Semaphore_ID_Map (Interrupt) := 0;
+ Task_Lock (Interrupt) := False;
+ Server_ID (Interrupt) := Null_Task;
+ POP.Unlock (Self_ID);
+
+ exit;
+ end if;
+ end loop;
+ end Interrupt_Server_Task;
+
+begin
+ -- Elaboration code for package System.Interrupts
+
+ -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent.
+
+ Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
+
+ -- Initialize the lock L.
+
+ Initialization.Defer_Abort (Self);
+ POP.Initialize_Lock (L'Access, POP.PO_Level);
+ Initialization.Undefer_Abort (Self);
+
+ -- During the elaboration of this package body we want the RTS to
+ -- inherit its signal mask from the Environment Task.
+
+ -- The Environment Task should have gotten its mask from
+ -- the enclosing process during the RTS start up. (See
+ -- in s-inmaop.adb). Pass the Interrupt_Mask of the Environment
+ -- task to the Interrupt_Manager.
+
+ -- Note : At this point we know that all tasks (including
+ -- RTS internal servers) are masked for non-reserved signals
+ -- (see s-taprop.adb). Only the Interrupt_Manager will have
+ -- masks set up differently, inheriting the original Environment
+ -- Task's mask.
+
+ Interrupt_Manager.Initialize (IMOP.Environment_Mask);
+end System.Interrupts;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.11 $
+-- --
+-- Copyright (C) 1991-2001 Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks version of this package.
+
+-- It is likely to need tailoring to fit each operating system
+-- and machine architecture.
+
+-- PLEASE DO NOT add any dependences on other packages.
+-- This package is designed to work with or without tasking support.
+
+-- See the other warnings in the package specification before making
+-- any modifications to this file.
+
+-- Make a careful study of all signals available under the OS,
+-- to see which need to be reserved, kept always unmasked,
+-- or kept always unmasked.
+-- Be on the lookout for special signals that
+-- may be used by the thread library.
+
+with Interfaces.C;
+-- used for int and other types
+
+with System.Error_Reporting;
+pragma Warnings (Off, System.Error_Reporting);
+-- used for Shutdown
+
+with System.OS_Interface;
+-- used for various Constants, Signal and types
+
+with Unchecked_Conversion;
+
+package body System.Interrupt_Management is
+
+ use Interfaces.C;
+ use System.Error_Reporting;
+ use System.OS_Interface;
+
+ function To_Isr is new Unchecked_Conversion (Long_Integer, isr_address);
+
+ type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
+ Exception_Interrupts : constant Interrupt_List :=
+ (SIGFPE, SIGILL, SIGSEGV, SIGBUS);
+
+ -- Keep these variables global so that they are initialized only once.
+
+ Exception_Action : aliased struct_sigaction;
+ Default_Action : aliased struct_sigaction;
+
+ -- ????? Use these horrible imports here to solve elaboration order
+ -- problems.
+
+ type Task_Id is access all Integer;
+
+ Interrupt_ID_Map : array (Interrupt_ID) of Task_Id;
+ pragma Import (Ada, Interrupt_ID_Map,
+ "system__task_primitives__interrupt_operations__interrupt_id_map");
+
+ ----------------------
+ -- Notify_Exception --
+ ----------------------
+
+ procedure Notify_Exception (signo : Signal);
+ -- Identify the Ada exception to be raised using
+ -- the information when the system received a synchronous signal.
+
+ procedure Notify_Exception (signo : Signal) is
+ Mask : aliased sigset_t;
+ Result : Interfaces.C.int;
+ My_Id : pthread_t;
+ begin
+ -- VxWorks will always mask out the signal during the signal
+ -- handler and will reenable it on a longjmp. GNAT does
+ -- not generate a longjmp to return from a signal handler
+ -- so the signal will still be masked unless we unmask it.
+ Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access);
+ Result := sigdelset (Mask'Access, signo);
+ Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null);
+
+ -- VxWorks will suspend the task when it gets a hardware
+ -- exception. We take the liberty of resuming the task
+ -- for the application.
+ My_Id := taskIdSelf;
+ if taskIsSuspended (My_Id) /= 0 then
+ Result := taskResume (My_Id);
+ end if;
+
+ -- As long as we are using a longjmp to return control to the
+ -- exception handler on the runtime stack, we are safe. The original
+ -- signal mask (the one we had before coming into this signal catching
+ -- function) will be restored by the longjmp. Therefore, raising
+ -- an exception in this handler should be a safe operation.
+
+ -- Check that treatment of exception propagation here
+ -- is consistent with treatment of the abort signal in
+ -- System.Task_Primitives.Operations.
+
+ -- How can SIGSEGV be split into constraint and storage errors?
+ -- What should SIGILL really raise ? Some implementations have
+ -- codes for different types of SIGILL and some raise Storage_Error.
+ -- What causes SIGBUS and should it be caught?
+ -- Peter Burwood
+
+ case signo is
+ when SIGFPE =>
+ raise Constraint_Error;
+ when SIGILL =>
+ raise Constraint_Error;
+ when SIGSEGV =>
+ raise Program_Error;
+ when SIGBUS =>
+ raise Program_Error;
+ when others =>
+ pragma Assert (Shutdown ("Unexpected signal"));
+ null;
+ end case;
+ end Notify_Exception;
+
+ -------------------
+ -- Notify_Signal --
+ -------------------
+
+ -- VxWorks needs a special casing here. Each VxWorks task has a completely
+ -- separate signal handling, so the usual signal masking can't work.
+ -- This idea is to handle all the signals in all the tasks, and when
+ -- such a signal occurs, redirect it to the dedicated task (if any) or
+ -- reraise it.
+
+ procedure Notify_Signal (signo : Signal);
+
+ procedure Notify_Signal (signo : Signal) is
+ Mask : aliased sigset_t;
+ Result : Interfaces.C.int;
+ My_Id : pthread_t;
+ old_isr : isr_address;
+
+ function Get_Thread_Id (T : Task_Id) return pthread_t;
+ pragma Import (Ada, Get_Thread_Id,
+ "system__task_primitives__operations__get_thread_id");
+
+ begin
+ -- VxWorks will always mask out the signal during the signal
+ -- handler and will reenable it on a longjmp. GNAT does
+ -- not generate a longjmp to return from a signal handler
+ -- so the signal will still be masked unless we unmask it.
+ Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access);
+ Result := sigdelset (Mask'Access, signo);
+ Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null);
+
+ -- VxWorks will suspend the task when it gets a hardware
+ -- exception. We take the liberty of resuming the task
+ -- for the application.
+ My_Id := taskIdSelf;
+ if taskIsSuspended (My_Id) /= 0 then
+ Result := taskResume (My_Id);
+ end if;
+
+ -- ??? Need a lock around this, in case the handler is detached
+ -- between the two following statements.
+
+ if Interrupt_ID_Map (Interrupt_ID (signo)) /= null then
+ Result :=
+ kill (Get_Thread_Id (Interrupt_ID_Map (Interrupt_ID (signo))),
+ Signal (signo));
+ else
+ old_isr := c_signal (signo, To_Isr (SIG_DFL));
+ Result := kill (My_Id, Signal (signo));
+ end if;
+ end Notify_Signal;
+
+ ---------------------------
+ -- Initialize_Interrupts --
+ ---------------------------
+
+ -- Since there is no signal inheritance between VxWorks tasks, we need
+ -- to initialize signal handling in each task.
+
+ procedure Initialize_Interrupts is
+ old_act : aliased struct_sigaction;
+ Result : Interfaces.C.int;
+
+ begin
+ for J in Interrupt_ID'First + 1 .. Interrupt_ID'Last loop
+ if J /= Abort_Task_Interrupt then
+ Result := sigaction (Signal (J), Default_Action'Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
+
+ for J in Exception_Interrupts'Range loop
+ Keep_Unmasked (Exception_Interrupts (J)) := True;
+ Result :=
+ sigaction
+ (Signal (Exception_Interrupts (J)), Exception_Action'Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end loop;
+ end Initialize_Interrupts;
+
+begin
+ declare
+ mask : aliased sigset_t;
+ default_mask : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ begin
+ -- The VxWorks POSIX threads library currently needs initialization.
+ -- We wish it could be in System.OS_Interface, but that would
+ -- cause an elaboration problem.
+
+ pthread_init;
+
+ Abort_Task_Interrupt := SIGABRT;
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ Exception_Action.sa_handler := Notify_Exception'Address;
+ Default_Action.sa_handler := Notify_Signal'Address;
+
+ Exception_Action.sa_flags := SA_SIGINFO + SA_ONSTACK;
+ Default_Action.sa_flags := SA_SIGINFO + SA_ONSTACK;
+ -- Send us extra signal information (SA_SIGINFO) on the
+ -- stack (SA_ONSTACK).
+ -- There is no SA_NODEFER in VxWorks. The signal mask is
+ -- restored after a longjmp so the SA_NODEFER option is
+ -- not needed. - Dan Eischen
+
+ Result := sigemptyset (mask'Access);
+ pragma Assert (Result = 0);
+ Result := sigemptyset (default_mask'Access);
+ pragma Assert (Result = 0);
+
+ for J in Interrupt_ID'First + 1 .. Interrupt_ID'Last loop
+ Result := sigaddset (default_mask'Access, Signal (J));
+ pragma Assert (Result = 0);
+ end loop;
+
+ for J in Exception_Interrupts'Range loop
+ Result := sigaddset (mask'Access, Signal (Exception_Interrupts (J)));
+ pragma Assert (Result = 0);
+ Result :=
+ sigdelset (default_mask'Access, Signal (Exception_Interrupts (J)));
+ pragma Assert (Result = 0);
+ end loop;
+
+ Exception_Action.sa_mask := mask;
+ Default_Action.sa_mask := default_mask;
+
+ -- Initialize_Interrupts is called for each task in Enter_Task
+
+ Keep_Unmasked (Abort_Task_Interrupt) := True;
+
+ Reserve := Reserve or Keep_Unmasked or Keep_Masked;
+
+ Reserve (0) := True;
+ -- We do not have Signal 0 in reality. We just use this value
+ -- to identify non-existent signals (see s-intnam.ads). Therefore,
+ -- Signal 0 should not be used in all signal related operations hence
+ -- mark it as reserved.
+ end;
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.15 $
+-- --
+-- Copyright (C) 1997-2001 Free Software Foundation --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks version.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+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 Interfaces.C; use Interfaces.C;
+
+with System.VxWorks;
+-- used for Wind_TCB_Ptr
+
+with Unchecked_Conversion;
+
+package body System.OS_Interface is
+
+ use System.VxWorks;
+
+ -- Option flags for taskSpawn
+
+ VX_UNBREAKABLE : constant := 16#0002#;
+ VX_FP_TASK : constant := 16#0008#;
+ VX_FP_PRIVATE_ENV : constant := 16#0080#;
+ VX_NO_STACK_FILL : constant := 16#0100#;
+
+ function taskSpawn
+ (name : System.Address; -- Pointer to task name
+ priority : int;
+ options : int;
+ stacksize : size_t;
+ start_routine : Thread_Body;
+ arg1 : System.Address;
+ arg2 : int := 0;
+ arg3 : int := 0;
+ arg4 : int := 0;
+ arg5 : int := 0;
+ arg6 : int := 0;
+ arg7 : int := 0;
+ arg8 : int := 0;
+ arg9 : int := 0;
+ arg10 : int := 0) return pthread_t;
+ pragma Import (C, taskSpawn, "taskSpawn");
+
+ procedure taskDelete (tid : pthread_t);
+ pragma Import (C, taskDelete, "taskDelete");
+
+ -- These are the POSIX scheduling priorities. These are enabled
+ -- when the global variable posixPriorityNumbering is 1.
+
+ POSIX_SCHED_FIFO_LOW_PRI : constant := 0;
+ POSIX_SCHED_FIFO_HIGH_PRI : constant := 255;
+ POSIX_SCHED_RR_LOW_PRI : constant := 0;
+ POSIX_SCHED_RR_HIGH_PRI : constant := 255;
+
+ -- These are the VxWorks native (default) scheduling priorities.
+ -- These are used when the global variable posixPriorityNumbering
+ -- is 0.
+
+ SCHED_FIFO_LOW_PRI : constant := 255;
+ SCHED_FIFO_HIGH_PRI : constant := 0;
+ SCHED_RR_LOW_PRI : constant := 255;
+ SCHED_RR_HIGH_PRI : constant := 0;
+
+ -- Global variable to enable POSIX priority numbering.
+ -- By default, it is 0 and VxWorks native priority numbering
+ -- is used.
+
+ posixPriorityNumbering : int;
+ pragma Import (C, posixPriorityNumbering, "posixPriorityNumbering");
+
+ -- VxWorks will let you set round-robin scheduling globally
+ -- for all tasks, but not for individual tasks. Attempting
+ -- to set the scheduling policy for a specific task (using
+ -- sched_setscheduler) to something other than what the system
+ -- is currently using will fail. If you wish to change the
+ -- scheduling policy, then use the following function to set
+ -- it globally for all tasks. When ticks is 0, time slicing
+ -- (round-robin scheduling) is disabled.
+
+ function kernelTimeSlice (ticks : int) return int;
+ pragma Import (C, kernelTimeSlice, "kernelTimeSlice");
+
+ function taskPriorityGet
+ (tid : pthread_t;
+ pPriority : access int)
+ return int;
+ pragma Import (C, taskPriorityGet, "taskPriorityGet");
+
+ function taskPrioritySet
+ (tid : pthread_t;
+ newPriority : int)
+ return int;
+ pragma Import (C, taskPrioritySet, "taskPrioritySet");
+
+ function To_Wind_TCB_Ptr is
+ new Unchecked_Conversion (pthread_t, Wind_TCB_Ptr);
+
+
+ -- Error codes (errno). The lower level 16 bits are the
+ -- error code, with the upper 16 bits representing the
+ -- module number in which the error occurred. By convention,
+ -- the module number is 0 for UNIX errors. VxWorks reserves
+ -- module numbers 1-500, with the remaining module numbers
+ -- being available for user applications.
+
+ M_objLib : constant := 61 * 2**16;
+ -- semTake() failure with ticks = NO_WAIT
+ S_objLib_OBJ_UNAVAILABLE : constant := M_objLib + 2;
+ -- semTake() timeout with ticks > NO_WAIT
+ S_objLib_OBJ_TIMEOUT : constant := M_objLib + 4;
+
+ -- We use two different kinds of VxWorks semaphores: mutex
+ -- and binary semaphores. A null (0) ID is returned when
+ -- a semaphore cannot be created. Binary semaphores and common
+ -- operations are declared in the spec of this package,
+ -- as they are used to implement hardware interrupt handling
+
+ function semMCreate
+ (options : int) return SEM_ID;
+ pragma Import (C, semMCreate, "semMCreate");
+
+
+ function taskLock return int;
+ pragma Import (C, taskLock, "taskLock");
+
+ function taskUnlock return int;
+ pragma Import (C, taskUnlock, "taskUnlock");
+
+ -------------------------------------------------------
+ -- Convenience routines to convert between VxWorks --
+ -- priority and POSIX priority. --
+ -------------------------------------------------------
+
+ function To_Vxworks_Priority (Priority : in int) return int;
+ pragma Inline (To_Vxworks_Priority);
+
+ function To_Posix_Priority (Priority : in int) return int;
+ pragma Inline (To_Posix_Priority);
+
+ function To_Vxworks_Priority (Priority : in int) return int is
+ begin
+ return SCHED_FIFO_LOW_PRI - Priority;
+ end To_Vxworks_Priority;
+
+ function To_Posix_Priority (Priority : in int) return int is
+ begin
+ return SCHED_FIFO_LOW_PRI - Priority;
+ end To_Posix_Priority;
+
+ ----------------------------------------
+ -- Implementation of POSIX routines --
+ ----------------------------------------
+
+ -----------------------------------------
+ -- Nonstandard Thread Initialization --
+ -----------------------------------------
+
+ procedure pthread_init is
+ begin
+ Keys_Created := 0;
+ Time_Slice := -1;
+ end pthread_init;
+
+ ---------------------------
+ -- POSIX.1c Section 3 --
+ ---------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int
+ is
+ Result : Interfaces.C.int;
+
+ function sigwaitinfo
+ (set : access sigset_t; sigvalue : System.Address) return int;
+ pragma Import (C, sigwaitinfo, "sigwaitinfo");
+
+ begin
+ Result := sigwaitinfo (set, System.Null_Address);
+
+ if Result /= -1 then
+ sig.all := Signal (Result);
+ return 0;
+ else
+ sig.all := 0;
+ return errno;
+ end if;
+ end sigwait;
+
+ ----------------------------
+ -- POSIX.1c Section 11 --
+ ----------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int is
+ begin
+ -- Let's take advantage of VxWorks priority inversion
+ -- protection.
+ --
+ -- ??? - Do we want to also specify SEM_DELETE_SAFE???
+
+ attr.Flags := int (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
+
+ -- Initialize the ceiling priority to the maximim priority.
+ -- We will use POSIX priorities since these routines are
+ -- emulating POSIX routines.
+
+ attr.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI;
+ attr.Protocol := PTHREAD_PRIO_INHERIT;
+ return 0;
+ end pthread_mutexattr_init;
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int is
+ begin
+ attr.Flags := 0;
+ attr.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI;
+ attr.Protocol := PTHREAD_PRIO_INHERIT;
+ return 0;
+ end pthread_mutexattr_destroy;
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int
+ is
+ Result : int := 0;
+
+ begin
+ -- A mutex should initially be created full and the task
+ -- protected from deletion while holding the semaphore.
+
+ mutex.Mutex := semMCreate (attr.Flags);
+ mutex.Prio_Ceiling := attr.Prio_Ceiling;
+ mutex.Protocol := attr.Protocol;
+
+ if mutex.Mutex = 0 then
+ Result := errno;
+ end if;
+
+ return Result;
+ end pthread_mutex_init;
+
+ function pthread_mutex_destroy
+ (mutex : access pthread_mutex_t) return int
+ is
+ Result : STATUS;
+ begin
+ Result := semDelete (mutex.Mutex);
+
+ if Result /= 0 then
+ Result := errno;
+ end if;
+
+ mutex.Mutex := 0; -- Ensure the mutex is properly cleaned.
+ mutex.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI;
+ mutex.Protocol := PTHREAD_PRIO_INHERIT;
+ return Result;
+ end pthread_mutex_destroy;
+
+ function pthread_mutex_lock
+ (mutex : access pthread_mutex_t) return int
+ is
+ Result : int;
+ WTCB_Ptr : Wind_TCB_Ptr;
+ begin
+ WTCB_Ptr := To_Wind_TCB_Ptr (taskIdSelf);
+
+ if WTCB_Ptr = null then
+ return errno;
+ end if;
+
+ -- Check the current inherited priority in the WIND_TCB
+ -- against the mutex ceiling priority and return EINVAL
+ -- upon a ceiling violation.
+ --
+ -- We always convert the VxWorks priority to POSIX priority
+ -- in case the current priority ordering has changed (see
+ -- posixPriorityNumbering). The mutex ceiling priority is
+ -- maintained as POSIX compatible.
+
+ if mutex.Protocol = PTHREAD_PRIO_PROTECT and then
+ To_Posix_Priority (WTCB_Ptr.Priority) > mutex.Prio_Ceiling
+ then
+ return EINVAL;
+ end if;
+
+ Result := semTake (mutex.Mutex, WAIT_FOREVER);
+
+ if Result /= 0 then
+ Result := errno;
+ end if;
+
+ return Result;
+ end pthread_mutex_lock;
+
+ function pthread_mutex_unlock
+ (mutex : access pthread_mutex_t) return int
+ is
+ Result : int;
+ begin
+ Result := semGive (mutex.Mutex);
+
+ if Result /= 0 then
+ Result := errno;
+ end if;
+
+ return Result;
+ end pthread_mutex_unlock;
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int is
+ begin
+ attr.Flags := SEM_Q_PRIORITY;
+ return 0;
+ end pthread_condattr_init;
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int is
+ begin
+ attr.Flags := 0;
+ return 0;
+ end pthread_condattr_destroy;
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int
+ is
+ Result : int := 0;
+
+ begin
+ -- Condition variables should be initially created
+ -- empty.
+
+ cond.Sem := semBCreate (attr.Flags, SEM_EMPTY);
+ cond.Waiting := 0;
+
+ if cond.Sem = 0 then
+ Result := errno;
+ end if;
+
+ return Result;
+ end pthread_cond_init;
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int is
+ Result : int;
+
+ begin
+ Result := semDelete (cond.Sem);
+
+ if Result /= 0 then
+ Result := errno;
+ end if;
+
+ return Result;
+ end pthread_cond_destroy;
+
+ function pthread_cond_signal
+ (cond : access pthread_cond_t) return int
+ is
+ Result : int := 0;
+ Status : int;
+
+ begin
+ -- Disable task scheduling.
+
+ Status := taskLock;
+
+ -- Iff someone is currently waiting on the condition variable
+ -- then release the semaphore; we don't want to leave the
+ -- semaphore in the full state because the next guy to do
+ -- a condition wait operation would not block.
+
+ if cond.Waiting > 0 then
+ Result := semGive (cond.Sem);
+
+ -- One less thread waiting on the CV.
+
+ cond.Waiting := cond.Waiting - 1;
+
+ if Result /= 0 then
+ Result := errno;
+ end if;
+ end if;
+
+ -- Reenable task scheduling.
+
+ Status := taskUnlock;
+
+ return Result;
+ end pthread_cond_signal;
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int
+ is
+ Result : int;
+ Status : int;
+ begin
+ -- Disable task scheduling.
+
+ Status := taskLock;
+
+ -- Release the mutex as required by POSIX.
+
+ Result := semGive (mutex.Mutex);
+
+ -- Indicate that there is another thread waiting on the CV.
+
+ cond.Waiting := cond.Waiting + 1;
+
+ -- Perform a blocking operation to take the CV semaphore.
+ -- Note that a blocking operation in VxWorks will reenable
+ -- task scheduling. When we are no longer blocked and control
+ -- is returned, task scheduling will again be disabled.
+
+ Result := semTake (cond.Sem, WAIT_FOREVER);
+
+ if Result /= 0 then
+ cond.Waiting := cond.Waiting - 1;
+ Result := EINVAL;
+ end if;
+
+ -- Take the mutex as required by POSIX.
+
+ Status := semTake (mutex.Mutex, WAIT_FOREVER);
+
+ if Status /= 0 then
+ Result := EINVAL;
+ end if;
+
+ -- Reenable task scheduling.
+
+ Status := taskUnlock;
+
+ return Result;
+ end pthread_cond_wait;
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int
+ is
+ Result : int;
+ Status : int;
+ Ticks : int;
+ TS : aliased timespec;
+ begin
+ Status := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
+
+ -- Calculate the number of clock ticks for the timeout.
+
+ Ticks := To_Clock_Ticks (To_Duration (abstime.all) - To_Duration (TS));
+
+ if Ticks <= 0 then
+ -- It is not worth the time to try to perform a semTake,
+ -- because we know it will always fail. A semTake with
+ -- ticks = 0 (NO_WAIT) will not block and therefore not
+ -- allow another task to give the semaphore. And if we've
+ -- designed pthread_cond_signal correctly, the semaphore
+ -- should never be left in a full state.
+ --
+ -- Make sure we give up the CPU.
+
+ Status := taskDelay (0);
+ return ETIMEDOUT;
+ end if;
+
+ -- Disable task scheduling.
+
+ Status := taskLock;
+
+ -- Release the mutex as required by POSIX.
+
+ Result := semGive (mutex.Mutex);
+
+ -- Indicate that there is another thread waiting on the CV.
+
+ cond.Waiting := cond.Waiting + 1;
+
+ -- Perform a blocking operation to take the CV semaphore.
+ -- Note that a blocking operation in VxWorks will reenable
+ -- task scheduling. When we are no longer blocked and control
+ -- is returned, task scheduling will again be disabled.
+
+ Result := semTake (cond.Sem, Ticks);
+
+ if Result /= 0 then
+ if errno = S_objLib_OBJ_TIMEOUT then
+ Result := ETIMEDOUT;
+ else
+ Result := EINVAL;
+ end if;
+ cond.Waiting := cond.Waiting - 1;
+ end if;
+
+ -- Take the mutex as required by POSIX.
+
+ Status := semTake (mutex.Mutex, WAIT_FOREVER);
+
+ if Status /= 0 then
+ Result := EINVAL;
+ end if;
+
+ -- Reenable task scheduling.
+
+ Status := taskUnlock;
+
+ return Result;
+ end pthread_cond_timedwait;
+
+ ----------------------------
+ -- POSIX.1c Section 13 --
+ ----------------------------
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int is
+ begin
+ if protocol < PTHREAD_PRIO_NONE
+ or protocol > PTHREAD_PRIO_PROTECT
+ then
+ return EINVAL;
+ end if;
+
+ attr.Protocol := protocol;
+ return 0;
+ end pthread_mutexattr_setprotocol;
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int is
+ begin
+ -- Our interface to the rest of the world is meant
+ -- to be POSIX compliant; keep the priority in POSIX
+ -- format.
+
+ attr.Prio_Ceiling := prioceiling;
+ return 0;
+ end pthread_mutexattr_setprioceiling;
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int
+ is
+ Result : int;
+ begin
+ -- Convert the POSIX priority to VxWorks native
+ -- priority.
+
+ Result := taskPrioritySet (thread,
+ To_Vxworks_Priority (param.sched_priority));
+ return 0;
+ end pthread_setschedparam;
+
+ function sched_yield return int is
+ begin
+ return taskDelay (0);
+ end sched_yield;
+
+ function pthread_sched_rr_set_interval (usecs : int) return int is
+ Result : int := 0;
+ D_Slice : Duration;
+ begin
+ -- Check to see if round-robin scheduling (time slicing)
+ -- is enabled. If the time slice is the default value (-1)
+ -- or any negative number, we will leave the kernel time
+ -- slice unchanged. If the time slice is 0, we disable
+ -- kernel time slicing by setting it to 0. Otherwise, we
+ -- set the kernel time slice to the specified value converted
+ -- to clock ticks.
+
+ Time_Slice := usecs;
+
+ if Time_Slice > 0 then
+ D_Slice := Duration (Time_Slice) / Duration (1_000_000.0);
+ Result := kernelTimeSlice (To_Clock_Ticks (D_Slice));
+
+ else
+ if Time_Slice = 0 then
+ Result := kernelTimeSlice (0);
+ end if;
+ end if;
+
+ return Result;
+ end pthread_sched_rr_set_interval;
+
+ function pthread_attr_init (attr : access pthread_attr_t) return int is
+ begin
+ attr.Stacksize := 100000; -- What else can I do?
+ attr.Detachstate := PTHREAD_CREATE_DETACHED;
+ attr.Priority := POSIX_SCHED_FIFO_LOW_PRI;
+ attr.Taskname := System.Null_Address;
+ return 0;
+ end pthread_attr_init;
+
+ function pthread_attr_destroy (attr : access pthread_attr_t) return int is
+ begin
+ attr.Stacksize := 0;
+ attr.Detachstate := 0;
+ attr.Priority := POSIX_SCHED_FIFO_LOW_PRI;
+ attr.Taskname := System.Null_Address;
+ return 0;
+ end pthread_attr_destroy;
+
+ function pthread_attr_setdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : int) return int is
+ begin
+ attr.Detachstate := detachstate;
+ return 0;
+ end pthread_attr_setdetachstate;
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int is
+ begin
+ attr.Stacksize := stacksize;
+ return 0;
+ end pthread_attr_setstacksize;
+
+ -- In VxWorks tasks, we can set the task name. This
+ -- makes it really convenient for debugging.
+
+ function pthread_attr_setname_np
+ (attr : access pthread_attr_t;
+ name : System.Address) return int is
+ begin
+ attr.Taskname := name;
+ return 0;
+ end pthread_attr_setname_np;
+
+ function pthread_create
+ (thread : access pthread_t;
+ attr : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int is
+ begin
+ thread.all := taskSpawn (attr.Taskname,
+ To_Vxworks_Priority (attr.Priority), VX_FP_TASK, attr.Stacksize,
+ start_routine, arg);
+
+ if thread.all = -1 then
+ return -1;
+ else
+ return 0;
+ end if;
+ end pthread_create;
+
+ function pthread_detach (thread : pthread_t) return int is
+ begin
+ return 0;
+ end pthread_detach;
+
+ procedure pthread_exit (status : System.Address) is
+ begin
+ taskDelete (0);
+ end pthread_exit;
+
+ function pthread_self return pthread_t is
+ begin
+ return taskIdSelf;
+ end pthread_self;
+
+ function pthread_equal (t1 : pthread_t; t2 : pthread_t) return int is
+ begin
+ if t1 = t2 then
+ return 1;
+ else
+ return 0;
+ end if;
+ end pthread_equal;
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int
+ is
+ Result : int;
+ begin
+ if Integer (key) not in Key_Storage'Range then
+ return EINVAL;
+ end if;
+
+ Key_Storage (Integer (key)) := value;
+ Result := taskVarAdd (taskIdSelf, Key_Storage (Integer (key))'Access);
+
+ -- We should be able to directly set the key with the following:
+ -- Key_Storage (key) := value;
+ -- but we'll be safe and use taskVarSet.
+ -- ??? Come back and revisit this.
+
+ Result := taskVarSet (taskIdSelf,
+ Key_Storage (Integer (key))'Access, value);
+ return Result;
+ end pthread_setspecific;
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address is
+ begin
+ return Key_Storage (Integer (key));
+ end pthread_getspecific;
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int is
+ begin
+ Keys_Created := Keys_Created + 1;
+
+ if Keys_Created not in Key_Storage'Range then
+ return ENOMEM;
+ end if;
+
+ key.all := pthread_key_t (Keys_Created);
+ return 0;
+ end pthread_key_create;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.ts_sec) + Duration (TS.ts_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' (ts_sec => S,
+ ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ --------------------
+ -- To_Clock_Ticks --
+ --------------------
+
+ -- ??? - For now, we'll always get the system clock rate
+ -- since it is allowed to be changed during run-time in
+ -- VxWorks. A better method would be to provide an operation
+ -- to set it that so we can always know its value.
+ --
+ -- Another thing we should probably allow for is a resultant
+ -- tick count greater than int'Last. This should probably
+ -- be a procedure with two output parameters, one in the
+ -- range 0 .. int'Last, and another representing the overflow
+ -- count.
+
+ function To_Clock_Ticks (D : Duration) return int is
+ Ticks : Long_Long_Integer;
+ Rate_Duration : Duration;
+ Ticks_Duration : Duration;
+ begin
+
+ -- Ensure that the duration can be converted to ticks
+ -- at the current clock tick rate without overflowing.
+
+ Rate_Duration := Duration (sysClkRateGet);
+
+ if D > (Duration'Last / Rate_Duration) then
+ Ticks := Long_Long_Integer (int'Last);
+
+ else
+ -- We always want to round up to the nearest clock tick.
+
+ Ticks_Duration := D * Rate_Duration;
+ Ticks := Long_Long_Integer (Ticks_Duration);
+
+ if Ticks_Duration > Duration (Ticks) then
+ Ticks := Ticks + 1;
+ end if;
+
+ if Ticks > Long_Long_Integer (int'Last) then
+ Ticks := Long_Long_Integer (int'Last);
+ end if;
+ end if;
+
+ return int (Ticks);
+ end To_Clock_Ticks;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.16 $
+-- --
+-- Copyright (C) 1997-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks version of this package.
+--
+-- VxWorks does not directly support the needed POSIX routines, but it
+-- does have other routines that make it possible to code equivalent
+-- POSIX compliant routines. The approach taken is to provide an
+-- FSU threads compliant interface.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Elaborate_Body.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+with System.VxWorks;
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ 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;
+ subtype char is Interfaces.C.char;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "errnoGet");
+
+ EINTR : constant := 4;
+ EAGAIN : constant := 35;
+ ENOMEM : constant := 12;
+ EINVAL : constant := 22;
+ ETIMEDOUT : constant := 60;
+
+ FUNC_ERR : constant := -1;
+
+ ----------------------------
+ -- Signals and Interrupts --
+ ----------------------------
+
+ -- In order to support both signal and hardware interrupt handling,
+ -- the ranges of "interrupt IDs" for the vectored hardware interrupts
+ -- and the signals are catenated. In other words, the external IDs
+ -- used to designate signals are relocated beyond the range of the
+ -- vectored interrupts. The IDs given in Ada.Interrupts.Names should
+ -- be used to designate signals; vectored interrupts are designated
+ -- by their interrupt number.
+
+ NSIG : constant := 32;
+ -- Number of signals on the target OS
+ type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1);
+
+ Max_HW_Interrupt : constant := System.VxWorks.Num_HW_Interrupts - 1;
+ type HW_Interrupt is new int range 0 .. Max_HW_Interrupt;
+
+ Max_Interrupt : constant := Max_HW_Interrupt + NSIG;
+
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGFPE : constant := 8; -- floating point exception
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+
+ -----------------------------------
+ -- Signal processing definitions --
+ -----------------------------------
+
+ -- The how in sigprocmask().
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ -- The sa_flags in struct sigaction.
+ SA_SIGINFO : constant := 16#0002#;
+ SA_ONSTACK : constant := 16#0004#;
+
+ -- ANSI args and returns from signal().
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ type sigset_t is private;
+
+ 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;
+
+ 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");
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ type isr_address is access procedure (sig : int);
+
+ function c_signal (sig : Signal; handler : isr_address) return isr_address;
+ pragma Import (C, c_signal, "signal");
+
+ function sigwait (set : access sigset_t; sig : access Signal) return int;
+ pragma Inline (sigwait);
+
+ type sigset_t_ptr is access all sigset_t;
+
+ function pthread_sigmask
+ (how : int;
+ set : sigset_t_ptr;
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "sigprocmask");
+
+ ----------
+ -- Time --
+ ----------
+
+ type time_t is new unsigned_long;
+
+ type timespec is record
+ ts_sec : time_t;
+ ts_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t; -- System wide realtime clock
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ function To_Clock_Ticks (D : Duration) return int;
+ -- Convert a duration value (in seconds) into clock ticks.
+
+ function clock_gettime
+ (clock_id : clockid_t; tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "clock_gettime");
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ -- Scheduling policies.
+ SCHED_FIFO : constant := 1;
+ SCHED_RR : constant := 2;
+ SCHED_OTHER : constant := 4;
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+
+ 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 := 0;
+ PTHREAD_CREATE_JOINABLE : constant := 1;
+
+ function kill (pid : pthread_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ -- VxWorks doesn't have getpid; taskIdSelf is the equivalent
+ -- routine.
+ function getpid return pthread_t;
+ pragma Import (C, getpid, "taskIdSelf");
+
+ ---------------------------------
+ -- Nonstandard Thread Routines --
+ ---------------------------------
+
+ procedure pthread_init;
+ pragma Inline (pthread_init);
+ -- Vxworks requires this for the moment.
+
+ function taskIdSelf return pthread_t;
+ pragma Import (C, taskIdSelf, "taskIdSelf");
+
+ function taskSuspend (tid : pthread_t) return int;
+ pragma Import (C, taskSuspend, "taskSuspend");
+
+ function taskResume (tid : pthread_t) return int;
+ pragma Import (C, taskResume, "taskResume");
+
+ function taskIsSuspended (tid : pthread_t) return int;
+ pragma Import (C, taskIsSuspended, "taskIsSuspended");
+
+ function taskVarAdd
+ (tid : pthread_t;
+ pVar : access System.Address) return int;
+ pragma Import (C, taskVarAdd, "taskVarAdd");
+
+ function taskVarDelete
+ (tid : pthread_t;
+ pVar : access System.Address) return int;
+ pragma Import (C, taskVarDelete, "taskVarDelete");
+
+ function taskVarSet
+ (tid : pthread_t;
+ pVar : access System.Address;
+ value : System.Address) return int;
+ pragma Import (C, taskVarSet, "taskVarSet");
+
+ function taskVarGet
+ (tid : pthread_t;
+ pVar : access System.Address) return int;
+ pragma Import (C, taskVarGet, "taskVarGet");
+
+ function taskInfoGet
+ (tid : pthread_t;
+ pTaskDesc : access System.VxWorks.TASK_DESC) return int;
+ pragma Import (C, taskInfoGet, "taskInfoGet");
+
+ function taskDelay (ticks : int) return int;
+ pragma Import (C, taskDelay, "taskDelay");
+
+ function sysClkRateGet return int;
+ pragma Import (C, sysClkRateGet, "sysClkRateGet");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Inline (pthread_mutexattr_init);
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Inline (pthread_mutexattr_destroy);
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Inline (pthread_mutex_init);
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Inline (pthread_mutex_destroy);
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Inline (pthread_mutex_lock);
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Inline (pthread_mutex_unlock);
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Inline (pthread_condattr_init);
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Inline (pthread_condattr_destroy);
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Inline (pthread_cond_init);
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Inline (pthread_cond_destroy);
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Inline (pthread_cond_signal);
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Inline (pthread_cond_wait);
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Inline (pthread_cond_timedwait);
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ PTHREAD_PRIO_NONE : constant := 0;
+ PTHREAD_PRIO_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Inline (pthread_mutexattr_setprotocol);
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+ pragma Inline (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 Inline (pthread_setschedparam);
+
+ function sched_yield return int;
+ pragma Inline (sched_yield);
+
+ function pthread_sched_rr_set_interval (usecs : int) return int;
+ pragma Inline (pthread_sched_rr_set_interval);
+
+ ---------------------------
+ -- P1003.1c - Section 16 --
+ ---------------------------
+
+ function pthread_attr_init (attr : access pthread_attr_t) return int;
+ pragma Inline (pthread_attr_init);
+
+ function pthread_attr_destroy (attr : access pthread_attr_t) return int;
+ pragma Inline (pthread_attr_destroy);
+
+ function pthread_attr_setdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : int) return int;
+ pragma Inline (pthread_attr_setdetachstate);
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Inline (pthread_attr_setstacksize);
+
+ function pthread_attr_setname_np
+ (attr : access pthread_attr_t;
+ name : System.Address) return int;
+ -- In VxWorks tasks, we have a non-portable routine to set the
+ -- task name. This makes it really convenient for debugging.
+ pragma Inline (pthread_attr_setname_np);
+
+ function pthread_create
+ (thread : access pthread_t;
+ attr : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Inline (pthread_create);
+
+ function pthread_detach (thread : pthread_t) return int;
+ pragma Inline (pthread_detach);
+
+ procedure pthread_exit (status : System.Address);
+ pragma Inline (pthread_exit);
+
+ function pthread_self return pthread_t;
+ pragma Inline (pthread_self);
+
+ function pthread_equal (t1 : pthread_t; t2 : pthread_t) return int;
+ pragma Inline (pthread_equal);
+ -- be careful not to use "=" on thread_t!
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Inline (pthread_setspecific);
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Inline (pthread_getspecific);
+
+ type destructor_pointer is access procedure (arg : System.Address);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Inline (pthread_key_create);
+
+ -- VxWorks binary semaphores. These are exported for use by the
+ -- implementation of hardware interrupt handling.
+
+ subtype STATUS is int;
+ -- Equivalent of the C type STATUS
+
+ OK : constant STATUS := 0;
+ ERROR : constant STATUS := Interfaces.C."-" (1);
+
+ -- Semaphore creation flags.
+
+ SEM_Q_FIFO : constant := 0;
+ SEM_Q_PRIORITY : constant := 1;
+ SEM_DELETE_SAFE : constant := 4; -- only valid for binary semaphore
+ SEM_INVERSION_SAFE : constant := 8; -- only valid for binary semaphore
+
+ -- Semaphore initial state flags;
+
+ SEM_EMPTY : constant := 0;
+ SEM_FULL : constant := 1;
+
+ -- Semaphore take (semTake) time constants.
+
+ WAIT_FOREVER : constant := -1;
+ NO_WAIT : constant := 0;
+
+ type SEM_ID is new long;
+ -- The VxWorks semaphore ID is an integer which is really just
+ -- a pointer to a semaphore structure.
+
+ function semBCreate (Options : int; Initial_State : int) return SEM_ID;
+ -- Create a binary semaphore. Returns ID, or 0 if memory could not
+ -- be allocated
+ pragma Import (C, semBCreate, "semBCreate");
+
+ function semTake (SemID : SEM_ID; Timeout : int) return STATUS;
+ -- Attempt to take binary semaphore. Error is returned if operation
+ -- times out
+ pragma Import (C, semTake, "semTake");
+
+ function semGive (SemID : SEM_ID) return STATUS;
+ -- Release one thread blocked on the semaphore
+ pragma Import (C, semGive, "semGive");
+
+ function semFlush (SemID : SEM_ID) return STATUS;
+ -- Release all threads blocked on the semaphore
+ pragma Import (C, semFlush, "semFlush");
+
+ function semDelete (SemID : SEM_ID) return STATUS;
+ -- Delete a semaphore
+ pragma Import (C, semDelete, "semDelete");
+
+
+private
+ -- This interface assumes that "unsigned" and "int" are 32-bit entities.
+
+ type sigset_t is new long;
+
+ type pid_t is new int;
+
+ ERROR_PID : constant pid_t := -1;
+
+ type clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 0;
+
+ -- Priority ceilings are now implemented in the body of
+ -- this package.
+
+ type pthread_mutexattr_t is record
+ Flags : int; -- mutex semaphore creation flags
+ Prio_Ceiling : int; -- priority ceiling
+ Protocol : int;
+ end record;
+
+ type pthread_mutex_t is record
+ Mutex : SEM_ID;
+ Protocol : int;
+ Prio_Ceiling : int; -- priority ceiling of lock
+ end record;
+
+ type pthread_condattr_t is record
+ Flags : int;
+ end record;
+
+ type pthread_cond_t is record
+ Sem : SEM_ID; -- VxWorks semaphore ID
+ Waiting : Integer; -- Number of queued tasks waiting
+ end record;
+
+ type pthread_attr_t is record
+ Stacksize : size_t;
+ Detachstate : int;
+ Priority : int;
+ Taskname : System.Address;
+ end record;
+
+ type pthread_t is new long;
+
+ type pthread_key_t is new int;
+
+ -- These are to store the pthread_keys that are created with
+ -- pthread_key_create. Currently, we only need one key.
+
+ Key_Storage : array (1 .. 10) of aliased System.Address;
+ Keys_Created : Integer;
+
+ Time_Slice : int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ P R I M I T I V E S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- Copyright (C) 1998-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for VxWorks targets
+
+with System.OS_Interface;
+-- Since the thread library is part of the VxWorks kernel, using OS_Interface
+-- is not a problem here, as long as we only use System.OS_Interface as a
+-- set of C imported routines: using Ada routines from this package would
+-- create a dependency on libgnarl in libgnat, which is not desirable.
+
+with Interfaces.C;
+-- used for type int
+
+package body System.OS_Primitives is
+
+ use System.OS_Interface;
+
+ --------------------------
+ -- Internal functions --
+ --------------------------
+
+ function To_Clock_Ticks (D : Duration) return int;
+ -- Convert a duration value (in seconds) into clock ticks.
+ -- Note that this routine is duplicated from System.OS_Interface since
+ -- as explained above, we do not want to depend on libgnarl
+
+ function To_Clock_Ticks (D : Duration) return int is
+ Ticks : Long_Long_Integer;
+ Rate_Duration : Duration;
+ Ticks_Duration : Duration;
+ begin
+ -- Ensure that the duration can be converted to ticks
+ -- at the current clock tick rate without overflowing.
+
+ Rate_Duration := Duration (sysClkRateGet);
+
+ if D > (Duration'Last / Rate_Duration) then
+ Ticks := Long_Long_Integer (int'Last);
+ else
+ -- We always want to round up to the nearest clock tick.
+
+ Ticks_Duration := D * Rate_Duration;
+ Ticks := Long_Long_Integer (Ticks_Duration);
+
+ if Ticks_Duration > Duration (Ticks) then
+ Ticks := Ticks + 1;
+ end if;
+
+ if Ticks > Long_Long_Integer (int'Last) then
+ Ticks := Long_Long_Integer (int'Last);
+ end if;
+ end if;
+
+ return int (Ticks);
+ end To_Clock_Ticks;
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock return Duration is
+ TS : aliased timespec;
+ Result : int;
+
+ use type Interfaces.C.int;
+ begin
+ Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+ return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9;
+ end Clock;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration renames Clock;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Time : Duration;
+ Mode : Integer)
+ is
+ Result : int;
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Check_Time : Duration := Clock;
+
+ begin
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Time + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ loop
+ Result := taskDelay (To_Clock_Ticks (Rel_Time));
+ Check_Time := Clock;
+
+ exit when Abs_Time <= Check_Time;
+
+ Rel_Time := Abs_Time - Check_Time;
+ end loop;
+ end if;
+ end Timed_Delay;
+
+end System.OS_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.13 $
+-- --
+-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks/68k version of this package
+
+-- This package defines some system dependent parameters for GNAT. These
+-- are values that are referenced by the runtime library and are therefore
+-- relevant to the target machine.
+
+-- The parameters whose value is defined in the spec are not generally
+-- expected to be changed. If they are changed, it will be necessary to
+-- recompile the run-time library.
+
+-- The parameters which are defined by functions can be changed by modifying
+-- the body of System.Parameters in file s-parame.adb. A change to this body
+-- requires only rebinding and relinking of the application.
+
+-- Note: do not introduce any pragma Inline statements into this unit, since
+-- otherwise the relinking and rebinding capability would be deactivated.
+
+package System.Parameters is
+pragma Pure (Parameters);
+
+ ---------------------------------------
+ -- Task And Stack Allocation Control --
+ ---------------------------------------
+
+ type Task_Storage_Size is new Integer;
+ -- Type used in tasking units for task storage size
+
+ type Size_Type is new Task_Storage_Size;
+ -- Type used to provide task storage size to runtime
+
+ Unspecified_Size : constant Size_Type := Size_Type'First;
+ -- Value used to indicate that no size type is set
+
+ subtype Ratio is Size_Type range -1 .. 100;
+ Dynamic : constant Size_Type := -1;
+ -- Secondary_Stack_Ratio is a constant between 0 and 100 wich
+ -- determines the percentage of the allocate task stack that is
+ -- used by the secondary stack (the rest being the primary stack).
+ -- The special value of minus one indicates that the secondary
+ -- stack is to be allocated from the heap instead.
+
+ Sec_Stack_Ratio : constant Ratio := -1;
+ -- This constant defines the handling of the secondary stack
+
+ Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic;
+ -- Convenient Boolean for testing for dynmaic secondary stack
+
+ function Default_Stack_Size return Size_Type;
+ -- Default task stack size used if none is specified
+
+ function Minimum_Stack_Size return Size_Type;
+ -- Minimum task stack size permitted
+
+ function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
+ -- Given the storage size stored in the TCB, return the Storage_Size
+ -- value required by the RM for the Storage_Size attribute. The
+ -- required adjustment is as follows:
+ --
+ -- when Size = Unspecified_Size, return Default_Stack_Size
+ -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
+ -- otherwise return given Size
+
+ Stack_Grows_Down : constant Boolean := True;
+ -- This constant indicates whether the stack grows up (False) or
+ -- down (True) in memory as functions are called. It is used for
+ -- proper implementation of the stack overflow check.
+
+ ----------------------------------------------
+ -- Characteristics of types in Interfaces.C --
+ ----------------------------------------------
+
+ long_bits : constant := Long_Integer'Size;
+ -- Number of bits in type long and unsigned_long. The normal convention
+ -- is that this is the same as type Long_Integer, but this is not true
+ -- of all targets. For example, in OpenVMS long /= Long_Integer.
+
+ ----------------------------------------------
+ -- Behavior of Pragma Finalize_Storage_Only --
+ ----------------------------------------------
+
+ -- Garbage_Collected is a Boolean constant whose value indicates the
+ -- effect of the pragma Finalize_Storage_Entry on a controlled type.
+
+ -- Garbage_Collected = False
+
+ -- The system releases all storage on program termination only,
+ -- but not other garbage collection occurs, so finalization calls
+ -- are ommitted only for outer level onjects can be omitted if
+ -- pragma Finalize_Storage_Only is used.
+
+ -- Garbage_Collected = True
+
+ -- The system provides full garbage collection, so it is never
+ -- necessary to release storage for controlled objects for which
+ -- a pragma Finalize_Storage_Only is used.
+
+ Garbage_Collected : constant Boolean := False;
+ -- The storage mode for this system (release on program exit)
+
+end System.Parameters;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (VXWORKS Version Alpha, Mips) --
+-- --
+-- $Revision: 1.14 $
+-- --
+-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ 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 := Integer'Last;
+
+ 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 := Standard'Tick;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := Standard'Storage_Unit;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Standard'Address_Size;
+
+ -- 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 :=
+ Bit_Order'Val (Standard'Default_Bit_Order);
+
+ -- Priority-related Declarations (RM D.1)
+
+ -- 256 is reserved for the VxWorks kernel
+ -- 248 - 255 correspond to hardware interrupt levels 0 .. 7
+ -- 247 is a catchall default "interrupt" priority for signals, allowing
+ -- higher priority than normal tasks, but lower than hardware
+ -- priority levels. Protected Object ceilings can override
+ -- these values
+ -- 246 is used by the Interrupt_Manager task
+
+ Max_Priority : constant Positive := 245;
+
+ Max_Interrupt_Priority : constant Positive := 255;
+
+ subtype Any_Priority is Integer
+ range 0 .. Standard'Max_Interrupt_Priority;
+
+ subtype Priority is Any_Priority
+ range 0 .. Standard'Max_Priority;
+
+ -- Functional notation is needed in the following to avoid visibility
+ -- problems when this package is compiled through rtsfind in the middle
+ -- of another compilation.
+
+ subtype Interrupt_Priority is Any_Priority
+ range
+ Standard."+" (Standard'Max_Priority, 1) ..
+ Standard'Max_Interrupt_Priority;
+
+ Default_Priority : constant Priority :=
+ Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
+
+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.
+
+ AAMP : constant Boolean := False;
+ Command_Line_Args : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := True;
+ Stack_Check_Probes : constant Boolean := False;
+ Stack_Check_Default : constant Boolean := False;
+ Denorm : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ Machine_Overflows : constant Boolean := False;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Long_Shifts_Inlined : constant Boolean := False;
+ High_Integrity_Mode : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+end System;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.41 $
+-- --
+-- Copyright (C) 1991-2001 Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks version of this package
+
+-- 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 System.Tasking.Debug;
+-- used for Known_Tasks
+
+with Interfaces.C;
+-- used for int
+-- size_t
+
+with System.Interrupt_Management;
+-- used for Keep_Unmasked
+-- Abort_Task_Interrupt
+-- Interrupt_ID
+-- Initialize_Interrupts
+
+with System.Soft_Links;
+-- used for Defer/Undefer_Abort
+
+-- Note that we do not use System.Tasking.Initialization directly since
+-- this 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.Initialization
+
+with System.OS_Interface;
+-- used for various type, constant, and operations
+
+with System.Parameters;
+-- used for Size_Type
+
+with System.Tasking;
+-- used for Ada_Task_Control_Block
+-- Task_ID
+-- ATCB components and types
+
+with System.Task_Info;
+-- used for Task_Image
+
+with System.OS_Primitives;
+-- used for Delay_Modes
+
+with System.VxWorks;
+-- used for TASK_DESC
+
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+package body System.Task_Primitives.Operations is
+
+ use System.Tasking.Debug;
+ use System.Tasking;
+ use System.Task_Info;
+ use Interfaces.C;
+ use System.OS_Interface;
+ use System.Parameters;
+ use System.OS_Primitives;
+
+ package SSL renames System.Soft_Links;
+
+ ------------------
+ -- Local Data --
+ ------------------
+
+ -- The followings are logically constants, but need to be initialized
+ -- at run time.
+
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_ID associated with a VxWorks task.
+
+ All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
+ -- See comments on locking rules in System.Tasking (spec).
+
+ Environment_Task_ID : Task_ID;
+ -- A variable to hold Task_ID for the environment task.
+
+ Unblocked_Signal_Mask : aliased sigset_t;
+ -- The set of signals that should unblocked in all tasks
+
+ -- The followings are internal configuration constants needed.
+
+ Time_Slice_Val : Integer;
+ pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
+
+ Locking_Policy : Character;
+ pragma Import (C, Locking_Policy, "__gl_locking_policy");
+
+ Dispatching_Policy : Character;
+ pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
+
+ FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
+ -- Indicates whether FIFO_Within_Priorities is set.
+
+ Mutex_Protocol : Interfaces.C.int;
+
+ Stack_Limit : aliased System.Address;
+ pragma Import (C, Stack_Limit, "__gnat_stack_limit");
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Abort_Handler (signo : Signal);
+
+ function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
+
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ procedure Abort_Handler (signo : Signal) is
+ Self_ID : constant Task_ID := Self;
+ Result : Interfaces.C.int;
+ Old_Set : aliased sigset_t;
+
+ begin
+ if Self_ID.Deferral_Level = 0
+ and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level and then
+ not Self_ID.Aborting
+ then
+ Self_ID.Aborting := True;
+
+ -- Make sure signals used for RTS internal purpose are unmasked
+
+ Result := pthread_sigmask (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_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
+ Task_Descriptor : aliased System.VxWorks.TASK_DESC;
+ Result : Interfaces.C.int;
+
+ begin
+ if On then
+ Result := taskInfoGet (T.Common.LL.Thread,
+ Task_Descriptor'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ Stack_Limit := Task_Descriptor.td_pStackLimit;
+ 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 is
+ Result : System.Address;
+
+ begin
+ Result := pthread_getspecific (ATCB_Key);
+ pragma Assert (Result /= System.Null_Address);
+ return To_Task_ID (Result);
+ end Self;
+
+ -----------------------------
+ -- Install_Signal_Handlers --
+ -----------------------------
+
+ procedure Install_Signal_Handlers;
+ pragma Inline (Install_Signal_Handlers);
+
+ procedure Install_Signal_Handlers is
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Tmp_Set : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ begin
+ 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 (Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ Interrupt_Management.Initialize_Interrupts;
+ end Install_Signal_Handlers;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ -- Note: mutexes and cond_variables needed per-task basis are
+ -- initialized in Intialize_TCB and the Storage_Error is
+ -- handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...)
+ -- used in RTS is initialized before any status change of RTS.
+ -- Therefore rasing Storage_Error in the following routines
+ -- should be able to be handled safely.
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : 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;
+
+ Result := pthread_mutexattr_setprotocol
+ (Attributes'Access, Mutex_Protocol);
+ pragma Assert (Result = 0);
+
+ Result := pthread_mutexattr_setprioceiling
+ (Attributes'Access, Interfaces.C.int (Prio));
+ pragma Assert (Result = 0);
+
+ Result := pthread_mutex_init (L, Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+ end Initialize_Lock;
+
+ procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) 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;
+
+ Result := pthread_mutexattr_setprotocol
+ (Attributes'Access, Mutex_Protocol);
+ pragma Assert (Result = 0);
+
+ Result := pthread_mutexattr_setprioceiling
+ (Attributes'Access,
+ Interfaces.C.int (System.Any_Priority'Last));
+ pragma Assert (Result = 0);
+
+ Result := pthread_mutex_init (L, Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_destroy (L);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : 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 : access Lock; Ceiling_Violation : out Boolean) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (L);
+
+ -- 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;
+
+ procedure Write_Lock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ Write_Lock (L, Ceiling_Violation);
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ -------------
+ -- Sleep --
+ -------------
+
+ procedure Sleep (Self_ID : Task_ID;
+ Reason : System.Tasking.Task_States) is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Self_ID = Self);
+ Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access);
+
+ -- 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 : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ Check_Time : constant Duration := Monotonic_Clock;
+ 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;
+ else
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+ end if;
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ or else Self_ID.Pending_Priority_Change;
+
+ Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access, Request'Access);
+ Yielded := True;
+ exit when Abs_Time <= Monotonic_Clock;
+
+ if Result = 0 or Result = EINTR then
+
+ -- Somebody may have called Wakeup for us
+
+ Timedout := False;
+ exit;
+ end if;
+
+ pragma Assert (Result = ETIMEDOUT);
+ end loop;
+ end if;
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ -- 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
+ Check_Time : constant Duration := Monotonic_Clock;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+ Yielded : Boolean := False;
+ begin
+
+ -- Only the little window between deferring abort and
+ -- locking Self_ID is the reason we need to
+ -- check for pending abort and priority change below! :(
+
+ SSL.Abort_Defer.all;
+ Write_Lock (Self_ID);
+
+ if Mode = Relative then
+ Abs_Time := Time + Check_Time;
+ else
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+ end if;
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+ Self_ID.Common.State := Delay_Sleep;
+
+ loop
+ if Self_ID.Pending_Priority_Change then
+ Self_ID.Pending_Priority_Change := False;
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
+ end if;
+
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access, Request'Access);
+ Yielded := True;
+ exit when Abs_Time <= Monotonic_Clock;
+
+ pragma Assert (Result = 0
+ or else Result = ETIMEDOUT
+ or else Result = EINTR);
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+
+ if not Yielded then
+ Result := sched_yield;
+ end if;
+ SSL.Abort_Undefer.all;
+ end Timed_Delay;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ TS : aliased timespec;
+ Result : Interfaces.C.int;
+ begin
+ Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+ return To_Duration (TS);
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ begin
+ return 10#1.0#E-6;
+ end RT_Resolution;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
+ 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;
+
+ begin
+ Result := sched_yield;
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ type Prio_Array_Type is array (System.Any_Priority) of Integer;
+ pragma Atomic_Components (Prio_Array_Type);
+
+ Prio_Array : Prio_Array_Type;
+ -- Global array containing the id of the currently running task for
+ -- each priority.
+ --
+ -- Note: we assume that we are on a single processor with run-til-blocked
+ -- scheduling.
+
+ procedure Set_Priority
+ (T : Task_ID;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ Param : aliased struct_sched_param;
+ Array_Item : Integer;
+ Result : Interfaces.C.int;
+
+ begin
+ Param.sched_priority := Interfaces.C.int (Prio);
+
+ if 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_RR, Param'Access);
+ end if;
+
+ pragma Assert (Result = 0);
+
+ if FIFO_Within_Priorities then
+
+ -- Annex D requirement [RM D.2.2 par. 9]:
+ -- If the task drops its priority due to the loss of inherited
+ -- priority, it is added at the head of the ready queue for its
+ -- new active priority.
+
+ if Loss_Of_Inheritance
+ and then Prio < T.Common.Current_Priority
+ then
+ Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
+ Prio_Array (T.Common.Base_Priority) := Array_Item;
+
+ loop
+ -- Let some processes a chance to arrive
+
+ Yield;
+
+ -- Then wait for our turn to proceed
+
+ exit when Array_Item = Prio_Array (T.Common.Base_Priority)
+ or else Prio_Array (T.Common.Base_Priority) = 1;
+ end loop;
+
+ Prio_Array (T.Common.Base_Priority) :=
+ Prio_Array (T.Common.Base_Priority) - 1;
+ end if;
+ end if;
+
+ T.Common.Current_Priority := Prio;
+ end Set_Priority;
+
+ ------------------
+ -- Get_Priority --
+ ------------------
+
+ function Get_Priority (T : Task_ID) return System.Any_Priority is
+ begin
+ return T.Common.Current_Priority;
+ end Get_Priority;
+
+ ----------------
+ -- Enter_Task --
+ ----------------
+
+ procedure Enter_Task (Self_ID : Task_ID) is
+ Result : Interfaces.C.int;
+
+ procedure Init_Float;
+ pragma Import (C, Init_Float, "__gnat_init_float");
+ -- Properly initializes the FPU for PPC/MIPS systems.
+
+ begin
+ Self_ID.Common.LL.Thread := pthread_self;
+
+ Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID));
+ pragma Assert (Result = 0);
+
+ Init_Float;
+
+ -- Install the signal handlers.
+ -- This is called for each task since there is no signal inheritance
+ -- between VxWorks tasks.
+
+ Install_Signal_Handlers;
+
+ Lock_All_Tasks_List;
+
+ for T in Known_Tasks'Range loop
+ if Known_Tasks (T) = null then
+ Known_Tasks (T) := Self_ID;
+ Self_ID.Known_Tasks_Index := T;
+ exit;
+ end if;
+ end loop;
+
+ Unlock_All_Tasks_List;
+ 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;
+
+ ----------------------
+ -- Initialize_TCB --
+ ----------------------
+
+ procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
+ Mutex_Attr : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+ Cond_Attr : aliased pthread_condattr_t;
+
+ begin
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_mutexattr_setprotocol
+ (Mutex_Attr'Access, Mutex_Protocol);
+ pragma Assert (Result = 0);
+
+ Result := pthread_mutexattr_setprioceiling
+ (Mutex_Attr'Access, Interfaces.C.int (System.Any_Priority'Last));
+ pragma Assert (Result = 0);
+
+ Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
+ Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
+ Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = 0 then
+ Succeeded := True;
+ else
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Succeeded := False;
+ end if;
+
+ Result := pthread_condattr_destroy (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+ end Initialize_TCB;
+
+ -----------------
+ -- Create_Task --
+ -----------------
+
+ procedure Create_Task
+ (T : Task_ID;
+ Wrapper : System.Address;
+ Stack_Size : System.Parameters.Size_Type;
+ Priority : System.Any_Priority;
+ Succeeded : out Boolean)
+ is
+ use type System.Task_Info.Task_Image_Type;
+
+ Adjusted_Stack_Size : Interfaces.C.size_t;
+ Attributes : aliased pthread_attr_t;
+ Result : Interfaces.C.int;
+
+ function Thread_Body_Access is new
+ Unchecked_Conversion (System.Address, Thread_Body);
+
+ begin
+ if Stack_Size = Unspecified_Size then
+ Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size);
+
+ elsif Stack_Size < Minimum_Stack_Size then
+ Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
+
+ else
+ Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
+ end if;
+
+ -- Ask for 4 extra bytes of stack space so that the ATCB
+ -- pointer can be stored below the stack limit, plus extra
+ -- space for the frame of Task_Wrapper. This is so the user
+ -- gets the amount of stack requested exclusive of the needs
+ -- of the runtime.
+ --
+ -- We also have to allocate 10 more bytes for the task name
+ -- storage and enough space for the Wind Task Control Block
+ -- which is around 0x778 bytes. VxWorks also seems to carve out
+ -- additional space, so use 2048 as a nice round number.
+ -- We might want to increment to the nearest page size in
+ -- case we ever support VxVMI.
+ --
+ -- XXX - we should come back and visit this so we can
+ -- set the task name to something appropriate.
+ Adjusted_Stack_Size := Adjusted_Stack_Size + 2048;
+
+ 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);
+
+ -- Let's check to see if the task has an image string and
+ -- use that as the VxWorks task name.
+ if T.Common.Task_Image /= null then
+ declare
+ Task_Name : aliased constant String :=
+ T.Common.Task_Image.all & ASCII.NUL;
+ begin
+ Result := pthread_attr_setname_np
+ (Attributes'Access, Task_Name'Address);
+
+ -- 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));
+ end;
+ else
+ -- No specified task name
+ Result := pthread_create
+ (T.Common.LL.Thread'Access,
+ Attributes'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
+ end if;
+ pragma Assert (Result = 0);
+
+ Succeeded := Result = 0;
+
+ Result := pthread_attr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+
+ Task_Creation_Hook (T.Common.LL.Thread);
+
+ Set_Priority (T, Priority);
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_ID) is
+ Result : Interfaces.C.int;
+ Tmp : Task_ID := T;
+
+ procedure Free is new
+ Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
+
+ begin
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+
+ Result := pthread_cond_destroy (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+
+ if T.Known_Tasks_Index /= -1 then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ end if;
+
+ Free (Tmp);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ Task_Termination_Hook;
+ pthread_exit (System.Null_Address);
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_ID) is
+ Result : Interfaces.C.int;
+ begin
+ Result := kill (T.Common.LL.Thread,
+ Signal (Interrupt_Management.Abort_Task_Interrupt));
+ pragma Assert (Result = 0);
+ end Abort_Task;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy versions. The only currently working versions is for solaris
+ -- (native).
+
+ function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ 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_All_Tasks_List --
+ -------------------------
+
+ procedure Lock_All_Tasks_List is
+ begin
+ Write_Lock (All_Tasks_L'Access);
+ end Lock_All_Tasks_List;
+
+ ---------------------------
+ -- Unlock_All_Tasks_List --
+ ---------------------------
+
+ procedure Unlock_All_Tasks_List is
+ begin
+ Unlock (All_Tasks_L'Access);
+ end Unlock_All_Tasks_List;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ if T.Common.LL.Thread /= Thread_Self then
+ return taskSuspend (T.Common.LL.Thread) = 0;
+ else
+ return True;
+ end if;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ if T.Common.LL.Thread /= Thread_Self then
+ return taskResume (T.Common.LL.Thread) = 0;
+ else
+ return True;
+ end if;
+ end Resume_Task;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_ID) is
+ begin
+ Environment_Task_ID := Environment_Task;
+
+ -- Initialize the lock used to synchronize chain of all ATCBs.
+
+ Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
+
+ Enter_Task (Environment_Task);
+ end Initialize;
+
+begin
+ declare
+ Result : Interfaces.C.int;
+
+ begin
+ if Locking_Policy = 'C' then
+ Mutex_Protocol := PTHREAD_PRIO_PROTECT;
+ else
+ -- We default to VxWorks native priority inheritence
+ -- and inversion safe mutexes with no ceiling checks.
+ Mutex_Protocol := PTHREAD_PRIO_INHERIT;
+ end if;
+
+ if Time_Slice_Val > 0 then
+ Result := pthread_sched_rr_set_interval
+ (Interfaces.C.int (Time_Slice_Val));
+ end if;
+
+ -- 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 Interrupt_Management.Keep_Unmasked (J) then
+ Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
+
+ Result := pthread_key_create (ATCB_Key'Access, null);
+ pragma Assert (Result = 0);
+
+ Result := taskVarAdd (getpid, Stack_Limit'Access);
+ pragma Assert (Result = 0);
+ end;
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- I N T E R F A C E S . C P P --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 2000, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the OpenVMS/Alpha DEC C++ (cxx) version of this package.
+
+with Ada.Tags; use Ada.Tags;
+with System; use System;
+with System.Storage_Elements; use System.Storage_Elements;
+with Unchecked_Conversion;
+
+package body Interfaces.CPP is
+
+ subtype Cstring is String (Positive);
+ type Cstring_Ptr is access all Cstring;
+ type Tag_Table is array (Natural range <>) of Vtable_Ptr;
+ pragma Suppress_Initialization (Tag_Table);
+
+ type Type_Specific_Data is record
+ Idepth : Natural;
+ Expanded_Name : Cstring_Ptr;
+ External_Tag : Cstring_Ptr;
+ HT_Link : Tag;
+ Ancestor_Tags : Tag_Table (Natural);
+ end record;
+
+ type Vtable_Entry is record
+ Pfn : System.Address;
+ end record;
+
+ type Type_Specific_Data_Ptr is access all Type_Specific_Data;
+ type Vtable_Entry_Array is array (Positive range <>) of Vtable_Entry;
+
+ type VTable is record
+ Prims_Ptr : Vtable_Entry_Array (Positive);
+ TSD : Type_Specific_Data_Ptr;
+ -- Location of TSD is unknown so it got moved here to be out of the
+ -- way of Prims_Ptr. Find it later. ???
+ end record;
+
+ --------------------------------------------------------
+ -- Unchecked Conversions for Tag, Vtable_Ptr, and TSD --
+ --------------------------------------------------------
+
+ function To_Type_Specific_Data_Ptr is
+ new Unchecked_Conversion (Address, Type_Specific_Data_Ptr);
+
+ function To_Address is new Unchecked_Conversion (Vtable_Ptr, Address);
+ function To_Address is
+ new Unchecked_Conversion (Type_Specific_Data_Ptr, Address);
+
+ function To_Vtable_Ptr is new Unchecked_Conversion (Tag, Vtable_Ptr);
+ function To_Tag is new Unchecked_Conversion (Vtable_Ptr, Tag);
+
+ ---------------------------------------------
+ -- Unchecked Conversions for String Fields --
+ ---------------------------------------------
+
+ function To_Cstring_Ptr is
+ new Unchecked_Conversion (Address, Cstring_Ptr);
+
+ function To_Address is
+ new Unchecked_Conversion (Cstring_Ptr, Address);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Length (Str : Cstring_Ptr) return Natural;
+ -- Length of string represented by the given pointer (treating the
+ -- string as a C-style string, which is Nul terminated).
+
+ --------------------
+ -- Displaced_This --
+ --------------------
+
+ function Displaced_This
+ (Current_This : System.Address;
+ Vptr : Vtable_Ptr;
+ Position : Positive)
+ return System.Address
+ is
+ begin
+ return Current_This;
+-- + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1);
+ end Displaced_This;
+
+ -----------------------
+ -- CPP_CW_Membership --
+ -----------------------
+
+ function CPP_CW_Membership
+ (Obj_Tag : Vtable_Ptr;
+ Typ_Tag : Vtable_Ptr)
+ return Boolean
+ is
+ Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth;
+ begin
+ return Pos >= 0 and then Obj_Tag.TSD.Ancestor_Tags (Pos) = Typ_Tag;
+ end CPP_CW_Membership;
+
+ ---------------------------
+ -- CPP_Get_Expanded_Name --
+ ---------------------------
+
+ function CPP_Get_Expanded_Name (T : Vtable_Ptr) return Address is
+ begin
+ return To_Address (T.TSD.Expanded_Name);
+ end CPP_Get_Expanded_Name;
+
+ --------------------------
+ -- CPP_Get_External_Tag --
+ --------------------------
+
+ function CPP_Get_External_Tag (T : Vtable_Ptr) return Address is
+ begin
+ return To_Address (T.TSD.External_Tag);
+ end CPP_Get_External_Tag;
+
+ -------------------------------
+ -- CPP_Get_Inheritance_Depth --
+ -------------------------------
+
+ function CPP_Get_Inheritance_Depth (T : Vtable_Ptr) return Natural is
+ begin
+ return T.TSD.Idepth;
+ end CPP_Get_Inheritance_Depth;
+
+ -------------------------
+ -- CPP_Get_Prim_Op_Address --
+ -------------------------
+
+ function CPP_Get_Prim_Op_Address
+ (T : Vtable_Ptr;
+ Position : Positive)
+ return Address is
+ begin
+ return T.Prims_Ptr (Position).Pfn;
+ end CPP_Get_Prim_Op_Address;
+
+ -------------------------------
+ -- CPP_Get_Remotely_Callable --
+ -------------------------------
+
+ function CPP_Get_Remotely_Callable (T : Vtable_Ptr) return Boolean is
+ begin
+ return True;
+ end CPP_Get_Remotely_Callable;
+
+ -----------------
+ -- CPP_Get_TSD --
+ -----------------
+
+ function CPP_Get_TSD (T : Vtable_Ptr) return Address is
+ begin
+ return To_Address (T.TSD);
+ end CPP_Get_TSD;
+
+ --------------------
+ -- CPP_Inherit_DT --
+ --------------------
+
+ procedure CPP_Inherit_DT
+ (Old_T : Vtable_Ptr;
+ New_T : Vtable_Ptr;
+ Entry_Count : Natural)
+ is
+ begin
+ if Old_T /= null then
+ New_T.Prims_Ptr (1 .. Entry_Count)
+ := Old_T.Prims_Ptr (1 .. Entry_Count);
+ end if;
+ end CPP_Inherit_DT;
+
+ ---------------------
+ -- CPP_Inherit_TSD --
+ ---------------------
+
+ procedure CPP_Inherit_TSD
+ (Old_TSD : Address;
+ New_Tag : Vtable_Ptr)
+ is
+ TSD : constant Type_Specific_Data_Ptr
+ := To_Type_Specific_Data_Ptr (Old_TSD);
+
+ New_TSD : Type_Specific_Data renames New_Tag.TSD.all;
+
+ begin
+ if TSD /= null then
+ New_TSD.Idepth := TSD.Idepth + 1;
+ New_TSD.Ancestor_Tags (1 .. New_TSD.Idepth)
+ := TSD.Ancestor_Tags (0 .. TSD.Idepth);
+ else
+ New_TSD.Idepth := 0;
+ end if;
+
+ New_TSD.Ancestor_Tags (0) := New_Tag;
+ end CPP_Inherit_TSD;
+
+ ---------------------------
+ -- CPP_Set_Expanded_Name --
+ ---------------------------
+
+ procedure CPP_Set_Expanded_Name (T : Vtable_Ptr; Value : Address) is
+ begin
+ T.TSD.Expanded_Name := To_Cstring_Ptr (Value);
+ end CPP_Set_Expanded_Name;
+
+ --------------------------
+ -- CPP_Set_External_Tag --
+ --------------------------
+
+ procedure CPP_Set_External_Tag (T : Vtable_Ptr; Value : Address) is
+ begin
+ T.TSD.External_Tag := To_Cstring_Ptr (Value);
+ end CPP_Set_External_Tag;
+
+ -------------------------------
+ -- CPP_Set_Inheritance_Depth --
+ -------------------------------
+
+ procedure CPP_Set_Inheritance_Depth
+ (T : Vtable_Ptr;
+ Value : Natural)
+ is
+ begin
+ T.TSD.Idepth := Value;
+ end CPP_Set_Inheritance_Depth;
+
+ -----------------------------
+ -- CPP_Set_Prim_Op_Address --
+ -----------------------------
+
+ procedure CPP_Set_Prim_Op_Address
+ (T : Vtable_Ptr;
+ Position : Positive;
+ Value : Address)
+ is
+ begin
+ T.Prims_Ptr (Position).Pfn := Value;
+ end CPP_Set_Prim_Op_Address;
+
+ -------------------------------
+ -- CPP_Set_Remotely_Callable --
+ -------------------------------
+
+ procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean) is
+ begin
+ null;
+ end CPP_Set_Remotely_Callable;
+
+ -----------------
+ -- CPP_Set_TSD --
+ -----------------
+
+ procedure CPP_Set_TSD (T : Vtable_Ptr; Value : Address) is
+ begin
+ T.TSD := To_Type_Specific_Data_Ptr (Value);
+ end CPP_Set_TSD;
+
+ -------------------
+ -- Expanded_Name --
+ -------------------
+
+ function Expanded_Name (T : Vtable_Ptr) return String is
+ Result : Cstring_Ptr := T.TSD.Expanded_Name;
+
+ begin
+ return Result (1 .. Length (Result));
+ end Expanded_Name;
+
+ ------------------
+ -- External_Tag --
+ ------------------
+
+ function External_Tag (T : Vtable_Ptr) return String is
+ Result : Cstring_Ptr := T.TSD.External_Tag;
+
+ begin
+ return Result (1 .. Length (Result));
+ end External_Tag;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Str : Cstring_Ptr) return Natural is
+ Len : Integer := 1;
+
+ begin
+ while Str (Len) /= ASCII.Nul loop
+ Len := Len + 1;
+ end loop;
+
+ return Len - 1;
+ end Length;
+
+ procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is
+ begin
+ null;
+ end CPP_Set_RC_Offset;
+
+ function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is
+ begin
+ return 0;
+ end CPP_Get_RC_Offset;
+end Interfaces.CPP;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- I N T E R F A C E S . C _ S T R E A M S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1996-1999 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Alpha/VMS version.
+
+package body Interfaces.C_Streams is
+
+ ------------
+ -- fread --
+ ------------
+
+ function fread
+ (buffer : voids;
+ size : size_t;
+ count : size_t;
+ stream : FILEs)
+ return size_t
+ is
+ Get_Count : size_t := 0;
+ type Buffer_Type is array (size_t range 1 .. count,
+ size_t range 1 .. size) of Character;
+ type Buffer_Access is access Buffer_Type;
+ function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
+ BA : Buffer_Access := To_BA (buffer);
+ Ch : int;
+ begin
+
+ -- This Fread goes with the Fwrite below.
+ -- The C library fread sometimes can't read fputc generated files.
+
+ for C in 1 .. count loop
+ for S in 1 .. size loop
+ Ch := fgetc (stream);
+ if Ch = EOF then
+ return 0;
+ end if;
+ BA.all (C, S) := Character'Val (Ch);
+ end loop;
+ Get_Count := Get_Count + 1;
+ end loop;
+ return Get_Count;
+ end fread;
+
+ ------------
+ -- fread --
+ ------------
+
+ function fread
+ (buffer : voids;
+ index : size_t;
+ size : size_t;
+ count : size_t;
+ stream : FILEs)
+ return size_t
+ is
+ Get_Count : size_t := 0;
+ type Buffer_Type is array (size_t range 1 .. count,
+ size_t range 1 .. size) of Character;
+ type Buffer_Access is access Buffer_Type;
+ function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
+ BA : Buffer_Access := To_BA (buffer);
+ Ch : int;
+ begin
+
+ -- This Fread goes with the Fwrite below.
+ -- The C library fread sometimes can't read fputc generated files.
+
+ for C in 1 + index .. count + index loop
+ for S in 1 .. size loop
+ Ch := fgetc (stream);
+ if Ch = EOF then
+ return 0;
+ end if;
+ BA.all (C, S) := Character'Val (Ch);
+ end loop;
+ Get_Count := Get_Count + 1;
+ end loop;
+ return Get_Count;
+ end fread;
+
+ ------------
+ -- fwrite --
+ ------------
+
+ function fwrite
+ (buffer : voids;
+ size : size_t;
+ count : size_t;
+ stream : FILEs)
+ return size_t
+ is
+ Put_Count : size_t := 0;
+ type Buffer_Type is array (size_t range 1 .. count,
+ size_t range 1 .. size) of Character;
+ type Buffer_Access is access Buffer_Type;
+ function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
+ BA : Buffer_Access := To_BA (buffer);
+ begin
+
+ -- Fwrite on VMS has the undesirable effect of always generating at
+ -- least one record of output per call, regardless of buffering. To
+ -- get around this, we do multiple fputc calls instead.
+
+ for C in 1 .. count loop
+ for S in 1 .. size loop
+ if fputc (Character'Pos (BA.all (C, S)), stream) = EOF then
+ exit;
+ end if;
+ end loop;
+ Put_Count := Put_Count + 1;
+ end loop;
+ return Put_Count;
+ end fwrite;
+
+ -------------
+ -- setvbuf --
+ -------------
+
+ function setvbuf
+ (stream : FILEs;
+ buffer : chars;
+ mode : int;
+ size : size_t)
+ return int
+ is
+ function C_setvbuf
+ (stream : FILEs;
+ buffer : chars;
+ mode : int;
+ size : size_t)
+ return int;
+ pragma Import (C, C_setvbuf, "setvbuf");
+
+ use type System.Address;
+ begin
+
+ -- In order for the above fwrite hack to work, we must always buffer
+ -- stdout and stderr. Is_regular_file on VMS cannot detect when
+ -- these are redirected to a file, so checking for that condition
+ -- doesnt help.
+
+ if mode = IONBF
+ and then (stream = stdout or else stream = stderr)
+ then
+ return C_setvbuf (stream, buffer, IOLBF, size);
+ else
+ return C_setvbuf (stream, buffer, mode, size);
+ end if;
+ end setvbuf;
+
+end Interfaces.C_Streams;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- I N T E R F A C E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the OpenVMS version of this package which adds Float_Representation
+-- pragmas to the IEEE floating point types to enusre they remain IEEE in
+-- thse presence of a VAX_Float Float_Representatin configuration pragma.
+
+-- It assumes integer sizes of 8, 16, 32 and 64 are available, and that IEEE
+-- floating-point formats are available.
+
+package Interfaces is
+pragma Pure (Interfaces);
+
+ type Integer_8 is range -2 ** 7 .. 2 ** 7 - 1;
+ for Integer_8'Size use 8;
+
+ type Integer_16 is range -2 ** 15 .. 2 ** 15 - 1;
+ for Integer_16'Size use 16;
+
+ type Integer_32 is range -2 ** 31 .. 2 ** 31 - 1;
+ for Integer_32'Size use 32;
+
+ type Integer_64 is range -2 ** 63 .. 2 ** 63 - 1;
+ for Integer_64'Size use 64;
+
+ type Unsigned_8 is mod 2 ** 8;
+ for Unsigned_8'Size use 8;
+
+ type Unsigned_16 is mod 2 ** 16;
+ for Unsigned_16'Size use 16;
+
+ type Unsigned_32 is mod 2 ** 32;
+ for Unsigned_32'Size use 32;
+
+ type Unsigned_64 is mod 2 ** 64;
+ for Unsigned_64'Size use 64;
+
+ function Shift_Left
+ (Value : Unsigned_8;
+ Amount : Natural)
+ return Unsigned_8;
+
+ function Shift_Right
+ (Value : Unsigned_8;
+ Amount : Natural)
+ return Unsigned_8;
+
+ function Shift_Right_Arithmetic
+ (Value : Unsigned_8;
+ Amount : Natural)
+ return Unsigned_8;
+
+ function Rotate_Left
+ (Value : Unsigned_8;
+ Amount : Natural)
+ return Unsigned_8;
+
+ function Rotate_Right
+ (Value : Unsigned_8;
+ Amount : Natural)
+ return Unsigned_8;
+
+ function Shift_Left
+ (Value : Unsigned_16;
+ Amount : Natural)
+ return Unsigned_16;
+
+ function Shift_Right
+ (Value : Unsigned_16;
+ Amount : Natural)
+ return Unsigned_16;
+
+ function Shift_Right_Arithmetic
+ (Value : Unsigned_16;
+ Amount : Natural)
+ return Unsigned_16;
+
+ function Rotate_Left
+ (Value : Unsigned_16;
+ Amount : Natural)
+ return Unsigned_16;
+
+ function Rotate_Right
+ (Value : Unsigned_16;
+ Amount : Natural)
+ return Unsigned_16;
+
+ function Shift_Left
+ (Value : Unsigned_32;
+ Amount : Natural)
+ return Unsigned_32;
+
+ function Shift_Right
+ (Value : Unsigned_32;
+ Amount : Natural)
+ return Unsigned_32;
+
+ function Shift_Right_Arithmetic
+ (Value : Unsigned_32;
+ Amount : Natural)
+ return Unsigned_32;
+
+ function Rotate_Left
+ (Value : Unsigned_32;
+ Amount : Natural)
+ return Unsigned_32;
+
+ function Rotate_Right
+ (Value : Unsigned_32;
+ Amount : Natural)
+ return Unsigned_32;
+
+ function Shift_Left
+ (Value : Unsigned_64;
+ Amount : Natural)
+ return Unsigned_64;
+
+ function Shift_Right
+ (Value : Unsigned_64;
+ Amount : Natural)
+ return Unsigned_64;
+
+ function Shift_Right_Arithmetic
+ (Value : Unsigned_64;
+ Amount : Natural)
+ return Unsigned_64;
+
+ function Rotate_Left
+ (Value : Unsigned_64;
+ Amount : Natural)
+ return Unsigned_64;
+
+ function Rotate_Right
+ (Value : Unsigned_64;
+ Amount : Natural)
+ return Unsigned_64;
+
+ pragma Import (Intrinsic, Shift_Left);
+ pragma Import (Intrinsic, Shift_Right);
+ pragma Import (Intrinsic, Shift_Right_Arithmetic);
+ pragma Import (Intrinsic, Rotate_Left);
+ pragma Import (Intrinsic, Rotate_Right);
+
+ -- Floating point types. We use the digits value to define the IEEE
+ -- forms, otherwise a configuration pragma specifying VAX float can
+ -- default the digits to an illegal value for IEEE.
+ -- Note: it is harmless, and explicitly permitted, to include additional
+ -- types in interfaces, so it is not wrong to have IEEE_Extended_Float
+ -- defined even if the extended format is not available.
+
+ type IEEE_Float_32 is digits 6;
+ pragma Float_Representation (IEEE_Float, IEEE_Float_32);
+
+ type IEEE_Float_64 is digits 15;
+ pragma Float_Representation (IEEE_Float, IEEE_Float_64);
+
+ type IEEE_Extended_Float is digits 15;
+ pragma Float_Representation (IEEE_Float, IEEE_Extended_Float);
+
+end Interfaces;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.8 $ --
+-- --
+-- Copyright (C) 1997-1998, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a POSIX-like version of this package.
+-- Note: this file can only be used for POSIX compliant systems.
+
+with Interfaces.C;
+-- used for int
+-- size_t
+-- unsigned
+
+with System.OS_Interface;
+-- used for various type, constant, and operations
+
+with System.Storage_Elements;
+-- used for To_Address
+-- Integer_Address
+
+with Unchecked_Conversion;
+
+package body System.Interrupt_Management.Operations is
+
+ use Interfaces.C;
+ use System.OS_Interface;
+
+ type Interrupt_Mask_Ptr is access all Interrupt_Mask;
+
+ function "+" is new
+ Unchecked_Conversion (Interrupt_Mask_Ptr, sigset_t_ptr);
+
+ ---------------------
+ -- Local Variables --
+ ---------------------
+
+ Initial_Action : array (Signal) of aliased struct_sigaction;
+
+ Default_Action : aliased struct_sigaction;
+
+ Ignore_Action : aliased struct_sigaction;
+
+ ----------------------------
+ -- Thread_Block_Interrupt --
+ ----------------------------
+
+ procedure Thread_Block_Interrupt
+ (Interrupt : Interrupt_ID)
+ is
+ Result : Interfaces.C.int;
+ Mask : aliased sigset_t;
+
+ begin
+ Result := sigemptyset (Mask'Access);
+ pragma Assert (Result = 0);
+ Result := sigaddset (Mask'Access, Signal (Interrupt));
+ pragma Assert (Result = 0);
+ Result := pthread_sigmask (SIG_BLOCK, Mask'Unchecked_Access, null);
+ pragma Assert (Result = 0);
+ end Thread_Block_Interrupt;
+
+ ------------------------------
+ -- Thread_Unblock_Interrupt --
+ ------------------------------
+
+ procedure Thread_Unblock_Interrupt
+ (Interrupt : Interrupt_ID)
+ is
+ Mask : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := sigemptyset (Mask'Access);
+ pragma Assert (Result = 0);
+ Result := sigaddset (Mask'Access, Signal (Interrupt));
+ pragma Assert (Result = 0);
+ Result := pthread_sigmask (SIG_UNBLOCK, Mask'Unchecked_Access, null);
+ pragma Assert (Result = 0);
+ end Thread_Unblock_Interrupt;
+
+ ------------------------
+ -- Set_Interrupt_Mask --
+ ------------------------
+
+ procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_sigmask
+ (SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), null);
+ pragma Assert (Result = 0);
+ end Set_Interrupt_Mask;
+
+ procedure Set_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ OMask : access Interrupt_Mask)
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_sigmask
+ (SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), +Interrupt_Mask_Ptr (OMask));
+ pragma Assert (Result = 0);
+ end Set_Interrupt_Mask;
+
+ ------------------------
+ -- Get_Interrupt_Mask --
+ ------------------------
+
+ procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_sigmask
+ (SIG_SETMASK, null, +Interrupt_Mask_Ptr (Mask));
+ pragma Assert (Result = 0);
+ end Get_Interrupt_Mask;
+
+ --------------------
+ -- Interrupt_Wait --
+ --------------------
+
+ function Interrupt_Wait
+ (Mask : access Interrupt_Mask)
+ return Interrupt_ID
+ is
+ Result : Interfaces.C.int;
+ Sig : aliased Signal;
+
+ begin
+ Result := sigwait (Mask, Sig'Access);
+
+ if Result /= 0 then
+ return 0;
+ end if;
+
+ return Interrupt_ID (Sig);
+ end Interrupt_Wait;
+
+ ----------------------------
+ -- Install_Default_Action --
+ ----------------------------
+
+ procedure Install_Default_Action (Interrupt : Interrupt_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := sigaction
+ (Signal (Interrupt),
+ Initial_Action (Signal (Interrupt))'Access, null);
+ pragma Assert (Result = 0);
+ end Install_Default_Action;
+
+ ---------------------------
+ -- Install_Ignore_Action --
+ ---------------------------
+
+ procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := sigaction (Signal (Interrupt), Ignore_Action'Access, null);
+ pragma Assert (Result = 0);
+ end Install_Ignore_Action;
+
+ -------------------------
+ -- Fill_Interrupt_Mask --
+ -------------------------
+
+ procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := sigfillset (Mask);
+ pragma Assert (Result = 0);
+ end Fill_Interrupt_Mask;
+
+ --------------------------
+ -- Empty_Interrupt_Mask --
+ --------------------------
+
+ procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := sigemptyset (Mask);
+ pragma Assert (Result = 0);
+ end Empty_Interrupt_Mask;
+
+ ---------------------------
+ -- Add_To_Interrupt_Mask --
+ ---------------------------
+
+ procedure Add_To_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID)
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := sigaddset (Mask, Signal (Interrupt));
+ pragma Assert (Result = 0);
+ end Add_To_Interrupt_Mask;
+
+ --------------------------------
+ -- Delete_From_Interrupt_Mask --
+ --------------------------------
+
+ procedure Delete_From_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID)
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := sigdelset (Mask, Signal (Interrupt));
+ pragma Assert (Result = 0);
+ end Delete_From_Interrupt_Mask;
+
+ ---------------
+ -- Is_Member --
+ ---------------
+
+ function Is_Member
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID) return Boolean
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := sigismember (Mask, Signal (Interrupt));
+ pragma Assert (Result = 0 or else Result = 1);
+ return Result = 1;
+ end Is_Member;
+
+ -------------------------
+ -- Copy_Interrupt_Mask --
+ -------------------------
+
+ procedure Copy_Interrupt_Mask
+ (X : out Interrupt_Mask;
+ Y : Interrupt_Mask)
+ is
+ begin
+ X := Y;
+ end Copy_Interrupt_Mask;
+
+ ----------------------------
+ -- Interrupt_Self_Process --
+ ----------------------------
+
+ procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := kill (getpid, Signal (Interrupt));
+ pragma Assert (Result = 0);
+ end Interrupt_Self_Process;
+
+begin
+
+ declare
+ mask : aliased sigset_t;
+ allmask : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ begin
+ for Sig in 1 .. Signal'Last loop
+ Result := sigaction
+ (Sig, null, Initial_Action (Sig)'Unchecked_Access);
+
+ -- ??? [assert 1]
+ -- we can't check Result here since sigaction will fail on
+ -- SIGKILL, SIGSTOP, and possibly other signals
+ -- pragma Assert (Result = 0);
+
+ end loop;
+
+ -- Setup the masks to be exported.
+
+ Result := sigemptyset (mask'Access);
+ pragma Assert (Result = 0);
+
+ Result := sigfillset (allmask'Access);
+ pragma Assert (Result = 0);
+
+ Default_Action.sa_flags := 0;
+ Default_Action.sa_mask := mask;
+ Default_Action.sa_handler :=
+ Storage_Elements.To_Address
+ (Storage_Elements.Integer_Address (SIG_DFL));
+
+ Ignore_Action.sa_flags := 0;
+ Ignore_Action.sa_mask := mask;
+ Ignore_Action.sa_handler :=
+ Storage_Elements.To_Address
+ (Storage_Elements.Integer_Address (SIG_IGN));
+
+ for I in Interrupt_ID loop
+ if Keep_Unmasked (I) then
+ Result := sigaddset (mask'Access, Signal (I));
+ pragma Assert (Result = 0);
+ Result := sigdelset (allmask'Access, Signal (I));
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
+
+ -- The Keep_Unmasked signals should be unmasked for Environment task
+
+ Result := pthread_sigmask (SIG_UNBLOCK, mask'Unchecked_Access, null);
+ pragma Assert (Result = 0);
+
+ -- Get the signal mask of the Environment Task
+
+ Result := pthread_sigmask (SIG_SETMASK, null, mask'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ -- Setup the constants exported
+
+ Environment_Mask := Interrupt_Mask (mask);
+
+ All_Tasks_Mask := Interrupt_Mask (allmask);
+ end;
+
+end System.Interrupt_Management.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.14 $
+-- --
+-- Copyright (C) 1991-2001, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the default version of this package
+
+-- This is a Sun OS (FSU THREADS) version of this package
+
+-- PLEASE DO NOT add any dependences on other packages. ??? why not ???
+-- This package is designed to work with or without tasking support.
+
+-- See the other warnings in the package specification before making
+-- any modifications to this file.
+
+-- Make a careful study of all signals available under the OS, to see which
+-- need to be reserved, kept always unmasked, or kept always unmasked. Be on
+-- the lookout for special signals that may be used by the thread library.
+
+-- Since this is a multi target file, the signal <-> exception mapping
+-- is simple minded. If you need a more precise and target specific
+-- signal handling, create a new s-intman.adb that will fit your needs.
+
+-- This file assumes that:
+--
+-- SIGFPE, SIGILL, SIGSEGV and SIGBUS exist. They are mapped as follows:
+-- SIGPFE => Constraint_Error
+-- SIGILL => Program_Error
+-- SIGSEGV => Storage_Error
+-- SIGBUS => Storage_Error
+--
+-- SIGINT exists and will be kept unmasked unless the pragma
+-- Unreserve_All_Interrupts is specified anywhere in the application.
+--
+-- System.OS_Interface contains the following:
+-- SIGADAABORT: the signal that will be used to abort tasks.
+-- Unmasked: the OS specific set of signals that should be unmasked in
+-- all the threads. SIGADAABORT is unmasked by
+-- default
+-- Reserved: the OS specific set of signals that are reserved.
+
+with Interfaces.C;
+-- used for int and other types
+
+with System.OS_Interface;
+-- used for various Constants, Signal and types
+
+package body System.Interrupt_Management is
+
+ use Interfaces.C;
+ use System.OS_Interface;
+
+ type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
+ Exception_Interrupts : constant Interrupt_List :=
+ (SIGFPE, SIGILL, SIGSEGV, SIGBUS);
+
+ Unreserve_All_Interrupts : Interfaces.C.int;
+ pragma Import
+ (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Notify_Exception (signo : Signal);
+ -- This function identifies the Ada exception to be raised using
+ -- the information when the system received a synchronous signal.
+ -- Since this function is machine and OS dependent, different code
+ -- has to be provided for different target.
+
+ ----------------------
+ -- Notify_Exception --
+ ----------------------
+
+ Signal_Mask : aliased sigset_t;
+ -- The set of signals handled by Notify_Exception
+
+ procedure Notify_Exception (signo : Signal) is
+ Result : Interfaces.C.int;
+
+ begin
+ -- With the __builtin_longjmp, the signal mask is not restored, so we
+ -- need to restore it explicitely.
+
+ Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null);
+ pragma Assert (Result = 0);
+
+ -- Check that treatment of exception propagation here
+ -- is consistent with treatment of the abort signal in
+ -- System.Task_Primitives.Operations.
+
+ case signo is
+ when SIGFPE =>
+ raise Constraint_Error;
+ when SIGILL =>
+ raise Program_Error;
+ when SIGSEGV =>
+ raise Storage_Error;
+ when SIGBUS =>
+ raise Storage_Error;
+ when others =>
+ null;
+ end case;
+ end Notify_Exception;
+
+ ---------------------------
+ -- Initialize_Interrupts --
+ ---------------------------
+
+ -- Nothing needs to be done on this platform.
+
+ procedure Initialize_Interrupts is
+ begin
+ null;
+ end Initialize_Interrupts;
+
+-------------------------
+-- Package Elaboration --
+-------------------------
+
+begin
+ declare
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Result : Interfaces.C.int;
+
+ begin
+ -- Need to call pthread_init very early because it is doing signal
+ -- initializations.
+
+ pthread_init;
+
+ Abort_Task_Interrupt := SIGADAABORT;
+
+ act.sa_handler := Notify_Exception'Address;
+
+ act.sa_flags := 0;
+
+ -- On some targets, we set sa_flags to SA_NODEFER so that during the
+ -- handler execution we do not change the Signal_Mask to be masked for
+ -- the Signal.
+
+ -- This is a temporary fix to the problem that the Signal_Mask is
+ -- not restored after the exception (longjmp) from the handler.
+ -- The right fix should be made in sigsetjmp so that we save
+ -- the Signal_Set and restore it after a longjmp.
+
+ -- Since SA_NODEFER is obsolete, instead we reset explicitely
+ -- the mask in the exception handler.
+
+ Result := sigemptyset (Signal_Mask'Access);
+ pragma Assert (Result = 0);
+
+ -- ??? For the same reason explained above, we can't mask these
+ -- signals because otherwise we won't be able to catch more than
+ -- one signal.
+
+ act.sa_mask := Signal_Mask;
+
+ Keep_Unmasked (Abort_Task_Interrupt) := True;
+ Keep_Unmasked (SIGXCPU) := True;
+ Keep_Unmasked (SIGFPE) := True;
+ Result :=
+ sigaction
+ (Signal (SIGFPE), act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ -- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but at
+ -- the same time, disable the ability of handling this signal via
+ -- package Ada.Interrupts.
+
+ -- The pragma Unreserve_All_Interrupts let the user the ability to
+ -- change this behavior.
+
+ if Unreserve_All_Interrupts = 0 then
+ Keep_Unmasked (SIGINT) := True;
+ end if;
+
+ for J in
+ Exception_Interrupts'First + 1 .. Exception_Interrupts'Last
+ loop
+ Keep_Unmasked (Exception_Interrupts (J)) := True;
+
+ if Unreserve_All_Interrupts = 0 then
+ Result :=
+ sigaction
+ (Signal (Exception_Interrupts (J)), act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
+
+ for J in Unmasked'Range loop
+ Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
+ end loop;
+
+ Reserve := Keep_Unmasked or Keep_Masked;
+
+ for J in Reserved'Range loop
+ Reserve (Interrupt_ID (Reserved (J))) := True;
+ end loop;
+
+ -- We do not have Signal 0 in reality. We just use this value
+ -- to identify non-existent signals (see s-intnam.ads). Therefore,
+ -- Signal 0 should not be used in all signal related operations hence
+ -- mark it as reserved.
+
+ Reserve (0) := True;
+ end;
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.6 $
+-- --
+-- Copyright (C) 1997-2001 Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a FSU 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.
+
+with Interfaces.C;
+
+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;
+
+ function To_Duration (TV : struct_timeval) return Duration is
+ begin
+ return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
+ 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;
+
+ ----------------
+ -- To_Timeval --
+ ----------------
+
+ function To_Timeval (D : Duration) return struct_timeval is
+ S : long;
+ F : Duration;
+
+ begin
+ S := long (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 struct_timeval' (tv_sec => S,
+ tv_usec => long (Long_Long_Integer (F * 10#1#E6)));
+ end To_Timeval;
+
+ -------------
+ -- sigwait --
+ -------------
+
+ -- FSU_THREADS has a nonstandard sigwait
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int
+ is
+ Result : int;
+
+ function sigwait_base (set : access sigset_t) return int;
+ pragma Import (C, sigwait_base, "sigwait");
+
+ begin
+ Result := sigwait_base (set);
+
+ if Result = -1 then
+ sig.all := 0;
+ return errno;
+ end if;
+
+ sig.all := Signal (Result);
+ return 0;
+ end sigwait;
+
+ ------------------------
+ -- pthread_mutex_lock --
+ ------------------------
+
+ -- FSU_THREADS has nonstandard pthread_mutex_lock and unlock.
+ -- It sets errno but the standard Posix requires it to be returned.
+
+ 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");
+
+ Result : int;
+
+ begin
+ Result := pthread_mutex_lock_base (mutex);
+
+ if Result /= 0 then
+ return errno;
+ end if;
+
+ return 0;
+ end pthread_mutex_lock;
+
+ --------------------------
+ -- pthread_mutex_unlock --
+ --------------------------
+
+ 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");
+
+ Result : int;
+
+ begin
+ Result := pthread_mutex_unlock_base (mutex);
+
+ if Result /= 0 then
+ return errno;
+ end if;
+
+ return 0;
+ end pthread_mutex_unlock;
+
+ -----------------------
+ -- pthread_cond_wait --
+ -----------------------
+
+ -- FSU_THREADS has a nonstandard pthread_cond_wait.
+ -- The FSU_THREADS version returns EINTR when interrupted.
+
+ 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");
+
+ Result : int;
+
+ begin
+ Result := pthread_cond_wait_base (cond, mutex);
+
+ if Result = EINTR then
+ return 0;
+ else
+ return Result;
+ end if;
+ end pthread_cond_wait;
+
+ ----------------------------
+ -- pthread_cond_timedwait --
+ ----------------------------
+
+ -- FSU_THREADS has a nonstandard pthread_cond_timedwait. The
+ -- FSU_THREADS version returns -1 and set errno to EAGAIN for timeout.
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int
+ is
+ function pthread_cond_timedwait_base
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait");
+
+ Result : int;
+
+ begin
+ Result := pthread_cond_timedwait_base (cond, mutex, abstime);
+
+ if Result = -1 then
+ if errno = EAGAIN then
+ return ETIMEDOUT;
+ else
+ return EINVAL;
+ end if;
+ end if;
+
+ return 0;
+ end pthread_cond_timedwait;
+
+ ---------------------------
+ -- pthread_setschedparam --
+ ---------------------------
+
+ -- FSU_THREADS does not have pthread_setschedparam
+
+ -- This routine returns a non-negative value upon failure
+ -- but the error code can not be set conforming the POSIX standard.
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int
+ is
+ function pthread_setschedattr
+ (thread : pthread_t;
+ attr : pthread_attr_t) return int;
+ pragma Import (C, pthread_setschedattr, "pthread_setschedattr");
+
+ attr : aliased pthread_attr_t;
+ Result : int;
+
+ begin
+ Result := pthread_attr_init (attr'Access);
+
+ if Result /= 0 then
+ return Result;
+ end if;
+
+ attr.sched := policy;
+
+ -- Short-cut around pthread_attr_setprio
+
+ attr.prio := param.sched_priority;
+
+ Result := pthread_setschedattr (thread, attr);
+
+ if Result /= 0 then
+ return Result;
+ end if;
+
+ Result := pthread_attr_destroy (attr'Access);
+
+ if Result /= 0 then
+ return Result;
+ else
+ return 0;
+ end if;
+ end pthread_setschedparam;
+
+ -------------------------
+ -- pthread_getspecific --
+ -------------------------
+
+ -- FSU_THREADS has a nonstandard pthread_getspecific
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address is
+ function pthread_getspecific_base
+ (key : pthread_key_t;
+ value : access System.Address) return int;
+ pragma Import (C, pthread_getspecific_base, "pthread_getspecific");
+
+ Tmp : aliased System.Address;
+ Result : int;
+
+ begin
+ Result := pthread_getspecific_base (key, Tmp'Access);
+
+ if Result /= 0 then
+ return System.Null_Address;
+ end if;
+
+ return Tmp;
+ end pthread_getspecific;
+
+ ---------------------------------
+ -- pthread_attr_setdetachstate --
+ ---------------------------------
+
+ function pthread_attr_setdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : int) return int
+ is
+ function pthread_attr_setdetachstate_base
+ (attr : access pthread_attr_t;
+ detachstate : access int) return int;
+ pragma Import
+ (C, pthread_attr_setdetachstate_base, "pthread_attr_setdetachstate");
+
+ Tmp : aliased int := detachstate;
+
+ begin
+ return pthread_attr_setdetachstate_base (attr, Tmp'Access);
+ end pthread_attr_setdetachstate;
+
+ -----------------
+ -- sched_yield --
+ -----------------
+
+ -- FSU_THREADS does not have sched_yield;
+
+ function sched_yield return int is
+ procedure sched_yield_base (arg : System.Address);
+ pragma Import (C, sched_yield_base, "pthread_yield");
+
+ begin
+ sched_yield_base (System.Null_Address);
+ return 0;
+ end sched_yield;
+
+ ----------------
+ -- Stack_Base --
+ ----------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ begin
+ return thread.stack_base;
+ end Get_Stack_Base;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ P R I M I T I V E S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1998-2001 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for POSIX-like operating systems
+
+package body System.OS_Primitives is
+
+ -- ??? These definitions are duplicated from System.OS_Interface
+ -- because we don't want to depend on any package. Consider removing
+ -- these declarations in System.OS_Interface and move these ones in
+ -- the spec.
+
+ type struct_timezone is record
+ tz_minuteswest : Integer;
+ tz_dsttime : Integer;
+ end record;
+ pragma Convention (C, struct_timezone);
+ type struct_timezone_ptr is access all struct_timezone;
+
+ type time_t is new Integer;
+
+ type struct_timeval is record
+ tv_sec : time_t;
+ tv_usec : Integer;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ function gettimeofday
+ (tv : access struct_timeval;
+ tz : struct_timezone_ptr) return Integer;
+ pragma Import (C, gettimeofday, "gettimeofday");
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : Long_Integer;
+ end record;
+ pragma Convention (C, timespec);
+
+ function nanosleep (rqtp, rmtp : access timespec) return Integer;
+ pragma Import (C, nanosleep, "nanosleep");
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock return Duration is
+ TV : aliased struct_timeval;
+ Result : Integer;
+
+ begin
+ Result := gettimeofday (TV'Access, null);
+ return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
+ end Clock;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration renames Clock;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return 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_Integer (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Time : Duration;
+ Mode : Integer)
+ is
+ Request : aliased timespec;
+ Remaind : aliased timespec;
+ Result : Integer;
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Check_Time : Duration := Clock;
+ begin
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Time + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ loop
+ Request := To_Timespec (Rel_Time);
+ Result := nanosleep (Request'Access, Remaind'Access);
+ Check_Time := Clock;
+
+ exit when Abs_Time <= Check_Time;
+
+ Rel_Time := Abs_Time - Check_Time;
+ end loop;
+ end if;
+ end Timed_Delay;
+
+end System.OS_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.40 $
+-- --
+-- Copyright (C) 1991-2001, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a POSIX-like version of this package
+
+-- This package contains all the GNULL primitives that interface directly
+-- with the underlying OS.
+
+-- Note: this file can only be used for POSIX compliant systems that
+-- implement SCHED_FIFO and Ceiling Locking correctly.
+
+-- For configurations where SCHED_FIFO and priority ceiling are not a
+-- requirement, this file can also be used (e.g AiX threads)
+
+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 System.Tasking.Debug;
+-- used for Known_Tasks
+
+with System.Task_Info;
+-- used for Task_Info_Type
+
+with Interfaces.C;
+-- used for int
+-- size_t
+
+with System.Interrupt_Management;
+-- used for Keep_Unmasked
+-- Abort_Task_Interrupt
+-- Interrupt_ID
+
+with System.Interrupt_Management.Operations;
+-- used for Set_Interrupt_Mask
+-- All_Tasks_Mask
+pragma Elaborate_All (System.Interrupt_Management.Operations);
+
+with System.Parameters;
+-- used for Size_Type
+
+with System.Tasking;
+-- used for Ada_Task_Control_Block
+-- Task_ID
+
+with System.Soft_Links;
+-- used for Defer/Undefer_Abort
+
+-- Note that we do not use System.Tasking.Initialization directly since
+-- this 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.Initialization
+
+with System.OS_Primitives;
+-- used for Delay_Modes
+
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+package body System.Task_Primitives.Operations is
+
+ use System.Tasking.Debug;
+ use System.Tasking;
+ use Interfaces.C;
+ use System.OS_Interface;
+ use System.Parameters;
+ use System.OS_Primitives;
+
+ package SSL renames System.Soft_Links;
+
+ ------------------
+ -- Local Data --
+ ------------------
+
+ -- The followings are logically constants, but need to be initialized
+ -- at run time.
+
+ All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
+ -- See comments on locking rules in System.Tasking (spec).
+
+ 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");
+
+ FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
+ -- Indicates whether FIFO_Within_Priorities is set.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Abort_Handler
+ (Sig : Signal);
+
+ function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
+
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+
+ --------------------
+ -- Local Packages --
+ --------------------
+
+ package Specific is
+
+ procedure Initialize (Environment_Task : Task_ID);
+ pragma Inline (Initialize);
+ -- Initialize various data needed by this package.
+
+ 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.
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ -- Target-dependent binding of inter-thread Abort signal to
+ -- the raising of the Abort_Signal exception.
+
+ -- The technical issues and alternatives here are essentially
+ -- the same as for raising exceptions in response to other
+ -- signals (e.g. Storage_Error). See code and comments in
+ -- the package body System.Interrupt_Management.
+
+ -- Some implementations may not allow an exception to be propagated
+ -- out of a handler, and others might leave the signal or
+ -- interrupt that invoked this handler masked after the exceptional
+ -- return to the application code.
+
+ -- GNAT exceptions are originally implemented using setjmp()/longjmp().
+ -- On most UNIX systems, this will allow transfer out of a signal handler,
+ -- which is usually the only mechanism available for implementing
+ -- asynchronous handlers of this kind. However, some
+ -- systems do not restore the signal mask on longjmp(), leaving the
+ -- abort signal masked.
+
+ -- Alternative solutions include:
+
+ -- 1. Change the PC saved in the system-dependent Context
+ -- parameter to point to code that raises the exception.
+ -- Normal return from this handler will then raise
+ -- the exception after the mask and other system state has
+ -- been restored (see example below).
+
+ -- 2. Use siglongjmp()/sigsetjmp() to implement exceptions.
+
+ -- 3. Unmask the signal in the Abortion_Signal exception handler
+ -- (in the RTS).
+
+ -- The following procedure would be needed if we can't lonjmp out of
+ -- a signal handler (See below)
+
+ -- procedure Raise_Abort_Signal is
+ -- begin
+ -- raise Standard'Abort_Signal;
+ -- end if;
+
+ procedure Abort_Handler
+ (Sig : Signal) is
+
+ T : Task_ID := Self;
+ Result : Interfaces.C.int;
+ Old_Set : aliased sigset_t;
+
+ begin
+ -- Assuming it is safe to longjmp out of a signal handler, the
+ -- following code can be used:
+
+ 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'Unchecked_Access, Old_Set'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ raise Standard'Abort_Signal;
+ end if;
+
+ -- Otherwise, something like this is required:
+ -- if not Abort_Is_Deferred.all then
+ -- -- Overwrite the return PC address with the address of the
+ -- -- special raise routine, and "return" to that routine's
+ -- -- starting address.
+ -- Context.PC := Raise_Abort_Signal'Address;
+ -- return;
+ -- 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 --
+ ---------------------
+
+ -- Note: mutexes and cond_variables needed per-task basis are
+ -- initialized in Intialize_TCB and the Storage_Error is
+ -- handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...)
+ -- used in RTS is initialized before any status change of RTS.
+ -- Therefore rasing Storage_Error in the following routines
+ -- should be able to be handled safely.
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : 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
+ Result := pthread_mutexattr_setprotocol
+ (Attributes'Access, PTHREAD_PRIO_PROTECT);
+ pragma Assert (Result = 0);
+
+ Result := pthread_mutexattr_setprioceiling
+ (Attributes'Access, Interfaces.C.int (Prio));
+ pragma Assert (Result = 0);
+
+ elsif Locking_Policy = 'I' then
+ Result := pthread_mutexattr_setprotocol
+ (Attributes'Access, PTHREAD_PRIO_INHERIT);
+ pragma Assert (Result = 0);
+ end if;
+
+ Result := pthread_mutex_init (L, Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+ end Initialize_Lock;
+
+ procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) 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
+ Result := pthread_mutexattr_setprotocol
+ (Attributes'Access, PTHREAD_PRIO_PROTECT);
+ pragma Assert (Result = 0);
+
+ Result := pthread_mutexattr_setprioceiling
+ (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
+ pragma Assert (Result = 0);
+
+ elsif Locking_Policy = 'I' then
+ Result := pthread_mutexattr_setprotocol
+ (Attributes'Access, PTHREAD_PRIO_INHERIT);
+ pragma Assert (Result = 0);
+ 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 : access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_destroy (L);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : 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 : access Lock; Ceiling_Violation : out Boolean) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (L);
+
+ -- 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;
+
+ procedure Write_Lock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ Write_Lock (L, Ceiling_Violation);
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ -------------
+ -- Sleep --
+ -------------
+
+ procedure Sleep (Self_ID : Task_ID;
+ Reason : System.Tasking.Task_States) is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Self_ID = Self);
+ Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access);
+
+ -- 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
+ Check_Time : constant Duration := Monotonic_Clock;
+ 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
+ or else Self_ID.Pending_Priority_Change;
+
+ Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access, Request'Access);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ if Result = 0 or Result = EINTR then
+
+ -- Somebody may have called Wakeup for us
+
+ Timedout := False;
+ exit;
+ end if;
+
+ pragma Assert (Result = ETIMEDOUT);
+ end loop;
+ end if;
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ -- 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
+ Check_Time : constant Duration := Monotonic_Clock;
+ Abs_Time : Duration;
+ Rel_Time : Duration;
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ -- Only the little window between deferring abort and
+ -- locking Self_ID is the reason we need to
+ -- check for pending abort and priority change below! :(
+
+ SSL.Abort_Defer.all;
+ 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
+ if Self_ID.Pending_Priority_Change then
+ Self_ID.Pending_Priority_Change := False;
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
+ end if;
+
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access, Request'Access);
+ exit when Abs_Time <= Monotonic_Clock;
+
+ pragma Assert (Result = 0
+ or else Result = ETIMEDOUT
+ or else Result = EINTR);
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+ Result := sched_yield;
+ SSL.Abort_Undefer.all;
+ 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
+ begin
+ return 10#1.0#E-6;
+ end RT_Resolution;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
+ 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;
+
+ begin
+ if Do_Yield then
+ Result := sched_yield;
+ end if;
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_Priority
+ (T : Task_ID;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ Result : Interfaces.C.int;
+ Param : aliased struct_sched_param;
+
+ begin
+ T.Common.Current_Priority := Prio;
+ Param.sched_priority := Interfaces.C.int (Prio);
+
+ if Time_Slice_Supported and then Time_Slice_Val > 0 then
+ Result := pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_RR, Param'Access);
+
+ elsif FIFO_Within_Priorities 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_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_All_Tasks_List;
+
+ for I in Known_Tasks'Range loop
+ if Known_Tasks (I) = null then
+ Known_Tasks (I) := Self_ID;
+ Self_ID.Known_Tasks_Index := I;
+ exit;
+ end if;
+ end loop;
+
+ Unlock_All_Tasks_List;
+ 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;
+
+ ----------------------
+ -- 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);
+
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_mutexattr_setprotocol
+ (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT);
+ pragma Assert (Result = 0);
+
+ Result := pthread_mutexattr_setprioceiling
+ (Mutex_Attr'Access, Interfaces.C.int (System.Any_Priority'Last));
+ pragma Assert (Result = 0);
+
+ Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
+ Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
+ Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = 0 then
+ Succeeded := True;
+ else
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ Succeeded := False;
+ end if;
+
+ Result := pthread_condattr_destroy (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+ end Initialize_TCB;
+
+ -----------------
+ -- Create_Task --
+ -----------------
+
+ procedure Create_Task
+ (T : Task_ID;
+ Wrapper : System.Address;
+ Stack_Size : System.Parameters.Size_Type;
+ Priority : System.Any_Priority;
+ Succeeded : out Boolean)
+ is
+ Attributes : aliased pthread_attr_t;
+ Adjusted_Stack_Size : Interfaces.C.size_t;
+ Result : Interfaces.C.int;
+
+ function Thread_Body_Access is new
+ Unchecked_Conversion (System.Address, Thread_Body);
+
+ use System.Task_Info;
+
+ begin
+ if Stack_Size = Unspecified_Size then
+ Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size);
+
+ elsif Stack_Size < Minimum_Stack_Size then
+ Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
+
+ else
+ Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
+ end if;
+
+ 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);
+
+ Set_Priority (T, Priority);
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_ID) is
+ Result : Interfaces.C.int;
+ Tmp : Task_ID := T;
+
+ procedure Free is new
+ Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
+
+ begin
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+
+ Result := pthread_cond_destroy (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+
+ if T.Known_Tasks_Index /= -1 then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ end if;
+
+ Free (Tmp);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ pthread_exit (System.Null_Address);
+ 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;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy versions. The only currently working versions is for solaris
+ -- (native).
+
+ function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ 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_All_Tasks_List --
+ -------------------------
+
+ procedure Lock_All_Tasks_List is
+ begin
+ Write_Lock (All_Tasks_L'Access);
+ end Lock_All_Tasks_List;
+
+ ---------------------------
+ -- Unlock_All_Tasks_List --
+ ---------------------------
+
+ procedure Unlock_All_Tasks_List is
+ begin
+ Unlock (All_Tasks_L'Access);
+ end Unlock_All_Tasks_List;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ return False;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id) return Boolean is
+ begin
+ return False;
+ end Resume_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;
+
+ begin
+ Environment_Task_ID := Environment_Task;
+
+ -- Initialize the lock used to synchronize chain of all ATCBs.
+
+ Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
+
+ Specific.Initialize (Environment_Task);
+
+ Enter_Task (Environment_Task);
+
+ -- Install the abort-signal handler
+
+ 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 Initialize;
+
+begin
+ declare
+ Result : Interfaces.C.int;
+
+ begin
+ -- Mask Environment task for all signals. The original mask of the
+ -- Environment task will be recovered by Interrupt_Server task
+ -- during the elaboration of s-interr.adb.
+
+ System.Interrupt_Management.Operations.Set_Interrupt_Mask
+ (System.Interrupt_Management.Operations.All_Tasks_Mask'Access);
+
+ -- 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;
+ end;
+
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $
+-- --
+-- Copyright (C) 1991-2000, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a POSIX-like version of this package.
+-- Note: this file can only be used for POSIX compliant systems.
+
+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 System.OS_Interface;
+-- used for pthread_mutex_t
+-- pthread_cond_t
+-- pthread_t
+
+package System.Task_Primitives is
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects.
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system.
+ -- The difference between Lock and the RTS_Lock is that the later
+ -- one serves only as a semaphore so that do not check for
+ -- ceiling violations.
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper
+ -- declared local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task
+ -- basis. A component of this type is guaranteed to be included
+ -- in the Ada_Task_Control_Block.
+
+private
+
+ type Lock is new System.OS_Interface.pthread_mutex_t;
+ type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
+
+ type Private_Data is record
+ Thread : aliased System.OS_Interface.pthread_t;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb).
+ -- They put the same value (thr_self value). We do not want to
+ -- use lock on those operations and the only thing we have to
+ -- make sure is that they are updated in atomic fashion.
+
+ LWP : aliased System.Address;
+ -- The purpose of this field is to provide a better tasking support on
+ -- gdb. The order of the two first fields (Thread and LWP) is important.
+ -- On targets where lwp is not relevant, this is equivalent to Thread.
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 . --
+-- S P E C I F I C --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 1991-1998, Florida State University --
+-- --
+-- 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 2, or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a FSU-like version of this package.
+
+separate (System.Task_Primitives.Operations)
+package body Specific is
+
+ ------------------
+ -- Local Data --
+ ------------------
+
+ -- The followings are logically constants, but need to be initialized
+ -- at run time.
+
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_ID associated with a thread
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_ID) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_key_create (ATCB_Key'Access, null);
+ pragma Assert (Result = 0);
+ Result := pthread_setspecific (ATCB_Key, To_Address (Environment_Task));
+ pragma Assert (Result = 0);
+ end Initialize;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
+ pragma Assert (Result = 0);
+ end Set;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_ID is
+ Result : System.Address;
+
+ begin
+ Result := pthread_getspecific (ATCB_Key);
+ pragma Assert (Result /= System.Null_Address);
+ return To_Task_ID (Result);
+ end Self;
+
+end Specific;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E B A C K --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1999-2000 Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This version assumes that System.Machine_State_Operations.Pop_Frame can
+-- work with the Info parameter being null.
+
+with System.Machine_State_Operations;
+
+package body System.Traceback is
+
+ use System.Machine_State_Operations;
+
+ ----------------
+ -- Call_Chain --
+ ----------------
+
+ procedure Call_Chain
+ (Traceback : System.Address;
+ Max_Len : Natural;
+ Len : out Natural;
+ Exclude_Min,
+ Exclude_Max : System.Address := System.Null_Address)
+ is
+ type Tracebacks_Array is array (1 .. Max_Len) of Code_Loc;
+ pragma Suppress_Initialization (Tracebacks_Array);
+
+ M : Machine_State;
+ Code : Code_Loc;
+ J : Natural := 1;
+ Trace : Tracebacks_Array;
+ for Trace'Address use Traceback;
+
+ begin
+ M := Allocate_Machine_State;
+ Set_Machine_State (M);
+
+ loop
+ Code := Get_Code_Loc (M);
+
+ exit when Code = Null_Address or else J = Max_Len + 1;
+
+ if Code < Exclude_Min or else Code > Exclude_Max then
+ Trace (J) := Code;
+ J := J + 1;
+ end if;
+
+ Pop_Frame (M, System.Null_Address);
+ end loop;
+
+ Len := J - 1;
+ Free_Machine_State (M);
+ end Call_Chain;
+
+ ------------------
+ -- C_Call_Chain --
+ ------------------
+
+ function C_Call_Chain
+ (Traceback : System.Address;
+ Max_Len : Natural) return Natural
+ is
+ Val : Natural;
+ begin
+ Call_Chain (Traceback, Max_Len, Val);
+ return Val;
+ end C_Call_Chain;
+
+end System.Traceback;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . N U M E R I C S . A U X --
+-- --
+-- B o d y --
+-- (Machine Version for x86) --
+-- --
+-- $Revision: 1.15 $
+-- --
+-- Copyright (C) 1998-2000 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- File a-numaux.adb <- 86numaux.adb
+
+-- This version of Numerics.Aux is for the IEEE Double Extended floating
+-- point format on x86.
+
+with System.Machine_Code; use System.Machine_Code;
+
+package body Ada.Numerics.Aux is
+
+ NL : constant String := ASCII.LF & ASCII.HT;
+
+ type FPU_Stack_Pointer is range 0 .. 7;
+ for FPU_Stack_Pointer'Size use 3;
+
+ type FPU_Status_Word is record
+ B : Boolean; -- FPU Busy (for 8087 compatability only)
+ ES : Boolean; -- Error Summary Status
+ SF : Boolean; -- Stack Fault
+
+ Top : FPU_Stack_Pointer;
+
+ -- Condition Code Flags
+
+ -- C2 is set by FPREM and FPREM1 to indicate incomplete reduction.
+ -- In case of successfull recorction, C0, C3 and C1 are set to the
+ -- three least significant bits of the result (resp. Q2, Q1 and Q0).
+
+ -- C2 is used by FPTAN, FSIN, FCOS, and FSINCOS to indicate that
+ -- that source operand is beyond the allowable range of
+ -- -2.0**63 .. 2.0**63.
+
+ C3 : Boolean;
+ C2 : Boolean;
+ C1 : Boolean;
+ C0 : Boolean;
+
+ -- Exception Flags
+
+ PE : Boolean; -- Precision
+ UE : Boolean; -- Underflow
+ OE : Boolean; -- Overflow
+ ZE : Boolean; -- Zero Divide
+ DE : Boolean; -- Denormalized Operand
+ IE : Boolean; -- Invalid Operation
+ end record;
+
+ for FPU_Status_Word use record
+ B at 0 range 15 .. 15;
+ C3 at 0 range 14 .. 14;
+ Top at 0 range 11 .. 13;
+ C2 at 0 range 10 .. 10;
+ C1 at 0 range 9 .. 9;
+ C0 at 0 range 8 .. 8;
+ ES at 0 range 7 .. 7;
+ SF at 0 range 6 .. 6;
+ PE at 0 range 5 .. 5;
+ UE at 0 range 4 .. 4;
+ OE at 0 range 3 .. 3;
+ ZE at 0 range 2 .. 2;
+ DE at 0 range 1 .. 1;
+ IE at 0 range 0 .. 0;
+ end record;
+
+ for FPU_Status_Word'Size use 16;
+
+ -----------------------
+ -- Local subprograms --
+ -----------------------
+
+ function Is_Nan (X : Double) return Boolean;
+ -- Return True iff X is a IEEE NaN value
+
+ function Logarithmic_Pow (X, Y : Double) return Double;
+ -- Implementation of X**Y using Exp and Log functions (binary base)
+ -- to calculate the exponentiation. This is used by Pow for values
+ -- for values of Y in the open interval (-0.25, 0.25)
+
+ function Reduce (X : Double) return Double;
+ -- Implement partial reduction of X by Pi in the x86.
+
+ -- Note that for the Sin, Cos and Tan functions completely accurate
+ -- reduction of the argument is done for arguments in the range of
+ -- -2.0**63 .. 2.0**63, using a 66-bit approximation of Pi.
+
+
+ pragma Inline (Is_Nan);
+ pragma Inline (Reduce);
+
+ ---------------------------------
+ -- Basic Elementary Functions --
+ ---------------------------------
+
+ -- This section implements a few elementary functions that are
+ -- used to build the more complex ones. This ordering enables
+ -- better inlining.
+
+ ----------
+ -- Atan --
+ ----------
+
+ function Atan (X : Double) return Double is
+ Result : Double;
+
+ begin
+ Asm (Template =>
+ "fld1" & NL
+ & "fpatan",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", X));
+
+ -- The result value is NaN iff input was invalid
+
+ if not (Result = Result) then
+ raise Argument_Error;
+ end if;
+
+ return Result;
+ end Atan;
+
+ ---------
+ -- Exp --
+ ---------
+
+ function Exp (X : Double) return Double is
+ Result : Double;
+ begin
+ Asm (Template =>
+ "fldl2e " & NL
+ & "fmulp %%st, %%st(1)" & NL -- X * log2 (E)
+ & "fld %%st(0) " & NL
+ & "frndint " & NL -- Integer (X * Log2 (E))
+ & "fsubr %%st, %%st(1)" & NL -- Fraction (X * Log2 (E))
+ & "fxch " & NL
+ & "f2xm1 " & NL -- 2**(...) - 1
+ & "fld1 " & NL
+ & "faddp %%st, %%st(1)" & NL -- 2**(Fraction (X * Log2 (E)))
+ & "fscale " & NL -- E ** X
+ & "fstp %%st(1) ",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", X));
+ return Result;
+ end Exp;
+
+ ------------
+ -- Is_Nan --
+ ------------
+
+ function Is_Nan (X : Double) return Boolean is
+ begin
+ -- The IEEE NaN values are the only ones that do not equal themselves
+
+ return not (X = X);
+ end Is_Nan;
+
+ ---------
+ -- Log --
+ ---------
+
+ function Log (X : Double) return Double is
+ Result : Double;
+
+ begin
+ Asm (Template =>
+ "fldln2 " & NL
+ & "fxch " & NL
+ & "fyl2x " & NL,
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", X));
+ return Result;
+ end Log;
+
+ ------------
+ -- Reduce --
+ ------------
+
+ function Reduce (X : Double) return Double is
+ Result : Double;
+ begin
+ Asm
+ (Template =>
+ -- Partial argument reduction
+ "fldpi " & NL
+ & "fadd %%st(0), %%st" & NL
+ & "fxch %%st(1) " & NL
+ & "fprem1 " & NL
+ & "fstp %%st(1) ",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", X));
+ return Result;
+ end Reduce;
+
+ ----------
+ -- Sqrt --
+ ----------
+
+ function Sqrt (X : Double) return Double is
+ Result : Double;
+
+ begin
+ if X < 0.0 then
+ raise Argument_Error;
+ end if;
+
+ Asm (Template => "fsqrt",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", X));
+
+ return Result;
+ end Sqrt;
+
+ ---------------------------------
+ -- Other Elementary Functions --
+ ---------------------------------
+
+ -- These are built using the previously implemented basic functions
+
+ ----------
+ -- Acos --
+ ----------
+
+ function Acos (X : Double) return Double is
+ Result : Double;
+ begin
+ Result := 2.0 * Atan (Sqrt ((1.0 - X) / (1.0 + X)));
+
+ -- The result value is NaN iff input was invalid
+
+ if Is_Nan (Result) then
+ raise Argument_Error;
+ end if;
+
+ return Result;
+ end Acos;
+
+ ----------
+ -- Asin --
+ ----------
+
+ function Asin (X : Double) return Double is
+ Result : Double;
+ begin
+
+ Result := Atan (X / Sqrt ((1.0 - X) * (1.0 + X)));
+
+ -- The result value is NaN iff input was invalid
+
+ if Is_Nan (Result) then
+ raise Argument_Error;
+ end if;
+
+ return Result;
+ end Asin;
+
+ ---------
+ -- Cos --
+ ---------
+
+ function Cos (X : Double) return Double is
+ Reduced_X : Double := X;
+ Result : Double;
+ Status : FPU_Status_Word;
+
+ begin
+
+ loop
+ Asm
+ (Template =>
+ "fcos " & NL
+ & "xorl %%eax, %%eax " & NL
+ & "fnstsw %%ax ",
+ Outputs => (Double'Asm_Output ("=t", Result),
+ FPU_Status_Word'Asm_Output ("=a", Status)),
+ Inputs => Double'Asm_Input ("0", Reduced_X));
+
+ exit when not Status.C2;
+
+ -- Original argument was not in range and the result
+ -- is the unmodified argument.
+
+ Reduced_X := Reduce (Result);
+ end loop;
+
+ return Result;
+ end Cos;
+
+ ---------------------
+ -- Logarithmic_Pow --
+ ---------------------
+
+ function Logarithmic_Pow (X, Y : Double) return Double is
+ Result : Double;
+
+ begin
+ Asm (Template => "" -- X : Y
+ & "fyl2x " & NL -- Y * Log2 (X)
+ & "fst %%st(1) " & NL -- Y * Log2 (X) : Y * Log2 (X)
+ & "frndint " & NL -- Int (...) : Y * Log2 (X)
+ & "fsubr %%st, %%st(1)" & NL -- Int (...) : Fract (...)
+ & "fxch " & NL -- Fract (...) : Int (...)
+ & "f2xm1 " & NL -- 2**Fract (...) - 1 : Int (...)
+ & "fld1 " & NL -- 1 : 2**Fract (...) - 1 : Int (...)
+ & "faddp %%st, %%st(1)" & NL -- 2**Fract (...) : Int (...)
+ & "fscale " & NL -- 2**(Fract (...) + Int (...))
+ & "fstp %%st(1) ",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs =>
+ (Double'Asm_Input ("0", X),
+ Double'Asm_Input ("u", Y)));
+
+ return Result;
+ end Logarithmic_Pow;
+
+ ---------
+ -- Pow --
+ ---------
+
+ function Pow (X, Y : Double) return Double is
+ type Mantissa_Type is mod 2**Double'Machine_Mantissa;
+ -- Modular type that can hold all bits of the mantissa of Double
+
+ -- For negative exponents, a division is done
+ -- at the end of the processing.
+
+ Negative_Y : constant Boolean := Y < 0.0;
+ Abs_Y : constant Double := abs Y;
+
+ -- During this function the following invariant is kept:
+ -- X ** (abs Y) = Base**(Exp_High + Exp_Mid + Exp_Low) * Factor
+
+ Base : Double := X;
+
+ Exp_High : Double := Double'Floor (Abs_Y);
+ Exp_Mid : Double;
+ Exp_Low : Double;
+ Exp_Int : Mantissa_Type;
+
+ Factor : Double := 1.0;
+
+ begin
+ -- Select algorithm for calculating Pow:
+ -- integer cases fall through
+
+ if Exp_High >= 2.0**Double'Machine_Mantissa then
+
+ -- In case of Y that is IEEE infinity, just raise constraint error
+
+ if Exp_High > Double'Safe_Last then
+ raise Constraint_Error;
+ end if;
+
+ -- Large values of Y are even integers and will stay integer
+ -- after division by two.
+
+ loop
+ -- Exp_Mid and Exp_Low are zero, so
+ -- X**(abs Y) = Base ** Exp_High = (Base**2) ** (Exp_High / 2)
+
+ Exp_High := Exp_High / 2.0;
+ Base := Base * Base;
+ exit when Exp_High < 2.0**Double'Machine_Mantissa;
+ end loop;
+
+ elsif Exp_High /= Abs_Y then
+ Exp_Low := Abs_Y - Exp_High;
+
+ Factor := 1.0;
+
+ if Exp_Low /= 0.0 then
+
+ -- Exp_Low now is in interval (0.0, 1.0)
+ -- Exp_Mid := Double'Floor (Exp_Low * 4.0) / 4.0;
+
+ Exp_Mid := 0.0;
+ Exp_Low := Exp_Low - Exp_Mid;
+
+ if Exp_Low >= 0.5 then
+ Factor := Sqrt (X);
+ Exp_Low := Exp_Low - 0.5; -- exact
+
+ if Exp_Low >= 0.25 then
+ Factor := Factor * Sqrt (Factor);
+ Exp_Low := Exp_Low - 0.25; -- exact
+ end if;
+
+ elsif Exp_Low >= 0.25 then
+ Factor := Sqrt (Sqrt (X));
+ Exp_Low := Exp_Low - 0.25; -- exact
+ end if;
+
+ -- Exp_Low now is in interval (0.0, 0.25)
+
+ -- This means it is safe to call Logarithmic_Pow
+ -- for the remaining part.
+
+ Factor := Factor * Logarithmic_Pow (X, Exp_Low);
+ end if;
+
+ elsif X = 0.0 then
+ return 0.0;
+ end if;
+
+ -- Exp_High is non-zero integer smaller than 2**Double'Machine_Mantissa
+
+ Exp_Int := Mantissa_Type (Exp_High);
+
+ -- Standard way for processing integer powers > 0
+
+ while Exp_Int > 1 loop
+ if (Exp_Int and 1) = 1 then
+
+ -- Base**Y = Base**(Exp_Int - 1) * Exp_Int for Exp_Int > 0
+
+ Factor := Factor * Base;
+ end if;
+
+ -- Exp_Int is even and Exp_Int > 0, so
+ -- Base**Y = (Base**2)**(Exp_Int / 2)
+
+ Base := Base * Base;
+ Exp_Int := Exp_Int / 2;
+ end loop;
+
+ -- Exp_Int = 1 or Exp_Int = 0
+
+ if Exp_Int = 1 then
+ Factor := Base * Factor;
+ end if;
+
+ if Negative_Y then
+ Factor := 1.0 / Factor;
+ end if;
+
+ return Factor;
+ end Pow;
+
+ ---------
+ -- Sin --
+ ---------
+
+ function Sin (X : Double) return Double is
+ Reduced_X : Double := X;
+ Result : Double;
+ Status : FPU_Status_Word;
+
+ begin
+
+ loop
+ Asm
+ (Template =>
+ "fsin " & NL
+ & "xorl %%eax, %%eax " & NL
+ & "fnstsw %%ax ",
+ Outputs => (Double'Asm_Output ("=t", Result),
+ FPU_Status_Word'Asm_Output ("=a", Status)),
+ Inputs => Double'Asm_Input ("0", Reduced_X));
+
+ exit when not Status.C2;
+
+ -- Original argument was not in range and the result
+ -- is the unmodified argument.
+
+ Reduced_X := Reduce (Result);
+ end loop;
+
+ return Result;
+ end Sin;
+
+ ---------
+ -- Tan --
+ ---------
+
+ function Tan (X : Double) return Double is
+ Reduced_X : Double := X;
+ Result : Double;
+ Status : FPU_Status_Word;
+
+ begin
+
+ loop
+ Asm
+ (Template =>
+ "fptan " & NL
+ & "xorl %%eax, %%eax " & NL
+ & "fnstsw %%ax " & NL
+ & "ffree %%st(0) " & NL
+ & "fincstp ",
+
+ Outputs => (Double'Asm_Output ("=t", Result),
+ FPU_Status_Word'Asm_Output ("=a", Status)),
+ Inputs => Double'Asm_Input ("0", Reduced_X));
+
+ exit when not Status.C2;
+
+ -- Original argument was not in range and the result
+ -- is the unmodified argument.
+
+ Reduced_X := Reduce (Result);
+ end loop;
+
+ return Result;
+ end Tan;
+
+ ----------
+ -- Sinh --
+ ----------
+
+ function Sinh (X : Double) return Double is
+ begin
+ -- Mathematically Sinh (x) is defined to be (Exp (X) - Exp (-X)) / 2.0
+
+ if abs X < 25.0 then
+ return (Exp (X) - Exp (-X)) / 2.0;
+
+ else
+ return Exp (X) / 2.0;
+ end if;
+
+ end Sinh;
+
+ ----------
+ -- Cosh --
+ ----------
+
+ function Cosh (X : Double) return Double is
+ begin
+ -- Mathematically Cosh (X) is defined to be (Exp (X) + Exp (-X)) / 2.0
+
+ if abs X < 22.0 then
+ return (Exp (X) + Exp (-X)) / 2.0;
+
+ else
+ return Exp (X) / 2.0;
+ end if;
+
+ end Cosh;
+
+ ----------
+ -- Tanh --
+ ----------
+
+ function Tanh (X : Double) return Double is
+ begin
+ -- Return the Hyperbolic Tangent of x
+ --
+ -- x -x
+ -- e - e Sinh (X)
+ -- Tanh (X) is defined to be ----------- = --------
+ -- x -x Cosh (X)
+ -- e + e
+
+ if abs X > 23.0 then
+ return Double'Copy_Sign (1.0, X);
+ end if;
+
+ return 1.0 / (1.0 + Exp (-2.0 * X)) - 1.0 / (1.0 + Exp (2.0 * X));
+
+ end Tanh;
+
+end Ada.Numerics.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . N U M E R I C S . A U X --
+-- --
+-- S p e c --
+-- (Machine Version for x86) --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1992-1998 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides the basic computational interface for the generic
+-- elementary functions. This implementation is based on the glibc assembly
+-- sources for the x86 glibc math library.
+
+-- Note: there are two versions of this package. One using the 80-bit x86
+-- long double format (which is this version), and one using 64-bit IEEE
+-- double (see file a-numaux.ads). The latter version imports the C
+-- routines directly.
+
+package Ada.Numerics.Aux is
+pragma Pure (Aux);
+
+ type Double is new Long_Long_Float;
+
+ function Sin (X : Double) return Double;
+
+ function Cos (X : Double) return Double;
+
+ function Tan (X : Double) return Double;
+
+ function Exp (X : Double) return Double;
+
+ function Sqrt (X : Double) return Double;
+
+ function Log (X : Double) return Double;
+
+ function Atan (X : Double) return Double;
+
+ function Acos (X : Double) return Double;
+
+ function Asin (X : Double) return Double;
+
+ function Sinh (X : Double) return Double;
+
+ function Cosh (X : Double) return Double;
+
+ function Tanh (X : Double) return Double;
+
+ function Pow (X, Y : Double) return Double;
+
+private
+ pragma Inline (Atan);
+ pragma Inline (Cos);
+ pragma Inline (Tan);
+ pragma Inline (Exp);
+ pragma Inline (Log);
+ pragma Inline (Sin);
+ pragma Inline (Sqrt);
+
+end Ada.Numerics.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . R P C --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Unchecked_Deallocation;
+with Ada.Streams;
+
+with System.RPC.Net_Trace;
+with System.RPC.Garlic;
+with System.RPC.Streams;
+pragma Elaborate (System.RPC.Garlic);
+
+package body System.RPC is
+
+ use type Ada.Streams.Stream_Element_Count;
+ use type Ada.Streams.Stream_Element_Offset;
+
+ use type Garlic.Protocol_Access;
+ use type Garlic.Lock_Method;
+
+ Max_Of_Message_Id : constant := 127;
+
+ subtype Message_Id_Type is
+ Integer range -Max_Of_Message_Id .. Max_Of_Message_Id;
+ -- A message id is either a request id or reply id. A message id is
+ -- provided with a message to a receiving stub which uses the opposite
+ -- as a reply id. A message id helps to retrieve to which task is
+ -- addressed a reply. When the environment task receives a message, the
+ -- message id is extracted : a positive message id stands for a call, a
+ -- negative message id stands for a reply. A null message id stands for
+ -- an asynchronous request.
+
+ subtype Request_Id_Type is Message_Id_Type range 1 .. Max_Of_Message_Id;
+ -- When a message id is positive, it is a request
+
+ type Message_Length_Per_Request is array (Request_Id_Type)
+ of Ada.Streams.Stream_Element_Count;
+
+ Header_Size : Ada.Streams.Stream_Element_Count
+ := Streams.Get_Integer_Initial_Size +
+ Streams.Get_SEC_Initial_Size;
+ -- Initial size needed for frequently used header streams
+
+ Stream_Error : exception;
+ -- Occurs when a read procedure is executed on an empty stream
+ -- or when a write procedure is executed on a full stream
+
+ Partition_RPC_Receiver : RPC_Receiver;
+ -- Cache the RPC_Recevier passed by Establish_RPC_Receiver
+
+ type Anonymous_Task_Node;
+
+ type Anonymous_Task_Node_Access is access Anonymous_Task_Node;
+ -- Types we need to construct a singly linked list of anonymous tasks
+ -- This pool is maintained to avoid a task creation each time a RPC
+ -- occurs - to be cont'd
+
+ task type Anonymous_Task_Type (Self : Anonymous_Task_Node_Access) is
+
+ entry Start
+ (Message_Id : in Message_Id_Type;
+ Partition : in Partition_ID;
+ Params_Size : in Ada.Streams.Stream_Element_Count;
+ Result_Size : in Ada.Streams.Stream_Element_Count;
+ Protocol : in Garlic.Protocol_Access);
+ -- This entry provides an anonymous task a remote call to perform
+ -- This task calls for a
+ -- Request id is provided to construct the reply id by using
+ -- -Request. Partition is used to send the reply message. Params_Size
+ -- is the size of the calling stub Params stream. Then, Protocol
+ -- (used by the environment task previously) allows to extract the
+ -- message following the header (The header is extracted by the
+ -- environment task)
+
+ end Anonymous_Task_Type;
+
+ type Anonymous_Task_Access is access Anonymous_Task_Type;
+
+ type Anonymous_Task_List is
+ record
+ Head : Anonymous_Task_Node_Access;
+ Tail : Anonymous_Task_Node_Access;
+ end record;
+
+ type Anonymous_Task_Node is
+ record
+ Element : Anonymous_Task_Access;
+ Next : Anonymous_Task_Node_Access;
+ end record;
+ -- Types we need to construct a singly linked list of anonymous tasks
+ -- This pool is maintained to avoid a task creation each time a RPC
+ -- occurs
+
+ protected Garbage_Collector is
+
+ procedure Allocate
+ (Item : out Anonymous_Task_Node_Access);
+ -- Anonymous task pool management : if there is an anonymous task
+ -- left, use it. Otherwise, allocate a new one
+
+ procedure Deallocate
+ (Item : in out Anonymous_Task_Node_Access);
+ -- Anonymous task pool management : queue this task in the pool
+ -- of inactive anonymous tasks.
+ private
+
+ Anonymous_List : Anonymous_Task_Node_Access;
+ -- The list root of inactive anonymous tasks
+
+ end Garbage_Collector;
+
+ task Dispatcher is
+
+ entry New_Request (Request : out Request_Id_Type);
+ -- To get a new request
+
+ entry Wait_On (Request_Id_Type)
+ (Length : out Ada.Streams.Stream_Element_Count);
+ -- To block the calling stub when it waits for a reply
+ -- When it is resumed, we provide the size of the reply
+
+ entry Wake_Up
+ (Request : in Request_Id_Type;
+ Length : in Ada.Streams.Stream_Element_Count);
+ -- To wake up the calling stub when the environnement task has
+ -- received a reply for this request
+
+ end Dispatcher;
+
+ task Environnement is
+
+ entry Start;
+ -- Receive no message until Partition_Receiver is set
+ -- Establish_RPC_Receiver decides when the environment task
+ -- is allowed to start
+
+ end Environnement;
+
+ protected Partition_Receiver is
+
+ entry Is_Set;
+ -- Blocks if the Partition_RPC_Receiver has not been set
+
+ procedure Set;
+ -- Done by Establish_RPC_Receiver when Partition_RPC_Receiver
+ -- is known
+
+ private
+
+ Was_Set : Boolean := False;
+ -- True when Partition_RPC_Receiver has been set
+
+ end Partition_Receiver;
+ -- Anonymous tasks have to wait for the Partition_RPC_Receiver
+ -- to be established
+
+ type Debug_Level is
+ (D_Elaborate, -- About the elaboration of this package
+ D_Communication, -- About calls to Send and Receive
+ D_Debug, -- Verbose
+ D_Exception); -- Exception handler
+ -- Debugging levels
+
+ package Debugging is new System.RPC.Net_Trace (Debug_Level, "RPC : ");
+ -- Debugging package
+
+ procedure D
+ (Flag : in Debug_Level; Info : in String) renames Debugging.Debug;
+ -- Shortcut
+
+ ------------------------
+ -- Partition_Receiver --
+ ------------------------
+
+ protected body Partition_Receiver is
+
+ -------------------------------
+ -- Partition_Receiver.Is_Set --
+ -------------------------------
+
+ entry Is_Set when Was_Set is
+ begin
+ null;
+ end Is_Set;
+
+ ----------------------------
+ -- Partition_Receiver.Set --
+ ----------------------------
+
+ procedure Set is
+ begin
+ Was_Set := True;
+ end Set;
+
+ end Partition_Receiver;
+
+ ---------------
+ -- Head_Node --
+ ---------------
+
+ procedure Head_Node
+ (Index : out Packet_Node_Access;
+ Stream : in Params_Stream_Type) is
+ begin
+ Index := Stream.Extra.Head;
+ exception when others =>
+ D (D_Exception, "exception in Head_Node");
+ raise;
+ end Head_Node;
+
+ ---------------
+ -- Tail_Node --
+ ---------------
+
+ procedure Tail_Node
+ (Index : out Packet_Node_Access;
+ Stream : in Params_Stream_Type) is
+ begin
+ Index := Stream.Extra.Tail;
+ exception when others =>
+ D (D_Exception, "exception in Tail_Node");
+ raise;
+ end Tail_Node;
+
+ ---------------
+ -- Null_Node --
+ ---------------
+
+ function Null_Node
+ (Index : in Packet_Node_Access) return Boolean is
+ begin
+ return Index = null;
+ exception when others =>
+ D (D_Exception, "exception in Null_Node");
+ raise;
+ end Null_Node;
+
+ ----------------------
+ -- Delete_Head_Node --
+ ----------------------
+
+ procedure Delete_Head_Node
+ (Stream : in out Params_Stream_Type) is
+
+ procedure Free is
+ new Unchecked_Deallocation
+ (Packet_Node, Packet_Node_Access);
+
+ Next_Node : Packet_Node_Access := Stream.Extra.Head.Next;
+
+ begin
+
+ -- Delete head node and free memory usage
+
+ Free (Stream.Extra.Head);
+ Stream.Extra.Head := Next_Node;
+
+ -- If the extra storage is empty, update tail as well
+
+ if Stream.Extra.Head = null then
+ Stream.Extra.Tail := null;
+ end if;
+
+ exception when others =>
+ D (D_Exception, "exception in Delete_Head_Node");
+ raise;
+ end Delete_Head_Node;
+
+ ---------------
+ -- Next_Node --
+ ---------------
+
+ procedure Next_Node
+ (Node : in out Packet_Node_Access) is
+ begin
+
+ -- Node is set to the next node
+ -- If not possible, Stream_Error is raised
+
+ if Node = null then
+ raise Stream_Error;
+ else
+ Node := Node.Next;
+ end if;
+
+ exception when others =>
+ D (D_Exception, "exception in Next_Node");
+ raise;
+ end Next_Node;
+
+ ---------------------
+ -- Append_New_Node --
+ ---------------------
+
+ procedure Append_New_Node
+ (Stream : in out Params_Stream_Type) is
+ Index : Packet_Node_Access;
+ begin
+
+ -- Set Index to the end of the linked list
+
+ Tail_Node (Index, Stream);
+
+ if Null_Node (Index) then
+
+ -- The list is empty : set head as well
+
+ Stream.Extra.Head := new Packet_Node;
+ Stream.Extra.Tail := Stream.Extra.Head;
+
+ else
+
+ -- The list is not empty : link new node with tail
+
+ Stream.Extra.Tail.Next := new Packet_Node;
+ Stream.Extra.Tail := Stream.Extra.Tail.Next;
+
+ end if;
+
+ exception when others =>
+ D (D_Exception, "exception in Append_New_Node");
+ raise;
+ end Append_New_Node;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : in out Params_Stream_Type;
+ Item : out Ada.Streams.Stream_Element_Array;
+ Last : out Ada.Streams.Stream_Element_Offset) renames
+ System.RPC.Streams.Read;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : in out Params_Stream_Type;
+ Item : in Ada.Streams.Stream_Element_Array) renames
+ System.RPC.Streams.Write;
+
+ -----------------------
+ -- Garbage_Collector --
+ -----------------------
+
+ protected body Garbage_Collector is
+
+ --------------------------------
+ -- Garbage_Collector.Allocate --
+ --------------------------------
+
+ procedure Allocate
+ (Item : out Anonymous_Task_Node_Access) is
+ New_Anonymous_Task_Node : Anonymous_Task_Node_Access;
+ Anonymous_Task : Anonymous_Task_Access;
+ begin
+
+ -- If the list is empty, allocate a new anonymous task
+ -- Otherwise, reuse the first queued anonymous task
+
+ if Anonymous_List = null then
+
+ -- Create a new anonymous task
+ -- Provide this new task with its id to allow it
+ -- to enqueue itself into the free anonymous task list
+ -- with the function Deallocate
+
+ New_Anonymous_Task_Node := new Anonymous_Task_Node;
+ Anonymous_Task :=
+ new Anonymous_Task_Type (New_Anonymous_Task_Node);
+ New_Anonymous_Task_Node.all := (Anonymous_Task, null);
+
+ else
+
+ -- Extract one task from the list
+ -- Set the Next field to null to avoid possible bugs
+
+ New_Anonymous_Task_Node := Anonymous_List;
+ Anonymous_List := Anonymous_List.Next;
+ New_Anonymous_Task_Node.Next := null;
+
+ end if;
+
+ -- Item is an out parameter
+
+ Item := New_Anonymous_Task_Node;
+
+ exception when others =>
+ D (D_Exception, "exception in Allocate (Anonymous Task)");
+ raise;
+ end Allocate;
+
+ ----------------------------------
+ -- Garbage_Collector.Deallocate --
+ ----------------------------------
+
+ procedure Deallocate
+ (Item : in out Anonymous_Task_Node_Access) is
+ begin
+
+ -- Enqueue the task in the free list
+
+ Item.Next := Anonymous_List;
+ Anonymous_List := Item;
+
+ exception when others =>
+ D (D_Exception, "exception in Deallocate (Anonymous Task)");
+ raise;
+ end Deallocate;
+
+ end Garbage_Collector;
+
+ ------------
+ -- Do_RPC --
+ ------------
+
+ procedure Do_RPC
+ (Partition : in Partition_ID;
+ Params : access Params_Stream_Type;
+ Result : access Params_Stream_Type) is
+ Protocol : Protocol_Access;
+ Request : Request_Id_Type;
+ Header : aliased Params_Stream_Type (Header_Size);
+ R_Length : Ada.Streams.Stream_Element_Count;
+ begin
+
+ -- Parameters order :
+ -- Opcode (provided and used by garlic)
+ -- (1) Size (provided by s-rpc and used by garlic)
+ -- (size of (2)+(3)+(4)+(5))
+ -- (2) Request (provided by calling stub (resp receiving stub) and
+ -- used by anonymous task (resp Do_RPC))
+ -- *** ZERO IF APC ***
+ -- (3) Res.len. (provided by calling stubs and used by anonymous task)
+ -- *** ZERO IF APC ***
+ -- (4) Receiver (provided by calling stubs and used by anonymous task)
+ -- (5) Params (provided by calling stubs and used by anonymous task)
+
+ -- The call is a remote call or a local call. A local call occurs
+ -- when the pragma All_Calls_Remote has been specified. Do_RPC is
+ -- called and the execution has to be performed in the PCS
+
+ if Partition /= Garlic.Get_My_Partition_ID then
+
+ -- Get a request id to be resumed when the reply arrives
+
+ Dispatcher.New_Request (Request);
+
+ -- Build header = request (2) + result.initial_size (3)
+
+ D (D_Debug, "Do_RPC - Build header");
+ Streams.Allocate (Header);
+ Streams.Integer_Write_Attribute -- (2)
+ (Header'Access, Request);
+ System.RPC.Streams.SEC_Write_Attribute -- (3)
+ (Header'Access, Result.Initial_Size);
+
+ -- Get a protocol method to communicate with the remote partition
+ -- and give the message size
+
+ D (D_Communication,
+ "Do_RPC - Lookup for protocol to talk to partition" &
+ Partition_ID'Image (Partition));
+ Garlic.Initiate_Send
+ (Partition,
+ Streams.Get_Stream_Size (Header'Access) +
+ Streams.Get_Stream_Size (Params), -- (1)
+ Protocol,
+ Garlic.Remote_Call);
+
+ -- Send the header by using the protocol method
+
+ D (D_Communication, "Do_RPC - Send Header to partition" &
+ Partition_ID'Image (Partition));
+ Garlic.Send
+ (Protocol.all,
+ Partition,
+ Header'Access); -- (2) + (3)
+
+ -- The header is deallocated
+
+ Streams.Deallocate (Header);
+
+ -- Send Params from Do_RPC
+
+ D (D_Communication, "Do_RPC - Send Params to partition" &
+ Partition_ID'Image (Partition));
+ Garlic.Send
+ (Protocol.all,
+ Partition,
+ Params); -- (4) + (5)
+
+ -- Let Garlic know we have nothing else to send
+
+ Garlic.Complete_Send
+ (Protocol.all,
+ Partition);
+ D (D_Debug, "Do_RPC - Suspend");
+
+ -- Wait for a reply and get the reply message length
+
+ Dispatcher.Wait_On (Request) (R_Length);
+ D (D_Debug, "Do_RPC - Resume");
+
+ declare
+ New_Result : aliased Params_Stream_Type (R_Length);
+ begin
+
+ -- Adjust the Result stream size right now to be able to load
+ -- the stream in one receive call. Create a temporary resutl
+ -- that will be substituted to Do_RPC one
+
+ Streams.Allocate (New_Result);
+
+ -- Receive the reply message from receiving stub
+
+ D (D_Communication, "Do_RPC - Receive Result from partition" &
+ Partition_ID'Image (Partition));
+ Garlic.Receive
+ (Protocol.all,
+ Partition,
+ New_Result'Access);
+
+ -- Let Garlic know we have nothing else to receive
+
+ Garlic.Complete_Receive
+ (Protocol.all,
+ Partition);
+
+ -- Update calling stub Result stream
+
+ D (D_Debug, "Do_RPC - Reconstruct Result");
+ Streams.Deallocate (Result.all);
+ Result.Initial := New_Result.Initial;
+ Streams.Dump ("|||", Result.all);
+
+ end;
+
+ else
+
+ -- Do RPC locally and first wait for Partition_RPC_Receiver to be
+ -- set
+
+ Partition_Receiver.Is_Set;
+ D (D_Debug, "Do_RPC - Locally");
+ Partition_RPC_Receiver.all (Params, Result);
+
+ end if;
+
+ exception when others =>
+ D (D_Exception, "exception in Do_RPC");
+ raise;
+ end Do_RPC;
+
+ ------------
+ -- Do_APC --
+ ------------
+
+ procedure Do_APC
+ (Partition : in Partition_ID;
+ Params : access Params_Stream_Type) is
+ Message_Id : Message_Id_Type := 0;
+ Protocol : Protocol_Access;
+ Header : aliased Params_Stream_Type (Header_Size);
+ begin
+
+ -- For more informations, see above
+ -- Request = 0 as we are not waiting for a reply message
+ -- Result length = 0 as we don't expect a result at all
+
+ if Partition /= Garlic.Get_My_Partition_ID then
+
+ -- Build header = request (2) + result.initial_size (3)
+ -- As we have an APC, the request id is null to indicate
+ -- to the receiving stub that we do not expect a reply
+ -- This comes from 0 = -0
+
+ D (D_Debug, "Do_APC - Build Header");
+ Streams.Allocate (Header);
+ Streams.Integer_Write_Attribute
+ (Header'Access, Integer (Message_Id));
+ Streams.SEC_Write_Attribute
+ (Header'Access, 0);
+
+ -- Get a protocol method to communicate with the remote partition
+ -- and give the message size
+
+ D (D_Communication,
+ "Do_APC - Lookup for protocol to talk to partition" &
+ Partition_ID'Image (Partition));
+ Garlic.Initiate_Send
+ (Partition,
+ Streams.Get_Stream_Size (Header'Access) +
+ Streams.Get_Stream_Size (Params),
+ Protocol,
+ Garlic.Remote_Call);
+
+ -- Send the header by using the protocol method
+
+ D (D_Communication, "Do_APC - Send Header to partition" &
+ Partition_ID'Image (Partition));
+ Garlic.Send
+ (Protocol.all,
+ Partition,
+ Header'Access);
+
+ -- The header is deallocated
+
+ Streams.Deallocate (Header);
+
+ -- Send Params from Do_APC
+
+ D (D_Communication, "Do_APC - Send Params to partition" &
+ Partition_ID'Image (Partition));
+ Garlic.Send
+ (Protocol.all,
+ Partition,
+ Params);
+
+ -- Let Garlic know we have nothing else to send
+
+ Garlic.Complete_Send
+ (Protocol.all,
+ Partition);
+ else
+
+ declare
+ Result : aliased Params_Stream_Type (0);
+ begin
+
+ -- Result is here a dummy parameter
+ -- No reason to deallocate as it is not allocated at all
+
+ Partition_Receiver.Is_Set;
+ D (D_Debug, "Do_APC - Locally");
+ Partition_RPC_Receiver.all (Params, Result'Access);
+
+ end;
+
+ end if;
+
+ exception when others =>
+ D (D_Exception, "exception in Do_APC");
+ raise;
+ end Do_APC;
+
+ ----------------------------
+ -- Establish_RPC_Receiver --
+ ----------------------------
+
+ procedure Establish_RPC_Receiver (
+ Partition : in Partition_ID;
+ Receiver : in RPC_Receiver) is
+ begin
+
+ -- Set Partition_RPC_Receiver and allow RPC mechanism
+
+ Partition_RPC_Receiver := Receiver;
+ Partition_Receiver.Set;
+ D (D_Elaborate, "Partition_Receiver is set");
+
+ exception when others =>
+ D (D_Exception, "exception in Establish_RPC_Receiver");
+ raise;
+ end Establish_RPC_Receiver;
+
+ ----------------
+ -- Dispatcher --
+ ----------------
+
+ task body Dispatcher is
+ Last_Request : Request_Id_Type := Request_Id_Type'First;
+ Current_Rqst : Request_Id_Type := Request_Id_Type'First;
+ Current_Size : Ada.Streams.Stream_Element_Count;
+ begin
+
+ loop
+
+ -- Three services :
+ -- New_Request to get an entry in Dispatcher table
+ -- Wait_On for Do_RPC calls
+ -- Wake_Up called by environment task when a Do_RPC receives
+ -- the result of its remote call
+
+ select
+
+ accept New_Request
+ (Request : out Request_Id_Type) do
+ Request := Last_Request;
+
+ -- << TODO >>
+ -- Avaibility check
+
+ if Last_Request = Request_Id_Type'Last then
+ Last_Request := Request_Id_Type'First;
+ else
+ Last_Request := Last_Request + 1;
+ end if;
+
+ end New_Request;
+
+ or
+
+ accept Wake_Up
+ (Request : in Request_Id_Type;
+ Length : in Ada.Streams.Stream_Element_Count) do
+
+ -- The environment reads the header and has been notified
+ -- of the reply id and the size of the result message
+
+ Current_Rqst := Request;
+ Current_Size := Length;
+
+ end Wake_Up;
+
+ -- << TODO >>
+ -- Must be select with delay for aborted tasks
+
+ select
+
+ accept Wait_On (Current_Rqst)
+ (Length : out Ada.Streams.Stream_Element_Count) do
+ Length := Current_Size;
+ end Wait_On;
+
+ or
+
+ -- To free the Dispatcher when a task is aborted
+
+ delay 1.0;
+
+ end select;
+
+ or
+
+ terminate;
+
+ end select;
+
+ end loop;
+
+ exception when others =>
+ D (D_Exception, "exception in Dispatcher body");
+ raise;
+ end Dispatcher;
+
+ -------------------------
+ -- Anonymous_Task_Type --
+ -------------------------
+
+ task body Anonymous_Task_Type is
+ Whoami : Anonymous_Task_Node_Access := Self;
+ C_Message_Id : Message_Id_Type; -- Current Message Id
+ C_Partition : Partition_ID; -- Current Partition
+ Params_S : Ada.Streams.Stream_Element_Count; -- Params message size
+ Result_S : Ada.Streams.Stream_Element_Count; -- Result message size
+ C_Protocol : Protocol_Access; -- Current Protocol
+ begin
+
+ loop
+
+ -- Get a new RPC to execute
+
+ select
+ accept Start
+ (Message_Id : in Message_Id_Type;
+ Partition : in Partition_ID;
+ Params_Size : in Ada.Streams.Stream_Element_Count;
+ Result_Size : in Ada.Streams.Stream_Element_Count;
+ Protocol : in Protocol_Access) do
+ C_Message_Id := Message_Id;
+ C_Partition := Partition;
+ Params_S := Params_Size;
+ Result_S := Result_Size;
+ C_Protocol := Protocol;
+ end Start;
+ or
+ terminate;
+ end select;
+
+ declare
+ Params : aliased Params_Stream_Type (Params_S);
+ Result : aliased Params_Stream_Type (Result_S);
+ Header : aliased Params_Stream_Type (Header_Size);
+ begin
+
+ -- We reconstruct all the client context : Params and Result
+ -- with the SAME size, then we receive Params from calling stub
+
+ D (D_Communication,
+ "Anonymous Task - Receive Params from partition" &
+ Partition_ID'Image (C_Partition));
+ Garlic.Receive
+ (C_Protocol.all,
+ C_Partition,
+ Params'Access);
+
+ -- Let Garlic know we don't receive anymore
+
+ Garlic.Complete_Receive
+ (C_Protocol.all,
+ C_Partition);
+
+ -- Check that Partition_RPC_Receiver has been set
+
+ Partition_Receiver.Is_Set;
+
+ -- Do it locally
+
+ D (D_Debug,
+ "Anonymous Task - Perform Partition_RPC_Receiver for request" &
+ Message_Id_Type'Image (C_Message_Id));
+ Partition_RPC_Receiver (Params'Access, Result'Access);
+
+ -- If this was a RPC we send the result back
+ -- Otherwise, do nothing else than deallocation
+
+ if C_Message_Id /= 0 then
+
+ -- Build Header = -C_Message_Id + Result Size
+ -- Provide the request id to the env task of the calling
+ -- stub partition We get the real result stream size : the
+ -- calling stub (in Do_RPC) updates its size to this one
+
+ D (D_Debug, "Anonymous Task - Build Header");
+ Streams.Allocate (Header);
+ Streams.Integer_Write_Attribute
+ (Header'Access, Integer (-C_Message_Id));
+ Streams.SEC_Write_Attribute
+ (Header'Access,
+ Streams.Get_Stream_Size (Result'Access));
+
+
+ -- Get a protocol method to comunicate with the remote
+ -- partition and give the message size
+
+ D (D_Communication,
+ "Anonymous Task - Lookup for protocol talk to partition" &
+ Partition_ID'Image (C_Partition));
+ Garlic.Initiate_Send
+ (C_Partition,
+ Streams.Get_Stream_Size (Header'Access) +
+ Streams.Get_Stream_Size (Result'Access),
+ C_Protocol,
+ Garlic.Remote_Call);
+
+ -- Send the header by using the protocol method
+
+ D (D_Communication,
+ "Anonymous Task - Send Header to partition" &
+ Partition_ID'Image (C_Partition));
+ Garlic.Send
+ (C_Protocol.all,
+ C_Partition,
+ Header'Access);
+
+ -- Send Result toDo_RPC
+
+ D (D_Communication,
+ "Anonymous Task - Send Result to partition" &
+ Partition_ID'Image (C_Partition));
+ Garlic.Send
+ (C_Protocol.all,
+ C_Partition,
+ Result'Access);
+
+ -- Let Garlic know we don't send anymore
+
+ Garlic.Complete_Send
+ (C_Protocol.all,
+ C_Partition);
+ Streams.Deallocate (Header);
+
+ end if;
+
+ Streams.Deallocate (Params);
+ Streams.Deallocate (Result);
+
+ end;
+
+ -- Enqueue into the anonymous task free list : become inactive
+
+ Garbage_Collector.Deallocate (Whoami);
+
+ end loop;
+
+ exception when others =>
+ D (D_Exception, "exception in Anonymous_Task_Type body");
+ raise;
+ end Anonymous_Task_Type;
+
+ -----------------
+ -- Environment --
+ -----------------
+
+ task body Environnement is
+ Partition : Partition_ID;
+ Message_Size : Ada.Streams.Stream_Element_Count;
+ Result_Size : Ada.Streams.Stream_Element_Count;
+ Message_Id : Message_Id_Type;
+ Header : aliased Params_Stream_Type (Header_Size);
+ Protocol : Protocol_Access;
+ Anonymous : Anonymous_Task_Node_Access;
+ begin
+
+ -- Wait the Partition_RPC_Receiver to be set
+
+ accept Start;
+ D (D_Elaborate, "Environment task elaborated");
+
+ loop
+
+ -- We receive first a fixed size message : the header
+ -- Header = Message Id + Message Size
+
+ Streams.Allocate (Header);
+
+ -- Garlic provides the size of the received message and the
+ -- protocol to use to communicate with the calling partition
+
+ Garlic.Initiate_Receive
+ (Partition,
+ Message_Size,
+ Protocol,
+ Garlic.Remote_Call);
+ D (D_Communication,
+ "Environment task - Receive protocol to talk to active partition" &
+ Partition_ID'Image (Partition));
+
+ -- Extract the header to route the message either to
+ -- an anonymous task (Message Id > 0 <=> Request Id)
+ -- or to a waiting task (Message Id < 0 <=> Reply Id)
+
+ D (D_Communication,
+ "Environment task - Receive Header from partition" &
+ Partition_ID'Image (Partition));
+ Garlic.Receive
+ (Protocol.all,
+ Partition,
+ Header'Access);
+
+ -- Evaluate the remaining size of the message
+
+ Message_Size := Message_Size -
+ Streams.Get_Stream_Size (Header'Access);
+
+ -- Extract from header : message id and message size
+
+ Streams.Integer_Read_Attribute (Header'Access, Message_Id);
+ Streams.SEC_Read_Attribute (Header'Access, Result_Size);
+
+ if Streams.Get_Stream_Size (Header'Access) /= 0 then
+
+ -- If there are stream elements left in the header ???
+
+ D (D_Exception, "Header is not empty");
+ raise Program_Error;
+
+ end if;
+
+ if Message_Id < 0 then
+
+ -- The message was sent by a receiving stub : wake up the
+ -- calling task - We have a reply there
+
+ D (D_Debug, "Environment Task - Receive Reply from partition" &
+ Partition_ID'Image (Partition));
+ Dispatcher.Wake_Up (-Message_Id, Result_Size);
+
+ else
+
+ -- The message was send by a calling stub : get an anonymous
+ -- task to perform the job
+
+ D (D_Debug, "Environment Task - Receive Request from partition" &
+ Partition_ID'Image (Partition));
+ Garbage_Collector.Allocate (Anonymous);
+
+ -- We substracted the size of the header from the size of the
+ -- global message in order to provide immediatly Params size
+
+ Anonymous.Element.Start
+ (Message_Id,
+ Partition,
+ Message_Size,
+ Result_Size,
+ Protocol);
+
+ end if;
+
+ -- Deallocate header : unnecessary - WARNING
+
+ Streams.Deallocate (Header);
+
+ end loop;
+
+ exception when others =>
+ D (D_Exception, "exception in Environment");
+ raise;
+ end Environnement;
+
+begin
+
+ -- Set debugging information
+
+ Debugging.Set_Environment_Variable ("RPC");
+ Debugging.Set_Debugging_Name ("D", D_Debug);
+ Debugging.Set_Debugging_Name ("E", D_Exception);
+ Debugging.Set_Debugging_Name ("C", D_Communication);
+ Debugging.Set_Debugging_Name ("Z", D_Elaborate);
+ D (D_Elaborate, "To be elaborated");
+
+ -- When this body is elaborated we should ensure that RCI name server
+ -- has been already elaborated : this means that Establish_RPC_Receiver
+ -- has already been called and that Partition_RPC_Receiver is set
+
+ Environnement.Start;
+ D (D_Elaborate, "ELABORATED");
+
+end System.RPC;
--- /dev/null
+# Top level makefile fragment for GNU Ada (GNAT).
+# Copyright (C) 1994, 1995, 1996, 1997, 1997, 1999, 2000, 2001
+# Free Software Foundation, Inc.
+
+#This file is part of GNU CC.
+
+#GNU CC is free software; you can redistribute it and/or modify
+#it under the terms of the GNU General Public License as published by
+#the Free Software Foundation; either version 2, or (at your option)
+#any later version.
+
+#GNU CC is distributed in the hope that it will be useful,
+#but WITHOUT 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
+#along with GNU CC; see the file COPYING. If not, write to
+#the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+# This file provides the language dependent support in the main Makefile.
+# Each language makefile fragment must provide the following targets:
+#
+# foo.all.build, foo.all.cross, foo.start.encap, foo.rest.encap,
+# foo.info, foo.dvi,
+# foo.install-normal, foo.install-common, foo.install-info, foo.install-man,
+# foo.uninstall, foo.mostlyclean, foo.clean, foo.distclean, foo.extraclean,
+# foo.maintainer-clean, foo.stage1, foo.stage2, foo.stage3, foo.stage4
+#
+# where `foo' is the name of the language.
+#
+# It should also provide rules for:
+#
+# - making any compiler driver (eg: g++)
+# - the compiler proper (eg: cc1plus)
+# - define the names for selecting the language in LANGUAGES.
+# tool definitions
+CHMOD = chmod
+CHMOD_AX_FLAGS = a+x
+MV = mv
+MKDIR = mkdir -p
+RM = rm -f
+RMDIR = rm -rf
+# default extensions
+shext =
+\f
+# Extra flags to pass to recursive makes.
+BOOT_ADAFLAGS= $(ADAFLAGS)
+ADAFLAGS= -gnatpg -gnata
+GNATLIBFLAGS= -gnatpg
+GNATLIBCFLAGS= -g -O2
+ADA_INCLUDE_DIR = $(libsubdir)/adainclude
+ADA_RTL_OBJ_DIR = $(libsubdir)/adalib
+THREAD_KIND=native
+GNATBIND = gnatbind
+ADA_FLAGS_TO_PASS = \
+ "ADA_FOR_BUILD=$(ADA_FOR_BUILD)" \
+ "ADA_INCLUDE_DIR=$(ADA_INCLUDE_DIR)" \
+ "ADA_RTL_OBJ_DIR=$(ADA_RTL_OBJ_DIR)" \
+ "ADAFLAGS=$(ADAFLAGS)" \
+ "ADA_FOR_TARGET=$(ADA_FOR_TARGET)" \
+ "INSTALL_DATA=$(INSTALL_DATA)" \
+ "INSTALL_PROGRAM=$(INSTALL_PROGRAM)"
+
+# Define the names for selecting Ada in LANGUAGES.
+Ada ada: gnat1$(exeext) gnatbind$(exeext)
+
+# Tell GNU Make to ignore these, if they exist.
+.PHONY: Ada ada
+
+# There are too many Ada sources to check against here. Let's
+# always force the recursive make.
+gnat1$(exeext): prefix.o $(LIBDEPS) $(BACKEND) force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
+ ../gnat1$(exeext)
+
+gnatbind$(exeext): force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
+ ../gnatbind$(exeext)
+
+gnatmake$(exeext): force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
+ ../gnatmake$(exeext)
+
+gnatbl$(exeext): force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
+ ../gnatbl$(exeext)
+
+gnatchop$(exeext): force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
+ ../gnatchop$(exeext)
+
+gnatcmd$(exeext): force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
+ ../gnatcmd$(exeext)
+
+gnatlink$(exeext): force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
+ ../gnatlink$(exeext)
+
+gnatkr$(exeext): force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
+ ../gnatkr$(exeext)
+
+gnatls$(exeext): force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
+ ../gnatls$(exeext)
+
+gnatmem$(exeext): force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
+ ../gnatmem$(exeext)
+
+gnatprep$(exeext): force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
+ ../gnatprep$(exeext)
+
+gnatpsta$(exeext): force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
+ ../gnatpsta$(exeext)
+
+gnatpsys$(exeext): force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
+ ../gnatpsys$(exeext)
+
+gnatxref$(exeext): force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
+ ../gnatxref$(exeext)
+
+gnatfind$(exeext): force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
+ ../gnatfind$(exeext)
+
+# Gnatlbr is extra tool only used on VMS
+
+gnatlbr$(exeext): force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
+ ../gnatlbr$(exeext)
+
+# use target-gcc
+gnattools: $(GCC_PARTS) force
+ $(MAKE) $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
+ CC="../xgcc -B../" STAGE_PREFIX=../ \
+ gnatbl$(exeext) gnatchop$(exeext) gnatcmd$(exeext) \
+ gnatkr$(exeext) gnatlink$(exeext) \
+ gnatls$(exeext) gnatmake$(exeext) gnatmem$(exeext) \
+ gnatprep$(exeext) gnatpsta$(exeext) gnatpsys$(exeext) \
+ gnatxref$(exeext) gnatfind$(exeext) $(EXTRA_GNATTOOLS)
+
+# use host-gcc
+cross-gnattools: force
+ $(MAKE) $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
+ gnatbl$(exeext) gnatchop$(exeext) gnatcmd$(exeext) \
+ gnatkr$(exeext) gnatlink$(exeext) \
+ gnatls$(exeext) gnatmake$(exeext) gnatmem$(exeext) \
+ gnatprep$(exeext) gnatpsta$(exeext) gnatpsys$(exeext) \
+ gnatxref$(exeext) gnatfind$(exeext) $(EXTRA_GNATTOOLS)
+
+gnatlib: force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) \
+ GNATLIBFLAGS="$(GNATLIBFLAGS)" \
+ GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \
+ TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" \
+ THREAD_KIND="$(THREAD_KIND)" \
+ gnatlib
+
+gnatlib-shared: force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) \
+ GNATLIBFLAGS="$(GNATLIBFLAGS)" \
+ GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \
+ GNATLIBLDFLAGS="$(GNATLIBLDFLAGS)" \
+ TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" \
+ THREAD_KIND="$(THREAD_KIND)" \
+ gnatlib-shared
+
+# use only for native compiler
+gnatlib_and_tools: gnatlib gnattools
+
+# use cross-gcc
+gnat-cross: force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) gnat-cross
+\f
+# Build hooks:
+
+ada.all.build:
+ada.all.cross:
+ -if [ -f gnatbind$(exeext) ] ; \
+ then \
+ $(MV) gnatbind$(exeext) gnatbind-cross$(exeext); \
+ fi
+ -if [ -f gnatbl$(exeext) ] ; \
+ then \
+ $(MV) gnatbl$(exeext) gnatbl-cross$(exeext); \
+ fi
+ -if [ -f gnatchop$(exeext) ] ; \
+ then \
+ $(MV) gnatchop$(exeext) gnatchop-cross$(exeext); \
+ fi
+ -if [ -f gnatcmd$(exeext) ] ; \
+ then \
+ $(MV) gnatcmd$(exeext) gnatcmd-cross$(exeext); \
+ fi
+ -if [ -f gnatkr$(exeext) ] ; \
+ then \
+ $(MV) gnatkr$(exeext) gnatkr-cross$(exeext); \
+ fi
+ -if [ -f gnatlink$(exeext) ] ; \
+ then \
+ $(MV) gnatlink$(exeext) gnatlink-cross$(exeext); \
+ fi
+ -if [ -f gnatls$(exeext) ] ; \
+ then \
+ $(MV) gnatls$(exeext) gnatls-cross$(exeext); \
+ fi
+ -if [ -f gnatmake$(exeext) ] ; \
+ then \
+ $(MV) gnatmake$(exeext) gnatmake-cross$(exeext); \
+ fi
+ -if [ -f gnatmem$(exeext) ] ; \
+ then \
+ $(MV) gnatmem$(exeext) gnatmem-cross$(exeext); \
+ fi
+ -if [ -f gnatprep$(exeext) ] ; \
+ then \
+ $(MV) gnatprep$(exeext) gnatprep-cross$(exeext); \
+ fi
+ -if [ -f gnatpsta$(exeext) ] ; \
+ then \
+ $(MV) gnatpsta$(exeext) gnatpsta-cross$(exeext); \
+ fi
+ -if [ -f gnatpsys$(exeext) ] ; \
+ then \
+ $(MV) gnatpsys$(exeext) gnatpsys-cross$(exeext); \
+ fi
+ -if [ -f gnatxref$(exeext) ] ; \
+ then \
+ $(MV) gnatxref$(exeext) gnatxref-cross$(exeext); \
+ fi
+ -if [ -f gnatfind$(exeext) ] ; \
+ then \
+ $(MV) gnatfind$(exeext) gnatfind-cross$(exeext); \
+ fi
+
+ada.start.encap:
+ada.rest.encap:
+ada.info:
+ada.dvi:
+\f
+# Install hooks:
+# gnat1 is installed elsewhere as part of $(COMPILERS).
+
+ada.install-normal:
+
+# Install the binder program as $(target_alias)-gnatbind
+# and also as either gnatbind (if native) or $(tooldir)/bin/gnatbind
+# likewise for gnatf, gnatchop, and gnatlink, gnatkr, gnatmake, gnatcmd,
+# gnatprep, gnatbl, gnatls, gnatxref, gnatfind
+ada.install-common:
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gnatbind-cross$(exeext) ] ; \
+ then \
+ $(RM) $(bindir)/$(target_alias)-gnatbind$(exeext); \
+ $(INSTALL_PROGRAM) gnatbind-cross$(exeext) $(bindir)/$(target_alias)-gnatbind$(exeext); \
+ if [ -d $(tooldir)/bin/. ] ; then \
+ rm -f $(tooldir)/bin/gnatbind$(exeext); \
+ $(INSTALL_PROGRAM) gnatbind-cross$(exeext) $(tooldir)/bin/gnatbind$(exeext); \
+ fi; \
+ else \
+ $(RM) $(bindir)/gnatbind$(exeext); \
+ $(INSTALL_PROGRAM) gnatbind$(exeext) $(bindir)/gnatbind$(exeext); \
+ fi ; \
+ fi
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gnatbl-cross$(exeext) ] ; \
+ then \
+ $(RM) $(bindir)/$(target_alias)-gnatbl$(exeext); \
+ $(INSTALL_PROGRAM) gnatbl-cross$(exeext) $(bindir)/$(target_alias)-gnatbl$(exeext); \
+ if [ -d $(tooldir)/bin/. ] ; then \
+ rm -f $(tooldir)/bin/gnatbl$(exeext); \
+ $(INSTALL_PROGRAM) gnatbl-cross$(exeext) $(tooldir)/bin/gnatbl$(exeext); \
+ fi; \
+ else \
+ $(RM) $(bindir)/gnatbl$(exeext); \
+ $(INSTALL_PROGRAM) gnatbl$(exeext) $(bindir)/gnatbl$(exeext); \
+ fi ; \
+ fi
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gnatchop-cross$(exeext) ] ; \
+ then \
+ $(RM) $(bindir)/$(target_alias)-gnatchop$(shext); \
+ $(INSTALL_PROGRAM) $(srcdir)/ada/gnatchop$(shext) $(bindir)/$(target_alias)-gnatchop$(shext); \
+ if [ -d $(tooldir)/bin/. ] ; then \
+ rm -f $(tooldir)/bin/gnatchop$(shext); \
+ $(INSTALL_PROGRAM) gnatchop$(shext) $(tooldir)/bin/gnatchop$(exeext); \
+ fi; \
+ else \
+ $(RM) $(bindir)/gnatchop$(shext); \
+ $(INSTALL_PROGRAM) $(srcdir)/ada/gnatchop$(shext) $(bindir)/gnatchop$(shext); \
+ fi ; \
+ fi
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gnatchop-cross$(exeext) ] ; \
+ then \
+ $(RM) $(bindir)/$(target_alias)-gnatchop$(exeext); \
+ $(INSTALL_PROGRAM) gnatchop-cross$(exeext) $(bindir)/$(target_alias)-gnatchop$(exeext); \
+ if [ -d $(tooldir)/bin/. ] ; then \
+ rm -f $(tooldir)/bin/gnatchop$(exeext); \
+ $(INSTALL_PROGRAM) gnatchop-cross$(exeext) $(tooldir)/bin/gnatchop$(exeext); \
+ fi; \
+ else \
+ $(RM) $(bindir)/gnatchop$(exeext); \
+ $(INSTALL_PROGRAM) gnatchop$(exeext) $(bindir)/gnatchop$(exeext); \
+ fi ; \
+ fi
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gnatcmd-cross$(exeext) ] ; \
+ then \
+ $(RM) $(bindir)/$(target_alias)-gnat$(exeext); \
+ $(INSTALL_PROGRAM) gnatcmd-cross$(exeext) $(bindir)/$(target_alias)-gnat$(exeext); \
+ if [ -d $(tooldir)/bin/. ] ; then \
+ rm -f $(tooldir)/bin/gnat$(exeext); \
+ $(INSTALL_PROGRAM) gnatcmd-cross$(exeext) $(tooldir)/bin/gnat$(exeext); \
+ fi; \
+ else \
+ $(RM) $(bindir)/gnat$(exeext); \
+ $(INSTALL_PROGRAM) gnatcmd$(exeext) $(bindir)/gnat$(exeext); \
+ fi ; \
+ fi
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gnatkr-cross$(exeext) ] ; \
+ then \
+ $(RM) $(bindir)/$(target_alias)-gnatkr$(exeext); \
+ $(INSTALL_PROGRAM) gnatkr-cross$(exeext) $(bindir)/$(target_alias)-gnatkr$(exeext); \
+ if [ -d $(tooldir)/bin/. ] ; then \
+ rm -f $(tooldir)/bin/gnatkr$(exeext); \
+ $(INSTALL_PROGRAM) gnatkr-cross$(exeext) $(tooldir)/bin/gnatkr$(exeext); \
+ fi; \
+ else \
+ $(RM) $(bindir)/gnatkr$(exeext); \
+ $(INSTALL_PROGRAM) gnatkr$(exeext) $(bindir)/gnatkr$(exeext); \
+ fi ; \
+ fi
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gnatlink-cross$(exeext) ] ; \
+ then \
+ $(RM) $(bindir)/$(target_alias)-gnatlink$(exeext); \
+ $(INSTALL_PROGRAM) gnatlink-cross$(exeext) $(bindir)/$(target_alias)-gnatlink$(exeext); \
+ if [ -d $(tooldir)/bin/. ] ; then \
+ rm -f $(tooldir)/bin/gnatlink$(exeext); \
+ $(INSTALL_PROGRAM) gnatlink-cross$(exeext) $(tooldir)/bin/gnatlink$(exeext); \
+ fi; \
+ else \
+ $(RM) $(bindir)/gnatlink$(exeext); \
+ $(INSTALL_PROGRAM) gnatlink$(exeext) $(bindir)/gnatlink$(exeext); \
+ fi ; \
+ fi
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gnatls-cross$(exeext) ] ; \
+ then \
+ $(RM) $(bindir)/$(target_alias)-gnatls$(exeext); \
+ $(INSTALL_PROGRAM) gnatls-cross$(exeext) $(bindir)/$(target_alias)-gnatls$(exeext); \
+ if [ -d $(tooldir)/bin/. ] ; then \
+ rm -f $(tooldir)/bin/gnatls$(exeext); \
+ $(INSTALL_PROGRAM) gnatls-cross$(exeext) $(tooldir)/bin/gnatls$(exeext); \
+ fi; \
+ else \
+ $(RM) $(bindir)/gnatls$(exeext); \
+ $(INSTALL_PROGRAM) gnatls$(exeext) $(bindir)/gnatls$(exeext); \
+ fi ; \
+ fi
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gnatmake-cross$(exeext) ] ; \
+ then \
+ $(RM) $(bindir)/$(target_alias)-gnatmake$(exeext); \
+ $(INSTALL_PROGRAM) gnatmake-cross$(exeext) $(bindir)/$(target_alias)-gnatmake$(exeext); \
+ if [ -d $(tooldir)/bin/. ] ; then \
+ rm -f $(tooldir)/bin/gnatmake$(exeext); \
+ $(INSTALL_PROGRAM) gnatmake-cross$(exeext) $(tooldir)/bin/gnatmake$(exeext); \
+ fi; \
+ else \
+ $(RM) $(bindir)/gnatmake$(exeext); \
+ $(INSTALL_PROGRAM) gnatmake$(exeext) $(bindir)/gnatmake$(exeext); \
+ fi ; \
+ fi
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gnatmem-cross$(exeext) ] ; \
+ then \
+ $(RM) $(bindir)/$(target_alias)-gnatmem$(exeext); \
+ $(INSTALL_PROGRAM) gnatmem-cross$(exeext) $(bindir)/$(target_alias)-gnatmem$(exeext); \
+ else \
+ $(RM) $(bindir)/gnatmem$(exeext); \
+ $(INSTALL_PROGRAM) gnatmem$(exeext) $(bindir)/gnatmem$(exeext); \
+ fi ; \
+ fi
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gnatprep-cross$(exeext) ] ; \
+ then \
+ $(RM) $(bindir)/$(target_alias)-gnatprep$(exeext); \
+ $(INSTALL_PROGRAM) gnatprep-cross$(exeext) $(bindir)/$(target_alias)-gnatprep$(exeext); \
+ if [ -d $(tooldir)/bin/. ] ; then \
+ rm -f $(tooldir)/bin/gnatprep$(exeext); \
+ $(INSTALL_PROGRAM) gnatprep-cross$(exeext) $(tooldir)/bin/gnatprep$(exeext); \
+ fi; \
+ else \
+ $(RM) $(bindir)/gnatprep$(exeext); \
+ $(INSTALL_PROGRAM) gnatprep$(exeext) $(bindir)/gnatprep$(exeext); \
+ fi ; \
+ fi
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gnatpsta-cross$(exeext) ] ; \
+ then \
+ $(RM) $(bindir)/$(target_alias)-gnatpsta$(exeext); \
+ $(INSTALL_PROGRAM) gnatpsta-cross$(exeext) $(bindir)/$(target_alias)-gnatpsta$(exeext); \
+ if [ -d $(tooldir)/bin/. ] ; then \
+ rm -f $(tooldir)/bin/gnatpsta$(exeext); \
+ $(INSTALL_PROGRAM) gnatpsta-cross$(exeext) $(tooldir)/bin/gnatpsta$(exeext); \
+ fi; \
+ else \
+ $(RM) $(bindir)/gnatpsta$(exeext); \
+ $(INSTALL_PROGRAM) gnatpsta$(exeext) $(bindir)/gnatpsta$(exeext); \
+ fi ; \
+ fi
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gnatpsys-cross$(exeext) ] ; \
+ then \
+ $(RM) $(bindir)/$(target_alias)-gnatpsys$(exeext); \
+ $(INSTALL_PROGRAM) gnatpsys-cross$(exeext) $(bindir)/$(target_alias)-gnatpsys$(exeext); \
+ if [ -d $(tooldir)/bin/. ] ; then \
+ rm -f $(tooldir)/bin/gnatpsys$(exeext); \
+ $(INSTALL_PROGRAM) gnatpsys-cross$(exeext) $(tooldir)/bin/gnatpsys$(exeext); \
+ fi; \
+ else \
+ $(RM) $(bindir)/gnatpsys$(exeext); \
+ $(INSTALL_PROGRAM) gnatpsys$(exeext) $(bindir)/gnatpsys$(exeext); \
+ fi ; \
+ fi
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gnatxref-cross$(exeext) ] ; \
+ then \
+ $(RM) $(bindir)/$(target_alias)-gnatxref$(exeext); \
+ $(INSTALL_PROGRAM) gnatxref-cross$(exeext) $(bindir)/$(target_alias)-gnatxref$(exeext); \
+ else \
+ $(RM) $(bindir)/gnatxref$(exeext); \
+ $(INSTALL_PROGRAM) gnatxref$(exeext) $(bindir)/gnatxref$(exeext); \
+ fi ; \
+ fi
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gnatfind-cross$(exeext) ] ; \
+ then \
+ $(RM) $(bindir)/$(target_alias)-gnatfind$(exeext); \
+ $(INSTALL_PROGRAM) gnatfind-cross$(exeext) $(bindir)/$(target_alias)-gnatfind$(exeext); \
+ else \
+ $(RM) $(bindir)/gnatfind$(exeext); \
+ $(INSTALL_PROGRAM) gnatfind$(exeext) $(bindir)/gnatfind$(exeext); \
+ fi ; \
+ fi
+#
+# Gnatlbr is only use on VMS
+#
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gnatchop$(exeext) ] ; \
+ then \
+ $(RM) $(bindir)/gnatchop$(exeext); \
+ $(INSTALL_PROGRAM) gnatchop$(exeext) $(bindir)/gnatchop$(exeext); \
+ fi ; \
+ if [ -f gnatlbr$(exeext) ] ; \
+ then \
+ $(RM) $(bindir)/gnatlbr$(exeext); \
+ $(INSTALL_PROGRAM) gnatlbr$(exeext) $(bindir)/gnatlbr$(exeext); \
+ fi ; \
+ fi
+#
+# Gnatdll is only use on Windows
+#
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ $(RM) $(bindir)/gnatdll$(exeext); \
+ $(INSTALL_PROGRAM) gnatdll$(exeext) $(bindir)/gnatdll$(exeext); \
+ fi
+#
+# Finally, install the library
+#
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ $(MAKE) $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) install-gnatlib; \
+ fi
+
+install-gnatlib:
+ $(MAKE) -f ada/Makefile $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) install-gnatlib
+
+ada.install-info:
+ada.install-man:
+
+ada.uninstall:
+ -$(RM) $(bindir)/gnatbind$(exeext)
+ -$(RM) $(bindir)/gnatbl$(exeext)
+ -$(RM) $(bindir)/gnatchop$(exeext)
+ -$(RM) $(bindir)/gnatcmd$(exeext)
+ -$(RM) $(bindir)/gnatdll$(exeext)
+ -$(RM) $(bindir)/gnatkr$(exeext)
+ -$(RM) $(bindir)/gnatlink$(exeext)
+ -$(RM) $(bindir)/gnatls$(exeext)
+ -$(RM) $(bindir)/gnatmake$(exeext)
+ -$(RM) $(bindir)/gnatmem$(exeext)
+ -$(RM) $(bindir)/gnatprep$(exeext)
+ -$(RM) $(bindir)/gnatpsta$(exeext)
+ -$(RM) $(bindir)/gnatpsys$(exeext)
+ -$(RM) $(bindir)/$(target_alias)-gnatbind$(exeext)
+ -$(RM) $(bindir)/$(target_alias)-gnatbl$(exeext)
+ -$(RM) $(bindir)/$(target_alias)-gnatchop$(exeext)
+ -$(RM) $(bindir)/$(target_alias)-gnatcmd$(exeext)
+ -$(RM) $(bindir)/$(target_alias)-gnatkr(exeext)
+ -$(RM) $(bindir)/$(target_alias)-gnatlink$(exeext)
+ -$(RM) $(bindir)/$(target_alias)-gnatls$(exeext)
+ -$(RM) $(bindir)/$(target_alias)-gnatmake$(exeext)
+ -$(RM) $(bindir)/$(target_alias)-gnatmem$(exeext)
+ -$(RM) $(bindir)/$(target_alias)-gnatprep$(exeext)
+ -$(RM) $(bindir)/$(target_alias)-gnatpsta$(exeext)
+ -$(RM) $(bindir)/$(target_alias)-gnatpsys$(exeext)
+ -$(RM) $(tooldir)/bin/gnatbind$(exeext)
+ -$(RM) $(tooldir)/bin/gnatbl$(exeext)
+ -$(RM) $(tooldir)/bin/gnatchop$(exeext)
+ -$(RM) $(tooldir)/bin/gnatcmd$(exeext)
+ -$(RM) $(tooldir)/bin/gnatdll$(exeext)
+ -$(RM) $(tooldir)/bin/gnatkr$(exeext)
+ -$(RM) $(tooldir)/bin/gnatlink$(exeext)
+ -$(RM) $(tooldir)/bin/gnatls$(exeext)
+ -$(RM) $(tooldir)/bin/gnatmake$(exeext)
+ -$(RM) $(tooldir)/bin/gnatmem$(exeext)
+ -$(RM) $(tooldir)/bin/gnatprep$(exeext)
+ -$(RM) $(tooldir)/bin/gnatpsta$(exeext)
+ -$(RM) $(tooldir)/bin/gnatpsys$(exeext)
+# Gnatlbr and Gnatchop are only used on VMS
+ -$(RM) $(bindir)/gnatlbr$(exeext) $(bindir)/gnatchop$(exeext)
+\f
+# Clean hooks:
+# A lot of the ancillary files are deleted by the main makefile.
+# We just have to delete files specific to us.
+
+ada.mostlyclean:
+ -$(RM) ada/*$(objext) ada/*.ali ada/b_*.c
+ -$(RM) ada/sdefault.adb ada/stamp-sdefault
+ -$(RMDIR) ada/tools
+ada.clean:
+ada.distclean:
+ -$(RM) ada/Makefile
+ -$(RM) gnatbl$(exeext)
+ -$(RM) gnatchop$(exeext)
+ -$(RM) gnatcmd$(exeext)
+ -$(RM) gnatdll$(exeext)
+ -$(RM) gnatkr$(exeext)
+ -$(RM) gnatlink$(exeext)
+ -$(RM) gnatls$(exeext)
+ -$(RM) gnatmake$(exeext)
+ -$(RM) gnatmem$(exeext)
+ -$(RM) gnatprep$(exeext)
+ -$(RM) gnatpsta$(exeext)
+ -$(RM) gnatpsys$(exeext)
+ -$(RM) gnatfind$(exeext)
+ -$(RM) gnatxref$(exeext)
+# Gnatlbr and Gnatchop are only used on VMS
+ -$(RM) gnatchop$(exeext) gnatlbr$(exeext)
+ -$(RM) ada/rts/*
+ -$(RMDIR) ada/rts
+ -$(RMDIR) ada/tools
+ada.extraclean:
+ada.maintainer-clean:
+ -$(RM) ada/a-sinfo.h
+ -$(RM) ada/a-einfo.h
+ -$(RM) ada/nmake.adb
+ -$(RM) ada/nmake.ads
+ -$(RM) ada/treeprs.ads
+\f
+# Stage hooks:
+# The main makefile has already created stage?/ada
+
+ada.stage1:
+ -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stage1/ada
+ -$(MV) ada/stamp-* stage1/ada
+ada.stage2:
+ -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stage2/ada
+ -$(MV) ada/stamp-* stage2/ada
+ada.stage3:
+ -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stage3/ada
+ -$(MV) ada/stamp-* stage3/ada
+ada.stage4:
+ -$(MV) ada/*$(objext) ada/*.ali ada/b_*.c stage4/ada
+ -$(MV) ada/stamp-* stage4/ada
+
+check-ada:
+\f
+# Bootstrapping targets for just GNAT - use the same stage directories
+gnatboot: force
+ -$(RM) gnatboot3
+ $(MAKE) gnat1$(exeext) gnatbind$(exeext) CC="$(CC)" \
+ CFLAGS="$(CFLAGS)"
+ $(MAKE) gnatboot2 BOOT_CFLAGS="$(BOOT_CFLAGS)" \
+ BOOT_ADAFLAGS="$(BOOT_ADAFLAGS)" \
+ LDFLAGS="$(BOOT_LDFLAGS)"
+
+gnatboot2: force
+ $(MAKE) gnatstage1
+ $(MAKE) gnat1$(exeext) gnatbind$(exeext) CC="gcc -B../stage1/"\
+ CFLAGS="$(BOOT_CFLAGS)" \
+ ADAFLAGS="$(BOOT_ADAFLAGS)"\
+ LDFLAGS="$(BOOT_LDFLAGS)" \
+ STAGE_PREFIX=../stage1/
+ $(MAKE) gnatboot3 BOOT_CFLAGS="$(BOOT_CFLAGS)" \
+ BOOT_ADAFLAGS="$(BOOT_ADAFLAGS)" \
+ LDFLAGS="$(BOOT_LDFLAGS)"
+
+gnatboot3:
+ $(MAKE) gnatstage2
+ $(MAKE) gnat1$(exeext) gnatbind$(exeext) CC="gcc -B../stage2/"\
+ CFLAGS="$(BOOT_CFLAGS)" \
+ ADAFLAGS="$(BOOT_ADAFLAGS)"\
+ LDFLAGS="$(BOOT_LDFLAGS)" \
+ STAGE_PREFIX=../stage2/
+
+gnatstage1: force
+ -$(MKDIR) stage1
+ -$(MKDIR) stage1/ada
+ -$(MV) gnat1$(exeext) gnatbind$(exeext) stage1
+ -$(MV) ada/*$(objext) ada/*.ali stage1/ada
+ -$(MV) ada/stamp-* stage1/ada
+
+gnatstage2: force
+ -$(MKDIR) stage2
+ -$(MKDIR) stage2/ada
+ -$(MV) gnat1$(exeext) gnatbind$(exeext) stage2
+ -$(MV) ada/*$(objext) ada/*.ali stage2/ada
+ -$(MV) ada/stamp-* stage2/ada
--- /dev/null
+# This is the Unix/NT makefile used to build an alternate GNAT run-time.
+# Note that no files in the original GNAT library dirctory will be
+# modified by this procedure
+#
+# This Makefile requires Gnu make.
+# Here is how to use this Makefile
+#
+# 1. Create a new directory (say adalib)
+# e.g. $ mkdir adalib
+# $ cd adalib
+#
+# 2. Copy this Makefile from the standard Adalib directory, e.g.
+# $ cp /usr/local/gnat/lib/gcc-lib/<target>/2.8.1/adalib/Makefile.adalib .
+#
+# 3. Copy or create a gnat.adc containing the configuration pragmas
+# you want to use to build the library
+# e.g. $ cp ~/gnat.adc gnat.adc
+#
+# 4. Determine the values of the following MACROS
+# ROOT (location of GNAT installation, e.g /usr/local)
+# and optionnally
+# CFLAGS (back end compilation flags such as -g -O2)
+# ADAFLAGS (front end compilation flags such as -gnatpgn)
+# *beware* the minimum value for this MACRO is -gnatpg
+# for proper compilation of the GNAT library
+# 5a. If you are using a native compile, call make
+# e.g. $ make -f Makefile.adalib ROOT=/usr/local CFLAGS="-g -O0"
+#
+# 5b. If you are using a cross compiler, you need to define two additional
+# MACROS:
+# CC (name of the cross compiler)
+# AR (name of the cross ar)
+#
+# e.g. $ make -f Makefile.adalib ROOT=/opt/gnu/gnat \
+# CFLAGS="-O2 -g -I/usr/wind/target/h" CC=powerpc-wrs-vxworks-gcc \
+# AR=arppc
+#
+# 6. put this new library on your Object PATH where you want to use it
+# in place of the original one. This can be achieved for instance by
+# updating the value of the environment variable ADA_OBJECTS_PATH
+
+SHELL=sh
+
+CC = gcc
+AR = ar
+GNAT_ROOT = $(shell cd $(ROOT);pwd)/
+target = $(shell $(CC) -dumpmachine)
+version = $(shell $(CC) -dumpversion)
+ADA_INCLUDE_PATH = $(GNAT_ROOT)lib/gcc-lib/$(target)/$(version)/adainclude/
+ADA_OBJECTS_PATH = $(GNAT_ROOT)lib/gcc-lib/$(target)/$(version)/adalib/
+
+vpath %.adb $(ADA_INCLUDE_PATH)
+vpath %.ads $(ADA_INCLUDE_PATH)
+vpath %.c $(ADA_INCLUDE_PATH)
+vpath %.h $(ADA_INCLUDE_PATH)
+
+CFLAGS = -O2
+ADAFLAGS = -gnatpgn
+ALL_ADAFLAGS = $(CFLAGS) $(ADA_CFLAGS) $(ADAFLAGS) -I.
+FORCE_DEBUG_ADAFLAGS = -g
+INCLUDES = -I$(ADA_INCLUDE_PATH)
+
+# Say how to compile Ada programs.
+.SUFFIXES: .ada .adb .ads
+
+.c.o:
+ $(CC) -c $(CFLAGS) $(ADA_CFLAGS) $(INCLUDES) $<
+.adb.o:
+ $(CC) -c $(ALL_ADAFLAGS) $<
+.ads.o:
+ $(CC) -c $(ALL_ADAFLAGS) $<
+
+GNAT_OBJS :=$(filter-out prefix.o __%,$(shell $(AR) t $(ADA_OBJECTS_PATH)libgnat.a))
+GNARL_OBJS:=$(filter-out __%,$(shell $(AR) t $(ADA_OBJECTS_PATH)libgnarl.a))
+OBJS := $(GNAT_OBJS) $(GNARL_OBJS)
+
+all: libgnat.a libgnarl.a
+ chmod 0444 *.ali *.a
+ rm *.o
+
+libgnat.a: $(GNAT_OBJS)
+ $(AR) r libgnat.a $(GNAT_OBJS)
+
+libgnarl.a: $(GNARL_OBJS)
+ $(AR) r libgnarl.a $(GNARL_OBJS)
+
+a-except.o: a-except.adb a-except.ads
+ $(CC) -c $(FORCE_DEBUG_ADAFLAGS) $(ALL_ADAFLAGS) -O0 -fno-inline $<
+
+s-assert.o: s-assert.adb s-assert.ads a-except.ads
+ $(CC) -c $(FORCE_DEBUG_ADAFLAGS) $(ALL_ADAFLAGS) $<
+
+s-tasdeb.o: s-tasdeb.adb
+ $(CC) -c $(FORCE_DEBUG_ADAFLAGS) $(ALL_ADAFLAGS) $<
+
+s-vaflop.o: s-vaflop.adb
+ $(CC) -c $(FORCE_DEBUG_ADAFLAGS) -O $(ALL_ADAFLAGS) $<
+
+s-memory.o: s-memory.adb s-memory.ads
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) $<
+
+a-init.o: a-init.c a-ada.h a-types.h a-raise.h
+ $(CC) -c $(CFLAGS) $(ADA_CFLAGS) \
+ $(ALL_CPPFLAGS) $(INCLUDES) -fexceptions $<
+
+a-traceb.o: a-traceb.c
+ $(CC) -c $(CFLAGS) $(ADA_CFLAGS) \
+ $(ALL_CPPFLAGS) $(INCLUDES) -fno-omit-frame-pointer $<
+
+prefix.o: prefix.c gansidecl.h
+ $(CC) -c $(CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \
+ -DPREFIX=\"$(GNAT_ROOT)\" $<
--- /dev/null
+# Makefile for GNU Ada Compiler (GNAT).
+# Copyright (C) 1994-2001 Free Software Foundation, Inc.
+
+#This file is part of GNU CC.
+
+#GNU CC is free software; you can redistribute it and/or modify
+#it under the terms of the GNU General Public License as published by
+#the Free Software Foundation; either version 2, or (at your option)
+#any later version.
+
+#GNU CC is distributed in the hope that it will be useful,
+#but WITHOUT 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
+#along with GNU CC; see the file COPYING. If not, write to
+#the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+# The makefile built from this file lives in the language subdirectory.
+# It's purpose is to provide support for:
+#
+# 1) recursion where necessary, and only then (building .o's), and
+# 2) building and debugging cc1 from the language subdirectory, and
+# 3) nothing else.
+#
+# The parent makefile handles all other chores, with help from the
+# language makefile fragment, of course.
+#
+# The targets for external use are:
+# all, TAGS, ???mostlyclean, ???clean.
+
+# This makefile will only work with Gnu make.
+# The rules are written assuming a minimum subset of tools are available:
+#
+# Required:
+# MAKE: Only Gnu make will work.
+# MV: Must accept (at least) one, maybe wildcard, source argument,
+# a file or directory destination, and support creation/
+# modification date preservation. Gnu mv -f works.
+# RM: Must accept an arbitrary number of space separated file
+# arguments, or one wildcard argument. Gnu rm works.
+# RMDIR: Must delete a directory and all its contents. Gnu rm -rf works.
+# ECHO: Must support command line redirection. Any Unix-like
+# shell will typically provide this, otherwise a custom version
+# is trivial to write.
+# AR: Gnu ar works.
+# MKDIR: Gnu mkdir works.
+# CHMOD: Gnu chmod works.
+# true: Does nothing and returns a normal successful return code.
+# pwd: Prints the current directory on stdout.
+# cd: Change directory.
+#
+# Optional:
+# BISON: Gnu bison works.
+# FLEX: Gnu flex works.
+# Other miscellaneous tools for obscure targets.
+
+# Suppress smart makes who think they know how to automake Yacc files
+.y.c:
+
+# Variables that exist for you to override.
+# See below for how to change them for certain systems.
+
+ALLOCA =
+# Various ways of specifying flags for compilations:
+# CFLAGS is for the user to override to, e.g., do a bootstrap with -O2.
+# BOOT_CFLAGS is the value of CFLAGS to pass
+# to the stage2 and stage3 compilations
+# XCFLAGS is used for most compilations but not when using the GCC just built.
+XCFLAGS =
+CFLAGS = -g
+BOOT_CFLAGS = -O $(CFLAGS)
+# These exists to be overridden by the x-* and t-* files, respectively.
+X_CFLAGS =
+T_CFLAGS =
+
+X_CPPFLAGS =
+T_CPPFLAGS =
+
+CC = cc
+BISON = bison
+BISONFLAGS =
+ECHO = echo
+LEX = flex
+LEXFLAGS =
+CHMOD = chmod
+CP = cp -p
+MV = mv -f
+RM = rm -f
+RMDIR = rm -rf
+MKDIR = mkdir -p
+AR = ar
+AR_FLAGS = rc
+# How to invoke ranlib.
+RANLIB = ranlib
+# Test to use to see whether ranlib exists on the system.
+RANLIB_TEST = [ -f /usr/bin/ranlib -o -f /bin/ranlib ]
+SHELL = /bin/sh
+# How to copy preserving the date
+INSTALL_DATA_DATE = cp -p
+MAKEINFO = makeinfo
+TEXI2DVI = texi2dvi
+GNATBIND = $(STAGE_PREFIX)gnatbind -C
+ADA_CFLAGS =
+ADAFLAGS = -gnatpg -gnata
+SOME_ADAFLAGS =-gnata
+FORCE_DEBUG_ADAFLAGS = -g
+GNATLIBFLAGS = -gnatpg
+GNATLIBCFLAGS= -g -O2
+ALL_ADAFLAGS = $(CFLAGS) $(ADA_CFLAGS) $(ADAFLAGS)
+MOST_ADAFLAGS = $(CFLAGS) $(ADA_CFLAGS) $(SOME_ADAFLAGS)
+THREAD_KIND=native
+GMEM_LIB=
+MISCLIB =
+
+objext = .o
+exeext =
+arext = .a
+soext = .so
+shext =
+
+HOST_CC=$(CC)
+HOST_CFLAGS=$(ALL_CFLAGS)
+HOST_CLIB=$(CLIB)
+HOST_LDFLAGS=$(LDFLAGS)
+HOST_CPPFLAGS=$(ALL_CPPFLAGS)
+HOST_ALLOCA=$(ALLOCA)
+HOST_MALLOC=$(MALLOC)
+HOST_OBSTACK=$(OBSTACK)
+
+# Define this as & to perform parallel make on a Sequent.
+# Note that this has some bugs, and it seems currently necessary
+# to compile all the gen* files first by hand to avoid erroneous results.
+P =
+
+# This is used instead of ALL_CFLAGS when compiling with GCC_FOR_TARGET.
+# It omits XCFLAGS, and specifies -B./.
+# It also specifies -B$(tooldir)/ to find as and ld for a cross compiler.
+GCC_CFLAGS=$(INTERNAL_CFLAGS) $(X_CFLAGS) $(T_CFLAGS) $(CFLAGS)
+
+# Tools to use when building a cross-compiler.
+# These are used because `configure' appends `cross-make'
+# to the makefile when making a cross-compiler.
+
+# We don't use cross-make. Instead we use the tools from the build tree,
+# if they are available.
+# program_transform_name and objdir are set by configure.in.
+program_transform_name =
+objdir = .
+
+target=@target@
+target_alias=@target_alias@
+xmake_file=@dep_host_xmake_file@
+tmake_file=@dep_tmake_file@
+#version=`sed -e 's/.*\"\([^ \"]*\)[ \"].*/\1/' < $(srcdir)/version.c`
+#mainversion=`sed -e 's/.*\"\([0-9]*\.[0-9]*\).*/\1/' < $(srcdir)/version.c`
+
+# Directory where sources are, from where we are.
+srcdir = @srcdir@
+VPATH = @srcdir@
+
+MACHMODE_H = $(srcdir)/../machmode.h $(srcdir)/../machmode.def
+RTL_H = $(srcdir)/../rtl.h $(srcdir)/../rtl.def $(MACHMODE_H)
+TREE_H = $(srcdir)/../tree.h $(srcdir)/../real.h $(srcdir)/../tree.def \
+ $(MACHMODE_H) $(srcdir)/../tree-check.h $(srdir)/../version.h \
+ $(srcdir)/../builtins.def
+
+fsrcdir:=$(shell cd $(srcdir);pwd)
+fsrcpfx:=$(shell cd $(srcdir);pwd)/
+fcurdir:=$(shell pwd)
+fcurpfx:=$(shell pwd)/
+
+# Top build directory, relative to here.
+top_builddir = ..
+
+# Internationalization library.
+INTLLIBS = @INTLLIBS@
+
+# Any system libraries needed just for GNAT.
+SYSLIBS = @GNAT_LIBEXC@
+
+# Choose the real default target.
+ALL=all
+
+# List of extra object files linked in with various programs.
+EXTRA_GNAT1_OBJS = ../prefix.o
+EXTRA_GNATBIND_OBJS = ../prefix.o
+EXTRA_GNATTOOLS_OBJS = ../prefix.o
+
+# List extra gnattools
+EXTRA_GNATTOOLS =
+
+# List of target dependent sources, overridden below as necessary
+TARGET_ADA_SRCS =
+
+# End of variables for you to override.
+
+# Definition of `all' is here so that new rules inserted by sed
+# do not specify the default target.
+all: all.indirect
+
+# This tells GNU Make version 3 not to put all variables in the environment.
+.NOEXPORT:
+
+# sed inserts variable overrides after the following line.
+####target overrides
+@target_overrides@
+
+####host overrides
+@host_overrides@
+
+####cross overrides
+@cross_defines@
+@cross_overrides@
+
+####build overrides
+@build_overrides@
+\f
+# Now figure out from those variables how to compile and link.
+
+\f
+# Now figure out from those variables how to compile and link.
+
+all.indirect: Makefile ../gnat1$(exeext)
+
+# IN_GCC tells obstack.h that we are using gcc's <stddef.h> file.
+INTERNAL_CFLAGS = $(CROSS) -DIN_GCC @extra_c_flags@
+
+# This is the variable actually used when we compile.
+LOOSE_CFLAGS = `echo $(CFLAGS) $(WARN2_CFLAGS)|sed -e 's/-pedantic//g' -e 's/-Wtraditional//g'`
+ALL_CFLAGS = $(INTERNAL_CFLAGS) $(X_CFLAGS) $(T_CFLAGS) $(LOOSE_CFLAGS) \
+ $(XCFLAGS)
+
+# Likewise.
+ALL_CPPFLAGS = $(CPPFLAGS) $(X_CPPFLAGS) $(T_CPPFLAGS)
+
+# Even if ALLOCA is set, don't use it if compiling with GCC.
+
+# This is where we get libiberty.a from.
+LIBIBERTY = ../../libiberty/libiberty.a
+
+# How to link with both our special library facilities
+# and the system's installed libraries.
+LIBS = $(INTLLIBS) $(LIBIBERTY) $(SYSLIBS)
+LIBDEPS = $(INTLLIBS) $(LIBIBERTY)
+
+# Specify the directories to be searched for header files.
+# Both . and srcdir are used, in that order,
+# so that tm.h and config.h will be found in the compilation
+# subdirectory rather than in the source directory.
+INCLUDES = -I- -I. -I.. -I$(srcdir) -I$(srcdir)/.. -I$(srcdir)/../config \
+ -I$(srcdir)/../../include
+
+ADA_INCLUDES = -I- -I. -I$(srcdir)
+
+INCLUDES_FOR_SUBDIR = -I. -I.. -I../.. -I../../include -I$(fsrcdir) \
+ -I$(fsrcdir)/.. -I$(fsrcdir)/../config -I$(fsrcdir)/../../include
+ADA_INCLUDES_FOR_SUBDIR = -I. -I$(fsrcdir)
+
+# Avoid a lot of time thinking about remaking Makefile.in and *.def.
+.SUFFIXES: .in .def
+
+# Say how to compile Ada programs.
+.SUFFIXES: .ada .adb .ads
+
+# Always use -I$(srcdir)/config when compiling.
+.c.o:
+ $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $<
+.adb.o:
+ $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $<
+.ads.o:
+ $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $<
+
+# This tells GNU make version 3 not to export all the variables
+# defined in this file into the environment.
+.NOEXPORT:
+\f
+# Lists of files for various purposes.
+
+# Languages-specific object files for Ada.
+# Object files for gnat1 from C sources.
+GNAT1_C_OBJS = b_gnat1.o adaint.o cstreams.o cio.o targtyps.o decl.o \
+ misc.o utils.o utils2.o trans.o cuintp.o argv.o raise.o \
+ init.o tracebak.o
+
+# Object files from Ada sources that are used by gnat1
+
+GNAT_ADA_OBJS = \
+ ada.o a-charac.o a-chlat1.o a-except.o s-memory.o s-traceb.o s-mastop.o \
+ s-except.o ali.o alloc.o atree.o butil.o casing.o checks.o comperr.o \
+ csets.o cstand.o debug.o debug_a.o einfo.o elists.o errout.o eval_fat.o \
+ exp_attr.o exp_ch11.o exp_ch12.o exp_ch13.o exp_ch2.o exp_ch3.o exp_ch4.o \
+ exp_ch5.o exp_ch6.o exp_ch7.o exp_ch8.o exp_ch9.o exp_code.o exp_dbug.o \
+ exp_disp.o exp_dist.o exp_fixd.o exp_aggr.o exp_imgv.o \
+ exp_intr.o exp_pakd.o exp_prag.o exp_smem.o \
+ exp_strm.o exp_tss.o exp_util.o exp_vfpt.o expander.o fname.o fname-uf.o \
+ freeze.o frontend.o gnat.o g-hesora.o g-htable.o g-os_lib.o \
+ g-speche.o get_targ.o gnatvsn.o \
+ hlo.o hostparm.o impunit.o \
+ interfac.o itypes.o inline.o krunch.o lib.o \
+ layout.o lib-load.o lib-util.o lib-xref.o lib-writ.o live.o \
+ namet.o nlists.o nmake.o opt.o osint.o output.o par.o \
+ repinfo.o restrict.o rident.o rtsfind.o \
+ s-assert.o s-parame.o s-stache.o s-stalib.o \
+ s-imgenu.o s-stoele.o s-soflin.o \
+ s-exctab.o s-secsta.o s-wchcnv.o s-wchcon.o s-wchjis.o s-unstyp.o \
+ scans.o scn.o sdefault.o sem.o sem_aggr.o \
+ sem_attr.o sem_cat.o sem_ch10.o sem_ch11.o sem_ch12.o sem_ch13.o sem_ch2.o \
+ sem_ch3.o sem_ch4.o sem_ch5.o sem_ch6.o sem_ch7.o sem_ch8.o sem_ch9.o \
+ sem_case.o sem_disp.o sem_dist.o \
+ sem_elab.o sem_elim.o sem_eval.o sem_intr.o \
+ sem_maps.o sem_mech.o sem_prag.o sem_res.o \
+ sem_smem.o sem_type.o sem_util.o sem_vfpt.o sem_warn.o \
+ sinfo-cn.o sinfo.o sinput.o sinput-l.o snames.o sprint.o stand.o stringt.o \
+ style.o switch.o stylesw.o validsw.o system.o \
+ table.o targparm.o tbuild.o tree_gen.o tree_io.o treepr.o treeprs.o \
+ ttypef.o ttypes.o types.o uintp.o uname.o urealp.o usage.o widechar.o
+
+# Object files for gnat executables
+GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) back_end.o gnat1drv.o
+GNAT1_OBJS = $(GNAT1_C_OBJS) $(GNAT1_ADA_OBJS) $(EXTRA_GNAT1_OBJS)
+GNATBIND_OBJS = \
+ link.o ada.o adaint.o cstreams.o cio.o ali.o ali-util.o \
+ alloc.o bcheck.o binde.o \
+ binderr.o bindgen.o bindusg.o \
+ butil.o casing.o csets.o \
+ debug.o fname.o gnat.o g-hesora.o g-htable.o \
+ g-os_lib.o gnatbind.o gnatvsn.o hostparm.o \
+ krunch.o namet.o opt.o osint.o output.o rident.o s-assert.o \
+ s-parame.o s-sopco3.o s-sopco4.o s-sopco5.o s-stache.o s-stalib.o \
+ s-stoele.o s-imgenu.o s-strops.o s-soflin.o s-wchcon.o s-wchjis.o \
+ sdefault.o switch.o stylesw.o validsw.o \
+ system.o table.o tree_io.o types.o widechar.o \
+ raise.o exit.o argv.o init.o final.o s-wchcnv.o s-exctab.o \
+ a-except.o s-memory.o s-traceb.o tracebak.o s-mastop.o s-except.o \
+ s-secsta.o $(EXTRA_GNATBIND_OBJS)
+
+GNATCHOP_RTL_OBJS = adaint.o argv.o cio.o cstreams.o exit.o \
+ final.o init.o raise.o sysdep.o ada.o a-comlin.o gnat.o a-string.o \
+ a-stmaco.o a-strsea.o a-charac.o a-chlat1.o g-except.o \
+ a-chahan.o a-strunb.o a-strfix.o a-strmap.o g-casuti.o g-comlin.o hostparm.o \
+ g-dirope.o g-hesora.o g-htable.o g-regexp.o interfac.o system.o s-assert.o \
+ s-parame.o i-cstrea.o s-exctab.o a-ioexce.o s-except.o s-stache.o s-stoele.o \
+ s-imgint.o a-tags.o a-stream.o s-strops.o s-sopco3.o s-bitops.o \
+ s-sopco4.o s-sopco5.o s-imgenu.o s-soflin.o s-secsta.o a-except.o \
+ s-mastop.o s-stalib.o g-os_lib.o s-unstyp.o s-stratt.o s-finroo.o s-finimp.o \
+ tracebak.o s-memory.o s-traceb.o a-finali.o a-filico.o s-ficobl.o s-fileio.o \
+ a-textio.o s-valuti.o s-valuns.o s-valint.o s-arit64.o
+
+GNATCHOP_OBJS = gnatchop.o gnatvsn.o \
+ $(GNATCHOP_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
+
+GNATCMD_RTL_OBJS = adaint.o argv.o raise.o exit.o final.o init.o \
+ ada.o a-charac.o a-chahan.o a-comlin.o cstreams.o cio.o \
+ a-except.o tracebak.o s-memory.o s-traceb.o s-mastop.o s-except.o \
+ a-finali.o a-filico.o a-ioexce.o a-stream.o \
+ a-string.o a-strmap.o a-stmaco.o g-htable.o \
+ sysdep.o a-tags.o a-textio.o gnat.o g-hesora.o g-os_lib.o \
+ interfac.o i-cstrea.o system.o s-assert.o s-bitops.o g-except.o s-exctab.o \
+ s-ficobl.o s-fileio.o s-finimp.o s-finroo.o s-imgint.o s-imguns.o \
+ s-parame.o s-secsta.o s-stalib.o s-imgenu.o s-stoele.o s-stratt.o \
+ s-stache.o s-sopco3.o s-sopco4.o s-sopco5.o \
+ s-strops.o s-soflin.o s-wchcon.o s-wchcnv.o s-wchjis.o s-unstyp.o
+
+GNATCMD_OBJS = alloc.o debug.o fname.o gnatcmd.o gnatvsn.o hostparm.o \
+ krunch.o namet.o opt.o osint.o casing.o csets.o widechar.o \
+ output.o sdefault.o switch.o stylesw.o validsw.o table.o tree_io.o types.o \
+ $(GNATCMD_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
+
+GNATKR_RTL_OBJS = ada.o a-charac.o a-chahan.o a-chlat1.o a-comlin.o \
+ cstreams.o a-finali.o \
+ a-string.o a-strmap.o a-stmaco.o a-stream.o a-tags.o \
+ gnat.o g-hesora.o g-htable.o interfac.o \
+ system.o s-bitops.o g-except.o s-finimp.o s-io.o s-parame.o s-secsta.o \
+ s-stopoo.o s-sopco3.o s-sopco4.o s-sopco5.o s-stache.o \
+ s-stoele.o s-soflin.o s-stalib.o s-unstyp.o adaint.o \
+ raise.o exit.o argv.o cio.o init.o final.o s-finroo.o \
+ a-except.o tracebak.o s-memory.o s-traceb.o s-mastop.o s-except.o \
+ a-filico.o s-strops.o s-stratt.o s-imgenu.o a-ioexce.o s-exctab.o
+GNATKR_OBJS = gnatkr.o gnatvsn.o \
+ krunch.o hostparm.o $(GNATKR_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
+
+GNATLINK_RTL_OBJS = \
+ adaint.o argv.o cio.o cstreams.o \
+ exit.o init.o final.o raise.o tracebak.o \
+ ada.o a-comlin.o a-except.o \
+ gnat.o g-hesora.o g-htable.o g-os_lib.o \
+ interfac.o i-cstrea.o \
+ system.o s-assert.o s-except.o s-exctab.o s-mastop.o \
+ s-parame.o s-secsta.o s-soflin.o s-sopco3.o s-sopco4.o \
+ s-stache.o s-stalib.o s-stoele.o s-imgenu.o s-strops.o \
+ s-memory.o s-traceb.o s-wchcnv.o s-wchcon.o s-wchjis.o
+
+GNATLINK_OBJS = gnatlink.o link.o \
+ alloc.o debug.o gnatvsn.o hostparm.o namet.o \
+ opt.o osint.o output.o sdefault.o stylesw.o validsw.o \
+ switch.o table.o tree_io.o types.o widechar.o \
+ $(GNATLINK_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
+
+GNATLS_RTL_OBJS = \
+ ada.o \
+ adaint.o \
+ argv.o \
+ a-charac.o \
+ a-chahan.o \
+ cio.o \
+ a-comlin.o \
+ cstreams.o \
+ a-except.o \
+ exit.o \
+ a-filico.o \
+ final.o \
+ a-finali.o \
+ init.o \
+ a-ioexce.o \
+ raise.o \
+ a-stmaco.o \
+ a-stream.o \
+ a-strfix.o \
+ a-string.o \
+ a-strmap.o \
+ a-strsea.o \
+ a-strunb.o \
+ sysdep.o \
+ a-tags.o \
+ a-textio.o \
+ tracebak.o \
+ gnat.o \
+ g-casuti.o \
+ g-dirope.o \
+ g-except.o \
+ g-hesora.o \
+ g-htable.o \
+ g-os_lib.o \
+ g-regexp.o \
+ interfac.o \
+ i-cstrea.o \
+ system.o \
+ s-assert.o \
+ s-bitops.o \
+ s-except.o \
+ s-exctab.o \
+ s-finroo.o \
+ s-finimp.o \
+ s-ficobl.o \
+ s-fileio.o \
+ s-imgenu.o \
+ s-imgint.o \
+ s-mastop.o \
+ s-parame.o \
+ s-secsta.o \
+ s-soflin.o \
+ s-sopco3.o \
+ s-sopco4.o \
+ s-sopco5.o \
+ s-stache.o \
+ s-stalib.o \
+ s-stoele.o \
+ s-stratt.o \
+ s-strops.o \
+ s-memory.o \
+ s-traceb.o \
+ s-valenu.o \
+ s-valuti.o \
+ s-wchcnv.o \
+ s-wchcon.o \
+ s-wchjis.o
+GNATLS_OBJS = \
+ ali.o \
+ ali-util.o \
+ alloc.o \
+ atree.o \
+ binderr.o \
+ butil.o \
+ casing.o \
+ csets.o \
+ debug.o \
+ einfo.o \
+ elists.o \
+ errout.o \
+ fname.o \
+ gnatls.o \
+ gnatvsn.o \
+ hostparm.o \
+ krunch.o \
+ lib.o \
+ namet.o \
+ nlists.o \
+ opt.o \
+ osint.o \
+ output.o \
+ prj.o \
+ prj-attr.o \
+ prj-com.o \
+ prj-dect.o \
+ prj-env.o \
+ prj-ext.o \
+ prj-nmsc.o \
+ prj-pars.o \
+ prj-part.o \
+ prj-proc.o \
+ prj-strt.o \
+ prj-tree.o \
+ prj-util.o \
+ rident.o \
+ scans.o \
+ scn.o \
+ sdefault.o \
+ sinfo.o \
+ sinfo-cn.o \
+ sinput.o \
+ sinput-p.o \
+ snames.o \
+ stand.o \
+ stringt.o \
+ style.o \
+ stylesw.o \
+ validsw.o \
+ switch.o \
+ table.o \
+ tree_io.o \
+ uintp.o \
+ uname.o \
+ urealp.o \
+ types.o \
+ widechar.o $(GNATLS_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
+
+GNATMAKE_RTL_OBJS = adaint.o argv.o raise.o exit.o a-comlin.o \
+ cio.o cstreams.o a-except.o s-mastop.o s-except.o final.o init.o \
+ a-finali.o a-filico.o s-finroo.o s-finimp.o s-ficobl.o\
+ a-charac.o a-chahan.o a-string.o a-strfix.o a-strmap.o a-strunb.o \
+ a-stmaco.o a-strsea.o a-textio.o s-bitops.o sysdep.o \
+ s-imgint.o s-stratt.o \
+ a-tags.o a-stream.o \
+ a-ioexce.o \
+ tracebak.o s-memory.o s-traceb.o \
+ gnat.o g-dirope.o g-os_lib.o g-hesora.o g-except.o \
+ i-cstrea.o \
+ s-parame.o s-stache.o s-stalib.o s-wchcon.o s-wchjis.o \
+ s-imgenu.o s-assert.o s-secsta.o s-stoele.o s-soflin.o s-fileio.o \
+ s-valenu.o s-valuti.o g-casuti.o \
+ system.o s-exctab.o s-strops.o s-sopco3.o s-sopco4.o s-sopco5.o \
+ g-htable.o g-regexp.o s-wchcnv.o
+
+GNATMAKE_OBJS = ali.o ali-util.o \
+ alloc.o atree.o binderr.o butil.o casing.o csets.o debug.o einfo.o elists.o \
+ errout.o fname.o fname-uf.o fname-sf.o \
+ gnatmake.o gnatvsn.o hostparm.o krunch.o lib.o make.o makeusg.o \
+ mlib.o mlib-fil.o mlib-prj.o mlib-tgt.o mlib-utl.o \
+ namet.o nlists.o opt.o osint.o output.o \
+ prj.o prj-attr.o prj-com.o prj-dect.o prj-env.o prj-ext.o prj-nmsc.o \
+ prj-pars.o prj-part.o prj-proc.o prj-strt.o prj-tree.o prj-util.o \
+ rident.o scans.o scn.o sdefault.o sfn_scan.o sinfo.o sinfo-cn.o \
+ sinput.o sinput-l.o sinput-p.o \
+ snames.o stand.o stringt.o style.o stylesw.o validsw.o switch.o\
+ table.o tree_io.o types.o \
+ uintp.o uname.o urealp.o usage.o widechar.o \
+ $(GNATMAKE_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
+
+GNATMEM_RTL_OBJS = \
+adaint.o \
+argv.o \
+cio.o \
+cstreams.o \
+exit.o \
+final.o \
+init.o \
+raise.o \
+sysdep.o \
+ada.o \
+a-comlin.o \
+a-except.o \
+a-filico.o \
+a-finali.o \
+a-flteio.o \
+a-inteio.o \
+a-ioexce.o \
+a-stream.o \
+a-tags.o \
+a-textio.o \
+a-tiflau.o \
+a-tigeau.o \
+a-tiinau.o \
+a-tiocst.o \
+gnat.o \
+g-casuti.o \
+g-hesora.o \
+g-htable.o \
+g-os_lib.o \
+gnatvsn.o \
+interfac.o \
+i-cstrea.o \
+system.o \
+s-assert.o \
+s-except.o \
+s-exctab.o \
+s-exngen.o \
+s-exnllf.o \
+s-fatllf.o \
+s-ficobl.o \
+s-fileio.o \
+s-finimp.o \
+s-finroo.o \
+s-imgbiu.o \
+s-imgenu.o \
+s-imgint.o \
+s-imgllb.o \
+s-imglli.o \
+s-imgllu.o \
+s-imgllw.o \
+s-imgrea.o \
+s-imguns.o \
+s-imgwiu.o \
+tracebak.o \
+s-memory.o \
+s-traceb.o \
+s-mastop.o \
+s-parame.o \
+s-powtab.o \
+s-secsta.o \
+s-sopco3.o \
+s-sopco4.o \
+s-sopco5.o \
+s-stache.o \
+s-stalib.o \
+s-stoele.o \
+s-stratt.o \
+s-strops.o \
+s-soflin.o \
+s-unstyp.o \
+s-valllu.o \
+s-vallli.o \
+s-valint.o \
+s-valrea.o \
+s-valuns.o \
+s-valuti.o
+GNATMEM_OBJS = gnatmem.o memroot.o gmem.o \
+ $(GNATMEM_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
+
+GNATPREP_RTL_OBJS = adaint.o argv.o raise.o exit.o final.o init.o \
+ ada.o a-charac.o a-chahan.o a-comlin.o cstreams.o cio.o \
+ a-except.o tracebak.o s-memory.o s-traceb.o s-mastop.o s-except.o \
+ a-finali.o a-filico.o a-ioexce.o a-stream.o a-string.o a-strmap.o \
+ a-stmaco.o a-strfix.o s-imgenu.o a-strsea.o a-strunb.o \
+ sysdep.o a-tags.o a-textio.o gnat.o g-hesora.o \
+ g-casuti.o g-dirope.o g-os_lib.o g-regexp.o g-comlin.o i-cstrea.o \
+ system.o s-bitops.o g-except.o s-exctab.o s-ficobl.o s-fileio.o s-finimp.o \
+ s-finroo.o s-imgint.o s-parame.o s-secsta.o s-stache.o s-stalib.o \
+ s-stoele.o s-sopco3.o s-sopco4.o s-sopco5.o s-arit64.o \
+ s-stratt.o s-strops.o s-soflin.o s-unstyp.o
+
+GNATPREP_OBJS = gnatprep.o gnatvsn.o \
+ hostparm.o $(GNATPREP_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
+
+GNATPSTA_RTL_OBJS = adaint.o argv.o cstreams.o cio.o \
+ deftarg.o a-except.o targtyps.o tracebak.o s-memory.o s-traceb.o \
+ s-mastop.o s-except.o exit.o a-filico.o final.o a-finali.o init.o \
+ a-ioexce.o raise.o a-stream.o get_targ.o gnat.o g-hesora.o \
+ sysdep.o a-tags.o a-textio.o i-cstrea.o system.o s-assert.o \
+ s-exctab.o s-fatllf.o s-ficobl.o s-fileio.o s-finimp.o s-finroo.o \
+ s-imgint.o s-imgrea.o s-imglli.o s-imgllu.o s-imguns.o s-parame.o \
+ s-powtab.o s-sopco3.o s-sopco4.o s-sopco5.o s-secsta.o s-stache.o \
+ s-stalib.o s-stoele.o s-stratt.o s-strops.o s-soflin.o \
+ s-imgenu.o g-htable.o
+
+GNATPSTA_OBJS = gnatpsta.o types.o ttypes.o \
+ gnatvsn.o ttypef.o $(GNATPSTA_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
+
+GNATPSYS_RTL_OBJS = adaint.o argv.o cstreams.o cio.o \
+ a-except.o tracebak.o s-memory.o s-traceb.o s-mastop.o s-except.o exit.o \
+ a-filico.o final.o a-finali.o init.o a-ioexce.o \
+ raise.o a-stream.o \
+ sysdep.o a-tags.o a-textio.o i-cstrea.o system.o s-assert.o \
+ gnat.o g-hesora.o g-htable.o s-imgenu.o \
+ s-exctab.o s-fatllf.o s-ficobl.o s-fileio.o s-finimp.o s-finroo.o \
+ s-imgint.o s-imgrea.o s-imglli.o s-imgllu.o s-imguns.o s-parame.o \
+ s-powtab.o s-secsta.o s-stache.o s-stalib.o s-stoele.o s-stratt.o \
+ s-strops.o s-soflin.o s-sopco3.o s-sopco4.o s-sopco5.o
+
+GNATPSYS_OBJS = gnatpsys.o \
+ gnatvsn.o $(GNATPSYS_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
+
+GNATXREF_RTL_OBJS = \
+ adaint.o argv.o cio.o cstreams.o \
+ exit.o init.o final.o raise.o sysdep.o tracebak.o \
+ ada.o a-charac.o a-chlat1.o gnat.o g-casuti.o g-hesora.o \
+ g-htable.o interfac.o system.o i-cstrea.o s-parame.o s-exctab.o \
+ a-ioexce.o a-string.o s-assert.o s-except.o \
+ s-imgenu.o s-stoele.o s-mastop.o \
+ s-imgint.o a-comlin.o s-soflin.o s-stache.o s-secsta.o s-stalib.o \
+ g-os_lib.o s-strops.o a-tags.o a-stream.o s-sopco3.o s-sopco4.o \
+ s-sopco5.o s-memory.o s-traceb.o a-except.o s-unstyp.o a-strmap.o \
+ a-stmaco.o \
+ a-chahan.o a-strsea.o a-strfix.o s-stratt.o s-finroo.o g-except.o \
+ s-bitops.o s-finimp.o a-finali.o a-filico.o a-strunb.o g-dirope.o \
+ g-comlin.o s-ficobl.o s-fileio.o a-textio.o g-regexp.o g-io_aux.o \
+ s-valuti.o s-valuns.o s-valint.o s-wchcon.o s-wchjis.o s-wchcnv.o
+
+GNATXREF_OBJS = gnatxref.o xr_tabls.o xref_lib.o \
+ alloc.o debug.o gnatvsn.o hostparm.o types.o output.o \
+ sdefault.o stylesw.o validsw.o tree_io.o opt.o table.o osint.o \
+ switch.o widechar.o namet.o \
+ $(GNATXREF_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
+
+GNATFIND_RTL_OBJS = \
+ adaint.o argv.o cio.o cstreams.o \
+ exit.o init.o final.o raise.o sysdep.o tracebak.o \
+ ada.o a-chahan.o a-charac.o a-chlat1.o a-comlin.o a-except.o \
+ a-filico.o a-finali.o a-ioexce.o a-stmaco.o a-stream.o \
+ a-strfix.o a-string.o a-strmap.o a-strsea.o a-strunb.o \
+ a-tags.o a-textio.o \
+ gnat.o g-casuti.o g-comlin.o g-dirope.o g-except.o \
+ g-hesora.o g-htable.o g-io_aux.o g-os_lib.o g-regexp.o \
+ interfac.o i-cstrea.o \
+ system.o s-assert.o s-bitops.o s-except.o s-exctab.o \
+ s-imgenu.o s-ficobl.o s-fileio.o s-finimp.o s-finroo.o s-imgint.o \
+ s-mastop.o s-parame.o s-secsta.o s-soflin.o s-sopco3.o \
+ s-sopco4.o s-sopco5.o s-stache.o s-stalib.o s-stoele.o \
+ s-stratt.o s-strops.o s-memory.o s-traceb.o s-unstyp.o s-valint.o \
+ s-valuns.o s-valuti.o s-wchcnv.o s-wchcon.o s-wchjis.o
+
+GNATFIND_OBJS = gnatfind.o xr_tabls.o xref_lib.o \
+ alloc.o debug.o gnatvsn.o hostparm.o namet.o opt.o \
+ osint.o output.o sdefault.o stylesw.o validsw.o switch.o table.o \
+ tree_io.o types.o widechar.o \
+ $(GNATFIND_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
+
+GNATDLL_RTL_OBJS = \
+ adaint.o argv.o cio.o cstreams.o \
+ exit.o init.o final.o raise.o sysdep.o tracebak.o \
+ a-charac.o a-chlat1.o a-chahan.o a-comlin.o a-except.o a-filico.o \
+ a-finali.o a-ioexce.o a-stream.o a-strfix.o a-string.o a-strmap.o \
+ a-strsea.o a-stmaco.o a-strunb.o a-tags.o a-textio.o ada.o \
+ g-casuti.o g-comlin.o g-dirope.o g-except.o g-hesora.o g-htable.o \
+ g-os_lib.o g-regexp.o gnat.o \
+ i-cstrea.o interfac.o \
+ s-bitops.o s-except.o s-exctab.o s-ficobl.o s-fileio.o s-finimp.o \
+ s-finroo.o s-imgint.o s-mastop.o s-parame.o s-secsta.o s-soflin.o \
+ s-sopco3.o s-sopco4.o s-stache.o s-stalib.o s-stoele.o s-stratt.o \
+ s-strops.o s-memory.o s-traceb.o s-unstyp.o system.o
+
+GNATDLL_OBJS = \
+ gnatdll.o gnatvsn.o mdll.o mdllfile.o mdlltool.o sdefault.o types.o \
+ $(GNATDLL_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
+
+# Convert the target variable into a space separated list of architecture,
+# manufacturer, and operating system and assign each of those to its own
+# variable.
+
+targ:=$(subst -, ,$(target))
+arch:=$(word 1,$(targ))
+ifeq ($(words $(targ)),2)
+ manu:=
+ osys:=$(word 2,$(targ))
+else
+ manu:=$(word 2,$(targ))
+ osys:=$(word 3,$(targ))
+endif
+
+# LIBGNAT_TARGET_PAIRS is a list of pairs of filenames.
+# The members of each pair must be separated by a '<' and no whitespace.
+# Each pair must be separated by some amount of whitespace from the following
+# pair.
+
+# Non-tasking case:
+
+LIBGNAT_TARGET_PAIRS = \
+a-intnam.ads<4nintnam.ads \
+s-inmaop.adb<5ninmaop.adb \
+s-intman.adb<5nintman.adb \
+s-osinte.ads<5nosinte.ads \
+s-osprim.adb<7sosprim.adb \
+s-taprop.adb<5ntaprop.adb \
+s-taspri.ads<5ntaspri.ads
+
+# Default shared object option. Note that we rely on the fact that the "soname"
+# option will always be present and last in this flag, so that we can have
+# $(SO_OPTS)libgnat-x.xx
+
+SO_OPTS=-Wl,-soname,
+
+# Default gnatlib-shared target.
+# This is needed on some targets to use a different gnatlib-shared target, e.g
+# gnatlib-shared-dual
+GNATLIB_SHARED=gnatlib-shared-default
+
+# default value for gnatmake's target dependant file
+MLIB_TGT=mlib-tgt
+
+# $(filter-out PATTERN...,TEXT) removes all PATTERN words from TEXT.
+# $(strip STRING) removes leading and trailing spaces from STRING.
+# If what's left is null then it's a match.
+
+ifeq ($(strip $(filter-out %86 os2 OS2 os2_emx,$(arch) $(osys))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-excpol.adb<4wexcpol.adb \
+ a-intnam.ads<4nintnam.ads \
+ a-numaux.adb<86numaux.adb \
+ a-numaux.ads<86numaux.ads \
+ s-inmaop.adb<5ninmaop.adb \
+ s-interr.adb<5ointerr.adb \
+ s-intman.adb<5nintman.adb \
+ s-mastop.adb<5omastop.adb \
+ s-osinte.adb<5oosinte.adb \
+ s-osinte.ads<5oosinte.ads \
+ s-osprim.adb<5oosprim.adb \
+ s-parame.adb<5oparame.adb \
+ system.ads<5osystem.ads \
+ s-taprop.adb<5otaprop.adb \
+ s-taspri.ads<5otaspri.ads
+
+ EXTRA_GNATRTL_NONTASKING_OBJS = \
+ i-os2err.o \
+ i-os2lib.o \
+ i-os2syn.o \
+ i-os2thr.o
+endif
+
+ifeq ($(strip $(filter-out %86 interix,$(arch) $(osys))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4pintnam.ads \
+ a-numaux.adb<86numaux.adb \
+ a-numaux.ads<86numaux.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<7sintman.adb \
+ s-mastop.adb<5omastop.adb \
+ s-osinte.adb<7sosinte.adb \
+ s-osinte.ads<5posinte.ads \
+ s-osprim.adb<5posprim.adb \
+ s-taprop.adb<7staprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-tpopsp.adb<7stpopsp.adb
+
+ THREADSLIB=-lgthreads -lmalloc
+
+# Work around for gcc optimization bug wrt cxa5a09
+a-numaux.o : a-numaux.adb a-numaux.ads
+ $(CC) -c $(ALL_ADAFLAGS) -O2 $(ADA_INCLUDES) $<
+
+# Work around for gcc optimization bug wrt cxf3a01
+a-teioed.o : a-teioed.adb a-teioed.ads
+ $(CC) -c $(ALL_ADAFLAGS) -O0 $(ADA_INCLUDES) $<
+
+endif
+
+# sysv5uw is SCO UnixWare 7
+ifeq ($(strip $(filter-out %86 sysv5uw%,$(arch) $(osys))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-excpol.adb<4hexcpol.adb \
+ a-intnam.ads<41intnam.ads \
+ a-numaux.adb<86numaux.adb \
+ a-numaux.ads<86numaux.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<7sintman.adb \
+ s-mastop.adb<5omastop.adb \
+ s-osinte.ads<51osinte.ads \
+ s-osinte.adb<51osinte.adb \
+ s-osprim.adb<5posprim.adb \
+ s-taprop.adb<7staprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-tpopsp.adb<5atpopsp.adb \
+ g-soccon.ads<31soccon.ads \
+ g-soliop.ads<31soliop.ads
+
+ THREADSLIB=-lthread
+ SO_OPTS=-Wl,-h,
+ GNATLIB_SHARED=gnatlib-shared-dual
+ LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+endif
+
+ifeq ($(strip $(filter-out sparc sun sunos4%,$(targ))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4uintnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<5uintman.adb \
+ s-osinte.adb<7sosinte.adb \
+ s-osinte.ads<5uosinte.ads \
+ s-osprim.adb<5posprim.adb \
+ s-taprop.adb<7staprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-tpopsp.adb<7stpopsp.adb
+endif
+
+ifeq ($(strip $(filter-out alpha% dec vms%,$(targ))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-caldel.adb<4vcaldel.adb \
+ a-calend.adb<4vcalend.adb \
+ a-calend.ads<4vcalend.ads \
+ a-excpol.adb<4wexcpol.adb \
+ a-intnam.ads<4vintnam.ads \
+ i-cstrea.adb<6vcstrea.adb \
+ i-cpp.adb<6vcpp.adb \
+ interfac.ads<6vinterf.ads \
+ s-asthan.adb<5vasthan.adb \
+ s-inmaop.adb<5vinmaop.adb \
+ s-interr.adb<5vinterr.adb \
+ s-intman.adb<5vintman.adb \
+ s-intman.ads<5vintman.ads \
+ s-mastop.adb<5vmastop.adb \
+ s-osinte.adb<5vosinte.adb \
+ s-osinte.ads<5vosinte.ads \
+ s-osprim.adb<5vosprim.adb \
+ s-osprim.ads<5vosprim.ads \
+ s-parame.ads<5vparame.ads \
+ s-taprop.adb<5vtaprop.adb \
+ s-taspri.ads<5vtaspri.ads \
+ s-tpopde.adb<5vtpopde.adb \
+ s-tpopde.ads<5vtpopde.ads \
+ s-vaflop.adb<5vvaflop.adb \
+ system.ads<5vsystem.ads
+
+ GNATLIB_SHARED=gnatlib-shared-vms
+ EXTRA_LIBGNAT_SRCS=vmshandler.asm
+ EXTRA_LIBGNAT_OBJS=vmshandler.o
+ EXTRA_GNATRTL_TASKING_OBJS=s-tpopde.o
+endif
+
+ifeq ($(strip $(filter-out alpha% dec vx%,$(targ))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-sytaco.ads<4zsytaco.ads \
+ a-sytaco.adb<4zsytaco.adb \
+ a-intnam.ads<4zintnam.ads \
+ a-numaux.ads<4znumaux.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-interr.adb<5zinterr.adb \
+ s-intman.adb<5zintman.adb \
+ s-osinte.adb<5zosinte.adb \
+ s-osinte.ads<5zosinte.ads \
+ s-osprim.adb<5zosprim.adb \
+ s-taprop.adb<5ztaprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-vxwork.ads<5avxwork.ads \
+ system.ads<5zsystem.ads
+
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o
+ EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
+endif
+
+ifeq ($(strip $(filter-out m68k% wrs vx%,$(targ))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-sytaco.ads<4zsytaco.ads \
+ a-sytaco.adb<4zsytaco.adb \
+ a-intnam.ads<4zintnam.ads \
+ a-numaux.ads<4znumaux.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-interr.adb<5zinterr.adb \
+ s-intman.adb<5zintman.adb \
+ s-osinte.adb<5zosinte.adb \
+ s-osinte.ads<5zosinte.ads \
+ s-osprim.adb<5zosprim.adb \
+ s-parame.ads<5zparame.ads \
+ s-taprop.adb<5ztaprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-vxwork.ads<5kvxwork.ads \
+ system.ads<5ksystem.ads
+
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o
+ EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
+
+# ??? work around a gcc -O2 bug on m68k
+s-interr.o : s-interr.adb s-interr.ads
+ $(CC) -c $(ALL_ADAFLAGS) -O1 $(ADA_INCLUDES) $<
+endif
+
+ifeq ($(strip $(filter-out powerpc% wrs vx%,$(targ))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-sytaco.ads<4zsytaco.ads \
+ a-sytaco.adb<4zsytaco.adb \
+ a-intnam.ads<4zintnam.ads \
+ a-numaux.ads<4znumaux.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-interr.adb<5zinterr.adb \
+ s-intman.adb<5zintman.adb \
+ s-osinte.adb<5zosinte.adb \
+ s-osinte.ads<5zosinte.ads \
+ s-osprim.adb<5zosprim.adb \
+ s-taprop.adb<5ztaprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-vxwork.ads<5pvxwork.ads \
+ system.ads<5ysystem.ads
+
+ ifeq ($(strip $(filter-out vxworks6% vxworksae%,$(osys))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-sytaco.ads<4zsytaco.ads \
+ a-sytaco.adb<4zsytaco.adb \
+ a-intnam.ads<4zintnam.ads \
+ a-numaux.ads<4znumaux.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-interr.adb<5zinterr.adb \
+ s-intman.adb<5zintman.adb \
+ s-osinte.adb<5zosinte.adb \
+ s-osinte.ads<5zosinte.ads \
+ s-osprim.adb<5zosprim.adb \
+ s-taprop.adb<5ztaprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-vxwork.ads<5qvxwork.ads \
+ system.ads<5ysystem.ads
+ endif
+
+ EXTRA_RAVEN_SOURCES=i-vxwork.ads s-vxwork.ads
+ EXTRA_RAVEN_OBJS=i-vxwork.o s-vxwork.o
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o
+ EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
+endif
+
+ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-sytaco.ads<4zsytaco.ads \
+ a-sytaco.adb<4zsytaco.adb \
+ a-intnam.ads<4zintnam.ads \
+ a-numaux.ads<4znumaux.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-interr.adb<5zinterr.adb \
+ s-intman.adb<5zintman.adb \
+ s-osinte.adb<5zosinte.adb \
+ s-osinte.ads<5zosinte.ads \
+ s-osprim.adb<5zosprim.adb \
+ s-taprop.adb<5ztaprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-vxwork.ads<5svxwork.ads \
+ system.ads<5ysystem.ads
+
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o
+ EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
+endif
+
+ifeq ($(strip $(filter-out mips% wrs vx%,$(targ))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-sytaco.ads<4zsytaco.ads \
+ a-sytaco.adb<4zsytaco.adb \
+ a-intnam.ads<4zintnam.ads \
+ a-numaux.ads<4znumaux.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-interr.adb<5zinterr.adb \
+ s-intman.adb<5zintman.adb \
+ s-osinte.adb<5zosinte.adb \
+ s-osinte.ads<5zosinte.ads \
+ s-osprim.adb<5zosprim.adb \
+ s-taprop.adb<5ztaprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-vxwork.ads<5mvxwork.ads \
+ system.ads<5zsystem.ads
+
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o
+ EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
+endif
+
+ifeq ($(strip $(filter-out sparc sun solaris2% sunos5%,$(targ))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4sintnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<5sintman.adb \
+ s-mastop.adb<5smastop.adb \
+ s-osinte.adb<5sosinte.adb \
+ s-osinte.ads<5sosinte.ads \
+ s-osprim.adb<5posprim.adb \
+ s-parame.adb<5sparame.adb \
+ s-taprop.adb<5staprop.adb \
+ s-tasinf.adb<5stasinf.adb \
+ s-tasinf.ads<5stasinf.ads \
+ s-taspri.ads<5staspri.ads \
+ s-tpopse.adb<5stpopse.adb \
+ g-soccon.ads<3ssoccon.ads \
+ g-soliop.ads<3ssoliop.ads \
+ system.ads<5ssystem.ads
+
+ THREADSLIB=-lposix4 -lthread
+ MISCLIB=-laddr2line -lbfd -lposix4 -lnsl -lsocket
+ SO_OPTS=-Wl,-h,
+ GNATLIB_SHARED=gnatlib-shared-dual
+ GMEM_LIB=gmemlib
+ LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+
+ ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4sintnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<5sintman.adb \
+ s-mastop.adb<5smastop.adb \
+ s-osinte.adb<7sosinte.adb \
+ s-osinte.ads<5tosinte.ads \
+ s-osprim.adb<5posprim.adb \
+ s-taprop.adb<7staprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-tpopsp.adb<7stpopsp.adb \
+ g-soccon.ads<3ssoccon.ads \
+ g-soliop.ads<3ssoliop.ads \
+ system.ads<5ssystem.ads
+
+ THREADSLIB=-lgthreads -lmalloc
+ endif
+
+ ifeq ($(strip $(filter-out pthread PTHREAD,$(THREAD_KIND))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4sintnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<7sintman.adb \
+ s-mastop.adb<5smastop.adb \
+ s-osinte.adb<5iosinte.adb \
+ s-osinte.ads<54osinte.ads \
+ s-osprim.adb<5posprim.adb \
+ s-taprop.adb<7staprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-tpopsp.adb<5atpopsp.adb \
+ g-soccon.ads<3ssoccon.ads \
+ g-soliop.ads<3ssoliop.ads \
+ system.ads<5ssystem.ads
+
+ THREADSLIB=-lposix4 -lpthread
+ endif
+endif
+
+ifeq ($(strip $(filter-out %86 solaris2%,$(arch) $(osys))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-numaux.adb<86numaux.adb \
+ a-numaux.ads<86numaux.ads \
+ a-intnam.ads<4sintnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<5sintman.adb \
+ s-mastop.adb<5omastop.adb \
+ s-osinte.adb<5sosinte.adb \
+ s-osinte.ads<5sosinte.ads \
+ s-osprim.adb<5posprim.adb \
+ s-parame.adb<5sparame.adb \
+ s-taprop.adb<5staprop.adb \
+ s-tasinf.adb<5stasinf.adb \
+ s-tasinf.ads<5stasinf.ads \
+ s-taspri.ads<5staspri.ads \
+ s-tpopse.adb<5etpopse.adb \
+ g-soccon.ads<3ssoccon.ads \
+ g-soliop.ads<3ssoliop.ads \
+ system.ads<5esystem.ads
+
+ THREADSLIB=-lposix4 -lthread
+ MISCLIB=-lposix4 -lnsl -lsocket
+ SO_OPTS=-Wl,-h,
+ GNATLIB_SHARED=gnatlib-shared-dual
+ LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+
+# ??? work around a gcc -O3 bug on x86
+a-numaux.o : a-numaux.adb a-numaux.ads
+ $(CC) -c $(ALL_ADAFLAGS) -O2 $(ADA_INCLUDES) $<
+endif
+
+ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4lintnam.ads \
+ a-numaux.adb<86numaux.adb \
+ a-numaux.ads<86numaux.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<5lintman.adb \
+ s-mastop.adb<5omastop.adb \
+ s-osinte.adb<5iosinte.adb \
+ s-osinte.ads<5iosinte.ads \
+ s-osprim.adb<7sosprim.adb \
+ s-taprop.adb<5itaprop.adb \
+ s-taspri.ads<5itaspri.ads \
+ system.ads<5lsystem.ads
+
+ MLIB_TGT=5lml-tgt
+ MISCLIB=-laddr2line -lbfd
+ THREADSLIB=-lpthread
+ GNATLIB_SHARED=gnatlib-shared-dual
+ GMEM_LIB=gmemlib
+ LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+
+ ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4lintnam.ads \
+ a-numaux.adb<86numaux.adb \
+ a-numaux.ads<86numaux.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<5lintman.adb \
+ s-mastop.adb<5omastop.adb \
+ s-osinte.adb<7sosinte.adb \
+ s-osinte.ads<5losinte.ads \
+ s-osprim.adb<7sosprim.adb \
+ s-taprop.adb<7staprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-tpopsp.adb<7stpopsp.adb \
+ system.ads<5lsystem.ads
+
+ THREADSLIB=-lgthreads -lmalloc
+ endif
+
+ ifeq ($(strip $(filter-out rt-linux RT-LINUX,$(THREAD_KIND))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4nintnam.ads \
+ s-inmaop.adb<5ninmaop.adb \
+ s-intman.adb<5nintman.adb \
+ s-osinte.adb<5qosinte.adb \
+ s-osinte.ads<5qosinte.ads \
+ s-osprim.adb<5qosprim.adb \
+ s-parame.ads<5qparame.ads \
+ s-stache.adb<5qstache.adb \
+ s-taprop.adb<5qtaprop.adb \
+ s-taspri.ads<5qtaspri.ads \
+ system.ads<5lsystem.ads
+
+ THREADSLIB=
+ RT_FLAGS=-D__RT__
+ endif
+endif
+
+ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),)
+ ifeq ($(strip $(filter-out mips sgi irix6%,$(targ))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4gintnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<5fintman.adb \
+ s-mastop.adb<5gmastop.adb \
+ s-osinte.adb<5aosinte.adb \
+ s-osinte.ads<5fosinte.ads \
+ s-osprim.adb<7sosprim.adb \
+ s-proinf.adb<5gproinf.adb \
+ s-proinf.ads<5gproinf.ads \
+ s-taprop.adb<5ftaprop.adb \
+ s-tasinf.ads<5ftasinf.ads \
+ s-taspri.ads<7staspri.ads \
+ s-tpgetc.adb<5gtpgetc.adb \
+ s-traceb.adb<7straceb.adb \
+ g-soccon.ads<3gsoccon.ads \
+ system.ads<5gsystem.ads
+
+ THREADSLIB=-lpthread
+ GMEM_LIB=gmemlib
+
+ else
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4gintnam.ads \
+ s-inmaop.adb<5ninmaop.adb \
+ s-interr.adb<5ginterr.adb \
+ s-intman.adb<5gintman.adb \
+ s-mastop.adb<5gmastop.adb \
+ s-osinte.adb<5aosinte.adb \
+ s-osinte.ads<5gosinte.ads \
+ s-osprim.adb<7sosprim.adb \
+ s-proinf.adb<5gproinf.adb \
+ s-proinf.ads<5gproinf.ads \
+ s-taprop.adb<5gtaprop.adb \
+ s-tasinf.adb<5gtasinf.adb \
+ s-tasinf.ads<5gtasinf.ads \
+ s-taspri.ads<7staspri.ads \
+ s-tpgetc.adb<5gtpgetc.adb \
+ s-traceb.adb<7straceb.adb \
+ g-soccon.ads<3gsoccon.ads \
+ system.ads<5fsystem.ads
+
+ THREADSLIB=-lathread
+ endif
+
+ EXTRA_GNATRTL_TASKING_OBJS=s-tpgetc.o a-tcbinf.o
+ MISCLIB=-lexc -laddr2line -lbfd
+ SO_OPTS=-Wl,-all,-set_version,sgi1.0,-update_registry,../so_locations,-soname,
+ LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+
+a-tcbinf.o: s-tpgetc.ali
+ ../../gnatbind -nostdlib -I- -I. s-tpgetc.ali
+ ../../gnatlink --GCC="../../xgcc -B../../" s-tpgetc.ali -o gen_tcbinf \
+ $(LIBGNAT_OBJS)
+ ./gen_tcbinf
+ $(CC) -c -g a-tcbinf.c
+ $(RM) gen_tcbinf
+
+# force debug info so that workshop can find the All_Tasks_List symbol
+s-taskin.o: s-taskin.adb s-taskin.ads
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) $<
+endif
+
+ifeq ($(strip $(filter-out hppa% hp hpux%,$(targ))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4hintnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<7sintman.adb \
+ s-osinte.adb<5iosinte.adb \
+ s-osinte.ads<53osinte.ads \
+ s-parame.ads<5hparame.ads \
+ s-osprim.adb<7sosprim.adb \
+ s-traceb.adb<5htraceb.adb \
+ s-taprop.adb<7staprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-tpopsp.adb<5atpopsp.adb \
+ g-soccon.ads<3hsoccon.ads \
+ system.ads<5hsystem.ads
+
+ THREADSLIB=-lpthread -lc_r
+ soext=.sl
+ SO_OPTS=-Wl,+h,
+ GNATLIB_SHARED=gnatlib-shared-dual
+
+ ifeq ($(strip $(filter-out dce DCE,$(THREAD_KIND))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-excpol.adb<4wexcpol.adb \
+ a-intnam.ads<4hintnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-interr.adb<5ginterr.adb \
+ s-intman.adb<7sintman.adb \
+ s-osinte.adb<5hosinte.adb \
+ s-osinte.ads<5hosinte.ads \
+ s-parame.ads<5hparame.ads \
+ s-osprim.adb<7sosprim.adb \
+ s-traceb.adb<5htraceb.adb \
+ s-taprop.adb<5htaprop.adb \
+ s-taspri.ads<5htaspri.ads \
+ g-soccon.ads<3hsoccon.ads \
+ system.ads<5hsystem.ads
+
+ THREADSLIB=-lcma
+ endif
+endif
+
+ifeq ($(strip $(filter-out ibm aix4%,$(manu) $(osys))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4cintnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<7sintman.adb \
+ s-osinte.adb<5bosinte.adb \
+ s-osinte.ads<5bosinte.ads \
+ s-osprim.adb<7sosprim.adb \
+ s-taprop.adb<7staprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-tpopsp.adb<7stpopsp.adb \
+ g-soccon.ads<3bsoccon.ads \
+ system.ads<5bsystem.ads
+
+ THREADSLIB=-lpthreads
+ ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4cintnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<7sintman.adb \
+ s-osinte.adb<7sosinte.adb \
+ s-osinte.ads<5cosinte.ads \
+ s-osprim.adb<7sosprim.adb \
+ s-taprop.adb<7staprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-tpopsp.adb<7stpopsp.adb \
+ g-soccon.ads<3bsoccon.ads \
+ system.ads<5bsystem.ads
+
+ THREADSLIB=-lgthreads -lmalloc
+ endif
+endif
+
+ifeq ($(strip $(filter-out lynxos,$(osys))),)
+ ifeq ($(strip $(filter-out %86 lynxos,$(arch) $(osys))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-numaux.adb<86numaux.adb \
+ a-numaux.ads<86numaux.ads \
+ a-intnam.ads<42intnam.ads \
+ s-mastop.adb<5omastop.adb \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<7sintman.adb \
+ s-osinte.adb<52osinte.adb \
+ s-osinte.ads<52osinte.ads \
+ s-osprim.adb<7sosprim.adb \
+ s-taprop.adb<7staprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-tpopsp.adb<7stpopsp.adb \
+ system.ads<52system.ads
+
+ ifeq ($(strip $(filter-out pthread PTHREAD,$(THREAD_KIND))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-numaux.adb<86numaux.adb \
+ a-numaux.ads<86numaux.ads \
+ a-intnam.ads<42intnam.ads \
+ s-mastop.adb<5omastop.adb \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<7sintman.adb \
+ s-osinte.adb<56osinte.adb \
+ s-osinte.ads<56osinte.ads \
+ s-osprim.adb<7sosprim.adb \
+ s-taprop.adb<7staprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-tpopsp.adb<5atpopsp.adb \
+ system.ads<52system.ads
+ endif
+
+ else
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<42intnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<7sintman.adb \
+ s-osinte.adb<52osinte.adb \
+ s-osinte.ads<52osinte.ads \
+ s-osprim.adb<7sosprim.adb \
+ s-taprop.adb<7staprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-tpopsp.adb<7stpopsp.adb \
+ system.ads<52system.ads
+ endif
+endif
+
+ifeq ($(strip $(filter-out rtems,$(osys))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4rintnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<7sintman.adb \
+ s-osinte.adb<5rosinte.adb \
+ s-osinte.ads<5rosinte.ads \
+ s-osprim.adb<7sosprim.adb \
+ s-parame.adb<5rparame.adb \
+ s-taprop.adb<7staprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-tpopsp.adb<5atpopsp.adb
+endif
+
+ifeq ($(strip $(filter-out go32 msdos,$(osys))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4dintnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<7sintman.adb \
+ s-osinte.adb<7sosinte.adb \
+ s-osinte.ads<5dosinte.ads \
+ s-osprim.adb<7sosprim.adb \
+ s-taprop.adb<7staprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-tpopsp.adb<7stpopsp.adb
+endif
+
+ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4aintnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<7sintman.adb \
+ s-mastop.adb<5amastop.adb \
+ s-osinte.adb<5aosinte.adb \
+ s-osinte.ads<5aosinte.ads \
+ s-osprim.adb<5posprim.adb \
+ s-taprop.adb<5ataprop.adb \
+ s-tasinf.ads<5atasinf.ads \
+ s-taspri.ads<5ataspri.ads \
+ s-tpopsp.adb<5atpopsp.adb \
+ s-traceb.adb<7straceb.adb \
+ g-soccon.ads<3asoccon.ads \
+ system.ads<5asystem.ads
+
+ MISCLIB=-laddr2line -lbfd
+ THREADSLIB=-lpthread -lmach -lexc -lrt
+ LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+endif
+
+ifeq ($(strip $(filter-out ppc mac machten,$(targ))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4mintnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<7sintman.adb \
+ s-osinte.adb<7sosinte.adb \
+ s-osinte.ads<5mosinte.ads \
+ s-osprim.adb<7sosprim.adb \
+ s-taprop.adb<7staprop.adb \
+ s-taspri.ads<7staspri.ads \
+ s-tpopsp.adb<7stpopsp.adb
+endif
+
+ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-calend.adb<4wcalend.adb \
+ a-excpol.adb<4wexcpol.adb \
+ a-intnam.ads<4wintnam.ads \
+ a-numaux.adb<86numaux.adb \
+ a-numaux.ads<86numaux.ads \
+ s-gloloc.adb<5wgloloc.adb \
+ s-inmaop.adb<5ninmaop.adb \
+ s-interr.adb<5ginterr.adb \
+ s-intman.adb<5wintman.adb \
+ s-mastop.adb<5omastop.adb \
+ s-memory.adb<5wmemory.adb \
+ s-osinte.ads<5wosinte.ads \
+ s-osprim.adb<5wosprim.adb \
+ s-taprop.adb<5wtaprop.adb \
+ s-taspri.ads<5wtaspri.ads \
+ g-socthi.ads<3wsocthi.ads \
+ g-socthi.adb<3wsocthi.adb \
+ g-soccon.ads<3wsoccon.ads \
+ g-soliop.ads<3wsoliop.ads \
+ system.ads<5wsystem.ads
+
+ MISCLIB = -laddr2line -lbfd -lwsock32
+ GMEM_LIB=gmemlib
+ EXTRA_GNATTOOLS = ../gnatdll$(exeext)
+ EXTRA_GNATRTL_NONTASKING_OBJS = g-regist.o
+
+# ??? work around a gcc -O3 bug on x86
+a-numaux.o : a-numaux.adb a-numaux.ads
+ $(CC) -c $(ALL_ADAFLAGS) -O2 $(ADA_INCLUDES) $<
+endif
+
+# The runtime library for gnat comprises two directories. One contains the
+# Ada source files that the compiler (gnat1) needs -- these files are listed
+# by ADA_INCLUDE_SRCS -- and the other contains the object files and their
+# corresponding .ali files for the parts written in Ada, libgnat.a for
+# the parts of the runtime written in C, and libgthreads.a for the pthreads
+# emulation library. LIBGNAT_OBJS lists the objects that go into libgnat.a,
+# while GNATRTL_OBJS lists the object files compiled from Ada sources that
+# go into the directory. The pthreads emulation is built in the threads
+# subdirectory and copied.
+LIBGNAT_SRCS = ada.h adaint.c adaint.h argv.c cio.c cstreams.c \
+ errno.c exit.c cal.c \
+ raise.h raise.c sysdep.c types.h io-aux.c init.c \
+ final.c tracebak.c expect.c $(EXTRA_LIBGNAT_SRCS)
+
+LIBGNAT_OBJS = adaint.o argv.o cio.o cstreams.o errno.o exit.o \
+ raise.o sysdep.o io-aux.o init.o cal.o final.o \
+ tracebak.o expect.o ../../prefix.o $(EXTRA_LIBGNAT_OBJS)
+
+# NOTE ??? - when the -I option for compiling Ada code is made to work,
+# the library installation will change and there will be a
+# GNAT_RTL_SRCS. Right now we count on being able to build GNATRTL_OBJS
+# from ADA_INCLUDE_SRCS.
+
+# Objects needed only for tasking
+GNATRTL_TASKING_OBJS= \
+ a-dynpri.o \
+ a-interr.o \
+ a-intsig.o \
+ a-intnam.o \
+ a-reatim.o \
+ a-retide.o \
+ a-sytaco.o \
+ a-taside.o \
+ g-thread.o \
+ s-asthan.o \
+ s-inmaop.o \
+ s-interr.o \
+ s-intman.o \
+ s-osinte.o \
+ s-proinf.o \
+ s-taenca.o \
+ s-taprob.o \
+ s-taprop.o \
+ s-tarest.o \
+ s-tasdeb.o \
+ s-tasinf.o \
+ s-tasini.o \
+ s-taskin.o \
+ s-taspri.o \
+ s-tasque.o \
+ s-tasres.o \
+ s-tasren.o \
+ s-tassta.o \
+ s-tasuti.o \
+ s-taasde.o \
+ s-tadeca.o \
+ s-tadert.o \
+ s-tataat.o \
+ s-tpinop.o \
+ s-tpoben.o \
+ s-tpobop.o \
+ s-tposen.o $(EXTRA_GNATRTL_TASKING_OBJS)
+
+# Objects needed for non-tasking.
+GNATRTL_NONTASKING_OBJS= \
+ a-caldel.o \
+ a-calend.o \
+ a-chahan.o \
+ a-charac.o \
+ a-chlat1.o \
+ a-colien.o \
+ a-colire.o \
+ a-comlin.o \
+ a-cwila1.o \
+ a-decima.o \
+ a-einuoc.o \
+ a-except.o \
+ a-exctra.o \
+ a-filico.o \
+ a-finali.o \
+ a-flteio.o \
+ a-fwteio.o \
+ a-inteio.o \
+ a-ioexce.o \
+ a-iwteio.o \
+ a-lfteio.o \
+ a-lfwtio.o \
+ a-liteio.o \
+ a-liwtio.o \
+ a-llftio.o \
+ a-llfwti.o \
+ a-llitio.o \
+ a-lliwti.o \
+ a-ncelfu.o \
+ a-nlcefu.o \
+ a-nlcoty.o \
+ a-nlelfu.o \
+ a-nllcef.o \
+ a-nllcty.o \
+ a-nllefu.o \
+ a-nscefu.o \
+ a-nscoty.o \
+ a-nselfu.o \
+ a-nucoty.o \
+ a-nuelfu.o \
+ a-nuflra.o \
+ a-numaux.o \
+ a-numeri.o \
+ a-sfteio.o \
+ a-sfwtio.o \
+ a-siteio.o \
+ a-siwtio.o \
+ a-ssicst.o \
+ a-ssitio.o \
+ a-ssiwti.o \
+ a-stmaco.o \
+ a-strbou.o \
+ a-stream.o \
+ a-strfix.o \
+ a-string.o \
+ a-strmap.o \
+ a-strsea.o \
+ a-strunb.o \
+ a-ststio.o \
+ a-stunau.o \
+ a-stwibo.o \
+ a-stwifi.o \
+ a-stwima.o \
+ a-stwise.o \
+ a-stwiun.o \
+ a-suteio.o \
+ a-swuwti.o \
+ a-swmwco.o \
+ a-tags.o \
+ a-teioed.o \
+ a-textio.o \
+ a-ticoau.o \
+ a-tideau.o \
+ a-tienau.o \
+ a-tiflau.o \
+ a-tigeau.o \
+ a-tiinau.o \
+ a-timoau.o \
+ a-tiocst.o \
+ a-titest.o \
+ a-witeio.o \
+ a-wtcoau.o \
+ a-wtcstr.o \
+ a-wtdeau.o \
+ a-wtedit.o \
+ a-wtenau.o \
+ a-wtflau.o \
+ a-wtgeau.o \
+ a-wtinau.o \
+ a-wtmoau.o \
+ a-wttest.o \
+ ada.o \
+ calendar.o \
+ g-awk.o \
+ g-busora.o \
+ g-calend.o \
+ g-casuti.o \
+ g-catiio.o \
+ g-cgi.o \
+ g-cgicoo.o \
+ g-cgideb.o \
+ g-comlin.o \
+ g-curexc.o \
+ g-debuti.o \
+ g-debpoo.o \
+ g-dirope.o \
+ g-except.o \
+ g-exctra.o \
+ g-expect.o \
+ g-flocon.o \
+ g-hesora.o \
+ g-htable.o \
+ g-io.o \
+ g-io_aux.o \
+ g-locfil.o \
+ g-moreex.o \
+ g-os_lib.o \
+ g-regexp.o \
+ g-regpat.o \
+ g-soccon.o \
+ g-socket.o \
+ g-socthi.o \
+ g-soliop.o \
+ g-souinf.o \
+ g-speche.o \
+ g-spipat.o \
+ g-spitbo.o \
+ g-sptabo.o \
+ g-sptain.o \
+ g-sptavs.o \
+ g-tasloc.o \
+ g-traceb.o \
+ g-trasym.o \
+ gnat.o \
+ i-c.o \
+ i-cexten.o \
+ i-cobol.o \
+ i-cpp.o \
+ i-cstrea.o \
+ i-cstrin.o \
+ i-fortra.o \
+ i-pacdec.o \
+ interfac.o \
+ ioexcept.o \
+ machcode.o \
+ s-addima.o \
+ s-arit64.o \
+ s-assert.o \
+ s-auxdec.o \
+ s-bitops.o \
+ s-chepoo.o \
+ s-direio.o \
+ s-errrep.o \
+ s-except.o \
+ s-exctab.o \
+ s-exnflt.o \
+ s-exngen.o \
+ s-exnint.o \
+ s-exnlfl.o \
+ s-exnlin.o \
+ s-exnllf.o \
+ s-exnlli.o \
+ s-exnsfl.o \
+ s-exnsin.o \
+ s-exnssi.o \
+ s-expflt.o \
+ s-expgen.o \
+ s-expint.o \
+ s-explfl.o \
+ s-explin.o \
+ s-expllf.o \
+ s-explli.o \
+ s-expllu.o \
+ s-expmod.o \
+ s-expsfl.o \
+ s-expsin.o \
+ s-expssi.o \
+ s-expuns.o \
+ s-fatflt.o \
+ s-fatlfl.o \
+ s-fatllf.o \
+ s-fatsfl.o \
+ s-ficobl.o \
+ s-fileio.o \
+ s-finimp.o \
+ s-finroo.o \
+ s-fore.o \
+ s-imgbiu.o \
+ s-imgboo.o \
+ s-imgcha.o \
+ s-imgdec.o \
+ s-imgenu.o \
+ s-imgint.o \
+ s-imgllb.o \
+ s-imglld.o \
+ s-imglli.o \
+ s-imgllu.o \
+ s-imgllw.o \
+ s-imgrea.o \
+ s-imguns.o \
+ s-imgwch.o \
+ s-imgwiu.o \
+ s-io.o \
+ s-gloloc.o \
+ s-maccod.o \
+ s-mantis.o \
+ s-mastop.o \
+ s-osprim.o \
+ s-pack03.o \
+ s-pack05.o \
+ s-pack06.o \
+ s-pack07.o \
+ s-pack09.o \
+ s-pack10.o \
+ s-pack11.o \
+ s-pack12.o \
+ s-pack13.o \
+ s-pack14.o \
+ s-pack15.o \
+ s-pack17.o \
+ s-pack18.o \
+ s-pack19.o \
+ s-pack20.o \
+ s-pack21.o \
+ s-pack22.o \
+ s-pack23.o \
+ s-pack24.o \
+ s-pack25.o \
+ s-pack26.o \
+ s-pack27.o \
+ s-pack28.o \
+ s-pack29.o \
+ s-pack30.o \
+ s-pack31.o \
+ s-pack33.o \
+ s-pack34.o \
+ s-pack35.o \
+ s-pack36.o \
+ s-pack37.o \
+ s-pack38.o \
+ s-pack39.o \
+ s-pack40.o \
+ s-pack41.o \
+ s-pack42.o \
+ s-pack43.o \
+ s-pack44.o \
+ s-pack45.o \
+ s-pack46.o \
+ s-pack47.o \
+ s-pack48.o \
+ s-pack49.o \
+ s-pack50.o \
+ s-pack51.o \
+ s-pack52.o \
+ s-pack53.o \
+ s-pack54.o \
+ s-pack55.o \
+ s-pack56.o \
+ s-pack57.o \
+ s-pack58.o \
+ s-pack59.o \
+ s-pack60.o \
+ s-pack61.o \
+ s-pack62.o \
+ s-pack63.o \
+ s-parame.o \
+ s-parint.o \
+ s-pooglo.o \
+ s-pooloc.o \
+ s-poosiz.o \
+ s-powtab.o \
+ s-rpc.o \
+ s-scaval.o \
+ s-secsta.o \
+ s-sequio.o \
+ s-shasto.o \
+ s-sopco3.o \
+ s-sopco4.o \
+ s-sopco5.o \
+ s-stache.o \
+ s-stalib.o \
+ s-stoele.o \
+ s-stopoo.o \
+ s-stratt.o \
+ s-strops.o \
+ s-soflin.o \
+ s-memory.o \
+ s-traceb.o \
+ s-unstyp.o \
+ s-vaflop.o \
+ s-valboo.o \
+ s-valcha.o \
+ s-valdec.o \
+ s-valenu.o \
+ s-valint.o \
+ s-vallld.o \
+ s-vallli.o \
+ s-valllu.o \
+ s-valrea.o \
+ s-valuns.o \
+ s-valuti.o \
+ s-valwch.o \
+ s-vercon.o \
+ s-vmexta.o \
+ s-wchcnv.o \
+ s-wchcon.o \
+ s-wchjis.o \
+ s-wchstw.o \
+ s-wchwts.o \
+ s-widboo.o \
+ s-widcha.o \
+ s-widenu.o \
+ s-widlli.o \
+ s-widllu.o \
+ s-widwch.o \
+ s-wwdcha.o \
+ s-wwdenu.o \
+ s-wwdwch.o \
+ system.o \
+ text_io.o $(EXTRA_GNATRTL_NONTASKING_OBJS)
+
+GNATRTL_OBJS = $(GNATRTL_NONTASKING_OBJS) $(GNATRTL_TASKING_OBJS)
+
+# Files which are suitable in no run time/hi integrity mode
+
+HIE_SOURCES = \
+ system.ads \
+ ada.ads \
+ a-unccon.ads \
+ a-uncdea.ads \
+ gnat.ads \
+ g-souinf.ads \
+ interfac.ads \
+ s-stoele.ads \
+ s-stoele.adb \
+ unchconv.ads \
+ unchdeal.ads \
+ s-maccod.ads \
+ s-unstyp.ads \
+ a-tags.ads \
+ a-tags.adb $(EXTRA_HIE_SOURCES)
+
+HIE_OBJS = \
+ system.o \
+ ada.o \
+ a-except.o \
+ gnat.o \
+ g-souinf.o \
+ interfac.o \
+ i-c.o \
+ s-stoele.o \
+ s-maccod.o \
+ s-unstyp.o \
+ a-tags.o $(EXTRA_HIE_OBJS)
+
+# Files which are needed in ravenscar mode
+
+RAVEN_SOURCES = \
+ $(HIE_SOURCES) \
+ s-arit64.ads \
+ s-arit64.adb \
+ s-parame.ads \
+ s-parame.adb \
+ g-except.ads \
+ s-stalib.ads \
+ s-stalib.adb \
+ s-soflin.ads \
+ s-soflin.adb \
+ s-secsta.ads \
+ s-secsta.adb \
+ s-osinte.ads \
+ s-osinte.adb \
+ s-tasinf.ads \
+ s-tasinf.adb \
+ s-taspri.ads \
+ s-taprop.ads \
+ s-taprop.adb \
+ s-taskin.ads \
+ s-interr.ads \
+ s-interr.adb \
+ s-taskin.adb \
+ a-reatim.ads \
+ a-reatim.adb \
+ a-retide.ads \
+ a-retide.adb \
+ s-taprob.ads \
+ s-taprob.adb \
+ s-tposen.ads \
+ s-tposen.adb \
+ s-tasres.ads \
+ s-tarest.ads \
+ s-tarest.adb $(EXTRA_RAVEN_SOURCES)
+
+# Files that need to be preprocessed before inclusion in a ravenscar run time
+
+RAVEN_MOD = \
+ s-tposen.adb \
+ s-tarest.adb
+
+# Objects to generate for the ravenscar run time
+
+RAVEN_OBJS = \
+ $(HIE_OBJS) \
+ g-except.o \
+ s-stalib.o \
+ s-arit64.o \
+ s-parame.o \
+ s-soflin.o \
+ s-secsta.o \
+ s-tasinf.o \
+ s-osinte.o \
+ s-taspri.o \
+ s-taprop.o \
+ s-taskin.o \
+ s-taprob.o \
+ s-tposen.o \
+ s-interr.o \
+ a-interr.o \
+ a-reatim.o \
+ a-retide.o \
+ s-tasres.o \
+ s-tarest.o $(EXTRA_RAVEN_OBJS)
+
+# Default run time files
+
+ADA_INCLUDE_SRCS =\
+ ada.ads calendar.ads directio.ads gnat.ads interfac.ads ioexcept.ads \
+ machcode.ads text_io.ads unchconv.ads unchdeal.ads \
+ sequenio.ads system.ads Makefile.adalib memtrack.adb \
+ a-*.adb a-*.ads g-*.ad? i-*.ad? \
+ s-[a-o]*.adb s-[p-z]*.adb \
+ s-[a-o]*.ads s-[p-z]*.ads
+
+# Files specific to the C interpreter bytecode compiler(s).
+BC_OBJS = ../bc-emit.o ../bc-optab.o
+
+# Language-independent object files.
+BACKEND = ../main.o ../attribs.o ../libbackend.a
+
+Makefile: $(srcdir)/Makefile.in $(srcdir)/../configure
+ cd ..; $(SHELL) config.status
+
+native: ../gnat1$(exeext)
+
+compiler: ../gnat1$(exeext)
+
+tools: ../gnatbl$(exeext) ../gnatchop$(exeext) ../gnatcmd$(exeext)\
+ ../gnatkr$(exeext) ../gnatlink$(exeext) ../gnatlbr$(exeext) \
+ ../gnatls$(exeext) ../gnatmake$(exeext) ../gnatmem$(exeext) \
+ ../gnatprep$(exeext) ../gnatpsta$(exeext) ../gnatpsys$(exeext) \
+ ../gnatxref$(exeext) ../gnatfind$(exeext)
+
+# Needs to be built with CC=gcc
+# Since the RTL should be built with the latest compiler, remove the
+# stamp target in the parent directory whenever gnat1 is rebuilt
+../gnat1$(exeext): $(P) $(GNAT1_OBJS) $(BACKEND) $(LIBDEPS) $(TARGET_ADA_SRCS)
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ $(GNAT1_OBJS) $(BACKEND) $(LIBS)
+ $(RM) ../stamp-gnatlib2
+
+../gnatbind$(exeext): $(P) b_gnatb.o $(GNATBIND_OBJS)
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatb.o $(GNATBIND_OBJS) \
+ $(LIBIBERTY) $(LIBS)
+
+../gnatchop$(exeext): $(P) b_gnatch.o $(GNATCHOP_OBJS)
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatch.o $(GNATCHOP_OBJS) \
+ $(LIBS)
+
+../gnatmake$(exeext): $(P) b_gnatm.o $(GNATMAKE_OBJS)
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatm.o $(GNATMAKE_OBJS) $(LIBS)
+
+gnatbl.o: gnatbl.c adaint.h
+ $(CC) $(ALL_CFLAGS) $(INCLUDES) -c $<
+
+../gnatbl$(exeext): gnatbl.o adaint.o
+ $(CC) -o $@ $(ALL_CFLAGS) $(LDFLAGS) gnatbl.o adaint.o $(LIBS)
+
+../gnatcmd$(exeext): $(P) b_gnatc.o $(GNATCMD_OBJS)
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatc.o $(GNATCMD_OBJS) $(LIBS)
+
+../gnatkr$(exeext): $(P) b_gnatkr.o $(GNATKR_OBJS)
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatkr.o $(GNATKR_OBJS) $(LIBS)
+
+../gnatlink$(exeext): $(P) b_gnatl.o $(GNATLINK_OBJS)
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatl.o $(GNATLINK_OBJS) $(LIBS)
+
+../gnatls$(exeext): $(P) b_gnatls.o $(GNATLS_OBJS)
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatls.o $(GNATLS_OBJS) $(LIBS)
+
+../gnatmem$(exeext): $(P) b_gnatmem.o $(GNATMEM_OBJS)
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatmem.o $(GNATMEM_OBJS) \
+ $(MISCLIB) $(LIBS)
+
+../gnatprep$(exeext): $(P) b_gnatp.o $(GNATPREP_OBJS)
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatp.o $(GNATPREP_OBJS) $(LIBS)
+
+../gnatpsta$(exeext): $(P) b_gnatpa.o $(GNATPSTA_OBJS)
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatpa.o $(GNATPSTA_OBJS) \
+ $(LIBS)
+
+../gnatpsys$(exeext): $(P) b_gnatps.o $(GNATPSYS_OBJS)
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatps.o $(GNATPSYS_OBJS) \
+ $(LIBS)
+
+../gnatxref$(exeext): $(P) b_gnatxref.o $(GNATXREF_OBJS)
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatxref.o $(GNATXREF_OBJS) \
+ $(LIBS)
+
+../gnatfind$(exeext): $(P) b_gnatfind.o $(GNATFIND_OBJS)
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatfind.o $(GNATFIND_OBJS) \
+ $(LIBS)
+
+../gnatdll$(exeext): $(P) b_gnatdll.o $(GNATDLL_OBJS)
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatdll.o $(GNATDLL_OBJS) \
+ $(LIBS)
+
+../stamp-gnatlib:
+ @if [ ! -f stamp-gnatlib ] ; \
+ then \
+ $(ECHO) You must first build the GNAT library: make gnatlib; \
+ false; \
+ else \
+ true; \
+ fi
+
+gnattools: force
+ $(MAKE) \
+ "CC=$(CC)" "ALL_CFLAGS=$(ALL_CFLAGS)" "INCLUDE=$(INCLUDES)" \
+ "LDFLAGS=$(LDFLAGS)" \
+ "MISCLIB=$(MISCLIB)" "exeext=$(exeext)" \
+ ../gnatbl$(exeext) ../gnatchop$(exeext) ../gnatcmd$(exeext) \
+ ../gnatkr$(exeext) ../gnatlink$(exeext) \
+ ../gnatls$(exeext) ../gnatmake$(exeext) ../gnatmem$(exeext) \
+ ../gnatprep$(exeext) ../gnatpsta$(exeext) ../gnatpsys$(exeext) \
+ ../gnatxref$(exeext) ../gnatfind$(exeext) $(EXTRA_GNATTOOLS)
+
+install-gnatlib: stamp-gnatlib
+# Create the directory before deleting it, in case the directory is
+# a list of directories (as it may be on VMS). This ensures we are
+# deleting the right one.
+ -$(MKDIR) $(ADA_RTL_OBJ_DIR)
+ -$(MKDIR) $(ADA_INCLUDE_DIR)
+ $(RMDIR) $(ADA_RTL_OBJ_DIR)
+ $(RMDIR) $(ADA_INCLUDE_DIR)
+ -$(MKDIR) $(ADA_RTL_OBJ_DIR)
+ -$(MKDIR) $(ADA_INCLUDE_DIR)
+ -$(INSTALL_DATA) ada/rts/Makefile.adalib $(ADA_RTL_OBJ_DIR)
+ for file in ada/rts/*.ali; do \
+ $(INSTALL_DATA) $$file $(ADA_RTL_OBJ_DIR); \
+ done
+ -for file in ada/rts/*$(arext);do \
+ $(INSTALL_DATA) $$file $(ADA_RTL_OBJ_DIR); \
+ done
+ifeq ($(strip $(filter-out alpha% dec vms%,$(targ))),)
+ -for file in ada/rts/lib*$(soext);do \
+ $(INSTALL_DATA) $$file $(ADA_RTL_OBJ_DIR); \
+ done
+else
+ -for file in ada/rts/lib*-**$(soext);do \
+ $(INSTALL_DATA) $$file $(ADA_RTL_OBJ_DIR); \
+ done
+endif
+ -$(LN) $(ADA_RTL_OBJ_DIR)/libgnat-*$(soext) \
+ $(ADA_RTL_OBJ_DIR)/libgnat$(soext)
+ -$(LN) $(ADA_RTL_OBJ_DIR)/libgnarl-*$(soext) \
+ $(ADA_RTL_OBJ_DIR)/libgnarl$(soext)
+# This copy must be done preserving the date on the original file.
+ for file in ada/rts/*.adb ada/rts/*.ads; do \
+ $(INSTALL_DATA_DATE) $$file $(ADA_INCLUDE_DIR); \
+ done
+ cd $(ADA_INCLUDE_DIR); $(CHMOD) a-wx *.adb
+ cd $(ADA_INCLUDE_DIR); $(CHMOD) a-wx *.ads
+
+../stamp-gnatlib2:
+ $(RM) rts/s-*.ali
+ $(RM) rts/s-*$(objext)
+ $(RM) rts/a-*.ali
+ $(RM) rts/a-*$(objext)
+ $(RM) rts/*.ali
+ $(RM) rts/*$(objext)
+ $(RM) rts/*$(arext)
+ $(RM) rts/*$(soext)
+ touch ../stamp-gnatlib2
+ $(RM) ../stamp-gnatlib
+
+# NOTE: The $(foreach ...) commands assume ";" is the valid separator between
+# successive target commands. Although the Gnu make documentation
+# implies this is true on all systems, I suspect it may not be, So care
+# has been taken to allow a sed script to look for ";)" and substitue
+# for ";" the appropriate character in the range of lines below
+# beginning with "GNULLI Begin" and ending with "GNULLI End"
+
+# GNULLI Begin ###########################################################
+
+../stamp-gnatlib1: Makefile ../stamp-gnatlib2
+ $(RMDIR) rts
+ $(MKDIR) rts
+ $(CHMOD) u+w rts
+# Copy target independent sources
+ $(foreach f,$(ADA_INCLUDE_SRCS) $(LIBGNAT_SRCS), \
+ $(LN_S) $(fsrcpfx)$(f) rts ;) true
+# Remove files to be replaced by target dependent sources
+ $(RM) $(foreach PAIR,$(LIBGNAT_TARGET_PAIRS), \
+ rts/$(word 1,$(subst <, ,$(PAIR))))
+# Copy new target dependent sources
+ $(foreach PAIR,$(LIBGNAT_TARGET_PAIRS), \
+ $(LN_S) $(fsrcpfx)$(word 2,$(subst <, ,$(PAIR))) \
+ rts/$(word 1,$(subst <, ,$(PAIR)));)
+ $(RM) ../stamp-gnatlib
+ touch ../stamp-gnatlib1
+
+# GNULLI End #############################################################
+
+# Don't use semicolon separated shell commands that involve list expansions.
+# The semicolon triggers a call to DCL on VMS and DCL can't handle command
+# line lengths in excess of 256 characters.
+# Example: cd rts; ar rc libfoo.a $(LONG_LIST_OF_OBJS)
+# is guaranteed to overflow the buffer.
+
+gnatlib: ../stamp-gnatlib1 ../stamp-gnatlib2
+# ../xgcc -B../ -dD -E ../tconfig.h $(INCLUDES) > rts/tconfig.h
+ $(MAKE) -C rts CC="../../xgcc -B../../" \
+ INCLUDES="$(INCLUDES_FOR_SUBDIR) -I./../.." \
+ CFLAGS="$(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS) -DIN_RTS" \
+ srcdir=$(fsrcdir) \
+ -f ../Makefile $(LIBGNAT_OBJS)
+ $(MAKE) -C rts CC="../../xgcc -B../../" \
+ ADA_INCLUDES="$(ADA_INCLUDES_FOR_SUBDIR)" \
+ CFLAGS="$(GNATLIBCFLAGS)" \
+ ADAFLAGS="$(GNATLIBFLAGS)" \
+ srcdir=$(fsrcdir) \
+ -f ../Makefile \
+ $(GNATRTL_OBJS)
+ $(RM) rts/libgnat$(arext) rts/libgnarl$(arext)
+ $(AR) $(AR_FLAGS) rts/libgnat$(arext) \
+ $(addprefix rts/,$(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS))
+ if $(RANLIB_TEST) ; then $(RANLIB) rts/libgnat$(arext); else true; fi
+ $(AR) $(AR_FLAGS) rts/libgnarl$(arext) \
+ $(addprefix rts/,$(GNATRTL_TASKING_OBJS))
+ if $(RANLIB_TEST) ; then $(RANLIB) rts/libgnarl$(arext); else true; fi
+ ifeq ($(GMEM_LIB),gmemlib)
+ $(AR) $(AR_FLAGS) rts/libgmem$(arext) rts/memtrack.o;
+ if $(RANLIB_TEST) ; then \
+ $(RANLIB) rts/libgmem$(arext); \
+ else \
+ true; \
+ fi
+ endif
+ $(CHMOD) a-wx rts/*.ali
+ touch ../stamp-gnatlib
+
+# generate read-only ali files for HI-E.
+
+internal-hielib: ../stamp-gnatlib1
+ sed -e 's/High_Integrity_Mode.*/High_Integrity_Mode : constant Boolean := True;/' rts/system.ads > rts/s.ads
+ $(MV) rts/s.ads rts/system.ads
+ $(MAKE) -C rts CC="../../xgcc -B../../" \
+ ADA_INCLUDES="$(ADA_INCLUDES_FOR_SUBDIR)" \
+ CFLAGS="$(GNATLIBCFLAGS)" \
+ ADAFLAGS="$(GNATLIBFLAGS)" \
+ srcdir=$(fsrcdir) \
+ -f ../Makefile \
+ $(HIE_OBJS)
+ $(CHMOD) a-wx rts/*.ali
+ $(RM) $(addprefix rts/,$(HIE_OBJS))
+ touch ../stamp-gnatlib
+
+hielib:
+ $(MAKE) ADA_INCLUDE_SRCS="$(HIE_SOURCES)" LIBGNAT_SRCS="" \
+ LIBGNAT_TARGET_PAIRS="a-except.ads<1aexcept.ads \
+ a-except.adb<1aexcept.adb \
+ i-c.ads<1ic.ads" internal-hielib
+
+internal-ravenlib: ../stamp-gnatlib1
+ echo "pragma Ravenscar;" > rts/gnat.adc
+ echo "pragma Restrictions (No_Exception_Handlers);" >> rts/gnat.adc
+ $(foreach f,$(RAVEN_MOD), \
+ $(RM) rts/$(f) ; \
+ grep -v "not needed in no exc mode" $(fsrcpfx)$(f) > rts/$(f) ;) true
+ $(MAKE) -C rts CC="../../xgcc -B../../" \
+ ADA_INCLUDES="$(ADA_INCLUDES_FOR_SUBDIR)" \
+ CFLAGS="$(GNATLIBCFLAGS)" \
+ ADAFLAGS="$(GNATLIBFLAGS)" \
+ srcdir=$(fsrcdir) \
+ -f ../Makefile \
+ $(RAVEN_OBJS)
+ $(CHMOD) a-wx rts/*.ali
+ touch ../stamp-gnatlib
+
+# Target for building a ravenscar run time for VxWorks/Cert PPC
+ravenppclib:
+ $(MAKE) ADA_INCLUDE_SRCS="$(RAVEN_SOURCES)" LIBGNAT_SRCS="" \
+ LIBGNAT_TARGET_PAIRS="a-except.ads<1aexcept.ads \
+ a-except.adb<1aexcept.adb \
+ i-c.ads<1ic.ads \
+ a-interr.adb<1ainterr.adb \
+ s-interr.ads<1sinterr.ads \
+ s-interr.adb<1sinterr.adb \
+ s-parame.ads<1sparame.ads \
+ s-secsta.adb<1ssecsta.adb \
+ s-soflin.ads<1ssoflin.ads \
+ s-soflin.adb<1ssoflin.adb \
+ s-stalib.ads<1sstalib.ads \
+ s-stalib.adb<1sstalib.adb \
+ s-taprop.ads<1staprop.ads \
+ s-taprop.adb<1staprop.adb \
+ a-sytaco.ads<1asytaco.ads \
+ a-sytaco.adb<1asytaco.adb \
+ a-intnam.ads<4zintnam.ads \
+ s-osinte.adb<5zosinte.adb \
+ s-osinte.ads<5zosinte.ads \
+ s-taspri.ads<5ztaspri.ads \
+ s-vxwork.ads<5pvxwork.ads \
+ system.ads<5ysystem.ads" internal-ravenlib
+
+
+# Warning: this target assumes that LIBRARY_VERSION has been set correctly.
+gnatlib-shared-default:
+ $(MAKE) $(FLAGS_TO_PASS) \
+ GNATLIBFLAGS="$(GNATLIBFLAGS)" \
+ GNATLIBCFLAGS="$(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS)" \
+ THREAD_KIND="$(THREAD_KIND)" \
+ gnatlib
+ $(RM) rts/libgnat$(soext) rts/libgnarl$(soext)
+ cd rts; ../../xgcc -B../../ -shared $(TARGET_LIBGCC2_CFLAGS) \
+ -o libgnat-$(LIBRARY_VERSION)$(soext) $(SO_OPTS)libgnat-$(LIBRARY_VERSION)$(soext) \
+ $(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS) $(MISCLIB) -lm
+ cd rts; ../../xgcc -B../../ -shared $(TARGET_LIBGCC2_CFLAGS) \
+ -o libgnarl-$(LIBRARY_VERSION)$(soext) $(SO_OPTS)libgnarl-$(LIBRARY_VERSION)$(soext) \
+ $(GNATRTL_TASKING_OBJS) $(THREADSLIB)
+ cd rts; $(LN) libgnat-$(LIBRARY_VERSION)$(soext) libgnat$(soext)
+ cd rts; $(LN) libgnarl-$(LIBRARY_VERSION)$(soext) libgnarl$(soext)
+
+gnatlib-shared-dual:
+ $(MAKE) $(FLAGS_TO_PASS) \
+ GNATLIBFLAGS="$(GNATLIBFLAGS)" \
+ GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \
+ THREAD_KIND="$(THREAD_KIND)" \
+ gnatlib
+ $(MV) rts/libgnat$(arext) rts/libgnarl$(arext) .
+ $(RM) ../stamp-gnatlib2
+ $(MAKE) $(FLAGS_TO_PASS) \
+ GNATLIBFLAGS="$(GNATLIBFLAGS)" \
+ GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \
+ THREAD_KIND="$(THREAD_KIND)" \
+ gnatlib-shared-default
+ $(MV) libgnat$(arext) libgnarl$(arext) rts
+
+gnatlib-shared-vms:
+ $(MAKE) $(FLAGS_TO_PASS) \
+ GNATLIBFLAGS="$(GNATLIBFLAGS)" \
+ GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \
+ THREAD_KIND="$(THREAD_KIND)" \
+ gnatlib
+ $(RM) rts/libgnat$(soext) rts/libgnarl$(soext)
+ rm -f rts/*.sym rts/gnatlib_symvec.opt
+ make -C rts -f ../Makefile.vms \
+ $(patsubst %.obj,%.sym,$(LIBGNAT_OBJS) $(GNATRTL_NONTASKING_OBJS))
+ append /new [.rts]*.sym [.rts]gnatlib_symvec.opt
+ ../xgcc.exe -g -B../ -nostartfiles -shared --for-linker=/noinform \
+ -o rts/libgnat.exe rts/libgnat.olb \
+ --for-linker=rts/gnatlib_symvec.opt \
+ --for-linker=gsmatch=equal,YY,MMDD
+ rm -f rts/*.sym rts/gnatlib_symvec.opt
+ make -C rts -f ../Makefile.vms \
+ $(patsubst %.obj,%.sym,$(GNATRTL_TASKING_OBJS))
+ append /new [.rts]*.sym [.rts]gnatlib_symvec.opt
+ ../xgcc.exe -g -B../ -nostartfiles -shared --for-linker=/noinform \
+ -o rts/libgnarl.exe rts/libgnarl.olb rts/libgnat.exe \
+ --for-linker=rts/gnatlib_symvec.opt \
+ --for-linker=gsmatch=equal,YY,MMDD
+
+gnatlib-shared:
+ $(MAKE) $(FLAGS_TO_PASS) \
+ GNATLIBFLAGS="$(GNATLIBFLAGS)" \
+ GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \
+ THREAD_KIND="$(THREAD_KIND)" \
+ $(GNATLIB_SHARED)
+
+# .s files for cross-building
+gnat-cross: force
+ make $(GNAT1_ADA_OBJS) CC="gcc -B../stage1/" CFLAGS="-S -gnatp" \
+ HOST_CFLAGS= HOST_CC=cc
+
+# Compiling object files from source files.
+
+# Note that dependencies on obstack.h are not written
+# because that file is not part of GCC.
+# Dependencies on gvarargs.h are not written
+# because all that file does, when not compiling with GCC,
+# is include the system varargs.h.
+
+TREE_H = $(srcdir)/../tree.h $(srcdir)/../real.h $(srcdir)/../tree.def \
+ $(srcdir)/../machmode.h $(srcdir)/../machmode.def
+
+# Ada language specific files.
+
+ada_extra_files : treeprs.ads einfo.h sinfo.h nmake.adb nmake.ads
+
+b_gnat1.c : $(GNAT1_ADA_OBJS)
+ $(GNATBIND) $(ADA_INCLUDES) -o b_gnat1.c -n gnat1drv.ali
+b_gnat1.o : b_gnat1.c
+
+b_gnatb.c : $(GNATBIND_OBJS)
+ $(GNATBIND) $(ADA_INCLUDES) -o b_gnatb.c gnatbind.ali
+b_gnatb.o : b_gnatb.c
+
+b_gnatc.c : $(GNATCMD_OBJS)
+ $(GNATBIND) $(ADA_INCLUDES) -o b_gnatc.c gnatcmd.ali
+b_gnatc.o : b_gnatc.c
+
+b_gnatch.c : $(GNATCHOP_OBJS)
+ $(GNATBIND) $(ADA_INCLUDES) -o b_gnatch.c gnatchop.ali
+b_gnatch.o : b_gnatch.c
+
+b_gnatkr.c : $(GNATKR_OBJS)
+ $(GNATBIND) $(ADA_INCLUDES) -o b_gnatkr.c gnatkr.ali
+b_gnatkr.o : b_gnatkr.c
+
+b_gnatl.c : $(GNATLINK_OBJS)
+ $(GNATBIND) $(ADA_INCLUDES) -o b_gnatl.c gnatlink.ali
+b_gnatl.o : b_gnatl.c
+
+b_gnatls.c : $(GNATLS_OBJS)
+ $(GNATBIND) $(ADA_INCLUDES) -o b_gnatls.c gnatls.ali
+
+b_gnatm.c : $(GNATMAKE_OBJS)
+ $(GNATBIND) $(ADA_INCLUDES) -o b_gnatm.c gnatmake.ali
+b_gnatm.o : b_gnatm.c
+
+b_gnatmem.c : $(GNATMEM_OBJS)
+ $(GNATBIND) $(ADA_INCLUDES) -o b_gnatmem.c gnatmem.ali
+b_gnatmem.o : b_gnatmem.c
+
+b_gnatp.c : $(GNATPREP_OBJS)
+ $(GNATBIND) $(ADA_INCLUDES) -o b_gnatp.c gnatprep.ali
+b_gnatp.o : b_gnatp.c
+
+b_gnatpa.c : $(GNATPSTA_OBJS)
+ $(GNATBIND) $(ADA_INCLUDES) -o b_gnatpa.c gnatpsta.ali
+b_gnatpa.o : b_gnatpa.c
+
+b_gnatps.c : $(GNATPSYS_OBJS)
+ $(GNATBIND) $(ADA_INCLUDES) -o b_gnatps.c gnatpsys.ali
+b_gnatps.o : b_gnatps.c
+
+b_gnatxref.c : $(GNATXREF_OBJS)
+ $(GNATBIND) $(ADA_INCLUDES) -o b_gnatxref.c gnatxref.ali
+b_gnatxref.o : b_gnatxref.c
+
+b_gnatfind.c : $(GNATFIND_OBJS)
+ $(GNATBIND) $(ADA_INCLUDES) -o b_gnatfind.c gnatfind.ali
+b_gnatfind.o : b_gnatfind.c
+
+b_gnatdll.c : $(GNATDLL_OBJS)
+ $(GNATBIND) $(ADA_INCLUDES) -o b_gnatdll.c gnatdll.ali
+b_gnatdll.o : b_gnatdll.c
+
+$(srcdir)/treeprs.ads : treeprs.adt sinfo.ads xtreeprs.spt
+ (cd $(srcdir); xtreeprs)
+
+$(srcdir)/einfo.h : einfo.ads einfo.adb xeinfo.spt
+ (cd $(srcdir); xeinfo einfo.h)
+
+$(srcdir)/sinfo.h : sinfo.ads xsinfo.spt
+ (cd $(srcdir); xsinfo sinfo.h)
+
+$(srcdir)/nmake.adb : nmake.adt sinfo.ads xnmake.spt
+ (cd $(srcdir); xnmake)
+
+$(srcdir)/nmake.ads : nmake.adt sinfo.ads xnmake.spt
+ (cd $(srcdir); xnmake)
+
+ADA_INCLUDE_DIR = $(libsubdir)/adainclude
+ADA_RTL_OBJ_DIR = $(libsubdir)/adalib
+
+# Note: the strings below do not make sense for Ada strings in the OS/2
+# case. This is ignored for now since the OS/2 version doesn't use
+# these -- there are no default locations.
+sdefault.adb: stamp-sdefault ; @true
+stamp-sdefault : $(srcdir)/../version.c $(srcdir)/../move-if-change \
+ Makefile
+ $(ECHO) "package body Sdefault is" >tmp-sdefault.adb
+ $(ECHO) " S1 : aliased constant String := \"$(ADA_INCLUDE_DIR)/\";" >>tmp-sdefault.adb
+ $(ECHO) " S2 : aliased constant String := \"$(ADA_RTL_OBJ_DIR)/\";" >>tmp-sdefault.adb
+ $(ECHO) " S3 : aliased constant String := \"$(target)/\";" >>tmp-sdefault.adb
+ $(ECHO) " S4 : aliased constant String := \"$(libsubdir)/\";" >>tmp-sdefault.adb
+ $(ECHO) " function Include_Dir_Default_Name return String_Ptr is" >>tmp-sdefault.adb
+ $(ECHO) " begin" >>tmp-sdefault.adb
+ $(ECHO) " return new String'(S1);" >>tmp-sdefault.adb
+ $(ECHO) " end Include_Dir_Default_Name;" >>tmp-sdefault.adb
+ $(ECHO) " function Object_Dir_Default_Name return String_Ptr is" >>tmp-sdefault.adb
+ $(ECHO) " begin" >>tmp-sdefault.adb
+ $(ECHO) " return new String'(S2);" >>tmp-sdefault.adb
+ $(ECHO) " end Object_Dir_Default_Name;" >>tmp-sdefault.adb
+ $(ECHO) " function Target_Name return String_Ptr is" >>tmp-sdefault.adb
+ $(ECHO) " begin" >>tmp-sdefault.adb
+ $(ECHO) " return new String'(S3);" >>tmp-sdefault.adb
+ $(ECHO) " end Target_Name;" >>tmp-sdefault.adb
+ $(ECHO) " function Search_Dir_Prefix return String_Ptr is" >>tmp-sdefault.adb
+ $(ECHO) " begin" >>tmp-sdefault.adb
+ $(ECHO) " return new String'(S4);" >>tmp-sdefault.adb
+ $(ECHO) " end Search_Dir_Prefix;" >>tmp-sdefault.adb
+ $(ECHO) "end Sdefault;" >> tmp-sdefault.adb
+ $(srcdir)/../move-if-change tmp-sdefault.adb sdefault.adb
+ touch stamp-sdefault
+
+ADA_TREE_H = ada-tree.h ada-tree.def
+
+# special compiles for sdefault without -gnatg, to avoid long line error
+
+sdefault.o : sdefault.ads sdefault.adb types.ads unchdeal.ads \
+ system.ads s-exctab.ads s-stalib.ads unchconv.ads
+ $(CC) -c -O2 $(MOST_ADAFLAGS) $(ADA_INCLUDES) sdefault.adb
+
+# force debugging information on s-tasdeb.o so that it is always
+# possible to set conditional breakpoints on tasks.
+
+s-tasdeb.o : s-tasdeb.adb s-tasdeb.ads
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) $<
+
+# force debugging information on s-vaflop.o so that it is always
+# possible to call the VAX float debug print routines.
+# force at least -O so that the inline assembly works.
+
+s-vaflop.o : s-vaflop.adb s-vaflop.ads
+ $(CC) -c -O $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) $<
+
+# force debugging information on a-except.o so that it is always
+# possible to set conditional breakpoints on exceptions.
+# use -O1 otherwise gdb isn't able to get a full backtrace on mips targets.
+
+a-except.o : a-except.adb a-except.ads
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O1 -fno-inline \
+ $(ADA_INCLUDES) $<
+
+# force debugging information on s-assert.o so that it is always
+# possible to set breakpoint on assert failures.
+
+s-assert.o : s-assert.adb s-assert.ads a-except.ads
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O2 $(ADA_INCLUDES) $<
+
+# force debugging information on s-stalib.o so that it is always
+# possible to set breakpoints on exceptions.
+
+s-stalib.o : s-stalib.adb s-stalib.ads
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O2 $(ADA_INCLUDES) $<
+
+# force debugging information and no optimization on s-memory.o so that it
+# is always possible to set breakpoint on __gnat_malloc and __gnat_free
+# this is important for gnatmem using GDB. memtrack.o is built from
+# memtrack.adb, and used by the post-mortem analysis with gnatmem.
+
+s-memory.o : s-memory.adb s-memory.ads memtrack.o
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) $<
+
+memtrack.o : memtrack.adb s-memory.ads
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) $<
+
+# Need to keep the frame pointer in this file to pop the stack properly on
+# some targets.
+
+tracebak.o : tracebak.c
+ $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) \
+ $(ALL_CPPFLAGS) $(INCLUDES) -fno-omit-frame-pointer $<
+
+expect.o : expect.c
+io-aux.o : io-aux.c
+argv.o : argv.c
+cal.o : cal.c
+cio.o : cio.c
+ $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(RT_FLAGS) \
+ $(ALL_CPPFLAGS) $(INCLUDES) $<
+deftarg.o : deftarg.c
+errno.o : errno.c
+exit.o : raise.h exit.c
+final.o : raise.h final.c
+gmem.o : gmem.c
+
+raise.o : raise.c raise.h
+ $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(RT_FLAGS) \
+ $(ALL_CPPFLAGS) $(INCLUDES) $<
+
+ifeq ($(strip $(filter-out mips sgi irix5%,$(targ))),)
+init.o : init.c ada.h types.h raise.h
+ $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(RT_FLAGS) \
+ $(ALL_CPPFLAGS) $(INCLUDES) $<
+else
+init.o : init.c ada.h types.h raise.h
+ $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(RT_FLAGS) \
+ $(ALL_CPPFLAGS) $(INCLUDES) -fexceptions $<
+endif
+
+link.o : link.c
+sysdep.o : sysdep.c
+
+cuintp.o : cuintp.c $(CONFIG_H) $(TREE_H) ada.h types.h uintp.h atree.h \
+ stringt.h elists.h nlists.h fe.h gigi.h
+
+decl.o : decl.c $(CONFIG_H) $(TREE_H) $(srcdir)/../flags.h \
+ $(srcdir)/../toplev.h $(srcdir)/../convert.h ada.h types.h atree.h \
+ nlists.h elists.h uintp.h sinfo.h einfo.h snames.h namet.h \
+ stringt.h repinfo.h fe.h $(ADA_TREE_H) gigi.h
+
+misc.o : misc.c $(CONFIG_H) $(TREE_H) $(RTL_H) $(srcdir)/../expr.h \
+ ../insn-codes.h ../insn-flags.h ../insn-config.h $(srcdir)/../recog.h \
+ $(srcdir)/../flags.h $(srcdir)/../diagnostic.h $(srcdir)/../output.h \
+ $(srcdir)/../except.h ../tm_p.h ada.h types.h atree.h nlists.h elists.h \
+ sinfo.h einfo.h namet.h stringt.h uintp.h fe.h $(ADA_TREE_H) gigi.h
+
+targtyps.o : targtyps.c $(CONFIG_H) ada.h types.h atree.h nlists.h elists.h \
+ uintp.h sinfo.h einfo.h namet.h snames.h stringt.h urealp.h fe.h \
+ $(ADA_TREE_H) gigi.h
+
+trans.o : trans.c $(CONFIG_H) $(TREE_H) $(RTL_H) $(srcdir)/../flags.h ada.h \
+ types.h atree.h nlists.h elists.h uintp.h sinfo.h einfo.h \
+ namet.h snames.h stringt.h urealp.h fe.h $(ADA_TREE_H) gigi.h
+
+utils.o : utils.c $(CONFIG_H) $(TREE_H) $(srcdir)/../flags.h \
+ $(srcdir)/../convert.h $(srcdir)/../defaults.h ada.h types.h atree.h \
+ nlists.h elists.h sinfo.h einfo.h namet.h stringt.h uintp.h fe.h \
+ $(ADA_TREE_H) gigi.h
+
+utils2.o : utils2.c $(CONFIG_H) $(TREE_H) $(srcdir)/../flags.h ada.h types.h \
+ atree.h nlists.h elists.h sinfo.h einfo.h namet.h snames.h stringt.h \
+ uintp.h fe.h $(ADA_TREE_H) gigi.h
+
+# specific rules for tools needing target dependant sources
+# for each such source (e.g. mlib-tgt.adb) a link from the target
+# specific name to the default name is defined in the subdir "tools".
+# This subdir is added at the beginning of the source path fore the compilation
+# of this unit. Here are the step for adding a new target dependant source:
+# - create a Macro with the default name for the source (e.g. mlib-tgt)
+# - change the value if this Macro in each target-dependant section of this
+# Makefile (close to LIBGNAT_TARGET_PAIRS defs) if there is a
+# specific version of the file for this section
+# - Add a link from target dependant version to the default name in "tools"
+# (see stamp-tool_src_dir target)
+# - Add a specific target for the object in order to compile with
+# "tools" on the source path (see mlib-tgt)
+
+stamp-tool_src_dir:
+ -$(RMDIR) tools
+ -$(MKDIR) tools
+ -$(LN) $(fsrcdir)/$(MLIB_TGT).adb tools/mlib-tgt.adb
+ touch stamp-tool_src_dir
+
+mlib-tgt.o : stamp-tool_src_dir
+ $(CC) -c -Itools $(ALL_ADAFLAGS) $(ADA_INCLUDES) tools/mlib-tgt.adb
+
+# GNAT DEPENDENCIES
+# regular dependencies
+a-chahan.o : ada.ads a-charac.ads a-chahan.ads a-chahan.adb a-chlat1.ads \
+ a-string.ads a-strmap.ads a-stmaco.ads system.ads s-exctab.ads \
+ s-secsta.ads s-stalib.ads s-stoele.ads s-unstyp.ads unchconv.ads
+
+a-charac.o : ada.ads a-charac.ads system.ads
+
+a-chlat1.o : ada.ads a-charac.ads a-chlat1.ads system.ads
+
+a-comlin.o : ada.ads a-comlin.ads a-comlin.adb system.ads s-secsta.ads \
+ s-stoele.ads
+
+a-except.o : ada.ads a-except.ads a-except.adb a-excpol.adb a-uncdea.ads \
+ gnat.ads g-hesora.ads system.ads s-exctab.ads s-except.ads s-mastop.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-stoele.adb s-traceb.ads unchconv.ads
+
+a-filico.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-filico.adb \
+ a-stream.ads a-tags.ads a-tags.adb gnat.ads g-htable.ads system.ads \
+ s-exctab.ads s-finimp.ads s-finroo.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads s-unstyp.ads \
+ unchconv.ads
+
+a-finali.o : ada.ads a-except.ads a-finali.ads a-finali.adb a-stream.ads \
+ a-tags.ads a-tags.adb gnat.ads g-htable.ads system.ads s-exctab.ads \
+ s-finimp.ads s-finroo.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-stratt.ads s-unstyp.ads unchconv.ads
+
+a-flteio.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-flteio.ads \
+ a-flteio.ads a-ioexce.ads a-stream.ads a-tags.ads a-textio.ads \
+ a-tiflau.ads a-tiflio.ads a-tiflio.adb interfac.ads i-cstrea.ads \
+ system.ads s-exctab.ads s-ficobl.ads s-finimp.ads s-finroo.ads \
+ s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-stratt.ads s-unstyp.ads unchconv.ads
+
+a-inteio.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-inteio.ads \
+ a-inteio.ads a-ioexce.ads a-stream.ads a-tags.ads a-textio.ads \
+ a-tiinau.ads a-tiinio.ads a-tiinio.adb interfac.ads i-cstrea.ads \
+ system.ads s-exctab.ads s-ficobl.ads s-finimp.ads s-finroo.ads \
+ s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-stratt.ads s-unstyp.ads unchconv.ads
+
+a-ioexce.o : ada.ads a-ioexce.ads system.ads s-exctab.ads s-stalib.ads \
+ unchconv.ads
+
+a-stmaco.o : ada.ads a-charac.ads a-chlat1.ads a-string.ads a-strmap.ads \
+ a-stmaco.ads system.ads s-exctab.ads s-stalib.ads s-unstyp.ads \
+ unchconv.ads
+
+a-stream.o : ada.ads a-except.ads a-stream.ads a-tags.ads a-tags.adb \
+ gnat.ads g-htable.ads system.ads s-exctab.ads s-secsta.ads s-stalib.ads \
+ s-stoele.ads unchconv.ads
+
+a-strfix.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads a-string.ads \
+ a-strfix.ads a-strfix.adb a-strmap.ads a-strsea.ads system.ads \
+ s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-unstyp.ads unchconv.ads
+
+a-string.o : ada.ads a-string.ads system.ads s-exctab.ads s-stalib.ads \
+ unchconv.ads
+
+a-strmap.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads a-string.ads \
+ a-strmap.ads a-strmap.adb system.ads s-bitops.ads s-exctab.ads \
+ s-secsta.ads s-stalib.ads s-stoele.ads s-unstyp.ads unchconv.ads
+
+a-strsea.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads a-string.ads \
+ a-strmap.ads a-strsea.ads a-strsea.adb system.ads s-exctab.ads \
+ s-stalib.ads s-unstyp.ads unchconv.ads
+
+a-strunb.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads a-finali.ads \
+ a-stream.ads a-string.ads a-strfix.ads a-strmap.ads a-strsea.ads \
+ a-strunb.ads a-strunb.adb a-tags.ads a-tags.adb a-uncdea.ads gnat.ads \
+ g-htable.ads system.ads s-exctab.ads s-finimp.ads s-finroo.ads \
+ s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-stratt.ads s-unstyp.ads unchconv.ads
+
+a-tags.o : ada.ads a-except.ads a-tags.ads a-tags.adb a-uncdea.ads \
+ gnat.ads g-htable.ads g-htable.adb system.ads s-exctab.ads s-secsta.ads \
+ s-stalib.ads s-stoele.ads unchconv.ads
+
+a-textio.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \
+ a-stream.ads a-tags.ads a-tags.adb a-textio.ads a-textio.adb gnat.ads \
+ g-htable.ads interfac.ads i-cstrea.ads system.ads s-exctab.ads \
+ s-ficobl.ads s-fileio.ads s-finimp.ads s-finroo.ads s-parame.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-stratt.ads s-unstyp.ads unchconv.ads unchdeal.ads
+
+a-tiflau.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \
+ a-stream.ads a-tags.ads a-textio.ads a-tiflau.ads a-tiflau.adb \
+ a-tigeau.ads interfac.ads i-cstrea.ads system.ads s-exctab.ads \
+ s-ficobl.ads s-finimp.ads s-finroo.ads s-imgrea.ads s-parame.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-stratt.ads s-unstyp.ads s-valrea.ads unchconv.ads
+
+a-tigeau.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \
+ a-stream.ads a-tags.ads a-textio.ads a-tigeau.ads a-tigeau.adb \
+ interfac.ads i-cstrea.ads system.ads s-exctab.ads s-ficobl.ads \
+ s-fileio.ads s-finimp.ads s-finroo.ads s-parame.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads \
+ s-unstyp.ads unchconv.ads
+
+a-tiinau.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \
+ a-stream.ads a-tags.ads a-textio.ads a-tigeau.ads a-tiinau.ads \
+ a-tiinau.adb interfac.ads i-cstrea.ads system.ads s-exctab.ads \
+ s-ficobl.ads s-finimp.ads s-finroo.ads s-imgbiu.ads s-imgint.ads \
+ s-imgllb.ads s-imglli.ads s-imgllw.ads s-imgwiu.ads s-parame.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-stratt.ads s-unstyp.ads s-valint.ads s-vallli.ads unchconv.ads
+
+a-tiocst.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \
+ a-stream.ads a-tags.ads a-textio.ads a-tiocst.ads a-tiocst.adb \
+ interfac.ads i-cstrea.ads system.ads s-exctab.ads s-ficobl.ads \
+ s-fileio.ads s-finimp.ads s-finroo.ads s-parame.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads \
+ s-unstyp.ads unchconv.ads
+
+ada.o : ada.ads system.ads
+
+ali-util.o : ada.ads a-except.ads ali.ads ali-util.ads ali-util.adb \
+ alloc.ads binderr.ads casing.ads debug.ads gnat.ads g-htable.ads \
+ g-os_lib.ads gnatvsn.ads hostparm.ads namet.ads namet.adb opt.ads \
+ osint.ads output.ads rident.ads system.ads s-exctab.ads s-exctab.adb \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb tree_io.ads types.ads unchconv.ads \
+ unchdeal.ads widechar.ads
+
+ali.o : ada.ads a-except.ads a-uncdea.ads ali.ads ali.adb alloc.ads \
+ butil.ads casing.ads debug.ads fname.ads gnat.ads g-htable.ads \
+ g-htable.adb g-os_lib.ads gnatvsn.ads hostparm.ads namet.ads namet.adb \
+ opt.ads osint.ads output.ads rident.ads system.ads s-exctab.ads \
+ s-exctab.adb s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \
+ unchconv.ads unchdeal.ads widechar.ads
+
+alloc.o : alloc.ads system.ads
+
+atree.o : ada.ads a-except.ads a-uncdea.ads alloc.ads atree.ads atree.adb \
+ casing.ads debug.ads einfo.ads einfo.adb elists.ads elists.adb gnat.ads \
+ g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads namet.ads \
+ nlists.ads nlists.adb opt.ads output.ads sinfo.ads sinfo.adb sinput.ads \
+ snames.ads stand.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb tree_io.ads types.ads uintp.ads uintp.adb \
+ unchconv.ads unchdeal.ads urealp.ads
+
+back_end.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb \
+ back_end.ads back_end.adb casing.ads debug.ads einfo.ads einfo.adb \
+ elists.ads fname.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb namet.ads \
+ nlists.ads nlists.adb opt.ads osint.ads output.ads sinfo.ads sinfo.adb \
+ sinput.ads sinput.adb snames.ads stand.ads stringt.ads switch.ads \
+ system.ads s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \
+ tree_io.ads types.ads uintp.ads uintp.adb uname.ads unchconv.ads \
+ unchdeal.ads urealp.ads
+
+bcheck.o : ada.ads a-except.ads ali.ads ali-util.ads alloc.ads bcheck.ads \
+ bcheck.adb binderr.ads butil.ads casing.ads debug.ads fname.ads \
+ gnat.ads g-htable.ads g-os_lib.ads gnatvsn.ads hostparm.ads namet.ads \
+ namet.adb opt.ads osint.ads output.ads rident.ads system.ads \
+ s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \
+ types.ads unchconv.ads unchdeal.ads widechar.ads
+
+binde.o : ada.ads a-except.ads ali.ads alloc.ads binde.ads binde.adb \
+ binderr.ads butil.ads casing.ads debug.ads fname.ads gnat.ads \
+ g-htable.ads g-os_lib.ads gnatvsn.ads hostparm.ads namet.ads namet.adb \
+ opt.ads output.ads rident.ads system.ads s-exctab.ads s-secsta.ads \
+ s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \
+ types.ads unchconv.ads unchdeal.ads widechar.ads
+
+binderr.o : ada.ads a-except.ads alloc.ads binderr.ads binderr.adb \
+ butil.ads debug.ads gnat.ads g-os_lib.ads hostparm.ads namet.ads \
+ opt.ads output.ads system.ads s-exctab.ads s-stalib.ads s-wchcon.ads \
+ table.ads table.adb tree_io.ads types.ads unchconv.ads unchdeal.ads
+
+bindgen.o : ada.ads a-except.ads ali.ads alloc.ads binde.ads bindgen.ads \
+ bindgen.adb butil.ads casing.ads debug.ads fname.ads gnat.ads \
+ g-hesora.ads g-htable.ads g-os_lib.ads gnatvsn.ads hostparm.ads \
+ namet.ads opt.ads osint.ads output.ads rident.ads sdefault.ads \
+ system.ads s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-strops.ads s-sopco3.ads s-sopco4.ads \
+ s-sopco5.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \
+ unchconv.ads unchdeal.ads
+
+bindusg.o : bindusg.ads bindusg.adb gnat.ads g-os_lib.ads osint.ads \
+ output.ads system.ads s-exctab.ads s-stalib.ads types.ads unchconv.ads \
+ unchdeal.ads
+
+butil.o : ada.ads a-except.ads alloc.ads butil.ads butil.adb debug.ads \
+ gnat.ads g-os_lib.ads hostparm.ads namet.ads opt.ads output.ads \
+ system.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads table.adb \
+ tree_io.ads types.ads unchconv.ads unchdeal.ads
+
+casing.o : ada.ads a-except.ads alloc.ads casing.ads casing.adb csets.ads \
+ csets.adb debug.ads gnat.ads g-os_lib.ads hostparm.ads namet.ads \
+ opt.ads output.ads system.ads s-exctab.ads s-stalib.ads s-wchcon.ads \
+ table.ads table.adb tree_io.ads types.ads unchconv.ads unchdeal.ads \
+ widechar.ads
+
+checks.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ elists.adb errout.ads eval_fat.ads exp_ch11.ads exp_ch2.ads exp_ch7.ads \
+ exp_util.ads exp_util.adb freeze.ads get_targ.ads gnat.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads inline.ads itypes.ads lib.ads namet.ads \
+ nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \
+ restrict.ads rident.ads rtsfind.ads sem.ads sem_cat.ads sem_ch8.ads \
+ sem_eval.ads sem_eval.adb sem_res.ads sem_type.ads sem_util.ads \
+ sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \
+ stringt.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb tbuild.ads tbuild.adb tree_io.ads ttypes.ads \
+ types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads \
+ validsw.ads
+
+comperr.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ comperr.ads comperr.adb debug.ads einfo.ads einfo.adb elists.ads \
+ errout.ads fname.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \
+ gnatvsn.ads hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb \
+ namet.ads nlists.ads nlists.adb opt.ads osint.ads output.ads \
+ sdefault.ads sinfo.ads sinfo.adb sinput.ads sinput.adb snames.ads \
+ sprint.ads stand.ads stringt.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb tree_io.ads treepr.ads types.ads \
+ uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads
+
+csets.o : csets.ads csets.adb hostparm.ads opt.ads system.ads s-exctab.ads \
+ s-stalib.ads s-wchcon.ads types.ads unchconv.ads unchdeal.ads
+
+cstand.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ csets.ads cstand.ads cstand.adb debug.ads einfo.ads einfo.adb \
+ elists.ads errout.ads exp_util.ads freeze.ads get_targ.ads gnat.ads \
+ g-htable.ads g-os_lib.ads hostparm.ads layout.ads lib.ads lib-xref.ads \
+ namet.ads namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads \
+ output.ads restrict.ads rident.ads rtsfind.ads scans.ads scn.ads \
+ sem.ads sem_ch8.ads sem_eval.ads sem_mech.ads sem_res.ads sem_type.ads \
+ sem_util.ads sem_util.adb sinfo.ads sinfo.adb sinput.ads snames.ads \
+ stand.ads stringt.ads style.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads tbuild.adb \
+ tree_io.ads ttypef.ads ttypes.ads types.ads uintp.ads uintp.adb \
+ unchconv.ads unchdeal.ads urealp.ads urealp.adb widechar.ads
+
+debug.o : debug.ads debug.adb system.ads
+
+debug_a.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads debug_a.ads debug_a.adb einfo.ads elists.ads gnat.ads \
+ g-htable.ads g-os_lib.ads hostparm.ads nlists.ads nlists.adb opt.ads \
+ output.ads sinfo.ads sinput.ads snames.ads system.ads s-exctab.ads \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \
+ uintp.ads unchconv.ads unchdeal.ads urealp.ads
+
+einfo.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads gnat.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads namet.ads nlists.ads nlists.adb opt.ads \
+ output.ads sinfo.ads sinfo.adb sinput.ads snames.ads snames.adb \
+ stand.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb tree_io.ads types.ads uintp.ads uintp.adb \
+ unchconv.ads unchdeal.ads urealp.ads
+
+elists.o : ada.ads a-except.ads alloc.ads debug.ads elists.ads elists.adb \
+ gnat.ads g-os_lib.ads hostparm.ads opt.ads output.ads system.ads \
+ s-exctab.ads s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads \
+ types.ads unchconv.ads unchdeal.ads
+
+errout.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ csets.ads debug.ads einfo.ads einfo.adb elists.ads errout.ads \
+ errout.adb fname.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb namet.ads \
+ nlists.ads nlists.adb opt.ads output.ads scans.ads scn.ads sinfo.ads \
+ sinfo.adb sinput.ads sinput.adb snames.ads stand.ads stringt.ads \
+ style.ads style.adb stylesw.ads system.ads s-exctab.ads s-exctab.adb \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \
+ uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads
+
+eval_fat.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads eval_fat.ads eval_fat.adb \
+ gnat.ads g-htable.ads g-os_lib.ads hostparm.ads namet.ads nlists.ads \
+ nlists.adb opt.ads output.ads sem_util.ads sinfo.ads sinfo.adb \
+ sinput.ads snames.ads stand.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb targparm.ads tree_io.ads ttypef.ads \
+ types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads \
+ urealp.adb
+
+exp_aggr.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ elists.adb errout.ads exp_aggr.ads exp_aggr.adb exp_ch11.ads \
+ exp_ch2.ads exp_ch3.ads exp_ch7.ads exp_util.ads exp_util.adb \
+ expander.ads freeze.ads get_targ.ads gnat.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads inline.ads itypes.ads lib.ads namet.ads nlists.ads \
+ nlists.adb nmake.ads nmake.adb opt.ads output.ads restrict.ads \
+ rident.ads rtsfind.ads sem.ads sem_ch3.ads sem_ch8.ads sem_eval.ads \
+ sem_res.ads sem_util.ads sem_warn.ads sinfo.ads sinfo.adb sinput.ads \
+ snames.ads stand.ads stringt.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb tbuild.ads tbuild.adb tree_io.ads \
+ ttypes.ads types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads \
+ urealp.ads validsw.ads
+
+exp_attr.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ errout.ads exp_attr.ads exp_attr.adb exp_ch11.ads exp_ch2.ads \
+ exp_ch7.ads exp_ch9.ads exp_imgv.ads exp_pakd.ads exp_strm.ads \
+ exp_tss.ads exp_util.ads exp_util.adb fname.ads fname-uf.ads freeze.ads \
+ get_targ.ads gnat.ads g-htable.ads g-os_lib.ads gnatvsn.ads \
+ hostparm.ads inline.ads itypes.ads lib.ads lib-xref.ads namet.ads \
+ namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \
+ restrict.ads restrict.adb rident.ads rtsfind.ads scans.ads scn.ads \
+ sem.ads sem_ch13.ads sem_ch7.ads sem_ch8.ads sem_eval.ads sem_res.ads \
+ sem_type.ads sem_util.ads sem_util.adb sem_warn.ads sinfo.ads sinfo.adb \
+ sinput.ads snames.ads stand.ads stringt.ads stringt.adb style.ads \
+ system.ads s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \
+ targparm.ads tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads \
+ types.adb uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads \
+ urealp.ads validsw.ads widechar.ads
+
+exp_ch11.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ casing.adb csets.ads debug.ads einfo.ads einfo.adb elists.ads \
+ errout.ads exp_ch11.ads exp_ch11.adb exp_ch7.ads exp_util.ads fname.ads \
+ fname-uf.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads inline.ads lib.ads lib.adb lib-list.adb \
+ lib-sort.adb lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb \
+ nmake.ads nmake.adb opt.ads output.ads restrict.ads restrict.adb \
+ rident.ads rtsfind.ads scans.ads scn.ads sem.ads sem_ch5.ads \
+ sem_ch8.ads sem_eval.ads sem_res.ads sem_type.ads sem_util.ads \
+ sem_util.adb sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \
+ stringt.ads style.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb targparm.ads tbuild.ads tbuild.adb tree_io.ads \
+ ttypes.ads types.ads types.adb uintp.ads uintp.adb uname.ads \
+ unchconv.ads unchdeal.ads urealp.ads widechar.ads
+
+exp_ch12.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ errout.ads exp_ch12.ads exp_ch12.adb exp_ch2.ads exp_util.ads \
+ freeze.ads get_targ.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads \
+ namet.ads nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \
+ rtsfind.ads sem.ads sem_eval.ads sem_res.ads sem_util.ads sem_warn.ads \
+ sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads system.ads \
+ s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tbuild.ads \
+ tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb unchconv.ads \
+ unchdeal.ads urealp.ads validsw.ads
+
+exp_ch13.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads exp_ch13.ads exp_ch13.adb \
+ exp_ch3.ads exp_ch6.ads exp_imgv.ads exp_util.ads gnat.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads namet.ads nlists.ads nlists.adb nmake.ads \
+ nmake.adb opt.ads output.ads rtsfind.ads sem.ads sem_ch7.ads \
+ sem_ch8.ads sem_eval.ads sem_util.ads sinfo.ads sinfo.adb sinput.ads \
+ snames.ads stand.ads stringt.ads stringt.adb system.ads s-exctab.ads \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb tbuild.ads tree_io.ads \
+ types.ads types.adb uintp.ads uintp.adb unchconv.ads unchdeal.ads \
+ urealp.ads
+
+exp_ch2.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads debug.ads einfo.ads einfo.adb elists.ads elists.adb \
+ errout.ads exp_ch11.ads exp_ch2.ads exp_ch2.adb exp_ch7.ads \
+ exp_smem.ads exp_util.ads exp_util.adb exp_vfpt.ads get_targ.ads \
+ gnat.ads g-htable.ads g-os_lib.ads hostparm.ads inline.ads itypes.ads \
+ lib.ads namet.ads nlists.ads nlists.adb nmake.ads nmake.adb opt.ads \
+ output.ads restrict.ads rident.ads rtsfind.ads sem.ads sem_ch8.ads \
+ sem_eval.ads sem_res.ads sem_util.ads sinfo.ads sinfo.adb sinput.ads \
+ snames.ads stand.ads stringt.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb tbuild.ads tree_io.ads ttypes.ads \
+ types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads \
+ validsw.ads
+
+exp_ch3.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ elists.adb errout.ads exp_aggr.ads exp_ch11.ads exp_ch2.ads exp_ch3.ads \
+ exp_ch3.adb exp_ch4.ads exp_ch7.ads exp_ch9.ads exp_disp.ads \
+ exp_dist.ads exp_smem.ads exp_strm.ads exp_tss.ads exp_tss.adb \
+ exp_util.ads exp_util.adb fname.ads fname-uf.ads freeze.ads \
+ get_targ.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads inline.ads \
+ itypes.ads lib.ads namet.ads nlists.ads nlists.adb nmake.ads nmake.adb \
+ opt.ads output.ads restrict.ads restrict.adb rident.ads rtsfind.ads \
+ sem.ads sem_ch3.ads sem_ch8.ads sem_eval.ads sem_mech.ads sem_res.ads \
+ sem_util.ads sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads \
+ stand.ads stringt.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb tbuild.ads tbuild.adb tree_io.ads ttypes.ads \
+ types.ads uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads \
+ urealp.ads validsw.ads
+
+exp_ch4.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ elists.adb errout.ads exp_aggr.ads exp_ch11.ads exp_ch2.ads exp_ch3.ads \
+ exp_ch4.ads exp_ch4.adb exp_ch7.ads exp_ch9.ads exp_disp.ads \
+ exp_fixd.ads exp_pakd.ads exp_tss.ads exp_util.ads exp_util.adb \
+ exp_vfpt.ads freeze.ads get_targ.ads gnat.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads inline.ads itypes.ads lib.ads namet.ads nlists.ads \
+ nlists.adb nmake.ads nmake.adb opt.ads output.ads restrict.ads \
+ rident.ads rtsfind.ads sem.ads sem_cat.ads sem_ch13.ads sem_ch8.ads \
+ sem_eval.ads sem_res.ads sem_type.ads sem_util.ads sem_warn.ads \
+ sinfo.ads sinfo.adb sinfo-cn.ads sinput.ads snames.ads stand.ads \
+ stringt.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb tbuild.ads tbuild.adb tree_io.ads ttypes.ads \
+ types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads \
+ urealp.adb validsw.ads
+
+exp_ch5.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ errout.ads exp_aggr.ads exp_ch11.ads exp_ch2.ads exp_ch5.ads \
+ exp_ch5.adb exp_ch7.ads exp_dbug.ads exp_pakd.ads exp_util.ads \
+ exp_util.adb fname.ads fname-uf.ads freeze.ads get_targ.ads gnat.ads \
+ g-htable.ads g-os_lib.ads hostparm.ads inline.ads itypes.ads lib.ads \
+ lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb nmake.ads \
+ nmake.adb opt.ads output.ads restrict.ads restrict.adb rident.ads \
+ rtsfind.ads scans.ads scn.ads sem.ads sem_ch13.ads sem_ch8.ads \
+ sem_eval.ads sem_res.ads sem_type.ads sem_util.ads sem_util.adb \
+ sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \
+ stringt.ads style.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb targparm.ads tbuild.ads tbuild.adb tree_io.ads \
+ ttypes.ads types.ads uintp.ads uintp.adb uname.ads unchconv.ads \
+ unchdeal.ads urealp.ads validsw.ads widechar.ads
+
+exp_ch6.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ elists.adb errout.ads exp_ch11.ads exp_ch2.ads exp_ch3.ads exp_ch6.ads \
+ exp_ch6.adb exp_ch7.ads exp_ch9.ads exp_dbug.ads exp_disp.ads \
+ exp_dist.ads exp_intr.ads exp_pakd.ads exp_tss.ads exp_util.ads \
+ exp_util.adb freeze.ads get_targ.ads gnat.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads inline.ads itypes.ads lib.ads lib-xref.ads namet.ads \
+ namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \
+ restrict.ads rident.ads rtsfind.ads scans.ads scn.ads sem.ads \
+ sem_ch12.ads sem_ch13.ads sem_ch6.ads sem_ch8.ads sem_disp.ads \
+ sem_dist.ads sem_eval.ads sem_res.ads sem_type.ads sem_util.ads \
+ sem_util.adb sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads \
+ stand.ads stringt.ads style.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads tbuild.adb \
+ tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb unchconv.ads \
+ unchdeal.ads urealp.ads validsw.ads widechar.ads
+
+exp_ch7.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads debug.ads einfo.ads einfo.adb elists.ads errout.ads \
+ exp_ch11.ads exp_ch7.ads exp_ch7.adb exp_ch9.ads exp_dbug.ads \
+ exp_tss.ads exp_util.ads exp_util.adb fname.ads fname-uf.ads freeze.ads \
+ get_targ.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads inline.ads \
+ itypes.ads lib.ads lib-xref.ads namet.ads nlists.ads nlists.adb \
+ nmake.ads nmake.adb opt.ads output.ads restrict.ads restrict.adb \
+ rident.ads rtsfind.ads sem.ads sem_ch3.ads sem_ch7.ads sem_ch8.ads \
+ sem_eval.ads sem_res.ads sem_type.ads sem_util.ads sinfo.ads sinfo.adb \
+ sinput.ads snames.ads stand.ads stringt.ads system.ads s-exctab.ads \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads \
+ tbuild.adb tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb \
+ uname.ads unchconv.ads unchdeal.ads urealp.ads validsw.ads
+
+exp_ch8.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads debug.ads einfo.ads einfo.adb elists.ads errout.ads \
+ exp_ch11.ads exp_ch7.ads exp_ch8.ads exp_ch8.adb exp_dbug.ads \
+ exp_util.ads exp_util.adb get_targ.ads gnat.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads inline.ads itypes.ads lib.ads namet.ads \
+ nlists.ads nlists.adb nmake.ads opt.ads output.ads restrict.ads \
+ rident.ads rtsfind.ads sem.ads sem_ch8.ads sem_eval.ads sem_res.ads \
+ sem_util.ads sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \
+ stringt.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb tbuild.ads tree_io.ads ttypes.ads types.ads \
+ uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads validsw.ads
+
+exp_ch9.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ elists.adb errout.ads exp_ch11.ads exp_ch2.ads exp_ch3.ads exp_ch6.ads \
+ exp_ch7.ads exp_ch9.ads exp_ch9.adb exp_dbug.ads exp_smem.ads \
+ exp_tss.ads exp_util.ads exp_util.adb fname.ads fname-uf.ads freeze.ads \
+ get_targ.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads inline.ads \
+ itypes.ads lib.ads lib-xref.ads namet.ads namet.adb nlists.ads \
+ nlists.adb nmake.ads nmake.adb opt.ads output.ads restrict.ads \
+ restrict.adb rident.ads rtsfind.ads scans.ads scn.ads sem.ads \
+ sem_ch11.ads sem_ch6.ads sem_ch8.ads sem_elab.ads sem_eval.ads \
+ sem_res.ads sem_type.ads sem_util.ads sem_util.adb sem_warn.ads \
+ sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads stringt.ads \
+ style.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb targparm.ads tbuild.ads tbuild.adb tree_io.ads \
+ ttypes.ads types.ads uintp.ads uintp.adb uname.ads unchconv.ads \
+ unchdeal.ads urealp.ads validsw.ads widechar.ads
+
+exp_code.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads debug.ads einfo.ads einfo.adb elists.ads errout.ads \
+ eval_fat.ads exp_code.ads exp_code.adb exp_util.ads fname.ads \
+ freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb lib-xref.ads \
+ namet.ads namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads \
+ output.ads restrict.ads rident.ads rtsfind.ads scans.ads scn.ads \
+ sem.ads sem_cat.ads sem_ch8.ads sem_eval.ads sem_eval.adb sem_res.ads \
+ sem_type.ads sem_util.ads sem_util.adb sem_warn.ads sinfo.ads sinfo.adb \
+ sinput.ads snames.ads stand.ads stringt.ads stringt.adb style.ads \
+ system.ads s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \
+ targparm.ads tbuild.ads tree_io.ads ttypes.ads types.ads types.adb \
+ uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads \
+ widechar.ads
+
+exp_dbug.o : ada.ads a-except.ads a-uncdea.ads alloc.ads atree.ads \
+ atree.adb casing.ads checks.ads debug.ads einfo.ads einfo.adb \
+ elists.ads errout.ads eval_fat.ads exp_dbug.ads exp_dbug.adb \
+ exp_util.ads fname.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads \
+ g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads lib.ads lib.adb \
+ lib-list.adb lib-sort.adb namet.ads namet.adb nlists.ads nlists.adb \
+ nmake.ads nmake.adb opt.ads output.ads rtsfind.ads sem.ads sem_cat.ads \
+ sem_ch8.ads sem_eval.ads sem_eval.adb sem_res.ads sem_type.ads \
+ sem_util.ads sem_warn.ads sinfo.ads sinfo.adb sinput.ads sinput.adb \
+ snames.ads stand.ads stringt.ads stringt.adb system.ads s-exctab.ads \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \
+ uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads \
+ urealp.adb widechar.ads
+
+exp_disp.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ elists.adb errout.ads exp_ch11.ads exp_ch2.ads exp_ch7.ads exp_disp.ads \
+ exp_disp.adb exp_tss.ads exp_tss.adb exp_util.ads exp_util.adb \
+ fname.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads inline.ads itypes.ads lib.ads lib.adb \
+ lib-list.adb lib-sort.adb lib-xref.ads namet.ads namet.adb nlists.ads \
+ nlists.adb nmake.ads nmake.adb opt.ads output.ads restrict.ads \
+ rident.ads rtsfind.ads scans.ads scn.ads sem.ads sem_ch8.ads \
+ sem_disp.ads sem_eval.ads sem_res.ads sem_type.ads sem_util.ads \
+ sem_util.adb sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads \
+ stand.ads stringt.ads style.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads tbuild.adb \
+ tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb uname.ads \
+ unchconv.ads unchdeal.ads urealp.ads validsw.ads widechar.ads
+
+exp_dist.o : ada.ads a-except.ads a-uncdea.ads alloc.ads atree.ads \
+ atree.adb casing.ads debug.ads einfo.ads einfo.adb elists.ads \
+ elists.adb exp_dist.ads exp_dist.adb exp_tss.ads exp_util.ads fname.ads \
+ gnat.ads g-hesora.ads g-htable.ads g-htable.adb g-os_lib.ads \
+ hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb namet.ads \
+ nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \
+ restrict.ads rident.ads rtsfind.ads sem.ads sem_ch3.ads sem_ch8.ads \
+ sem_dist.ads sem_util.ads sinfo.ads sinfo.adb sinput.ads snames.ads \
+ stand.ads stringt.ads stringt.adb system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb tbuild.ads tbuild.adb tree_io.ads \
+ types.ads uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads \
+ urealp.ads
+
+exp_fixd.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ errout.ads eval_fat.ads exp_ch2.ads exp_fixd.ads exp_fixd.adb \
+ exp_util.ads freeze.ads get_targ.ads gnat.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads namet.ads nlists.ads nlists.adb nmake.ads nmake.adb \
+ opt.ads output.ads restrict.ads rident.ads rtsfind.ads sem.ads \
+ sem_cat.ads sem_ch8.ads sem_eval.ads sem_eval.adb sem_res.ads \
+ sem_type.ads sem_util.ads sem_warn.ads sinfo.ads sinfo.adb sinput.ads \
+ snames.ads stand.ads stringt.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb tbuild.ads tree_io.ads ttypes.ads \
+ types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads \
+ urealp.adb validsw.ads
+
+exp_imgv.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads debug.ads einfo.ads einfo.adb elists.ads exp_imgv.ads \
+ exp_imgv.adb exp_util.ads get_targ.ads gnat.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads lib.ads namet.ads nlists.ads nlists.adb \
+ nmake.ads nmake.adb opt.ads output.ads restrict.ads rident.ads \
+ rtsfind.ads sem_res.ads sinfo.ads sinfo.adb sinput.ads snames.ads \
+ stand.ads stringt.ads stringt.adb system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb tbuild.ads tbuild.adb tree_io.ads \
+ ttypes.ads types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads \
+ urealp.ads
+
+exp_intr.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads debug.ads einfo.ads einfo.adb elists.ads errout.ads \
+ exp_ch11.ads exp_ch4.ads exp_ch7.ads exp_ch9.ads exp_code.ads \
+ exp_fixd.ads exp_intr.ads exp_intr.adb exp_util.ads exp_util.adb \
+ fname.ads fname-uf.ads freeze.ads get_targ.ads gnat.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads inline.ads itypes.ads lib.ads lib-xref.ads \
+ namet.ads namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads \
+ output.ads restrict.ads restrict.adb rident.ads rtsfind.ads scans.ads \
+ scn.ads sem.ads sem_ch8.ads sem_eval.ads sem_res.ads sem_type.ads \
+ sem_util.ads sem_util.adb sinfo.ads sinfo.adb sinput.ads sinput.adb \
+ snames.ads stand.ads stringt.ads stringt.adb style.ads system.ads \
+ s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \
+ tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads uintp.ads \
+ uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads urealp.adb \
+ validsw.ads widechar.ads
+
+exp_pakd.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ errout.ads exp_ch11.ads exp_ch2.ads exp_ch7.ads exp_dbug.ads \
+ exp_pakd.ads exp_pakd.adb exp_util.ads exp_util.adb freeze.ads \
+ get_targ.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads inline.ads \
+ itypes.ads lib.ads namet.ads nlists.ads nlists.adb nmake.ads nmake.adb \
+ opt.ads output.ads restrict.ads rident.ads rtsfind.ads sem.ads \
+ sem_ch13.ads sem_ch8.ads sem_eval.ads sem_res.ads sem_util.ads \
+ sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \
+ stringt.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb targparm.ads tbuild.ads tbuild.adb tree_io.ads \
+ ttypes.ads types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads \
+ urealp.ads validsw.ads
+
+exp_prag.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ casing.adb csets.ads debug.ads einfo.ads einfo.adb elists.ads \
+ errout.ads exp_ch11.ads exp_prag.ads exp_prag.adb exp_tss.ads \
+ exp_util.ads expander.ads gnat.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads namet.ads nlists.ads nlists.adb nmake.ads nmake.adb \
+ opt.ads output.ads rtsfind.ads sem.ads sem_eval.ads sem_res.ads \
+ sem_util.ads sinfo.ads sinfo.adb sinput.ads snames.ads snames.adb \
+ stand.ads stringt.ads stringt.adb system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb tbuild.ads tree_io.ads types.ads \
+ types.adb uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads \
+ widechar.ads
+
+exp_smem.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads exp_smem.ads exp_smem.adb \
+ exp_util.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads \
+ namet.ads nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \
+ restrict.ads rident.ads rtsfind.ads sem.ads sem_util.ads sinfo.ads \
+ sinfo.adb sinput.ads snames.ads stand.ads stringt.ads stringt.adb \
+ system.ads s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \
+ tbuild.ads tbuild.adb tree_io.ads types.ads uintp.ads uintp.adb \
+ unchconv.ads unchdeal.ads urealp.ads
+
+exp_strm.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads exp_strm.ads exp_strm.adb \
+ exp_tss.ads fname.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb \
+ namet.ads nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \
+ restrict.ads rident.ads rtsfind.ads sinfo.ads sinfo.adb sinput.ads \
+ snames.ads stand.ads stringt.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb tbuild.ads tbuild.adb tree_io.ads \
+ ttypes.ads types.ads uintp.ads uintp.adb uname.ads unchconv.ads \
+ unchdeal.ads urealp.ads
+
+exp_tss.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads elists.adb exp_tss.ads \
+ exp_tss.adb exp_util.ads gnat.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads lib.ads namet.ads nlists.ads nlists.adb opt.ads output.ads \
+ rtsfind.ads sem_util.ads sinfo.ads sinfo.adb sinput.ads snames.ads \
+ stand.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb tree_io.ads types.ads uintp.ads uintp.adb \
+ unchconv.ads unchdeal.ads urealp.ads
+
+exp_util.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads debug.ads einfo.ads einfo.adb elists.ads elists.adb \
+ errout.ads eval_fat.ads exp_ch11.ads exp_ch7.ads exp_util.ads \
+ exp_util.adb fname.ads fname-uf.ads get_targ.ads gnat.ads g-hesora.ads \
+ g-htable.ads g-os_lib.ads hostparm.ads inline.ads itypes.ads lib.ads \
+ lib.adb lib-list.adb lib-sort.adb namet.ads nlists.ads nlists.adb \
+ nmake.ads nmake.adb opt.ads output.ads restrict.ads restrict.adb \
+ rident.ads rtsfind.ads sem.ads sem_cat.ads sem_ch8.ads sem_eval.ads \
+ sem_eval.adb sem_res.ads sem_type.ads sem_util.ads sem_warn.ads \
+ sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads stringt.ads \
+ system.ads s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \
+ tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads uintp.ads \
+ uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads validsw.ads
+
+exp_vfpt.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads exp_vfpt.ads exp_vfpt.adb \
+ gnat.ads g-htable.ads g-os_lib.ads hostparm.ads namet.ads nlists.ads \
+ nlists.adb nmake.ads nmake.adb opt.ads output.ads rtsfind.ads \
+ sem_res.ads sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \
+ system.ads s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \
+ tbuild.ads tree_io.ads ttypef.ads types.ads uintp.ads uintp.adb \
+ unchconv.ads unchdeal.ads urealp.ads urealp.adb
+
+expander.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads debug_a.ads debug_a.adb einfo.ads elists.ads errout.ads \
+ exp_aggr.ads exp_attr.ads exp_ch11.ads exp_ch12.ads exp_ch13.ads \
+ exp_ch2.ads exp_ch3.ads exp_ch4.ads exp_ch5.ads exp_ch6.ads exp_ch7.ads \
+ exp_ch8.ads exp_ch9.ads exp_prag.ads expander.ads expander.adb gnat.ads \
+ g-htable.ads g-os_lib.ads hostparm.ads nlists.ads nlists.adb opt.ads \
+ output.ads sem.ads sem_ch8.ads sem_util.ads sinfo.ads sinput.ads \
+ snames.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb tree_io.ads types.ads uintp.ads unchconv.ads \
+ unchdeal.ads urealp.ads
+
+fname-sf.o : alloc.ads casing.ads fname.ads fname-sf.ads fname-sf.adb \
+ fname-uf.ads gnat.ads g-os_lib.ads namet.ads osint.ads sfn_scan.ads \
+ system.ads s-exctab.ads s-stalib.ads s-stoele.ads table.ads types.ads \
+ unchconv.ads unchdeal.ads
+
+fname-uf.o : ada.ads a-except.ads a-uncdea.ads alloc.ads casing.ads \
+ debug.ads fname.ads fname-uf.ads fname-uf.adb gnat.ads g-htable.ads \
+ g-htable.adb g-os_lib.ads hostparm.ads krunch.ads namet.ads opt.ads \
+ osint.ads output.ads system.ads s-exctab.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb tree_io.ads types.ads unchconv.ads \
+ unchdeal.ads widechar.ads
+
+fname.o : ada.ads a-except.ads alloc.ads debug.ads fname.ads fname.adb \
+ gnat.ads g-os_lib.ads hostparm.ads namet.ads opt.ads output.ads \
+ system.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads table.adb \
+ tree_io.ads types.ads unchconv.ads unchdeal.ads
+
+freeze.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads elists.adb errout.ads \
+ exp_ch11.ads exp_ch7.ads exp_pakd.ads exp_util.ads freeze.ads \
+ freeze.adb get_targ.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads \
+ layout.ads lib.ads lib-xref.ads namet.ads namet.adb nlists.ads \
+ nlists.adb nmake.ads nmake.adb opt.ads output.ads restrict.ads \
+ rident.ads rtsfind.ads scans.ads scn.ads sem.ads sem_cat.ads \
+ sem_ch13.ads sem_ch6.ads sem_ch7.ads sem_ch8.ads sem_eval.ads \
+ sem_mech.ads sem_prag.ads sem_res.ads sem_type.ads sem_util.ads \
+ sem_util.adb sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \
+ stringt.ads style.ads system.ads s-exctab.ads s-exctab.adb s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads tree_io.ads \
+ ttypes.ads types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads \
+ urealp.ads widechar.ads
+
+frontend.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads cstand.ads debug.ads einfo.ads einfo.adb elists.ads \
+ exp_ch11.ads exp_dbug.ads fname.ads fname-uf.ads frontend.ads \
+ frontend.adb get_targ.ads gnat.ads g-hesora.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads inline.ads lib.ads lib.adb lib-list.adb \
+ lib-load.ads lib-sort.adb live.ads namet.ads nlists.ads nlists.adb \
+ opt.ads osint.ads output.ads par.ads rtsfind.ads scn.ads sem.ads \
+ sem_ch8.ads sem_elab.ads sem_prag.ads sem_warn.ads sinfo.ads sinfo.adb \
+ sinput.ads sinput.adb sinput-l.ads snames.ads sprint.ads stand.ads \
+ stringt.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb tree_io.ads types.ads uintp.ads uintp.adb uname.ads \
+ unchconv.ads unchdeal.ads urealp.ads
+
+g-casuti.o : gnat.ads g-casuti.ads g-casuti.adb system.ads
+
+g-comlin.o : ada.ads a-comlin.ads a-except.ads a-finali.ads a-filico.ads \
+ a-stream.ads a-tags.ads gnat.ads g-comlin.ads g-comlin.adb g-dirope.ads \
+ g-regexp.ads system.ads s-exctab.ads s-finimp.ads s-finroo.ads \
+ s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-stratt.ads s-strops.ads s-unstyp.ads unchconv.ads
+
+g-dirope.o : ada.ads a-charac.ads a-chahan.ads a-chlat1.ads a-except.ads \
+ a-finali.ads a-filico.ads a-stream.ads a-string.ads a-strfix.ads \
+ a-strmap.ads a-strunb.ads a-tags.ads gnat.ads g-dirope.ads g-dirope.adb \
+ g-os_lib.ads g-regexp.ads system.ads s-exctab.ads s-finimp.ads \
+ s-finroo.ads s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads s-unstyp.ads \
+ unchconv.ads unchdeal.ads
+
+g-except.o : gnat.ads g-except.ads system.ads
+
+g-hesora.o : gnat.ads g-hesora.ads g-hesora.adb system.ads
+
+g-htable.o : ada.ads a-uncdea.ads gnat.ads g-htable.ads g-htable.adb \
+ system.ads
+
+g-io_aux.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \
+ a-stream.ads a-tags.ads a-textio.ads gnat.ads g-io_aux.ads g-io_aux.adb \
+ interfac.ads i-cstrea.ads system.ads s-exctab.ads s-ficobl.ads \
+ s-finimp.ads s-finroo.ads s-parame.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads \
+ s-unstyp.ads unchconv.ads
+
+g-os_lib.o : ada.ads a-except.ads gnat.ads g-os_lib.ads g-os_lib.adb \
+ system.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads unchconv.ads unchdeal.ads
+
+g-regexp.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \
+ a-stream.ads a-tags.ads a-tags.adb a-textio.ads gnat.ads g-casuti.ads \
+ g-htable.ads g-regexp.ads g-regexp.adb interfac.ads i-cstrea.ads \
+ system.ads s-exctab.ads s-ficobl.ads s-finimp.ads s-finroo.ads \
+ s-imgint.ads s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads s-sopco3.ads \
+ s-unstyp.ads unchconv.ads unchdeal.ads
+
+g-speche.o : gnat.ads g-speche.ads g-speche.adb system.ads
+
+get_targ.o : get_targ.ads get_targ.adb system.ads s-exctab.ads \
+ s-stalib.ads types.ads unchconv.ads unchdeal.ads
+
+gnat.o : gnat.ads system.ads
+
+gnat1drv.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb \
+ back_end.ads casing.ads comperr.ads csets.ads debug.ads einfo.ads \
+ einfo.adb elists.ads errout.ads fname.ads fname-uf.ads frontend.ads \
+ get_targ.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \
+ gnat1drv.ads gnat1drv.adb gnatvsn.ads hostparm.ads inline.ads lib.ads \
+ lib.adb lib-list.adb lib-sort.adb lib-writ.ads namet.ads nlists.ads \
+ nlists.adb opt.ads osint.ads output.ads repinfo.ads restrict.ads \
+ rident.ads sem.ads sem_ch13.ads sem_warn.ads sinfo.ads sinfo.adb \
+ sinput.ads sinput-l.ads snames.ads sprint.ads stand.ads stringt.ads \
+ system.ads s-assert.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb targparm.ads tree_gen.ads tree_io.ads treepr.ads \
+ ttypes.ads types.ads uintp.ads uintp.adb uname.ads unchconv.ads \
+ unchdeal.ads urealp.ads usage.ads
+
+gnatbind.o : ada.ads a-except.ads ali.ads ali-util.ads alloc.ads \
+ bcheck.ads binde.ads binderr.ads bindgen.ads bindusg.ads butil.ads \
+ casing.ads csets.ads debug.ads gnat.ads g-htable.ads g-os_lib.ads \
+ gnatbind.ads gnatbind.adb gnatvsn.ads hostparm.ads namet.ads opt.ads \
+ osint.ads output.ads rident.ads switch.ads system.ads s-exctab.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-strops.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \
+ unchconv.ads unchdeal.ads
+
+gnatchop.o : ada.ads a-comlin.ads a-except.ads a-finali.ads a-filico.ads \
+ a-ioexce.ads a-stream.ads a-tags.ads a-textio.ads gnat.ads g-comlin.ads \
+ g-dirope.ads g-hesorg.ads g-hesorg.adb g-os_lib.ads g-regexp.ads \
+ g-table.ads g-table.adb gnatchop.adb gnatvsn.ads hostparm.ads \
+ interfac.ads i-cstrea.ads system.ads s-assert.ads s-exctab.ads \
+ s-ficobl.ads s-finimp.ads s-finroo.ads s-imgint.ads s-parame.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-stratt.ads s-strops.ads s-sopco3.ads s-sopco4.ads s-sopco5.ads \
+ s-unstyp.ads s-valint.ads unchconv.ads unchdeal.ads
+
+gnatcmd.o : ada.ads a-charac.ads a-chahan.ads a-comlin.ads a-except.ads \
+ a-finali.ads a-filico.ads a-ioexce.ads a-stream.ads a-tags.ads \
+ a-textio.ads debug.ads gnat.ads g-os_lib.ads gnatcmd.ads gnatcmd.adb \
+ gnatvsn.ads hostparm.ads interfac.ads i-cstrea.ads opt.ads osint.ads \
+ output.ads sdefault.ads system.ads s-assert.ads s-exctab.ads \
+ s-ficobl.ads s-finimp.ads s-finroo.ads s-imgint.ads s-parame.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-stratt.ads s-strops.ads s-sopco4.ads s-unstyp.ads s-wchcon.ads \
+ table.ads table.adb tree_io.ads types.ads unchconv.ads unchdeal.ads
+
+gnatfind.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads a-finali.ads \
+ a-filico.ads a-ioexce.ads a-stream.ads a-string.ads a-strfix.ads \
+ a-strmap.ads a-strunb.ads a-tags.ads a-textio.ads gnat.ads g-comlin.ads \
+ g-dirope.ads g-dyntab.ads g-os_lib.ads g-regexp.ads gnatfind.adb \
+ gnatvsn.ads hostparm.ads interfac.ads i-cstrea.ads osint.ads system.ads \
+ s-exctab.ads s-ficobl.ads s-finimp.ads s-finroo.ads s-parame.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-stratt.ads s-strops.ads s-unstyp.ads types.ads unchconv.ads \
+ unchdeal.ads xr_tabls.ads xref_lib.ads
+
+gnatkr.o : ada.ads a-charac.ads a-chahan.ads a-comlin.ads a-except.ads \
+ gnatkr.ads gnatkr.adb gnatvsn.ads krunch.ads system.ads s-exctab.ads \
+ s-io.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads unchconv.ads
+
+gnatlink.o : ada.ads a-comlin.ads a-except.ads debug.ads gnat.ads \
+ g-os_lib.ads gnatlink.ads gnatlink.adb gnatvsn.ads hostparm.ads \
+ interfac.ads i-cstrea.ads opt.ads osint.ads output.ads system.ads \
+ s-assert.ads s-exctab.ads s-parame.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-strops.ads s-sopco3.ads \
+ s-sopco4.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \
+ unchconv.ads unchdeal.ads
+
+gnatls.o : ada.ads a-except.ads ali.ads ali-util.ads alloc.ads binderr.ads \
+ butil.ads casing.ads csets.ads fname.ads gnat.ads g-htable.ads \
+ g-os_lib.ads gnatls.ads gnatls.adb gnatvsn.ads hostparm.ads namet.ads \
+ opt.ads osint.ads output.ads prj.ads prj-com.ads prj-env.ads \
+ prj-env.adb prj-ext.ads prj-pars.ads prj-util.ads rident.ads scans.ads \
+ snames.ads stringt.ads system.ads s-assert.ads s-exctab.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-strops.ads s-sopco3.ads s-sopco4.ads s-wchcon.ads table.ads types.ads \
+ unchconv.ads unchdeal.ads
+
+gnatmake.o : gnat.ads g-os_lib.ads gnatmake.ads gnatmake.adb gnatvsn.ads \
+ make.ads system.ads s-exctab.ads s-stalib.ads table.ads types.ads \
+ unchconv.ads unchdeal.ads
+
+gnatmem.o : ada.ads a-comlin.ads a-except.ads a-finali.ads a-filico.ads \
+ a-flteio.ads a-inteio.ads a-ioexce.ads a-stream.ads a-tags.ads \
+ a-textio.ads a-tiocst.ads a-tiflio.ads a-tiinio.ads a-uncdea.ads \
+ gnat.ads g-hesorg.ads g-hesorg.adb g-htable.ads g-htable.adb \
+ g-os_lib.ads gnatmem.adb gnatvsn.ads interfac.ads i-cstrea.ads \
+ memroot.ads system.ads s-exctab.ads s-ficobl.ads s-finimp.ads \
+ s-finroo.ads s-imgint.ads s-parame.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads \
+ s-sopco3.ads s-sopco4.ads s-sopco5.ads s-unstyp.ads s-valint.ads \
+ s-valuns.ads unchconv.ads unchdeal.ads
+
+gnatprep.o : ada.ads a-charac.ads a-chahan.ads a-chlat1.ads a-comlin.ads \
+ a-except.ads a-finali.ads a-filico.ads a-ioexce.ads a-stream.ads \
+ a-string.ads a-strfix.ads a-strmap.ads a-tags.ads a-textio.ads gnat.ads \
+ g-comlin.ads g-dirope.ads g-hesorg.ads g-hesorg.adb g-regexp.ads \
+ gnatprep.ads gnatprep.adb gnatvsn.ads interfac.ads i-cstrea.ads \
+ system.ads s-exctab.ads s-ficobl.ads s-finimp.ads s-finroo.ads \
+ s-imgint.ads s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads s-sopco3.ads \
+ s-sopco4.ads s-unstyp.ads unchconv.ads
+
+gnatpsta.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \
+ a-stream.ads a-tags.ads a-textio.ads get_targ.ads gnatpsta.adb \
+ gnatvsn.ads interfac.ads i-cstrea.ads system.ads s-exctab.ads \
+ s-ficobl.ads s-finimp.ads s-finroo.ads s-imgint.ads s-imgrea.ads \
+ s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-stratt.ads s-strops.ads s-sopco3.ads s-sopco4.ads \
+ s-sopco5.ads s-unstyp.ads ttypef.ads ttypes.ads types.ads unchconv.ads \
+ unchdeal.ads
+
+gnatpsys.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \
+ a-stream.ads a-tags.ads a-textio.ads gnatpsys.adb gnatvsn.ads \
+ interfac.ads i-cstrea.ads system.ads s-exctab.ads s-ficobl.ads \
+ s-finimp.ads s-finroo.ads s-imgenu.ads s-imgint.ads s-imglli.ads \
+ s-imgrea.ads s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-stratt.ads s-sopco3.ads s-sopco5.ads \
+ s-unstyp.ads unchconv.ads
+
+gnatvsn.o : gnatvsn.ads system.ads
+
+gnatxref.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads a-finali.ads \
+ a-filico.ads a-ioexce.ads a-stream.ads a-string.ads a-strfix.ads \
+ a-strmap.ads a-strunb.ads a-tags.ads a-textio.ads gnat.ads g-comlin.ads \
+ g-dirope.ads g-dyntab.ads g-os_lib.ads g-regexp.ads gnatvsn.ads \
+ gnatxref.adb hostparm.ads interfac.ads i-cstrea.ads osint.ads \
+ system.ads s-exctab.ads s-ficobl.ads s-finimp.ads s-finroo.ads \
+ s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-stratt.ads s-strops.ads s-unstyp.ads types.ads \
+ unchconv.ads unchdeal.ads xr_tabls.ads xref_lib.ads
+
+hlo.o : hlo.ads hlo.adb output.ads system.ads s-exctab.ads s-stalib.ads \
+ types.ads unchconv.ads unchdeal.ads
+
+hostparm.o : hostparm.ads system.ads
+
+i-cstrea.o : interfac.ads i-cstrea.ads i-cstrea.adb system.ads \
+ s-parame.ads unchconv.ads
+
+impunit.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads fname.ads gnat.ads \
+ g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads impunit.ads \
+ impunit.adb lib.ads lib.adb lib-list.adb lib-sort.adb namet.ads \
+ namet.adb nlists.ads nlists.adb opt.ads output.ads sinfo.ads sinfo.adb \
+ sinput.ads snames.ads stand.ads stringt.ads system.ads s-exctab.ads \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \
+ uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads \
+ widechar.ads
+
+inline.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads elists.adb errout.ads \
+ exp_ch11.ads exp_ch7.ads exp_tss.ads exp_tss.adb exp_util.ads fname.ads \
+ fname-uf.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads inline.ads inline.adb lib.ads lib.adb lib-list.adb \
+ lib-sort.adb namet.ads nlists.ads nlists.adb opt.ads output.ads \
+ rtsfind.ads sem_ch10.ads sem_ch12.ads sem_ch8.ads sem_util.ads \
+ sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads stringt.ads \
+ system.ads s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \
+ tree_io.ads types.ads uintp.ads uintp.adb uname.ads unchconv.ads \
+ unchdeal.ads urealp.ads
+
+interfac.o : interfac.ads system.ads
+
+itypes.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads gnat.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads itypes.ads itypes.adb namet.ads nlists.ads \
+ nlists.adb opt.ads output.ads sem_util.ads sinfo.ads sinfo.adb \
+ sinput.ads snames.ads stand.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb tree_io.ads types.ads uintp.ads \
+ uintp.adb unchconv.ads unchdeal.ads urealp.ads
+
+krunch.o : hostparm.ads krunch.ads krunch.adb system.ads s-stoele.ads
+
+layout.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads debug.ads einfo.ads einfo.adb elists.ads errout.ads \
+ exp_ch3.ads exp_util.ads freeze.ads get_targ.ads gnat.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads layout.ads layout.adb lib.ads lib-xref.ads \
+ namet.ads namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads \
+ output.ads repinfo.ads repinfo.adb restrict.ads rident.ads rtsfind.ads \
+ scans.ads scn.ads sem.ads sem_ch13.ads sem_ch8.ads sem_eval.ads \
+ sem_res.ads sem_type.ads sem_util.ads sem_util.adb sinfo.ads sinfo.adb \
+ sinput.ads snames.ads stand.ads stringt.ads style.ads system.ads \
+ s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \
+ tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads uintp.ads \
+ uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads widechar.ads
+
+lib-load.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads elists.ads errout.ads fname.ads fname-uf.ads \
+ gnat.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib-load.ads \
+ lib-load.adb namet.ads nlists.ads nlists.adb nmake.ads nmake.adb \
+ opt.ads osint.ads output.ads par.ads scn.ads sinfo.ads sinfo.adb \
+ sinput.ads sinput-l.ads snames.ads stand.ads system.ads s-exctab.ads \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb tbuild.ads tree_io.ads \
+ types.ads uintp.ads uname.ads unchconv.ads unchdeal.ads urealp.ads
+
+lib-util.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads \
+ g-os_lib.ads hostparm.ads lib.ads lib-util.ads lib-util.adb namet.ads \
+ opt.ads osint.ads output.ads system.ads s-exctab.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \
+ unchconv.ads unchdeal.ads
+
+lib-writ.o : ada.ads a-except.ads ali.ads alloc.ads atree.ads atree.adb \
+ casing.ads debug.ads einfo.ads einfo.adb elists.ads errout.ads \
+ fname.ads fname-uf.ads gnat.ads g-htable.ads g-os_lib.ads gnatvsn.ads \
+ hostparm.ads lib.ads lib-util.ads lib-util.adb lib-writ.ads \
+ lib-writ.adb lib-xref.ads namet.ads nlists.ads nlists.adb opt.ads \
+ osint.ads output.ads par.ads restrict.ads rident.ads scn.ads sinfo.ads \
+ sinfo.adb sinput.ads sinput.adb snames.ads stand.ads stringt.ads \
+ stringt.adb system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb targparm.ads tree_io.ads types.ads types.adb \
+ uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads
+
+lib-xref.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ csets.ads debug.ads einfo.ads einfo.adb elists.ads gnat.ads \
+ g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads \
+ lib-util.ads lib-util.adb lib-xref.ads lib-xref.adb namet.ads \
+ nlists.ads nlists.adb opt.ads osint.ads output.ads sinfo.ads sinfo.adb \
+ sinput.ads sinput.adb snames.ads stand.ads system.ads s-exctab.ads \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \
+ uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads widechar.ads
+
+lib.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads fname.ads gnat.ads \
+ g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib.adb \
+ lib-list.adb lib-sort.adb namet.ads namet.adb nlists.ads nlists.adb \
+ opt.ads output.ads sinfo.ads sinfo.adb sinput.ads sinput.adb snames.ads \
+ stand.ads stringt.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb tree_io.ads types.ads uintp.ads uintp.adb uname.ads \
+ unchconv.ads unchdeal.ads urealp.ads widechar.ads
+
+live.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads fname.ads gnat.ads \
+ g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib.adb \
+ lib-list.adb lib-sort.adb live.ads live.adb namet.ads nlists.ads \
+ nlists.adb opt.ads output.ads sem_util.ads sinfo.ads sinfo.adb \
+ sinput.ads snames.ads stand.ads stringt.ads system.ads s-exctab.ads \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-unstyp.ads s-wchcon.ads table.ads table.adb tree_io.ads \
+ types.ads uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads \
+ urealp.ads
+
+make.o : ada.ads a-charac.ads a-chahan.ads a-comlin.ads a-except.ads \
+ ali.ads ali-util.ads alloc.ads casing.ads csets.ads debug.ads \
+ errout.ads fname.ads fname-sf.ads fname-uf.ads gnat.ads g-htable.ads \
+ g-os_lib.ads gnatvsn.ads hostparm.ads make.ads make.adb makeusg.ads \
+ mlib.ads mlib-prj.ads mlib-tgt.ads mlib-utl.ads namet.ads opt.ads \
+ osint.ads output.ads prj.ads prj.adb prj-attr.ads prj-com.ads \
+ prj-env.ads prj-env.adb prj-ext.ads prj-pars.ads prj-util.ads \
+ rident.ads scans.ads scn.ads sfn_scan.ads sinfo.ads sinfo-cn.ads \
+ sinput.ads sinput-l.ads snames.ads stringt.ads switch.ads system.ads \
+ s-assert.ads s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-strops.ads s-sopco3.ads s-sopco5.ads \
+ s-wchcon.ads table.ads table.adb tree_io.ads types.ads uintp.ads \
+ unchconv.ads unchdeal.ads urealp.ads
+
+makeusg.o : gnat.ads g-os_lib.ads makeusg.ads makeusg.adb osint.ads \
+ output.ads system.ads s-exctab.ads s-stalib.ads types.ads unchconv.ads \
+ unchdeal.ads usage.ads
+
+memroot.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \
+ a-stream.ads a-tags.ads a-textio.ads a-uncdea.ads gnat.ads g-htable.ads \
+ g-htable.adb g-table.ads g-table.adb interfac.ads i-cstrea.ads \
+ memroot.ads memroot.adb system.ads s-assert.ads s-exctab.ads \
+ s-ficobl.ads s-finimp.ads s-finroo.ads s-parame.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads \
+ s-sopco5.ads s-unstyp.ads unchconv.ads
+
+memtrack.o : ada.ads a-except.ads system.ads s-memory.ads memtrack.adb \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-traceb.ads \
+ unchconv.ads
+
+mlib-fil.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads a-string.ads \
+ a-strfix.ads a-strmap.ads gnat.ads g-os_lib.ads mlib.ads mlib-fil.ads \
+ mlib-fil.adb mlib-tgt.ads system.ads s-exctab.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-sopco3.ads \
+ s-unstyp.ads types.ads unchconv.ads unchdeal.ads
+
+mlib-prj.o : ada.ads a-charac.ads a-chahan.ads a-except.ads a-finali.ads \
+ a-filico.ads a-stream.ads a-tags.ads alloc.ads casing.ads debug.ads \
+ gnat.ads g-dirope.ads g-os_lib.ads hostparm.ads mlib.ads mlib-fil.ads \
+ mlib-prj.ads mlib-prj.adb mlib-tgt.ads namet.ads opt.ads osint.ads \
+ output.ads prj.ads scans.ads system.ads s-assert.ads s-exctab.ads \
+ s-finimp.ads s-finroo.ads s-imgenu.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads \
+ s-sopco3.ads s-unstyp.ads s-wchcon.ads table.ads table.adb tree_io.ads \
+ types.ads unchconv.ads unchdeal.ads
+
+mlib-tgt.o : ada.ads a-charac.ads a-chahan.ads a-except.ads a-finali.ads \
+ a-filico.ads a-stream.ads a-tags.ads alloc.ads gnat.ads g-dirope.ads \
+ g-os_lib.ads hostparm.ads mlib.ads mlib-fil.ads mlib-tgt.ads \
+ mlib-tgt.adb mlib-utl.ads namet.ads opt.ads osint.ads output.ads \
+ system.ads s-exctab.ads s-finimp.ads s-finroo.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads \
+ s-strops.ads s-sopco3.ads s-sopco4.ads s-unstyp.ads s-wchcon.ads \
+ table.ads types.ads unchconv.ads unchdeal.ads
+
+mlib-utl.o : ada.ads a-except.ads alloc.ads gnat.ads g-os_lib.ads \
+ hostparm.ads mlib.ads mlib-fil.ads mlib-tgt.ads mlib-utl.ads \
+ mlib-utl.adb namet.ads opt.ads osint.ads output.ads system.ads \
+ s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-strops.ads s-wchcon.ads table.ads types.ads unchconv.ads \
+ unchdeal.ads
+
+mlib.o : ada.ads a-charac.ads a-chahan.ads a-except.ads gnat.ads \
+ g-os_lib.ads hostparm.ads mlib.ads mlib.adb mlib-utl.ads opt.ads \
+ osint.ads output.ads system.ads s-exctab.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-sopco4.ads s-wchcon.ads \
+ types.ads unchconv.ads unchdeal.ads
+
+namet.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \
+ hostparm.ads namet.ads namet.adb opt.ads output.ads system.ads \
+ s-exctab.ads s-secsta.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb tree_io.ads types.ads types.adb unchconv.ads \
+ unchdeal.ads widechar.ads
+
+nlists.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads elists.ads gnat.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads nlists.ads nlists.adb opt.ads output.ads sinfo.ads \
+ sinput.ads snames.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb tree_io.ads types.ads uintp.ads unchconv.ads \
+ unchdeal.ads urealp.ads
+
+nmake.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads elists.ads gnat.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads namet.ads nlists.ads nlists.adb nmake.ads nmake.adb \
+ opt.ads output.ads sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \
+ system.ads s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \
+ tree_io.ads types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads
+
+opt.o : ada.ads a-except.ads gnat.ads g-os_lib.ads gnatvsn.ads \
+ hostparm.ads opt.ads opt.adb system.ads s-exctab.ads s-stalib.ads \
+ s-wchcon.ads tree_io.ads types.ads unchconv.ads unchdeal.ads
+
+osint.o : ada.ads a-except.ads a-uncdea.ads alloc.ads debug.ads gnat.ads \
+ g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads namet.ads opt.ads \
+ osint.ads osint.adb output.ads sdefault.ads system.ads s-exctab.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb tree_io.ads types.ads unchconv.ads \
+ unchdeal.ads
+
+output.o : gnat.ads g-os_lib.ads output.ads output.adb system.ads \
+ s-exctab.ads s-stalib.ads types.ads unchconv.ads unchdeal.ads
+
+par.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ csets.ads debug.ads einfo.ads einfo.adb elists.ads elists.adb \
+ errout.ads fname.ads fname-uf.ads gnat.ads g-hesora.ads g-htable.ads \
+ g-os_lib.ads g-speche.ads hostparm.ads lib.ads lib.adb lib-list.adb \
+ lib-load.ads lib-sort.adb namet.ads namet.adb nlists.ads nlists.adb \
+ nmake.ads nmake.adb opt.ads osint.ads output.ads par.ads par.adb \
+ par-ch10.adb par-ch11.adb par-ch12.adb par-ch13.adb par-ch2.adb \
+ par-ch3.adb par-ch4.adb par-ch5.adb par-ch6.adb par-ch7.adb par-ch8.adb \
+ par-ch9.adb par-endh.adb par-labl.adb par-load.adb par-prag.adb \
+ par-sync.adb par-tchk.adb par-util.adb scans.ads scans.adb scn.ads \
+ scn.adb scn-nlit.adb scn-slit.adb sinfo.ads sinfo.adb sinfo-cn.ads \
+ sinput.ads sinput.adb sinput-l.ads snames.ads snames.adb stand.ads \
+ stringt.ads stringt.adb style.ads style.adb stylesw.ads system.ads \
+ s-exctab.ads s-exctab.adb s-imgenu.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \
+ tree_io.ads types.ads types.adb uintp.ads uintp.adb uname.ads \
+ unchconv.ads unchdeal.ads urealp.ads validsw.ads widechar.ads
+
+prj-attr.o : ada.ads a-charac.ads a-chahan.ads a-except.ads alloc.ads \
+ casing.ads debug.ads gnat.ads g-os_lib.ads hostparm.ads namet.ads \
+ opt.ads output.ads prj.ads prj-attr.ads prj-attr.adb scans.ads \
+ system.ads s-assert.ads s-exctab.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-sopco3.ads s-wchcon.ads \
+ table.ads table.adb tree_io.ads types.ads unchconv.ads unchdeal.ads
+
+prj-com.o : ada.ads a-except.ads a-uncdea.ads alloc.ads casing.ads \
+ debug.ads gnat.ads g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads \
+ namet.ads opt.ads output.ads prj.ads prj-com.ads prj-com.adb scans.ads \
+ stringt.ads system.ads s-assert.ads s-exctab.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb tree_io.ads types.ads unchconv.ads unchdeal.ads
+
+prj-dect.o : alloc.ads casing.ads errout.ads gnat.ads g-htable.ads \
+ g-os_lib.ads prj.ads prj-attr.ads prj-com.ads prj-dect.ads prj-dect.adb \
+ prj-strt.ads prj-tree.ads scans.ads sinfo.ads system.ads s-exctab.ads \
+ s-stalib.ads table.ads types.ads uintp.ads unchconv.ads unchdeal.ads \
+ urealp.ads
+
+prj-env.o : ada.ads a-except.ads alloc.ads casing.ads debug.ads gnat.ads \
+ g-htable.ads g-os_lib.ads hostparm.ads namet.ads opt.ads osint.ads \
+ output.ads prj.ads prj-com.ads prj-env.ads prj-env.adb prj-util.ads \
+ scans.ads snames.ads stringt.ads system.ads s-assert.ads s-exctab.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-strops.ads s-sopco3.ads s-wchcon.ads table.ads table.adb tree_io.ads \
+ types.ads unchconv.ads unchdeal.ads
+
+prj-ext.o : ada.ads a-except.ads a-uncdea.ads alloc.ads casing.ads \
+ gnat.ads g-htable.ads g-htable.adb g-os_lib.ads namet.ads prj.ads \
+ prj-com.ads prj-ext.ads prj-ext.adb scans.ads stringt.ads system.ads \
+ s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads table.ads types.ads unchconv.ads unchdeal.ads
+
+prj-nmsc.o : ada.ads a-charac.ads a-chahan.ads a-chlat1.ads a-except.ads \
+ a-finali.ads a-filico.ads a-stream.ads a-string.ads a-strfix.ads \
+ a-strmap.ads a-stmaco.ads a-tags.ads alloc.ads casing.ads errout.ads \
+ gnat.ads g-dirope.ads g-htable.ads g-os_lib.ads namet.ads osint.ads \
+ output.ads prj.ads prj-com.ads prj-nmsc.ads prj-nmsc.adb prj-util.ads \
+ scans.ads snames.ads stringt.ads system.ads s-assert.ads s-exctab.ads \
+ s-finimp.ads s-finroo.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads s-sopco3.ads \
+ s-sopco5.ads s-unstyp.ads table.ads types.ads uintp.ads unchconv.ads \
+ unchdeal.ads
+
+prj-pars.o : ada.ads a-except.ads alloc.ads casing.ads errout.ads gnat.ads \
+ g-htable.ads g-os_lib.ads output.ads prj.ads prj-attr.ads prj-com.ads \
+ prj-pars.ads prj-pars.adb prj-part.ads prj-proc.ads prj-tree.ads \
+ scans.ads system.ads s-exctab.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads table.ads types.ads uintp.ads unchconv.ads \
+ unchdeal.ads
+
+prj-part.o : ada.ads a-charac.ads a-chahan.ads a-except.ads a-finali.ads \
+ a-filico.ads a-stream.ads a-tags.ads alloc.ads casing.ads debug.ads \
+ errout.ads gnat.ads g-dirope.ads g-htable.ads g-os_lib.ads hostparm.ads \
+ namet.ads opt.ads osint.ads output.ads prj.ads prj-attr.ads prj-com.ads \
+ prj-dect.ads prj-part.ads prj-part.adb prj-tree.ads scans.ads scn.ads \
+ sinfo.ads sinput.ads sinput-p.ads stringt.ads system.ads s-assert.ads \
+ s-exctab.ads s-finimp.ads s-finroo.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads \
+ s-sopco3.ads s-unstyp.ads s-wchcon.ads table.ads table.adb tree_io.ads \
+ types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads
+
+prj-proc.o : ada.ads a-except.ads a-uncdea.ads alloc.ads casing.ads \
+ errout.ads gnat.ads g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads \
+ namet.ads opt.ads output.ads prj.ads prj-attr.ads prj-com.ads \
+ prj-ext.ads prj-nmsc.ads prj-proc.ads prj-proc.adb prj-tree.ads \
+ scans.ads stringt.ads system.ads s-assert.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-strops.ads s-sopco3.ads s-sopco5.ads s-wchcon.ads table.ads types.ads \
+ uintp.ads unchconv.ads unchdeal.ads
+
+prj-strt.o : ada.ads a-except.ads alloc.ads casing.ads debug.ads \
+ errout.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads opt.ads \
+ output.ads prj.ads prj-attr.ads prj-com.ads prj-strt.ads prj-strt.adb \
+ prj-tree.ads scans.ads sinfo.ads stringt.ads system.ads s-assert.ads \
+ s-exctab.ads s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads \
+ types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads
+
+prj-tree.o : ada.ads a-except.ads a-uncdea.ads casing.ads debug.ads \
+ gnat.ads g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads opt.ads \
+ output.ads prj.ads prj-attr.ads prj-com.ads prj-tree.ads prj-tree.adb \
+ scans.ads stringt.ads system.ads s-assert.ads s-exctab.ads s-stalib.ads \
+ s-wchcon.ads table.ads table.adb tree_io.ads types.ads unchconv.ads \
+ unchdeal.ads
+
+prj-util.o : ada.ads a-uncdea.ads alloc.ads casing.ads gnat.ads \
+ g-os_lib.ads namet.ads osint.ads prj.ads prj-util.ads prj-util.adb \
+ scans.ads stringt.ads system.ads s-exctab.ads s-secsta.ads s-stalib.ads \
+ s-stoele.ads table.ads types.ads unchconv.ads unchdeal.ads
+
+prj.o : ada.ads a-charac.ads a-chahan.ads a-except.ads alloc.ads \
+ casing.ads debug.ads errout.ads gnat.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads namet.ads opt.ads osint.ads output.ads prj.ads prj.adb \
+ prj-attr.ads prj-com.ads prj-env.ads scans.ads scn.ads sinfo.ads \
+ sinfo-cn.ads snames.ads stringt.ads system.ads s-assert.ads \
+ s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-sopco3.ads s-wchcon.ads table.ads table.adb tree_io.ads \
+ types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads
+
+repinfo.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads fname.ads gnat.ads \
+ g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib.adb \
+ lib-list.adb lib-sort.adb namet.ads nlists.ads nlists.adb opt.ads \
+ output.ads repinfo.ads repinfo.adb sinfo.ads sinfo.adb sinput.ads \
+ sinput.adb snames.ads stand.ads stringt.ads system.ads s-exctab.ads \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \
+ uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads
+
+restrict.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads errout.ads exp_util.ads \
+ fname.ads fname-uf.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb namet.ads \
+ nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \
+ restrict.ads restrict.adb rident.ads rtsfind.ads sinfo.ads sinfo.adb \
+ sinput.ads snames.ads stand.ads stringt.ads system.ads s-exctab.ads \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \
+ uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads
+
+rident.o : rident.ads system.ads
+
+rtsfind.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ csets.ads debug.ads einfo.ads einfo.adb elists.ads elists.adb fname.ads \
+ fname-uf.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads lib.ads lib.adb lib-list.adb lib-load.ads lib-sort.adb \
+ namet.ads namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads \
+ output.ads restrict.ads rident.ads rtsfind.ads rtsfind.adb sem.ads \
+ sem_ch7.ads sem_util.ads sinfo.ads sinfo.adb sinput.ads snames.ads \
+ stand.ads stringt.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb tbuild.ads tree_io.ads types.ads uintp.ads \
+ uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads widechar.ads
+
+s-arit64.o : gnat.ads g-except.ads interfac.ads system.ads s-arit64.ads \
+ s-arit64.adb unchconv.ads
+
+s-assert.o : ada.ads a-except.ads gnat.ads g-htable.ads system.ads \
+ s-assert.ads s-assert.adb s-exctab.ads s-exctab.adb s-stalib.ads \
+ unchconv.ads
+
+s-bitops.o : gnat.ads g-except.ads system.ads s-bitops.ads s-bitops.adb \
+ s-unstyp.ads unchconv.ads
+
+s-except.o : ada.ads a-except.ads system.ads s-except.ads s-stalib.ads \
+ unchconv.ads
+
+s-exctab.o : ada.ads a-uncdea.ads gnat.ads g-htable.ads g-htable.adb \
+ system.ads s-exctab.ads s-exctab.adb s-stalib.ads unchconv.ads
+
+s-exngen.o : system.ads s-exngen.ads s-exngen.adb
+
+s-exnllf.o : ada.ads a-except.ads system.ads s-exngen.ads s-exngen.adb \
+ s-exnllf.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ unchconv.ads
+
+s-fatllf.o : ada.ads a-unccon.ads system.ads s-assert.ads s-exctab.ads \
+ s-fatgen.ads s-fatgen.adb s-fatllf.ads s-stalib.ads s-unstyp.ads \
+ unchconv.ads
+
+s-ficobl.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-stream.ads \
+ a-tags.ads a-tags.adb gnat.ads g-htable.ads interfac.ads i-cstrea.ads \
+ system.ads s-exctab.ads s-ficobl.ads s-finimp.ads s-finroo.ads \
+ s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-stratt.ads s-unstyp.ads unchconv.ads
+
+s-fileio.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \
+ a-stream.ads a-tags.ads a-tags.adb gnat.ads g-htable.ads interfac.ads \
+ i-cstrea.ads system.ads s-exctab.ads s-ficobl.ads s-fileio.ads \
+ s-fileio.adb s-finimp.ads s-finroo.ads s-parame.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads \
+ s-unstyp.ads unchconv.ads unchdeal.ads
+
+s-finimp.o : ada.ads a-except.ads a-stream.ads a-tags.ads a-tags.adb \
+ a-unccon.ads gnat.ads g-htable.ads system.ads s-exctab.ads s-finimp.ads \
+ s-finimp.adb s-finroo.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-stoele.adb s-stratt.ads s-sopco3.ads \
+ s-unstyp.ads unchconv.ads
+
+s-finroo.o : ada.ads a-except.ads a-stream.ads a-tags.ads a-tags.adb \
+ gnat.ads g-htable.ads system.ads s-exctab.ads s-finroo.ads s-finroo.adb \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ unchconv.ads
+
+s-imgbiu.o : system.ads s-imgbiu.ads s-imgbiu.adb s-unstyp.ads
+
+s-imgenu.o : system.ads s-imgenu.ads s-imgenu.adb s-secsta.ads \
+ s-stoele.ads unchconv.ads
+
+s-imgint.o : system.ads s-imgint.ads s-imgint.adb s-secsta.ads \
+ s-stoele.ads
+
+s-imgllb.o : system.ads s-imgllb.ads s-imgllb.adb s-unstyp.ads
+
+s-imglli.o : system.ads s-imglli.ads s-imglli.adb s-secsta.ads \
+ s-stoele.ads
+
+s-imgllu.o : system.ads s-imgllu.ads s-imgllu.adb s-secsta.ads \
+ s-stoele.ads s-unstyp.ads
+
+s-imgllw.o : system.ads s-imgllw.ads s-imgllw.adb s-unstyp.ads
+
+s-imgrea.o : ada.ads a-unccon.ads system.ads s-assert.ads s-exctab.ads \
+ s-fatgen.ads s-fatgen.adb s-fatllf.ads s-imgllu.ads s-imgrea.ads \
+ s-imgrea.adb s-imguns.ads s-powtab.ads s-secsta.ads s-stalib.ads \
+ s-stoele.ads s-unstyp.ads unchconv.ads
+
+s-imguns.o : system.ads s-imguns.ads s-imguns.adb s-secsta.ads \
+ s-stoele.ads s-unstyp.ads
+
+s-imgwiu.o : system.ads s-imgwiu.ads s-imgwiu.adb s-unstyp.ads
+
+s-io.o : system.ads s-io.ads s-io.adb
+
+s-mastop.o : ada.ads a-except.ads system.ads s-except.ads s-mastop.ads \
+ s-mastop.adb s-stalib.ads s-stoele.ads unchconv.ads
+
+s-memory.o : ada.ads a-except.ads system.ads s-memory.ads s-memory.adb \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads unchconv.ads
+
+s-parame.o : system.ads s-parame.ads s-parame.adb
+
+s-powtab.o : system.ads s-powtab.ads
+
+s-secsta.o : ada.ads a-except.ads system.ads s-parame.ads s-secsta.ads \
+ s-secsta.adb s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ unchconv.ads unchdeal.ads
+
+s-soflin.o : ada.ads a-except.ads system.ads s-except.ads s-mastop.ads \
+ s-parame.ads s-secsta.ads s-soflin.ads s-soflin.adb s-stache.ads \
+ s-stalib.ads s-stoele.ads unchconv.ads
+
+s-sopco3.o : system.ads s-secsta.ads s-stoele.ads s-strops.ads \
+ s-sopco3.ads s-sopco3.adb
+
+s-sopco4.o : system.ads s-secsta.ads s-stoele.ads s-sopco3.ads \
+ s-sopco4.ads s-sopco4.adb
+
+s-sopco5.o : system.ads s-secsta.ads s-stoele.ads s-sopco4.ads \
+ s-sopco5.ads s-sopco5.adb
+
+s-stache.o : ada.ads a-except.ads system.ads s-parame.ads s-soflin.ads \
+ s-stache.ads s-stache.adb s-stalib.ads s-stoele.ads s-stoele.adb \
+ unchconv.ads
+
+s-stalib.o : ada.ads a-except.ads system.ads s-memory.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stalib.adb s-stoele.ads unchconv.ads
+
+s-stoele.o : system.ads s-stoele.ads s-stoele.adb unchconv.ads
+
+s-stopoo.o : ada.ads a-except.ads a-finali.ads a-stream.ads a-tags.ads \
+ a-tags.adb gnat.ads g-htable.ads system.ads s-exctab.ads s-finimp.ads \
+ s-finroo.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-stopoo.ads s-stratt.ads s-unstyp.ads unchconv.ads
+
+s-stratt.o : ada.ads a-except.ads a-ioexce.ads a-stream.ads a-tags.ads \
+ a-tags.adb gnat.ads g-htable.ads system.ads s-exctab.ads s-secsta.ads \
+ s-stalib.ads s-stoele.ads s-stratt.ads s-stratt.adb s-unstyp.ads \
+ unchconv.ads
+
+s-strops.o : system.ads s-secsta.ads s-stoele.ads s-strops.ads \
+ s-strops.adb
+
+s-traceb.o : system.ads s-traceb.ads s-traceb.adb
+
+s-unstyp.o : system.ads s-unstyp.ads
+
+s-valenu.o : system.ads s-valenu.ads s-valenu.adb s-valuti.ads \
+ unchconv.ads
+
+s-valint.o : system.ads s-unstyp.ads s-valint.ads s-valint.adb \
+ s-valuns.ads s-valuti.ads
+
+s-vallli.o : system.ads s-unstyp.ads s-vallli.ads s-vallli.adb \
+ s-valllu.ads s-valuti.ads
+
+s-valllu.o : system.ads s-unstyp.ads s-valllu.ads s-valllu.adb \
+ s-valuti.ads
+
+s-valrea.o : system.ads s-exngen.ads s-exnllf.ads s-powtab.ads \
+ s-valrea.ads s-valrea.adb s-valuti.ads
+
+s-valuns.o : system.ads s-unstyp.ads s-valuns.ads s-valuns.adb \
+ s-valuti.ads
+
+s-valuti.o : gnat.ads g-casuti.ads system.ads s-valuti.ads s-valuti.adb
+
+s-wchcnv.o : interfac.ads system.ads s-wchcnv.ads s-wchcnv.adb \
+ s-wchcon.ads s-wchjis.ads
+
+s-wchcon.o : system.ads s-wchcon.ads
+
+s-wchjis.o : system.ads s-wchjis.ads s-wchjis.adb
+
+scans.o : scans.ads scans.adb system.ads s-exctab.ads s-stalib.ads \
+ types.ads unchconv.ads unchdeal.ads
+
+scn.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ csets.ads debug.ads einfo.ads elists.ads errout.ads gnat.ads \
+ g-htable.ads g-os_lib.ads hostparm.ads namet.ads namet.adb nlists.ads \
+ nlists.adb opt.ads output.ads scans.ads scn.ads scn.adb scn-nlit.adb \
+ scn-slit.adb sinfo.ads sinfo.adb sinput.ads sinput.adb snames.ads \
+ stringt.ads stringt.adb style.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb tree_io.ads types.ads types.adb \
+ uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads urealp.adb \
+ widechar.ads
+
+sem.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads debug_a.ads debug_a.adb einfo.ads einfo.adb elists.ads \
+ errout.ads expander.ads fname.ads gnat.ads g-hesora.ads g-htable.ads \
+ g-os_lib.ads hlo.ads hostparm.ads inline.ads lib.ads lib.adb \
+ lib-list.adb lib-load.ads lib-sort.adb namet.ads nlists.ads nlists.adb \
+ opt.ads output.ads restrict.ads rident.ads sem.ads sem.adb sem_attr.ads \
+ sem_ch10.ads sem_ch11.ads sem_ch12.ads sem_ch13.ads sem_ch2.ads \
+ sem_ch2.adb sem_ch3.ads sem_ch4.ads sem_ch5.ads sem_ch6.ads sem_ch7.ads \
+ sem_ch8.ads sem_ch9.ads sem_prag.ads sem_util.ads sinfo.ads sinfo.adb \
+ sinput.ads snames.ads stand.ads stringt.ads system.ads s-exctab.ads \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \
+ types.adb uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads \
+ urealp.ads
+
+sem_aggr.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ elists.adb errout.ads eval_fat.ads exp_ch11.ads exp_ch2.ads exp_ch7.ads \
+ exp_util.ads exp_util.adb freeze.ads get_targ.ads gnat.ads g-htable.ads \
+ g-os_lib.ads g-speche.ads hostparm.ads inline.ads itypes.ads lib.ads \
+ lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb nmake.ads \
+ nmake.adb opt.ads output.ads restrict.ads rident.ads rtsfind.ads \
+ scans.ads scn.ads sem.ads sem_aggr.ads sem_aggr.adb sem_cat.ads \
+ sem_ch13.ads sem_ch8.ads sem_eval.ads sem_eval.adb sem_res.ads \
+ sem_type.ads sem_util.ads sem_util.adb sem_warn.ads sinfo.ads sinfo.adb \
+ sinput.ads snames.ads stand.ads stringt.ads stringt.adb style.ads \
+ system.ads s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \
+ targparm.ads tbuild.ads tree_io.ads ttypes.ads types.ads uintp.ads \
+ uintp.adb unchconv.ads unchdeal.ads urealp.ads validsw.ads widechar.ads
+
+sem_attr.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads alloc.ads \
+ atree.ads atree.adb casing.ads checks.ads checks.adb debug.ads \
+ einfo.ads einfo.adb elists.ads errout.ads eval_fat.ads exp_ch11.ads \
+ exp_ch2.ads exp_ch7.ads exp_tss.ads exp_util.ads exp_util.adb \
+ expander.ads freeze.ads get_targ.ads gnat.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads inline.ads itypes.ads lib.ads lib-xref.ads namet.ads \
+ nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \
+ restrict.ads rident.ads rtsfind.ads sem.ads sem_attr.ads sem_attr.adb \
+ sem_cat.ads sem_ch13.ads sem_ch6.ads sem_ch8.ads sem_dist.ads \
+ sem_eval.ads sem_eval.adb sem_res.ads sem_type.ads sem_util.ads \
+ sem_warn.ads sinfo.ads sinfo.adb sinput.ads sinput.adb snames.ads \
+ snames.adb stand.ads stringt.ads stringt.adb system.ads s-exctab.ads \
+ s-exctab.adb s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \
+ tbuild.ads tbuild.adb tree_io.ads ttypef.ads ttypes.ads types.ads \
+ types.adb uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads \
+ urealp.adb validsw.ads widechar.ads
+
+sem_case.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads errout.ads gnat.ads \
+ g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads namet.ads \
+ nlists.ads nlists.adb opt.ads output.ads sem.ads sem_case.ads \
+ sem_case.adb sem_eval.ads sem_res.ads sem_type.ads sem_util.ads \
+ sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads system.ads \
+ s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \
+ types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads
+
+sem_cat.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads elists.adb errout.ads \
+ exp_tss.ads fname.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb namet.ads \
+ nlists.ads nlists.adb opt.ads output.ads sem.ads sem_cat.ads \
+ sem_cat.adb sem_util.ads sinfo.ads sinfo.adb sinput.ads snames.ads \
+ stand.ads stringt.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb tree_io.ads types.ads uintp.ads uintp.adb uname.ads \
+ unchconv.ads unchdeal.ads urealp.ads
+
+sem_ch10.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads errout.ads exp_util.ads \
+ fname.ads fname-uf.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads \
+ g-htable.ads g-os_lib.ads hostparm.ads impunit.ads inline.ads lib.ads \
+ lib.adb lib-list.adb lib-load.ads lib-sort.adb lib-xref.ads namet.ads \
+ namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \
+ restrict.ads rident.ads rtsfind.ads scans.ads scn.ads sem.ads \
+ sem_ch10.ads sem_ch10.adb sem_ch6.ads sem_ch7.ads sem_ch8.ads \
+ sem_dist.ads sem_eval.ads sem_prag.ads sem_res.ads sem_type.ads \
+ sem_util.ads sem_util.adb sem_warn.ads sinfo.ads sinfo.adb sinfo-cn.ads \
+ sinput.ads sinput.adb snames.ads stand.ads stringt.ads style.ads \
+ system.ads s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \
+ targparm.ads tbuild.ads tree_io.ads ttypes.ads types.ads uintp.ads \
+ uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads widechar.ads
+
+sem_ch11.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads errout.ads gnat.ads \
+ g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib-xref.ads namet.ads \
+ nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \
+ restrict.ads rident.ads rtsfind.ads sem.ads sem_ch11.ads sem_ch11.adb \
+ sem_ch5.ads sem_ch8.ads sem_res.ads sem_util.ads sinfo.ads sinfo.adb \
+ sinput.ads snames.ads stand.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb tree_io.ads types.ads uintp.ads \
+ uintp.adb unchconv.ads unchdeal.ads urealp.ads
+
+sem_ch12.o : ada.ads a-except.ads a-uncdea.ads alloc.ads atree.ads \
+ atree.adb casing.ads debug.ads einfo.ads einfo.adb elists.ads \
+ elists.adb errout.ads exp_util.ads expander.ads fname.ads fname-uf.ads \
+ freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads g-htable.adb \
+ g-os_lib.ads hostparm.ads inline.ads lib.ads lib.adb lib-list.adb \
+ lib-load.ads lib-sort.adb lib-xref.ads namet.ads namet.adb nlists.ads \
+ nlists.adb nmake.ads nmake.adb opt.ads output.ads restrict.ads \
+ rident.ads rtsfind.ads scans.ads scn.ads sem.ads sem_cat.ads \
+ sem_ch10.ads sem_ch12.ads sem_ch12.adb sem_ch13.ads sem_ch3.ads \
+ sem_ch6.ads sem_ch7.ads sem_ch8.ads sem_elab.ads sem_elim.ads \
+ sem_eval.ads sem_res.ads sem_type.ads sem_util.ads sem_util.adb \
+ sinfo.ads sinfo.adb sinfo-cn.ads sinput.ads sinput-l.ads snames.ads \
+ stand.ads stringt.ads style.ads system.ads s-exctab.ads s-exctab.adb \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads \
+ tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb uname.ads \
+ unchconv.ads unchdeal.ads urealp.ads urealp.adb widechar.ads
+
+sem_ch13.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads errout.ads exp_tss.ads \
+ exp_util.ads fname.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb \
+ namet.ads nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \
+ rtsfind.ads sem.ads sem_ch13.ads sem_ch13.adb sem_ch8.ads sem_eval.ads \
+ sem_res.ads sem_type.ads sem_util.ads sinfo.ads sinfo.adb sinput.ads \
+ snames.ads stand.ads stringt.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb tbuild.ads tree_io.ads ttypes.ads \
+ types.ads uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads \
+ urealp.ads urealp.adb
+
+sem_ch2.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads elists.ads gnat.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads namet.ads nlists.ads nlists.adb opt.ads output.ads \
+ restrict.ads rident.ads sem_ch2.ads sem_ch2.adb sem_ch8.ads sinfo.ads \
+ sinfo.adb sinput.ads snames.ads stand.ads system.ads s-exctab.ads \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \
+ types.adb uintp.ads unchconv.ads unchdeal.ads urealp.ads
+
+sem_ch3.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ elists.adb errout.ads eval_fat.ads exp_ch11.ads exp_ch2.ads exp_ch3.ads \
+ exp_ch7.ads exp_dist.ads exp_tss.ads exp_util.ads exp_util.adb \
+ fname.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads inline.ads itypes.ads layout.ads lib.ads \
+ lib.adb lib-list.adb lib-sort.adb lib-xref.ads namet.ads namet.adb \
+ nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \
+ restrict.ads rident.ads rtsfind.ads scans.ads scn.ads sem.ads \
+ sem_case.ads sem_case.adb sem_cat.ads sem_cat.adb sem_ch13.ads \
+ sem_ch3.ads sem_ch3.adb sem_ch6.ads sem_ch7.ads sem_ch8.ads \
+ sem_disp.ads sem_dist.ads sem_elim.ads sem_eval.ads sem_eval.adb \
+ sem_mech.ads sem_res.ads sem_smem.ads sem_type.ads sem_util.ads \
+ sem_util.adb sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads \
+ stand.ads stringt.ads style.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads tbuild.adb \
+ tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb uname.ads \
+ unchconv.ads unchdeal.ads urealp.ads urealp.adb validsw.ads \
+ widechar.ads
+
+sem_ch4.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads errout.ads exp_util.ads \
+ freeze.ads get_targ.ads gnat.ads g-htable.ads g-os_lib.ads g-speche.ads \
+ hostparm.ads itypes.ads lib.ads lib-xref.ads namet.ads namet.adb \
+ nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \
+ restrict.ads rident.ads rtsfind.ads scans.ads scn.ads sem.ads \
+ sem_cat.ads sem_ch3.ads sem_ch4.ads sem_ch4.adb sem_ch8.ads \
+ sem_dist.ads sem_eval.ads sem_res.ads sem_type.ads sem_util.ads \
+ sem_util.adb sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \
+ stringt.ads style.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb targparm.ads tbuild.ads tree_io.ads ttypes.ads \
+ types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads \
+ widechar.ads
+
+sem_ch5.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ errout.ads eval_fat.ads exp_ch2.ads exp_util.ads expander.ads \
+ freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads lib.ads lib-xref.ads namet.ads namet.adb nlists.ads \
+ nlists.adb nmake.ads opt.ads output.ads restrict.ads rident.ads \
+ rtsfind.ads scans.ads scn.ads sem.ads sem_case.ads sem_case.adb \
+ sem_cat.ads sem_ch3.ads sem_ch5.ads sem_ch5.adb sem_ch8.ads \
+ sem_disp.ads sem_eval.ads sem_eval.adb sem_res.ads sem_type.ads \
+ sem_util.ads sem_util.adb sem_warn.ads sinfo.ads sinfo.adb sinput.ads \
+ snames.ads stand.ads stringt.ads style.ads system.ads s-exctab.ads \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads \
+ tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb unchconv.ads \
+ unchdeal.ads urealp.ads validsw.ads widechar.ads
+
+sem_ch6.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ elists.adb errout.ads exp_ch2.ads exp_ch7.ads exp_util.ads expander.ads \
+ fname.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads inline.ads lib.ads lib.adb lib-list.adb \
+ lib-sort.adb lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb \
+ nmake.ads nmake.adb opt.ads output.ads restrict.ads rident.ads \
+ rtsfind.ads scans.ads scn.ads sem.ads sem_cat.ads sem_ch12.ads \
+ sem_ch3.ads sem_ch4.ads sem_ch5.ads sem_ch6.ads sem_ch6.adb sem_ch8.ads \
+ sem_disp.ads sem_dist.ads sem_elim.ads sem_eval.ads sem_mech.ads \
+ sem_prag.ads sem_res.ads sem_type.ads sem_util.ads sem_util.adb \
+ sem_warn.ads sinfo.ads sinfo.adb sinfo-cn.ads sinput.ads snames.ads \
+ stand.ads stringt.ads stringt.adb style.ads stylesw.ads system.ads \
+ s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \
+ tbuild.ads tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb \
+ uname.ads unchconv.ads unchdeal.ads urealp.ads validsw.ads widechar.ads
+
+sem_ch7.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads elists.adb errout.ads \
+ exp_dbug.ads exp_disp.ads exp_util.ads freeze.ads get_targ.ads gnat.ads \
+ g-htable.ads g-os_lib.ads hostparm.ads inline.ads lib.ads lib-xref.ads \
+ namet.ads namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads \
+ output.ads restrict.ads rident.ads rtsfind.ads scans.ads scn.ads \
+ sem.ads sem_cat.ads sem_ch12.ads sem_ch3.ads sem_ch6.ads sem_ch7.ads \
+ sem_ch7.adb sem_ch8.ads sem_eval.ads sem_res.ads sem_type.ads \
+ sem_util.ads sem_util.adb sem_warn.ads sinfo.ads sinfo.adb sinput.ads \
+ snames.ads snames.adb stand.ads stringt.ads style.ads system.ads \
+ s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \
+ tbuild.ads tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb \
+ unchconv.ads unchdeal.ads urealp.ads widechar.ads
+
+sem_ch8.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads elists.adb errout.ads \
+ exp_util.ads fname.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads \
+ g-htable.ads g-os_lib.ads g-speche.ads hostparm.ads inline.ads lib.ads \
+ lib.adb lib-list.adb lib-load.ads lib-sort.adb lib-xref.ads namet.ads \
+ namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \
+ restrict.ads rident.ads rtsfind.ads scans.ads scn.ads sem.ads \
+ sem_ch12.ads sem_ch3.ads sem_ch4.ads sem_ch6.ads sem_ch8.ads \
+ sem_ch8.adb sem_eval.ads sem_res.ads sem_type.ads sem_util.ads \
+ sem_util.adb sinfo.ads sinfo.adb sinfo-cn.ads sinput.ads snames.ads \
+ stand.ads stringt.ads style.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads tree_io.ads \
+ ttypes.ads types.ads uintp.ads uintp.adb uname.ads unchconv.ads \
+ unchdeal.ads urealp.ads widechar.ads
+
+sem_ch9.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ errout.ads exp_ch2.ads exp_ch9.ads exp_util.ads fname.ads fname-uf.ads \
+ freeze.ads get_targ.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads \
+ itypes.ads lib.ads lib-xref.ads namet.ads namet.adb nlists.ads \
+ nlists.adb nmake.ads nmake.adb opt.ads output.ads restrict.ads \
+ restrict.adb rident.ads rtsfind.ads scans.ads scn.ads sem.ads \
+ sem_ch3.ads sem_ch5.ads sem_ch6.ads sem_ch8.ads sem_ch9.ads sem_ch9.adb \
+ sem_eval.ads sem_res.ads sem_type.ads sem_util.ads sem_util.adb \
+ sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \
+ stringt.ads style.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb targparm.ads tbuild.ads tree_io.ads ttypes.ads \
+ types.ads uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads \
+ urealp.ads validsw.ads widechar.ads
+
+sem_disp.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads elists.adb errout.ads \
+ exp_disp.ads exp_util.ads freeze.ads get_targ.ads gnat.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads lib.ads lib-xref.ads namet.ads namet.adb \
+ nlists.ads nlists.adb nmake.ads opt.ads output.ads restrict.ads \
+ rident.ads rtsfind.ads scans.ads scn.ads sem.ads sem_ch6.ads \
+ sem_ch8.ads sem_disp.ads sem_disp.adb sem_eval.ads sem_res.ads \
+ sem_type.ads sem_util.ads sem_util.adb sinfo.ads sinfo.adb sinput.ads \
+ snames.ads stand.ads stringt.ads style.ads system.ads s-exctab.ads \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads \
+ tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb unchconv.ads \
+ unchdeal.ads urealp.ads widechar.ads
+
+sem_dist.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads errout.ads exp_dist.ads \
+ exp_tss.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads \
+ namet.ads nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \
+ restrict.ads rident.ads rtsfind.ads sem.ads sem_dist.ads sem_dist.adb \
+ sem_res.ads sem_util.ads sinfo.ads sinfo.adb sinput.ads snames.ads \
+ stand.ads stringt.ads stringt.adb system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb tbuild.ads tbuild.adb tree_io.ads \
+ types.ads types.adb uintp.ads uintp.adb uname.ads unchconv.ads \
+ unchdeal.ads urealp.ads
+
+sem_elab.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ elists.adb errout.ads exp_ch2.ads exp_util.ads expander.ads fname.ads \
+ freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads lib.ads lib.adb lib-list.adb lib-load.ads lib-sort.adb \
+ lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb nmake.ads \
+ nmake.adb opt.ads output.ads restrict.ads rident.ads rtsfind.ads \
+ scans.ads scn.ads sem.ads sem_cat.ads sem_ch7.ads sem_ch8.ads \
+ sem_elab.ads sem_elab.adb sem_eval.ads sem_res.ads sem_type.ads \
+ sem_util.ads sem_util.adb sem_warn.ads sinfo.ads sinfo.adb sinput.ads \
+ sinput.adb snames.ads stand.ads stringt.ads style.ads system.ads \
+ s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \
+ tbuild.ads tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb \
+ uname.ads unchconv.ads unchdeal.ads urealp.ads validsw.ads widechar.ads
+
+sem_elim.o : ada.ads a-except.ads a-uncdea.ads alloc.ads atree.ads \
+ atree.adb casing.ads debug.ads einfo.ads einfo.adb elists.ads \
+ errout.ads gnat.ads g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads \
+ namet.ads nlists.ads nlists.adb opt.ads output.ads sem_elim.ads \
+ sem_elim.adb sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \
+ stringt.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb tree_io.ads types.ads uintp.ads uintp.adb \
+ unchconv.ads unchdeal.ads urealp.ads
+
+sem_eval.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \
+ elists.adb errout.ads eval_fat.ads exp_ch2.ads exp_util.ads freeze.ads \
+ get_targ.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads \
+ lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb nmake.ads \
+ nmake.adb opt.ads output.ads restrict.ads rident.ads rtsfind.ads \
+ scans.ads scn.ads sem.ads sem_cat.ads sem_ch8.ads sem_eval.ads \
+ sem_eval.adb sem_res.ads sem_type.ads sem_util.ads sem_util.adb \
+ sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \
+ stringt.ads stringt.adb style.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads tree_io.ads \
+ ttypes.ads types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads \
+ urealp.ads urealp.adb validsw.ads widechar.ads
+
+sem_intr.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads errout.ads fname.ads gnat.ads \
+ g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib.adb \
+ lib-list.adb lib-sort.adb namet.ads nlists.ads nlists.adb opt.ads \
+ output.ads sem_eval.ads sem_intr.ads sem_intr.adb sem_util.ads \
+ sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads stringt.ads \
+ stringt.adb system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb targparm.ads tree_io.ads types.ads uintp.ads \
+ uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads
+
+sem_maps.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads gnat.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads namet.ads nlists.ads nlists.adb opt.ads \
+ output.ads sem_maps.ads sem_maps.adb sinfo.ads sinfo.adb sinput.ads \
+ snames.ads stand.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb tree_io.ads types.ads uintp.ads uintp.adb \
+ unchconv.ads unchdeal.ads urealp.ads
+
+sem_mech.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads errout.ads gnat.ads \
+ g-htable.ads g-os_lib.ads hostparm.ads namet.ads nlists.ads nlists.adb \
+ opt.ads output.ads sem.ads sem_mech.ads sem_mech.adb sem_util.ads \
+ sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads system.ads \
+ s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \
+ tree_io.ads types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads \
+ urealp.ads
+
+sem_prag.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ casing.adb checks.ads csets.ads debug.ads einfo.ads einfo.adb \
+ elists.ads elists.adb errout.ads eval_fat.ads exp_dist.ads expander.ads \
+ fname.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb namet.ads \
+ namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \
+ restrict.ads rident.ads rtsfind.ads sem.ads sem_cat.ads sem_ch13.ads \
+ sem_ch8.ads sem_disp.ads sem_elim.ads sem_eval.ads sem_eval.adb \
+ sem_intr.ads sem_mech.ads sem_prag.ads sem_prag.adb sem_res.ads \
+ sem_type.ads sem_util.ads sem_vfpt.ads sem_warn.ads sinfo.ads sinfo.adb \
+ sinfo-cn.ads sinput.ads sinput.adb snames.ads snames.adb stand.ads \
+ stringt.ads stringt.adb stylesw.ads system.ads s-exctab.ads \
+ s-exctab.adb s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \
+ tbuild.ads tree_io.ads ttypes.ads types.ads types.adb uintp.ads \
+ uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads urealp.adb \
+ validsw.ads widechar.ads
+
+sem_res.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ checks.ads checks.adb debug.ads debug_a.ads debug_a.adb einfo.ads \
+ einfo.adb elists.ads errout.ads eval_fat.ads exp_ch11.ads exp_ch2.ads \
+ exp_ch7.ads exp_util.ads exp_util.adb expander.ads fname.ads freeze.ads \
+ get_targ.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads inline.ads itypes.ads lib.ads lib.adb lib-list.adb \
+ lib-sort.adb lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb \
+ nmake.ads nmake.adb opt.ads output.ads restrict.ads rident.ads \
+ rtsfind.ads scans.ads scn.ads sem.ads sem_aggr.ads sem_attr.ads \
+ sem_cat.ads sem_ch4.ads sem_ch6.ads sem_ch8.ads sem_disp.ads \
+ sem_dist.ads sem_elab.ads sem_eval.ads sem_eval.adb sem_intr.ads \
+ sem_res.ads sem_res.adb sem_type.ads sem_util.ads sem_util.adb \
+ sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \
+ stringt.ads stringt.adb style.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads tree_io.ads \
+ ttypes.ads types.ads types.adb uintp.ads uintp.adb uname.ads \
+ unchconv.ads unchdeal.ads urealp.ads urealp.adb validsw.ads \
+ widechar.ads
+
+sem_smem.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads errout.ads gnat.ads \
+ g-htable.ads g-os_lib.ads hostparm.ads namet.ads nlists.ads nlists.adb \
+ opt.ads output.ads sem_smem.ads sem_smem.adb sinfo.ads sinfo.adb \
+ sinput.ads snames.ads stand.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb tree_io.ads types.ads uintp.ads \
+ uintp.adb unchconv.ads unchdeal.ads urealp.ads
+
+sem_type.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads errout.ads exp_util.ads \
+ fname.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb \
+ lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb nmake.ads \
+ opt.ads output.ads restrict.ads rident.ads rtsfind.ads scans.ads \
+ scn.ads sem.ads sem_ch6.ads sem_ch8.ads sem_eval.ads sem_res.ads \
+ sem_type.ads sem_type.adb sem_util.ads sem_util.adb sinfo.ads sinfo.adb \
+ sinput.ads snames.ads stand.ads stringt.ads style.ads system.ads \
+ s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \
+ tbuild.ads tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb \
+ uname.ads unchconv.ads unchdeal.ads urealp.ads widechar.ads
+
+sem_util.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ casing.adb checks.ads csets.ads debug.ads einfo.ads einfo.adb \
+ elists.ads elists.adb errout.ads eval_fat.ads exp_ch11.ads exp_ch7.ads \
+ exp_util.ads exp_util.adb fname.ads freeze.ads get_targ.ads gnat.ads \
+ g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads inline.ads \
+ itypes.ads lib.ads lib.adb lib-list.adb lib-sort.adb lib-xref.ads \
+ namet.ads namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads \
+ output.ads restrict.ads rident.ads rtsfind.ads scans.ads scn.ads \
+ sem.ads sem_cat.ads sem_ch8.ads sem_eval.ads sem_eval.adb sem_res.ads \
+ sem_type.ads sem_util.ads sem_util.adb sem_warn.ads sinfo.ads sinfo.adb \
+ sinput.ads snames.ads stand.ads stringt.ads stringt.adb style.ads \
+ system.ads s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \
+ targparm.ads tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads \
+ types.adb uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads \
+ urealp.ads urealp.adb validsw.ads widechar.ads
+
+sem_vfpt.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ cstand.ads debug.ads einfo.ads einfo.adb elists.ads gnat.ads \
+ g-htable.ads g-os_lib.ads hostparm.ads namet.ads nlists.ads nlists.adb \
+ opt.ads output.ads sem_vfpt.ads sem_vfpt.adb sinfo.ads sinfo.adb \
+ sinput.ads snames.ads stand.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb targparm.ads tree_io.ads ttypef.ads \
+ types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads
+
+sem_warn.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads errout.ads exp_util.ads \
+ fname.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb \
+ lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb nmake.ads \
+ opt.ads output.ads restrict.ads rident.ads rtsfind.ads scans.ads \
+ scn.ads sem.ads sem_ch8.ads sem_eval.ads sem_res.ads sem_type.ads \
+ sem_util.ads sem_util.adb sem_warn.ads sem_warn.adb sinfo.ads sinfo.adb \
+ sinput.ads sinput.adb snames.ads stand.ads stringt.ads style.ads \
+ system.ads s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \
+ targparm.ads tbuild.ads tree_io.ads ttypes.ads types.ads uintp.ads \
+ uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads widechar.ads
+
+sfn_scan.o : ada.ads a-except.ads sfn_scan.ads sfn_scan.adb system.ads \
+ s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads unchconv.ads
+
+sinfo-cn.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads elists.ads gnat.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads nlists.ads nlists.adb opt.ads output.ads sinfo.ads \
+ sinfo-cn.ads sinfo-cn.adb sinput.ads snames.ads system.ads s-exctab.ads \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \
+ uintp.ads unchconv.ads unchdeal.ads urealp.ads
+
+sinfo.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads elists.ads gnat.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads nlists.ads nlists.adb opt.ads output.ads sinfo.ads \
+ sinfo.adb sinput.ads snames.ads system.ads s-exctab.ads s-imgenu.ads \
+ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \
+ s-wchcon.ads table.ads table.adb tree_io.ads types.ads uintp.ads \
+ uintp.adb unchconv.ads unchdeal.ads urealp.ads
+
+sinput-l.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads elists.ads gnat.ads g-htable.ads g-os_lib.ads \
+ hostparm.ads namet.ads nlists.ads nlists.adb opt.ads osint.ads \
+ output.ads scans.ads scn.ads sinfo.ads sinfo.adb sinput.ads \
+ sinput-l.ads sinput-l.adb snames.ads system.ads s-exctab.ads \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \
+ uintp.ads unchconv.ads unchdeal.ads urealp.ads
+
+sinput-p.o : ada.ads a-unccon.ads alloc.ads casing.ads gnat.ads \
+ g-os_lib.ads hostparm.ads namet.ads opt.ads scans.ads sinput.ads \
+ sinput-p.ads sinput-p.adb system.ads s-exctab.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads types.ads unchconv.ads unchdeal.ads
+
+sinput.o : ada.ads a-except.ads alloc.ads casing.ads debug.ads gnat.ads \
+ g-os_lib.ads hostparm.ads namet.ads namet.adb opt.ads output.ads \
+ sinput.ads sinput.adb system.ads s-exctab.ads s-secsta.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \
+ unchconv.ads unchdeal.ads widechar.ads
+
+snames.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \
+ hostparm.ads namet.ads opt.ads output.ads snames.ads snames.adb \
+ system.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads table.adb \
+ tree_io.ads types.ads unchconv.ads unchdeal.ads
+
+sprint.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads fname.ads gnat.ads \
+ g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib.adb \
+ lib-list.adb lib-sort.adb namet.ads nlists.ads nlists.adb opt.ads \
+ output.ads rtsfind.ads sinfo.ads sinfo.adb sinput.ads sinput-l.ads \
+ snames.ads sprint.ads sprint.adb stand.ads stringt.ads stringt.adb \
+ system.ads s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \
+ tree_io.ads types.ads uintp.ads uintp.adb uname.ads unchconv.ads \
+ unchdeal.ads urealp.ads urealp.adb
+
+stand.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \
+ hostparm.ads namet.ads opt.ads output.ads stand.ads stand.adb \
+ system.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads table.adb \
+ tree_io.ads types.ads unchconv.ads unchdeal.ads
+
+stringt.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \
+ hostparm.ads namet.ads opt.ads output.ads stringt.ads stringt.adb \
+ system.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads table.adb \
+ tree_io.ads types.ads types.adb unchconv.ads unchdeal.ads
+
+style.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ csets.ads debug.ads einfo.ads elists.ads errout.ads gnat.ads \
+ g-htable.ads g-os_lib.ads hostparm.ads namet.ads namet.adb nlists.ads \
+ nlists.adb opt.ads output.ads scans.ads scn.ads scn.adb scn-nlit.adb \
+ scn-slit.adb sinfo.ads sinfo.adb sinput.ads sinput.adb snames.ads \
+ stand.ads stringt.ads style.ads style.adb stylesw.ads system.ads \
+ s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \
+ types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads widechar.ads
+
+stylesw.o : hostparm.ads opt.ads stylesw.ads stylesw.adb system.ads \
+ s-exctab.ads s-stalib.ads s-wchcon.ads types.ads unchconv.ads \
+ unchdeal.ads
+
+switch.o : ada.ads a-except.ads debug.ads gnat.ads g-htable.ads \
+ g-os_lib.ads hostparm.ads opt.ads osint.ads stylesw.ads switch.ads \
+ switch.adb system.ads s-exctab.ads s-exctab.adb s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads types.ads \
+ unchconv.ads unchdeal.ads validsw.ads
+
+system.o : system.ads
+
+table.o : debug.ads gnat.ads g-os_lib.ads hostparm.ads opt.ads output.ads \
+ system.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads table.adb \
+ tree_io.ads types.ads unchconv.ads unchdeal.ads
+
+targparm.o : ada.ads a-except.ads alloc.ads casing.ads debug.ads fname.ads \
+ fname-uf.ads gnat.ads g-os_lib.ads hostparm.ads namet.ads opt.ads \
+ output.ads sinput.ads sinput.adb sinput-l.ads system.ads s-exctab.ads \
+ s-stalib.ads s-wchcon.ads table.ads table.adb targparm.ads targparm.adb \
+ tree_io.ads types.ads unchconv.ads unchdeal.ads
+
+tbuild.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads fname.ads gnat.ads \
+ g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib.adb \
+ lib-list.adb lib-sort.adb namet.ads namet.adb nlists.ads nlists.adb \
+ nmake.ads nmake.adb opt.ads output.ads restrict.ads rident.ads \
+ sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads stringt.ads \
+ system.ads s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \
+ tbuild.ads tbuild.adb tree_io.ads types.ads uintp.ads uintp.adb \
+ uname.ads unchconv.ads unchdeal.ads urealp.ads widechar.ads
+
+tree_gen.o : ada.ads a-except.ads alloc.ads atree.ads casing.ads debug.ads \
+ einfo.ads elists.ads fname.ads gnat.ads g-os_lib.ads hostparm.ads \
+ lib.ads namet.ads nlists.ads opt.ads osint.ads output.ads repinfo.ads \
+ sinfo.ads sinput.ads snames.ads stand.ads stringt.ads system.ads \
+ s-exctab.ads s-stalib.ads s-wchcon.ads table.ads table.adb tree_gen.ads \
+ tree_gen.adb tree_io.ads types.ads uintp.ads unchconv.ads unchdeal.ads \
+ urealp.ads
+
+tree_io.o : ada.ads a-except.ads debug.ads gnat.ads g-htable.ads \
+ g-os_lib.ads output.ads system.ads s-exctab.ads s-exctab.adb \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads tree_io.ads \
+ tree_io.adb types.ads unchconv.ads unchdeal.ads
+
+treepr.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ csets.ads debug.ads einfo.ads einfo.adb elists.ads elists.adb fname.ads \
+ gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads \
+ lib.adb lib-list.adb lib-sort.adb namet.ads nlists.ads nlists.adb \
+ opt.ads output.ads sem_mech.ads sinfo.ads sinfo.adb sinput.ads \
+ sinput.adb snames.ads stand.ads stringt.ads system.ads s-exctab.ads \
+ s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads treepr.ads \
+ treepr.adb treeprs.ads types.ads uintp.ads uintp.adb uname.ads \
+ unchconv.ads unchdeal.ads urealp.ads
+
+treeprs.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \
+ hostparm.ads opt.ads output.ads sinfo.ads system.ads s-exctab.ads \
+ s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads treeprs.ads \
+ types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads
+
+ttypef.o : system.ads ttypef.ads
+
+ttypes.o : get_targ.ads system.ads s-exctab.ads s-stalib.ads ttypes.ads \
+ types.ads unchconv.ads unchdeal.ads
+
+types.o : gnat.ads g-htable.ads system.ads s-exctab.ads s-exctab.adb \
+ s-stalib.ads types.ads types.adb unchconv.ads unchdeal.ads
+
+uintp.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \
+ hostparm.ads opt.ads output.ads system.ads s-exctab.ads s-stalib.ads \
+ s-wchcon.ads table.ads table.adb tree_io.ads types.ads uintp.ads \
+ uintp.adb unchconv.ads unchdeal.ads
+
+uname.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \
+ debug.ads einfo.ads einfo.adb elists.ads fname.ads gnat.ads \
+ g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib.adb \
+ lib-list.adb lib-sort.adb namet.ads nlists.ads nlists.adb opt.ads \
+ output.ads sinfo.ads sinfo.adb sinput.ads sinput.adb snames.ads \
+ stand.ads stringt.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \
+ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \
+ table.ads table.adb tree_io.ads types.ads uintp.ads uintp.adb uname.ads \
+ uname.adb unchconv.ads unchdeal.ads urealp.ads
+
+urealp.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \
+ hostparm.ads opt.ads output.ads system.ads s-exctab.ads s-stalib.ads \
+ s-wchcon.ads table.ads table.adb tree_io.ads types.ads uintp.ads \
+ uintp.adb unchconv.ads unchdeal.ads urealp.ads urealp.adb
+
+usage.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \
+ hostparm.ads namet.ads opt.ads osint.ads output.ads system.ads \
+ s-exctab.ads s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads \
+ types.ads unchconv.ads unchdeal.ads usage.ads usage.adb
+
+validsw.o : hostparm.ads opt.ads system.ads s-exctab.ads s-stalib.ads \
+ s-wchcon.ads types.ads unchconv.ads unchdeal.ads validsw.ads \
+ validsw.adb
+
+widechar.o : ada.ads a-except.ads hostparm.ads interfac.ads opt.ads \
+ system.ads s-exctab.ads s-soflin.ads s-stache.ads s-stalib.ads \
+ s-stoele.ads s-wchcnv.ads s-wchcnv.adb s-wchcon.ads s-wchjis.ads \
+ types.ads unchconv.ads unchdeal.ads widechar.ads widechar.adb
+
+xr_tabls.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads a-finali.ads \
+ a-filico.ads a-ioexce.ads a-stream.ads a-string.ads a-strfix.ads \
+ a-strmap.ads a-strunb.ads a-tags.ads a-textio.ads gnat.ads g-dirope.ads \
+ g-io_aux.ads g-os_lib.ads hostparm.ads interfac.ads i-cstrea.ads \
+ osint.ads system.ads s-exctab.ads s-ficobl.ads s-finimp.ads \
+ s-finroo.ads s-imgint.ads s-parame.ads s-secsta.ads s-soflin.ads \
+ s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads \
+ s-sopco3.ads s-unstyp.ads types.ads unchconv.ads unchdeal.ads \
+ xr_tabls.ads xr_tabls.adb
+
+xref_lib.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads a-finali.ads \
+ a-filico.ads a-ioexce.ads a-stream.ads a-string.ads a-strfix.ads \
+ a-strmap.ads a-strunb.ads a-tags.ads a-textio.ads gnat.ads g-comlin.ads \
+ g-dirope.ads g-dyntab.ads g-dyntab.adb g-io_aux.ads g-os_lib.ads \
+ g-regexp.ads hostparm.ads interfac.ads i-cstrea.ads osint.ads \
+ output.ads system.ads s-exctab.ads s-ficobl.ads s-finimp.ads \
+ s-finroo.ads s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads s-sopco3.ads \
+ s-sopco4.ads s-sopco5.ads s-unstyp.ads s-valint.ads types.ads \
+ unchconv.ads unchdeal.ads xr_tabls.ads xref_lib.ads xref_lib.adb
+
+# end of regular dependencies
+
+#In GNU Make, ignore whether `stage*' exists.
+.PHONY: stage1 stage2 stage3 stage4 clean realclean TAGS bootstrap
+.PHONY: risky-stage1 risky-stage2 risky-stage3 risky-stage4
+
+force:
+
+# Gnatlbr is only used on VMS
+
+GNATLBR_RTL_C_OBJS = adaint.o argv.o cio.o cstreams.o exit.o final.o init.o \
+ raise.o sysdep.o tracebak.o
+GNATLBR_C_OBJS = $(GNATLBR_RTL_C_OBJS)
+
+../gnatlbr$(exeext):: sdefault.o $(GNATLBR_C_OBJS) \
+ $(EXTRA_GNATTOOLS_OBJS)
+ $(RM) $@
+../gnatlbr$(exeext):: force
+ $(GNATMAKE) -a --GCC="$(CC)" $(ALL_ADAFLAGS) $(ADA_INCLUDES) \
+ --GNATBIND="$(GNATBIND)" --GNATLINK="$(GNATLINK)" \
+ -nostdlib $(fsrcpfx)gnatlbr -o $@ \
+ -largs --GCC="$(CC) $(ALL_CFLAGS) $(LDFLAGS)" \
+ $(GNATLBR_C_OBJS) $(EXTRA_GNATTOOLS_OBJS)
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M A C H I N E _ C O D E --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+ with System.Machine_Code;
+ package Machine_Code renames System.Machine_Code;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M A K E --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.172 $
+-- --
+-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions; use Ada.Exceptions;
+with Ada.Command_Line; use Ada.Command_Line;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+with ALI; use ALI;
+with ALI.Util; use ALI.Util;
+with Csets;
+with Debug;
+with Fname; use Fname;
+with Fname.SF; use Fname.SF;
+with Fname.UF; use Fname.UF;
+with Gnatvsn; use Gnatvsn;
+with Hostparm; use Hostparm;
+with Makeusg;
+with MLib.Prj;
+with MLib.Tgt;
+with MLib.Utl;
+with Namet; use Namet;
+with Opt; use Opt;
+with Osint; use Osint;
+with Gnatvsn;
+with Output; use Output;
+with Prj; use Prj;
+with Prj.Com;
+with Prj.Env;
+with Prj.Ext;
+with Prj.Pars;
+with Prj.Util;
+with SFN_Scan;
+with Sinput.L;
+with Snames; use Snames;
+with Stringt; use Stringt;
+with Table;
+with Types; use Types;
+with Switch; use Switch;
+
+with System.WCh_Con; use System.WCh_Con;
+
+package body Make is
+
+ use ASCII;
+ -- Make control characters visible
+
+ Standard_Library_Package_Body_Name : constant String := "s-stalib.adb";
+ -- Every program depends on this package, that must then be checked,
+ -- especially when -f and -a are used.
+
+ -------------------------
+ -- Note on terminology --
+ -------------------------
+
+ -- In this program, we use the phrase "termination" of a file name to
+ -- refer to the suffix that appears after the unit name portion. Very
+ -- often this is simply the extension, but in some cases, the sequence
+ -- may be more complex, for example in main.1.ada, the termination in
+ -- this name is ".1.ada" and in main_.ada the termination is "_.ada".
+
+ -------------------------------------
+ -- Queue (Q) Manipulation Routines --
+ -------------------------------------
+
+ -- The Q is used in Compile_Sources below. Its implementation uses the
+ -- GNAT generic package Table (basically an extensible array). Q_Front
+ -- points to the first valid element in the Q, whereas Q.First is the first
+ -- element ever enqueued, while Q.Last - 1 is the last element in the Q.
+ --
+ -- +---+--------------+---+---+---+-----------+---+--------
+ -- Q | | ........ | | | | ....... | |
+ -- +---+--------------+---+---+---+-----------+---+--------
+ -- ^ ^ ^
+ -- Q.First Q_Front Q.Last - 1
+ --
+ -- The elements comprised between Q.First and Q_Front - 1 are the
+ -- elements that have been enqueued and then dequeued, while the
+ -- elements between Q_Front and Q.Last - 1 are the elements currently
+ -- in the Q. When the Q is intialized Q_Front = Q.First = Q.Last.
+ -- After Compile_Sources has terminated its execution, Q_Front = Q.Last
+ -- and the elements contained between Q.Front and Q.Last-1 are those that
+ -- were explored and thus marked by Compile_Sources. Whenever the Q is
+ -- reinitialized, the elements between Q.First and Q.Last - 1 are unmarked.
+
+ procedure Init_Q;
+ -- Must be called to (re)initialize the Q.
+
+ procedure Insert_Q
+ (Source_File : File_Name_Type;
+ Source_Unit : Unit_Name_Type := No_Name);
+ -- Inserts Source_File at the end of Q. Provide Source_Unit when
+ -- possible for external use (gnatdist).
+
+ function Empty_Q return Boolean;
+ -- Returns True if Q is empty.
+
+ procedure Extract_From_Q
+ (Source_File : out File_Name_Type;
+ Source_Unit : out Unit_Name_Type);
+ -- Extracts the first element from the Q.
+
+ procedure Insert_Project_Sources
+ (The_Project : Project_Id;
+ Into_Q : Boolean);
+ -- If Into_Q is True, insert all sources of the project file that are not
+ -- already marked into the Q. If Into_Q is False, call Osint.Add_File for
+ -- all sources of the project file.
+
+ First_Q_Initialization : Boolean := True;
+ -- Will be set to false after Init_Q has been called once.
+
+ Q_Front : Natural;
+ -- Points to the first valid element in the Q.
+
+ Unique_Compile : Boolean := False;
+
+ type Q_Record is record
+ File : File_Name_Type;
+ Unit : Unit_Name_Type;
+ end record;
+ -- File is the name of the file to compile. Unit is for gnatdist
+ -- use in order to easily get the unit name of a file to compile
+ -- when its name is krunched or declared in gnat.adc.
+
+ package Q is new Table.Table (
+ Table_Component_Type => Q_Record,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 0,
+ Table_Initial => 4000,
+ Table_Increment => 100,
+ Table_Name => "Make.Q");
+ -- This is the actual Q.
+
+ -- The following instantiations and variables are necessary to save what
+ -- is found on the command line, in case there is a project file specified.
+
+ package Saved_Gcc_Switches is new Table.Table (
+ Table_Component_Type => String_Access,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 20,
+ Table_Increment => 100,
+ Table_Name => "Make.Saved_Gcc_Switches");
+
+ package Saved_Binder_Switches is new Table.Table (
+ Table_Component_Type => String_Access,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 20,
+ Table_Increment => 100,
+ Table_Name => "Make.Saved_Binder_Switches");
+
+ package Saved_Linker_Switches is new Table.Table
+ (Table_Component_Type => String_Access,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 20,
+ Table_Increment => 100,
+ Table_Name => "Make.Saved_Linker_Switches");
+
+ package Saved_Make_Switches is new Table.Table
+ (Table_Component_Type => String_Access,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 20,
+ Table_Increment => 100,
+ Table_Name => "Make.Saved_Make_Switches");
+
+ Saved_Maximum_Processes : Natural := 0;
+ Saved_WC_Encoding_Method : WC_Encoding_Method := WC_Encoding_Method'First;
+ Saved_WC_Encoding_Method_Set : Boolean := False;
+
+ type Arg_List_Ref is access Argument_List;
+ The_Saved_Gcc_Switches : Arg_List_Ref;
+
+ Project_File_Name : String_Access := null;
+ Current_Verbosity : Prj.Verbosity := Prj.Default;
+ Main_Project : Prj.Project_Id := No_Project;
+
+ procedure Add_Source_Dir (N : String);
+ -- Call Add_Src_Search_Dir.
+ -- Output one line when in verbose mode.
+
+ procedure Add_Source_Directories is
+ new Prj.Env.For_All_Source_Dirs (Action => Add_Source_Dir);
+
+ procedure Add_Object_Dir (N : String);
+ -- Call Add_Lib_Search_Dir.
+ -- Output one line when in verbose mode.
+
+ procedure Add_Object_Directories is
+ new Prj.Env.For_All_Object_Dirs (Action => Add_Object_Dir);
+
+ type Bad_Compilation_Info is record
+ File : File_Name_Type;
+ Unit : Unit_Name_Type;
+ Found : Boolean;
+ end record;
+ -- File is the name of the file for which a compilation failed.
+ -- Unit is for gnatdist use in order to easily get the unit name
+ -- of a file when its name is krunched or declared in gnat.adc.
+ -- Found is False if the compilation failed because the file could
+ -- not be found.
+
+ package Bad_Compilation is new Table.Table (
+ Table_Component_Type => Bad_Compilation_Info,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 20,
+ Table_Increment => 100,
+ Table_Name => "Make.Bad_Compilation");
+ -- Full name of all the source files for which compilation fails.
+
+ type Special_Argument is record
+ File : String_Access;
+ Args : Argument_List_Access;
+ end record;
+ -- File is the name of the file for which a special set of compilation
+ -- arguments (Args) is required.
+
+ package Special_Args is new Table.Table (
+ Table_Component_Type => Special_Argument,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 20,
+ Table_Increment => 100,
+ Table_Name => "Make.Special_Args");
+ -- Compilation arguments of all the source files for which an entry has
+ -- been found in the project file.
+
+ Original_Ada_Include_Path : constant String_Access :=
+ Getenv ("ADA_INCLUDE_PATH");
+ Original_Ada_Objects_Path : constant String_Access :=
+ Getenv ("ADA_OBJECTS_PATH");
+ Current_Ada_Include_Path : String_Access := null;
+ Current_Ada_Objects_Path : String_Access := null;
+
+ Max_Line_Length : constant := 127;
+ -- Maximum number of characters per line, when displaying a path
+
+ ----------------------
+ -- Marking Routines --
+ ----------------------
+
+ procedure Mark (Source_File : File_Name_Type);
+ -- Mark Source_File. Marking is used to signal that Source_File has
+ -- already been inserted in the Q.
+
+ function Is_Marked (Source_File : File_Name_Type) return Boolean;
+ -- Returns True if Source_File was previously marked.
+
+ procedure Unmark (Source_File : File_Name_Type);
+ -- Unmarks Source_File.
+
+ -------------------
+ -- Misc Routines --
+ -------------------
+
+ procedure List_Depend;
+ -- Prints to standard output the list of object dependencies. This list
+ -- can be used directly in a Makefile. A call to Compile_Sources must
+ -- precede the call to List_Depend. Also because this routine uses the
+ -- ALI files that were originally loaded and scanned by Compile_Sources,
+ -- no additional ALI files should be scanned between the two calls (i.e.
+ -- between the call to Compile_Sources and List_Depend.)
+
+ procedure Inform (N : Name_Id := No_Name; Msg : String);
+ -- Prints out the program name followed by a colon, N and S.
+
+ procedure List_Bad_Compilations;
+ -- Prints out the list of all files for which the compilation failed.
+
+ procedure Verbose_Msg
+ (N1 : Name_Id;
+ S1 : String;
+ N2 : Name_Id := No_Name;
+ S2 : String := "";
+ Prefix : String := " -> ");
+ -- If the verbose flag (Verbose_Mode) is set then print Prefix to standard
+ -- output followed by N1 and S1. If N2 /= No_Name then N2 is then printed
+ -- after S1. S2 is printed last. Both N1 and N2 are printed in quotation
+ -- marks.
+
+ -----------------------
+ -- Gnatmake Routines --
+ -----------------------
+
+ subtype Lib_Mark_Type is Byte;
+
+ Ada_Lib_Dir : constant Lib_Mark_Type := 1;
+ GNAT_Lib_Dir : constant Lib_Mark_Type := 2;
+
+ -- Note that the notion of GNAT lib dir is no longer used. The code
+ -- related to it has not been removed to give an idea on how to use
+ -- the directory prefix marking mechanism.
+
+ -- An Ada library directory is a directory containing ali and object
+ -- files but no source files for the bodies (the specs can be in the
+ -- same or some other directory). These directories are specified
+ -- in the Gnatmake command line with the switch "-Adir" (to specify the
+ -- spec location -Idir cab be used). Gnatmake skips the missing sources
+ -- whose ali are in Ada library directories. For an explanation of why
+ -- Gnatmake behaves that way, see the spec of Make.Compile_Sources.
+ -- The directory lookup penalty is incurred every single time this
+ -- routine is called.
+
+ function Is_External_Assignment (Argv : String) return Boolean;
+ -- Verify that an external assignment switch is syntactically correct.
+ -- Correct forms are
+ -- -Xname=value
+ -- -X"name=other value"
+ -- Assumptions: 'First = 1, Argv (1 .. 2) = "-X"
+ -- When this function returns True, the external assignment has
+ -- been entered by a call to Prj.Ext.Add, so that in a project
+ -- file, External ("name") will return "value".
+
+ function In_Ada_Lib_Dir (File : File_Name_Type) return Boolean;
+ -- Get directory prefix of this file and get lib mark stored in name
+ -- table for this directory. Then check if an Ada lib mark has been set.
+
+ procedure Mark_Dir_Path
+ (Path : String_Access;
+ Mark : Lib_Mark_Type);
+ -- Invoke Mark_Directory on each directory of the path.
+
+ procedure Mark_Directory
+ (Dir : String;
+ Mark : Lib_Mark_Type);
+ -- Store Dir in name table and set lib mark as name info to identify
+ -- Ada libraries.
+
+ function Object_File_Name (Source : String) return String;
+ -- Returns the object file name suitable for switch -o.
+
+ procedure Set_Ada_Paths
+ (For_Project : Prj.Project_Id;
+ Including_Libraries : Boolean);
+ -- Set, if necessary, env. variables ADA_INCLUDE_PATH and
+ -- ADA_OBJECTS_PATH.
+ --
+ -- Note: this will modify these environment variables only
+ -- for the current gnatmake process and all of its children
+ -- (invocations of the compiler, the binder and the linker).
+ -- The caller process ADA_INCLUDE_PATH and ADA_OBJECTS_PATH are
+ -- not affected.
+
+ procedure Set_Library_For
+ (Project : Project_Id;
+ There_Are_Libraries : in out Boolean);
+ -- If Project is a library project, add the correct
+ -- -L and -l switches to the linker invocation.
+
+ procedure Set_Libraries is
+ new For_Every_Project_Imported (Boolean, Set_Library_For);
+ -- Add the -L and -l switches to the linker for all
+ -- of the library projects.
+
+ ----------------------------------------------------
+ -- Compiler, Binder & Linker Data and Subprograms --
+ ----------------------------------------------------
+
+ Gcc : String_Access := Program_Name ("gcc");
+ Gnatbind : String_Access := Program_Name ("gnatbind");
+ Gnatlink : String_Access := Program_Name ("gnatlink");
+ -- Default compiler, binder, linker programs
+
+ Saved_Gcc : String_Access := null;
+ Saved_Gnatbind : String_Access := null;
+ Saved_Gnatlink : String_Access := null;
+ -- Given by the command line. Will be used, if non null.
+
+ Gcc_Path : String_Access :=
+ GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all);
+ Gnatbind_Path : String_Access :=
+ GNAT.OS_Lib.Locate_Exec_On_Path (Gnatbind.all);
+ Gnatlink_Path : String_Access :=
+ GNAT.OS_Lib.Locate_Exec_On_Path (Gnatlink.all);
+ -- Path for compiler, binder, linker programs, defaulted now for gnatdist.
+ -- Changed later if overridden on command line.
+
+ Comp_Flag : constant String_Access := new String'("-c");
+ Output_Flag : constant String_Access := new String'("-o");
+ Ada_Flag_1 : constant String_Access := new String'("-x");
+ Ada_Flag_2 : constant String_Access := new String'("ada");
+ No_gnat_adc : constant String_Access := new String'("-gnatA");
+ GNAT_Flag : constant String_Access := new String'("-gnatpg");
+ Do_Not_Check_Flag : constant String_Access := new String'("-x");
+
+ Object_Suffix : constant String := Get_Object_Suffix.all;
+ Executable_Suffix : constant String := Get_Executable_Suffix.all;
+
+ Display_Executed_Programs : Boolean := True;
+ -- Set to True if name of commands should be output on stderr.
+
+ Output_File_Name_Seen : Boolean := False;
+ -- Set to True after having scanned the file_name for
+ -- switch "-o file_name"
+
+ File_Name_Seen : Boolean := False;
+ -- Set to true after having seen at least one file name.
+ -- Used in Scan_Make_Arg only, but must be a global variable.
+
+ type Make_Program_Type is (None, Compiler, Binder, Linker);
+
+ Program_Args : Make_Program_Type := None;
+ -- Used to indicate if we are scanning gcc, gnatbind, or gnatbl
+ -- options within the gnatmake command line.
+ -- Used in Scan_Make_Arg only, but must be a global variable.
+
+ procedure Add_Switches
+ (The_Package : Package_Id;
+ File_Name : String;
+ Program : Make_Program_Type);
+ procedure Add_Switch
+ (S : String_Access;
+ Program : Make_Program_Type;
+ Append_Switch : Boolean := True;
+ And_Save : Boolean := True);
+ procedure Add_Switch
+ (S : String;
+ Program : Make_Program_Type;
+ Append_Switch : Boolean := True;
+ And_Save : Boolean := True);
+ -- Make invokes one of three programs (the compiler, the binder or the
+ -- linker). For the sake of convenience, some program specific switches
+ -- can be passed directly on the gnatmake commande line. This procedure
+ -- records these switches so that gnamake can pass them to the right
+ -- program. S is the switch to be added at the end of the command line
+ -- for Program if Append_Switch is True. If Append_Switch is False S is
+ -- added at the beginning of the command line.
+
+ procedure Check
+ (Lib_File : File_Name_Type;
+ ALI : out ALI_Id;
+ O_File : out File_Name_Type;
+ O_Stamp : out Time_Stamp_Type);
+ -- Determines whether the library file Lib_File is up-to-date or not. The
+ -- full name (with path information) of the object file corresponding to
+ -- Lib_File is returned in O_File. Its time stamp is saved in O_Stamp.
+ -- ALI is the ALI_Id corresponding to Lib_File. If Lib_File in not
+ -- up-to-date, then the corresponding source file needs to be recompiled.
+ -- In this case ALI = No_ALI_Id.
+
+ procedure Check_Linker_Options
+ (E_Stamp : Time_Stamp_Type;
+ O_File : out File_Name_Type;
+ O_Stamp : out Time_Stamp_Type);
+ -- Checks all linker options for linker files that are newer
+ -- than E_Stamp. If such objects are found, the youngest object
+ -- is returned in O_File and its stamp in O_Stamp.
+ --
+ -- If no obsolete linker files were found, the first missing
+ -- linker file is returned in O_File and O_Stamp is empty.
+ -- Otherwise O_File is No_File.
+
+ procedure Display (Program : String; Args : Argument_List);
+ -- Displays Program followed by the arguments in Args if variable
+ -- Display_Executed_Programs is set. The lower bound of Args must be 1.
+
+ --------------------
+ -- Add_Object_Dir --
+ --------------------
+
+ procedure Add_Object_Dir (N : String) is
+ begin
+ Add_Lib_Search_Dir (N);
+
+ if Opt.Verbose_Mode then
+ Write_Str ("Adding object directory """);
+ Write_Str (N);
+ Write_Str (""".");
+ Write_Eol;
+ end if;
+ end Add_Object_Dir;
+
+ --------------------
+ -- Add_Source_Dir --
+ --------------------
+
+ procedure Add_Source_Dir (N : String) is
+ begin
+ Add_Src_Search_Dir (N);
+
+ if Opt.Verbose_Mode then
+ Write_Str ("Adding source directory """);
+ Write_Str (N);
+ Write_Str (""".");
+ Write_Eol;
+ end if;
+ end Add_Source_Dir;
+
+ ----------------
+ -- Add_Switch --
+ ----------------
+
+ procedure Add_Switch
+ (S : String_Access;
+ Program : Make_Program_Type;
+ Append_Switch : Boolean := True;
+ And_Save : Boolean := True)
+ is
+ generic
+ with package T is new Table.Table (<>);
+ function Generic_Position return Integer;
+ -- Generic procedure that adds S at the end or beginning of T depending
+ -- of the value of the boolean Append_Switch.
+
+ ----------------------
+ -- Generic_Position --
+ ----------------------
+
+ function Generic_Position return Integer is
+ begin
+ T.Increment_Last;
+
+ if Append_Switch then
+ return Integer (T.Last);
+ else
+ for J in reverse T.Table_Index_Type'Succ (T.First) .. T.Last loop
+ T.Table (J) := T.Table (T.Table_Index_Type'Pred (J));
+ end loop;
+
+ return Integer (T.First);
+ end if;
+ end Generic_Position;
+
+ function Gcc_Switches_Pos is new Generic_Position (Gcc_Switches);
+ function Binder_Switches_Pos is new Generic_Position (Binder_Switches);
+ function Linker_Switches_Pos is new Generic_Position (Linker_Switches);
+
+ function Saved_Gcc_Switches_Pos is new
+ Generic_Position (Saved_Gcc_Switches);
+
+ function Saved_Binder_Switches_Pos is new
+ Generic_Position (Saved_Binder_Switches);
+
+ function Saved_Linker_Switches_Pos is new
+ Generic_Position (Saved_Linker_Switches);
+
+ -- Start of processing for Add_Switch
+
+ begin
+ if And_Save then
+ case Program is
+ when Compiler =>
+ Saved_Gcc_Switches.Table (Saved_Gcc_Switches_Pos) := S;
+
+ when Binder =>
+ Saved_Binder_Switches.Table (Saved_Binder_Switches_Pos) := S;
+
+ when Linker =>
+ Saved_Linker_Switches.Table (Saved_Linker_Switches_Pos) := S;
+
+ when None =>
+ raise Program_Error;
+ end case;
+
+ else
+ case Program is
+ when Compiler =>
+ Gcc_Switches.Table (Gcc_Switches_Pos) := S;
+
+ when Binder =>
+ Binder_Switches.Table (Binder_Switches_Pos) := S;
+
+ when Linker =>
+ Linker_Switches.Table (Linker_Switches_Pos) := S;
+
+ when None =>
+ raise Program_Error;
+ end case;
+ end if;
+ end Add_Switch;
+
+ procedure Add_Switch
+ (S : String;
+ Program : Make_Program_Type;
+ Append_Switch : Boolean := True;
+ And_Save : Boolean := True)
+ is
+ begin
+ Add_Switch (S => new String'(S),
+ Program => Program,
+ Append_Switch => Append_Switch,
+ And_Save => And_Save);
+ end Add_Switch;
+
+ ------------------
+ -- Add_Switches --
+ ------------------
+
+ procedure Add_Switches
+ (The_Package : Package_Id;
+ File_Name : String;
+ Program : Make_Program_Type)
+ is
+ Switches : Variable_Value;
+ Switch_List : String_List_Id;
+ Element : String_Element;
+
+ begin
+ if File_Name'Length > 0 then
+ Name_Len := File_Name'Length;
+ Name_Buffer (1 .. Name_Len) := File_Name;
+ Switches :=
+ Prj.Util.Value_Of
+ (Name => Name_Find,
+ Attribute_Or_Array_Name => Name_Switches,
+ In_Package => The_Package);
+
+ case Switches.Kind is
+ when Undefined =>
+ null;
+
+ when List =>
+ Program_Args := Program;
+
+ Switch_List := Switches.Values;
+
+ while Switch_List /= Nil_String loop
+ Element := String_Elements.Table (Switch_List);
+ String_To_Name_Buffer (Element.Value);
+
+ if Name_Len > 0 then
+ if Opt.Verbose_Mode then
+ Write_Str (" Adding ");
+ Write_Line (Name_Buffer (1 .. Name_Len));
+ end if;
+
+ Scan_Make_Arg
+ (Name_Buffer (1 .. Name_Len),
+ And_Save => False);
+ end if;
+
+ Switch_List := Element.Next;
+ end loop;
+
+ when Single =>
+ Program_Args := Program;
+ String_To_Name_Buffer (Switches.Value);
+
+ if Name_Len > 0 then
+ if Opt.Verbose_Mode then
+ Write_Str (" Adding ");
+ Write_Line (Name_Buffer (1 .. Name_Len));
+ end if;
+
+ Scan_Make_Arg
+ (Name_Buffer (1 .. Name_Len), And_Save => False);
+ end if;
+ end case;
+ end if;
+ end Add_Switches;
+
+ ----------
+ -- Bind --
+ ----------
+
+ procedure Bind (ALI_File : File_Name_Type; Args : Argument_List) is
+ Bind_Args : Argument_List (1 .. Args'Last + 2);
+ Bind_Last : Integer;
+ Success : Boolean;
+
+ begin
+ pragma Assert (Args'First = 1);
+
+ -- Optimize the simple case where the gnatbind command line looks like
+ -- gnatbind -aO. -I- file.ali --into-> gnatbind file.adb
+
+ if Args'Length = 2
+ and then Args (Args'First).all = "-aO" & Normalized_CWD
+ and then Args (Args'Last).all = "-I-"
+ and then ALI_File = Strip_Directory (ALI_File)
+ then
+ Bind_Last := Args'First - 1;
+
+ else
+ Bind_Last := Args'Last;
+ Bind_Args (Args'Range) := Args;
+ end if;
+
+ -- It is completely pointless to re-check source file time stamps.
+ -- This has been done already by gnatmake
+
+ Bind_Last := Bind_Last + 1;
+ Bind_Args (Bind_Last) := Do_Not_Check_Flag;
+
+ Get_Name_String (ALI_File);
+
+ Bind_Last := Bind_Last + 1;
+ Bind_Args (Bind_Last) := new String'(Name_Buffer (1 .. Name_Len));
+
+ Display (Gnatbind.all, Bind_Args (Args'First .. Bind_Last));
+
+ if Gnatbind_Path = null then
+ Osint.Fail ("error, unable to locate " & Gnatbind.all);
+ end if;
+
+ GNAT.OS_Lib.Spawn
+ (Gnatbind_Path.all, Bind_Args (Args'First .. Bind_Last), Success);
+
+ if not Success then
+ raise Bind_Failed;
+ end if;
+ end Bind;
+
+ -----------
+ -- Check --
+ -----------
+
+ procedure Check
+ (Lib_File : File_Name_Type;
+ ALI : out ALI_Id;
+ O_File : out File_Name_Type;
+ O_Stamp : out Time_Stamp_Type)
+ is
+ function First_New_Spec (A : ALI_Id) return File_Name_Type;
+ -- Looks in the with table entries of A and returns the spec file name
+ -- of the first withed unit (subprogram) for which no spec existed when
+ -- A was generated but for which there exists one now, implying that A
+ -- is now obsolete. If no such unit is found No_File is returned.
+ -- Otherwise the spec file name of the unit is returned.
+ --
+ -- **WARNING** in the event of Uname format modifications, one *MUST*
+ -- make sure this function is also updated.
+ --
+ -- Note: This function should really be in ali.adb and use Uname
+ -- services, but this causes the whole compiler to be dragged along
+ -- for gnatbind and gnatmake.
+
+ --------------------
+ -- First_New_Spec --
+ --------------------
+
+ function First_New_Spec (A : ALI_Id) return File_Name_Type is
+ Spec_File_Name : File_Name_Type := No_File;
+
+ function New_Spec (Uname : Unit_Name_Type) return Boolean;
+ -- Uname is the name of the spec or body of some ada unit.
+ -- This function returns True if the Uname is the name of a body
+ -- which has a spec not mentioned inali file A. If True is returned
+ -- Spec_File_Name above is set to the name of this spec file.
+
+ --------------
+ -- New_Spec --
+ --------------
+
+ function New_Spec (Uname : Unit_Name_Type) return Boolean is
+ Spec_Name : Unit_Name_Type;
+ File_Name : File_Name_Type;
+
+ begin
+ -- Test whether Uname is the name of a body unit (ie ends with %b)
+
+ Get_Name_String (Uname);
+ pragma
+ Assert (Name_Len > 2 and then Name_Buffer (Name_Len - 1) = '%');
+
+ if Name_Buffer (Name_Len) /= 'b' then
+ return False;
+ end if;
+
+ -- Convert unit name into spec name
+
+ -- ??? this code seems dubious in presence of pragma
+ -- Source_File_Name since there is no more direct relationship
+ -- between unit name and file name.
+
+ -- ??? Further, what about alternative subunit naming
+
+ Name_Buffer (Name_Len) := 's';
+ Spec_Name := Name_Find;
+ File_Name := Get_File_Name (Spec_Name, Subunit => False);
+
+ -- Look if File_Name is mentioned in A's sdep list.
+ -- If not look if the file exists. If it does return True.
+
+ for D in
+ ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep
+ loop
+ if Sdep.Table (D).Sfile = File_Name then
+ return False;
+ end if;
+ end loop;
+
+ if Full_Source_Name (File_Name) /= No_File then
+ Spec_File_Name := File_Name;
+ return True;
+ end if;
+
+ return False;
+ end New_Spec;
+
+ -- Start of processing for First_New_Spec
+
+ begin
+ U_Chk : for U in
+ ALIs.Table (A).First_Unit .. ALIs.Table (A).Last_Unit
+ loop
+ exit U_Chk when Units.Table (U).Utype = Is_Body_Only
+ and then New_Spec (Units.Table (U).Uname);
+
+ for W in Units.Table (U).First_With
+ ..
+ Units.Table (U).Last_With
+ loop
+ exit U_Chk when
+ Withs.Table (W).Afile /= No_File
+ and then New_Spec (Withs.Table (W).Uname);
+ end loop;
+ end loop U_Chk;
+
+ return Spec_File_Name;
+ end First_New_Spec;
+
+ ---------------------------------
+ -- Data declarations for Check --
+ ---------------------------------
+
+ Full_Lib_File : File_Name_Type;
+ -- Full name of current library file
+
+ Full_Obj_File : File_Name_Type;
+ -- Full name of the object file corresponding to Lib_File.
+
+ Lib_Stamp : Time_Stamp_Type;
+ -- Time stamp of the current ada library file.
+
+ Obj_Stamp : Time_Stamp_Type;
+ -- Time stamp of the current object file.
+
+ Modified_Source : File_Name_Type;
+ -- The first source in Lib_File whose current time stamp differs
+ -- from that stored in Lib_File.
+
+ New_Spec : File_Name_Type;
+ -- If Lib_File contains in its W (with) section a body (for a
+ -- subprogram) for which there exists a spec and the spec did not
+ -- appear in the Sdep section of Lib_File, New_Spec contains the file
+ -- name of this new spec.
+
+ Source_Name : Name_Id;
+ Text : Text_Buffer_Ptr;
+
+ Prev_Switch : Character;
+ -- First character of previous switch processed
+
+ Arg : Arg_Id := Arg_Id'First;
+ -- Current index in Args.Table for a given unit (init to stop warning)
+
+ Switch_Found : Boolean;
+ -- True if a given switch has been found
+
+ Num_Args : Integer;
+ -- Number of compiler arguments processed
+
+ Special_Arg : Argument_List_Access;
+ -- Special arguments if any of a given compilation file
+
+ -- Start of processing for Check
+
+ begin
+ pragma Assert (Lib_File /= No_File);
+
+ Text := Read_Library_Info (Lib_File);
+ Full_Lib_File := Full_Library_Info_Name;
+ Full_Obj_File := Full_Object_File_Name;
+ Lib_Stamp := Current_Library_File_Stamp;
+ Obj_Stamp := Current_Object_File_Stamp;
+
+ if Full_Lib_File = No_File then
+ Verbose_Msg (Lib_File, "being checked ...", Prefix => " ");
+ else
+ Verbose_Msg (Full_Lib_File, "being checked ...", Prefix => " ");
+ end if;
+
+ ALI := No_ALI_Id;
+ O_File := Full_Obj_File;
+ O_Stamp := Obj_Stamp;
+
+ if Text = null then
+ if Full_Lib_File = No_File then
+ Verbose_Msg (Lib_File, "missing.");
+
+ elsif Obj_Stamp (Obj_Stamp'First) = ' ' then
+ Verbose_Msg (Full_Obj_File, "missing.");
+
+ else
+ Verbose_Msg
+ (Full_Lib_File, "(" & String (Lib_Stamp) & ") newer than",
+ Full_Obj_File, "(" & String (Obj_Stamp) & ")");
+ end if;
+
+ else
+ ALI := Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True);
+ Free (Text);
+
+ if ALI = No_ALI_Id then
+ Verbose_Msg (Full_Lib_File, "incorrectly formatted ALI file");
+ return;
+
+ elsif ALIs.Table (ALI).Ver (1 .. ALIs.Table (ALI).Ver_Len) /=
+ Library_Version
+ then
+ Verbose_Msg (Full_Lib_File, "compiled with old GNAT version");
+ ALI := No_ALI_Id;
+ return;
+ end if;
+
+ -- Don't take Ali file into account if it was generated without
+ -- object.
+
+ if Opt.Operating_Mode /= Opt.Check_Semantics
+ and then ALIs.Table (ALI).No_Object
+ then
+ Verbose_Msg (Full_Lib_File, "has no corresponding object");
+ ALI := No_ALI_Id;
+ return;
+ end if;
+
+ -- Check for matching compiler switches if needed
+
+ if Opt.Check_Switches then
+ Prev_Switch := ASCII.Nul;
+ Num_Args := 0;
+
+ Get_Name_String (ALIs.Table (ALI).Sfile);
+
+ for J in 1 .. Special_Args.Last loop
+ if Special_Args.Table (J).File.all =
+ Name_Buffer (1 .. Name_Len)
+ then
+ Special_Arg := Special_Args.Table (J).Args;
+ exit;
+ end if;
+ end loop;
+
+ if Main_Project /= No_Project then
+ null;
+ end if;
+
+ if Special_Arg = null then
+ for J in Gcc_Switches.First .. Gcc_Switches.Last loop
+
+ -- Skip non switches, -I and -o switches
+
+ if (Gcc_Switches.Table (J) (1) = '-'
+ or else
+ Gcc_Switches.Table (J) (1) = Switch_Character)
+ and then Gcc_Switches.Table (J) (2) /= 'o'
+ and then Gcc_Switches.Table (J) (2) /= 'I'
+ then
+ Num_Args := Num_Args + 1;
+
+ -- Comparing switches is delicate because gcc reorders
+ -- a number of switches, according to lang-specs.h, but
+ -- gnatmake doesn't have the sufficient knowledge to
+ -- perform the same reordering. Instead, we ignore orders
+ -- between different "first letter" switches, but keep
+ -- orders between same switches, e.g -O -O2 is different
+ -- than -O2 -O, but -g -O is equivalent to -O -g.
+
+ if Gcc_Switches.Table (J) (2) /= Prev_Switch then
+ Prev_Switch := Gcc_Switches.Table (J) (2);
+ Arg :=
+ Units.Table (ALIs.Table (ALI).First_Unit).First_Arg;
+ end if;
+
+ Switch_Found := False;
+
+ for K in Arg ..
+ Units.Table (ALIs.Table (ALI).First_Unit).Last_Arg
+ loop
+ if Gcc_Switches.Table (J).all = Args.Table (K).all then
+ Arg := K + 1;
+ Switch_Found := True;
+ exit;
+ end if;
+ end loop;
+
+ if not Switch_Found then
+ if Opt.Verbose_Mode then
+ Verbose_Msg (ALIs.Table (ALI).Sfile,
+ "switch mismatch");
+ end if;
+
+ ALI := No_ALI_Id;
+ return;
+ end if;
+ end if;
+ end loop;
+
+ else
+ for J in Special_Arg'Range loop
+
+ -- Skip non switches, -I and -o switches
+
+ if (Special_Arg (J) (1) = '-'
+ or else Special_Arg (J) (1) = Switch_Character)
+ and then Special_Arg (J) (2) /= 'o'
+ and then Special_Arg (J) (2) /= 'I'
+ then
+ Num_Args := Num_Args + 1;
+
+ if Special_Arg (J) (2) /= Prev_Switch then
+ Prev_Switch := Special_Arg (J) (2);
+ Arg :=
+ Units.Table (ALIs.Table (ALI).First_Unit).First_Arg;
+ end if;
+
+ Switch_Found := False;
+
+ for K in Arg ..
+ Units.Table (ALIs.Table (ALI).First_Unit).Last_Arg
+ loop
+ if Special_Arg (J).all = Args.Table (K).all then
+ Arg := K + 1;
+ Switch_Found := True;
+ exit;
+ end if;
+ end loop;
+
+ if not Switch_Found then
+ if Opt.Verbose_Mode then
+ Verbose_Msg (ALIs.Table (ALI).Sfile,
+ "switch mismatch");
+ end if;
+
+ ALI := No_ALI_Id;
+ return;
+ end if;
+ end if;
+ end loop;
+ end if;
+
+ if Num_Args /=
+ Integer (Units.Table (ALIs.Table (ALI).First_Unit).Last_Arg -
+ Units.Table (ALIs.Table (ALI).First_Unit).First_Arg + 1)
+ then
+ if Opt.Verbose_Mode then
+ Verbose_Msg (ALIs.Table (ALI).Sfile,
+ "different number of switches");
+ end if;
+
+ ALI := No_ALI_Id;
+ return;
+ end if;
+ end if;
+
+ -- Get the source files and their time stamps. Note that some
+ -- sources may be missing if ALI is out-of-date.
+
+ Set_Source_Table (ALI);
+
+ Modified_Source := Time_Stamp_Mismatch (ALI);
+
+ if Modified_Source /= No_File then
+ ALI := No_ALI_Id;
+
+ if Opt.Verbose_Mode then
+ Source_Name := Full_Source_Name (Modified_Source);
+
+ if Source_Name /= No_File then
+ Verbose_Msg (Source_Name, "time stamp mismatch");
+ else
+ Verbose_Msg (Modified_Source, "missing");
+ end if;
+ end if;
+
+ else
+ New_Spec := First_New_Spec (ALI);
+
+ if New_Spec /= No_File then
+ ALI := No_ALI_Id;
+
+ if Opt.Verbose_Mode then
+ Source_Name := Full_Source_Name (New_Spec);
+
+ if Source_Name /= No_File then
+ Verbose_Msg (Source_Name, "new spec");
+ else
+ Verbose_Msg (New_Spec, "old spec missing");
+ end if;
+ end if;
+ end if;
+ end if;
+ end if;
+ end Check;
+
+ --------------------------
+ -- Check_Linker_Options --
+ --------------------------
+
+ procedure Check_Linker_Options
+ (E_Stamp : Time_Stamp_Type;
+ O_File : out File_Name_Type;
+ O_Stamp : out Time_Stamp_Type)
+ is
+ procedure Check_File (File : File_Name_Type);
+ -- Update O_File and O_Stamp if the given file is younger than E_Stamp
+ -- and O_Stamp, or if O_File is No_File and File does not exist.
+
+ function Get_Library_File (Name : String) return File_Name_Type;
+ -- Return the full file name including path of a library based
+ -- on the name specified with the -l linker option, using the
+ -- Ada object path. Return No_File if no such file can be found.
+
+ type Char_Array is array (Natural) of Character;
+ type Char_Array_Access is access constant Char_Array;
+
+ Template : Char_Array_Access;
+ pragma Import (C, Template, "__gnat_library_template");
+
+ ----------------
+ -- Check_File --
+ ----------------
+
+ procedure Check_File (File : File_Name_Type) is
+ Stamp : Time_Stamp_Type;
+ Name : File_Name_Type := File;
+
+ begin
+ Get_Name_String (Name);
+
+ -- Remove any trailing NUL characters
+
+ while Name_Len >= Name_Buffer'First
+ and then Name_Buffer (Name_Len) = NUL
+ loop
+ Name_Len := Name_Len - 1;
+ end loop;
+
+ if Name_Len <= 0 then
+ return;
+
+ elsif Name_Buffer (1) = Get_Switch_Character
+ or else Name_Buffer (1) = '-'
+ then
+ -- Do not check if File is a switch other than "-l"
+
+ if Name_Buffer (2) /= 'l' then
+ return;
+ end if;
+
+ -- The argument is a library switch, get actual name. It
+ -- is necessary to make a copy of the relevant part of
+ -- Name_Buffer as Get_Library_Name uses Name_Buffer as well.
+
+ declare
+ Base_Name : constant String := Name_Buffer (3 .. Name_Len);
+
+ begin
+ Name := Get_Library_File (Base_Name);
+ end;
+
+ if Name = No_File then
+ return;
+ end if;
+ end if;
+
+ Stamp := File_Stamp (Name);
+
+ -- Find the youngest object file that is younger than the
+ -- executable. If no such file exist, record the first object
+ -- file that is not found.
+
+ if (O_Stamp < Stamp and then E_Stamp < Stamp)
+ or else (O_File = No_File and then Stamp (Stamp'First) = ' ')
+ then
+ O_Stamp := Stamp;
+ O_File := Name;
+
+ -- Strip the trailing NUL if present
+
+ Get_Name_String (O_File);
+
+ if Name_Buffer (Name_Len) = NUL then
+ Name_Len := Name_Len - 1;
+ O_File := Name_Find;
+ end if;
+ end if;
+ end Check_File;
+
+ ----------------------
+ -- Get_Library_Name --
+ ----------------------
+
+ -- See comments in a-adaint.c about template syntax
+
+ function Get_Library_File (Name : String) return File_Name_Type is
+ File : File_Name_Type := No_File;
+
+ begin
+ Name_Len := 0;
+
+ for Ptr in Template'Range loop
+ case Template (Ptr) is
+ when '*' =>
+ Add_Str_To_Name_Buffer (Name);
+
+ when ';' =>
+ File := Full_Lib_File_Name (Name_Find);
+ exit when File /= No_File;
+ Name_Len := 0;
+
+ when NUL =>
+ exit;
+
+ when others =>
+ Add_Char_To_Name_Buffer (Template (Ptr));
+ end case;
+ end loop;
+
+ -- The for loop exited because the end of the template
+ -- was reached. File contains the last possible file name
+ -- for the library.
+
+ if File = No_File and then Name_Len > 0 then
+ File := Full_Lib_File_Name (Name_Find);
+ end if;
+
+ return File;
+ end Get_Library_File;
+
+ -- Start of processing for Check_Linker_Options
+
+ begin
+ O_File := No_File;
+ O_Stamp := (others => ' ');
+
+ -- Process linker options from the ALI files.
+
+ for Opt in 1 .. Linker_Options.Last loop
+ Check_File (Linker_Options.Table (Opt).Name);
+ end loop;
+
+ -- Process options given on the command line.
+
+ for Opt in Linker_Switches.First .. Linker_Switches.Last loop
+
+ -- Check if the previous Opt has one of the two switches
+ -- that take an extra parameter. (See GCC manual.)
+
+ if Opt = Linker_Switches.First
+ or else (Linker_Switches.Table (Opt - 1).all /= "-u"
+ and then
+ Linker_Switches.Table (Opt - 1).all /= "-Xlinker")
+ then
+ Name_Len := 0;
+ Add_Str_To_Name_Buffer (Linker_Switches.Table (Opt).all);
+ Check_File (Name_Find);
+ end if;
+ end loop;
+
+ end Check_Linker_Options;
+
+ ---------------------
+ -- Compile_Sources --
+ ---------------------
+
+ procedure Compile_Sources
+ (Main_Source : File_Name_Type;
+ Args : Argument_List;
+ First_Compiled_File : out Name_Id;
+ Most_Recent_Obj_File : out Name_Id;
+ Most_Recent_Obj_Stamp : out Time_Stamp_Type;
+ Main_Unit : out Boolean;
+ Compilation_Failures : out Natural;
+ Check_Readonly_Files : Boolean := False;
+ Do_Not_Execute : Boolean := False;
+ Force_Compilations : Boolean := False;
+ Keep_Going : Boolean := False;
+ In_Place_Mode : Boolean := False;
+ Initialize_ALI_Data : Boolean := True;
+ Max_Process : Positive := 1)
+ is
+ function Compile
+ (S : Name_Id;
+ L : Name_Id;
+ Args : Argument_List)
+ return Process_Id;
+ -- Compiles S using Args. If S is a GNAT predefined source
+ -- "-gnatpg" is added to Args. Non blocking call. L corresponds to the
+ -- expected library file name. Process_Id of the process spawned to
+ -- execute the compile.
+
+ type Compilation_Data is record
+ Pid : Process_Id;
+ Full_Source_File : File_Name_Type;
+ Lib_File : File_Name_Type;
+ Source_Unit : Unit_Name_Type;
+ end record;
+
+ Running_Compile : array (1 .. Max_Process) of Compilation_Data;
+ -- Used to save information about outstanding compilations.
+
+ Outstanding_Compiles : Natural := 0;
+ -- Current number of outstanding compiles
+
+ Source_Unit : Unit_Name_Type;
+ -- Current source unit
+
+ Source_File : File_Name_Type;
+ -- Current source file
+
+ Full_Source_File : File_Name_Type;
+ -- Full name of the current source file
+
+ Lib_File : File_Name_Type;
+ -- Current library file
+
+ Full_Lib_File : File_Name_Type;
+ -- Full name of the current library file
+
+ Obj_File : File_Name_Type;
+ -- Full name of the object file corresponding to Lib_File.
+
+ Obj_Stamp : Time_Stamp_Type;
+ -- Time stamp of the current object file.
+
+ Sfile : File_Name_Type;
+ -- Contains the source file of the units withed by Source_File
+
+ ALI : ALI_Id;
+ -- ALI Id of the current ALI file
+
+ Compilation_OK : Boolean;
+ Need_To_Compile : Boolean;
+
+ Pid : Process_Id;
+ Text : Text_Buffer_Ptr;
+
+ Data : Prj.Project_Data;
+
+ Arg_Index : Natural;
+ -- Index in Special_Args.Table of a given compilation file
+
+ Need_To_Check_Standard_Library : Boolean := Check_Readonly_Files;
+
+ procedure Add_Process
+ (Pid : Process_Id;
+ Sfile : File_Name_Type;
+ Afile : File_Name_Type;
+ Uname : Unit_Name_Type);
+ -- Adds process Pid to the current list of outstanding compilation
+ -- processes and record the full name of the source file Sfile that
+ -- we are compiling, the name of its library file Afile and the
+ -- name of its unit Uname.
+
+ procedure Await_Compile
+ (Sfile : out File_Name_Type;
+ Afile : out File_Name_Type;
+ Uname : out Unit_Name_Type;
+ OK : out Boolean);
+ -- Awaits that an outstanding compilation process terminates. When
+ -- it does set Sfile to the name of the source file that was compiled
+ -- Afile to the name of its library file and Uname to the name of its
+ -- unit. Note that this time stamp can be used to check whether the
+ -- compilation did generate an object file. OK is set to True if the
+ -- compilation succeeded. Note that Sfile, Afile and Uname could be
+ -- resp. No_File, No_File and No_Name if there were no compilations
+ -- to wait for.
+
+ procedure Collect_Arguments_And_Compile;
+ -- Collect arguments from project file (if any) and compile
+
+ package Good_ALI is new Table.Table (
+ Table_Component_Type => ALI_Id,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 50,
+ Table_Increment => 100,
+ Table_Name => "Make.Good_ALI");
+ -- Contains the set of valid ALI files that have not yet been scanned.
+
+ procedure Record_Good_ALI (A : ALI_Id);
+ -- Records in the previous set the Id of an ALI file.
+
+ function Good_ALI_Present return Boolean;
+ -- Returns True if any ALI file was recorded in the previous set.
+
+ function Get_Next_Good_ALI return ALI_Id;
+ -- Returns the next good ALI_Id record;
+
+ procedure Record_Failure
+ (File : File_Name_Type;
+ Unit : Unit_Name_Type;
+ Found : Boolean := True);
+ -- Records in the previous table that the compilation for File failed.
+ -- If Found is False then the compilation of File failed because we
+ -- could not find it. Records also Unit when possible.
+
+ function Bad_Compilation_Count return Natural;
+ -- Returns the number of compilation failures.
+
+ procedure Debug_Msg (S : String; N : Name_Id);
+ -- If Debug.Debug_Flag_W is set outputs string S followed by name N.
+
+ function Configuration_Pragmas_Switch
+ (For_Project : Project_Id)
+ return Argument_List;
+ -- Return an argument list of one element, if there is a configuration
+ -- pragmas file to be specified for For_Project,
+ -- otherwise return an empty argument list.
+
+ -----------------
+ -- Add_Process --
+ -----------------
+
+ procedure Add_Process
+ (Pid : Process_Id;
+ Sfile : File_Name_Type;
+ Afile : File_Name_Type;
+ Uname : Unit_Name_Type)
+ is
+ OC1 : constant Positive := Outstanding_Compiles + 1;
+
+ begin
+ pragma Assert (OC1 <= Max_Process);
+ pragma Assert (Pid /= Invalid_Pid);
+
+ Running_Compile (OC1).Pid := Pid;
+ Running_Compile (OC1).Full_Source_File := Sfile;
+ Running_Compile (OC1).Lib_File := Afile;
+ Running_Compile (OC1).Source_Unit := Uname;
+
+ Outstanding_Compiles := OC1;
+ end Add_Process;
+
+ --------------------
+ -- Await_Compile --
+ -------------------
+
+ procedure Await_Compile
+ (Sfile : out File_Name_Type;
+ Afile : out File_Name_Type;
+ Uname : out File_Name_Type;
+ OK : out Boolean)
+ is
+ Pid : Process_Id;
+
+ begin
+ pragma Assert (Outstanding_Compiles > 0);
+
+ Sfile := No_File;
+ Afile := No_File;
+ Uname := No_Name;
+ OK := False;
+
+ Wait_Process (Pid, OK);
+
+ if Pid = Invalid_Pid then
+ return;
+ end if;
+
+ for J in Running_Compile'First .. Outstanding_Compiles loop
+ if Pid = Running_Compile (J).Pid then
+ Sfile := Running_Compile (J).Full_Source_File;
+ Afile := Running_Compile (J).Lib_File;
+ Uname := Running_Compile (J).Source_Unit;
+
+ -- To actually remove this Pid and related info from
+ -- Running_Compile replace its entry with the last valid
+ -- entry in Running_Compile.
+
+ if J = Outstanding_Compiles then
+ null;
+
+ else
+ Running_Compile (J) :=
+ Running_Compile (Outstanding_Compiles);
+ end if;
+
+ Outstanding_Compiles := Outstanding_Compiles - 1;
+ return;
+ end if;
+ end loop;
+
+ raise Program_Error;
+ end Await_Compile;
+
+ ---------------------------
+ -- Bad_Compilation_Count --
+ ---------------------------
+
+ function Bad_Compilation_Count return Natural is
+ begin
+ return Bad_Compilation.Last - Bad_Compilation.First + 1;
+ end Bad_Compilation_Count;
+
+ -----------------------------------
+ -- Collect_Arguments_And_Compile --
+ -----------------------------------
+
+ procedure Collect_Arguments_And_Compile is
+ begin
+ -- If no project file is used, then just call Compile with
+ -- the specified Args.
+
+ if Main_Project = No_Project then
+ Pid := Compile (Full_Source_File, Lib_File, Args);
+
+ -- A project file was used
+
+ else
+ -- First check if the current source is an immediate
+ -- source of a project file.
+
+ if Opt.Verbose_Mode then
+ Write_Eol;
+ Write_Line ("Establishing Project context.");
+ end if;
+
+ declare
+ Source_File_Name : constant String :=
+ Name_Buffer (1 .. Name_Len);
+ Current_Project : Prj.Project_Id;
+ Path_Name : File_Name_Type := Source_File;
+ Compiler_Package : Prj.Package_Id;
+ Switches : Prj.Variable_Value;
+ Object_File : String_Access;
+
+ begin
+ if Opt.Verbose_Mode then
+ Write_Str ("Checking if the Project File exists for """);
+ Write_Str (Source_File_Name);
+ Write_Line (""".");
+ end if;
+
+ Prj.Env.
+ Get_Reference
+ (Source_File_Name => Source_File_Name,
+ Project => Current_Project,
+ Path => Path_Name);
+
+ if Current_Project = No_Project then
+
+ -- The current source is not an immediate source of any
+ -- project file. Call Compile with the specified Args plus
+ -- the saved gcc switches.
+
+ if Opt.Verbose_Mode then
+ Write_Str ("No Project File.");
+ Write_Eol;
+ end if;
+
+ Pid := Compile
+ (Full_Source_File,
+ Lib_File,
+ Args & The_Saved_Gcc_Switches.all);
+
+ -- We now know the project of the current source
+
+ else
+ -- Set ADA_INCLUDE_PATH and ADA_OBJECTS_PATH if the project
+ -- has changed.
+
+ -- Note: this will modify these environment variables only
+ -- for the current gnatmake process and all of its children
+ -- (invocations of the compiler, the binder and the linker).
+
+ -- The caller's ADA_INCLUDE_PATH and ADA_OBJECTS_PATH are
+ -- not affected.
+
+ Set_Ada_Paths (Current_Project, True);
+
+ Data := Projects.Table (Current_Project);
+
+ -- Check if it is a library project that needs to be
+ -- processed, only if it is not the main project.
+
+ if MLib.Tgt.Libraries_Are_Supported
+ and then Current_Project /= Main_Project
+ and then Data.Library
+ and then not Data.Flag1
+ then
+ -- Add to the Q all sources of the project that have
+ -- not been marked
+
+ Insert_Project_Sources
+ (The_Project => Current_Project, Into_Q => True);
+
+ -- Now mark the project as processed
+
+ Data.Flag1 := True;
+ Projects.Table (Current_Project).Flag1 := True;
+ end if;
+
+ Get_Name_String (Data.Object_Directory);
+
+ if Name_Buffer (Name_Len) = '/'
+ or else Name_Buffer (Name_Len) = Directory_Separator
+ then
+ Object_File :=
+ new String'
+ (Name_Buffer (1 .. Name_Len) &
+ Object_File_Name (Source_File_Name));
+
+ else
+ Object_File :=
+ new String'
+ (Name_Buffer (1 .. Name_Len) &
+ Directory_Separator &
+ Object_File_Name (Source_File_Name));
+ end if;
+
+ if Opt.Verbose_Mode then
+ Write_Str ("Project file is """);
+ Write_Str (Get_Name_String (Data.Name));
+ Write_Str (""".");
+ Write_Eol;
+ end if;
+
+ -- We know look for package Compiler
+ -- and get the switches from this package.
+
+ if Opt.Verbose_Mode then
+ Write_Str ("Checking package Compiler.");
+ Write_Eol;
+ end if;
+
+ Compiler_Package :=
+ Prj.Util.Value_Of
+ (Name => Name_Compiler,
+ In_Packages => Data.Decl.Packages);
+
+ if Compiler_Package /= No_Package then
+
+ if Opt.Verbose_Mode then
+ Write_Str ("Getting the switches.");
+ Write_Eol;
+ end if;
+
+ -- If package Gnatmake.Compiler exists, we get
+ -- the specific switches for the current source,
+ -- or the global switches, if any.
+
+ Switches :=
+ Prj.Util.Value_Of
+ (Name => Source_File,
+ Attribute_Or_Array_Name => Name_Switches,
+ In_Package => Compiler_Package);
+ end if;
+
+ case Switches.Kind is
+
+ -- We have a list of switches. We add to Args
+ -- these switches, plus the saved gcc switches.
+
+ when List =>
+
+ declare
+ Current : String_List_Id := Switches.Values;
+ Element : String_Element;
+ Number : Natural := 0;
+
+ begin
+ while Current /= Nil_String loop
+ Element := String_Elements.Table (Current);
+ Number := Number + 1;
+ Current := Element.Next;
+ end loop;
+
+ declare
+ New_Args : Argument_List (1 .. Number);
+
+ begin
+ Current := Switches.Values;
+
+ for Index in New_Args'Range loop
+ Element := String_Elements.Table (Current);
+ String_To_Name_Buffer (Element.Value);
+ New_Args (Index) :=
+ new String' (Name_Buffer (1 .. Name_Len));
+ Current := Element.Next;
+ end loop;
+
+ Pid := Compile
+ (Path_Name,
+ Lib_File,
+ Args & Output_Flag & Object_File &
+ Configuration_Pragmas_Switch
+ (Current_Project) &
+ New_Args & The_Saved_Gcc_Switches.all);
+ end;
+ end;
+
+ -- We have a single switch. We add to Args
+ -- this switch, plus the saved gcc switches.
+
+ when Single =>
+
+ String_To_Name_Buffer (Switches.Value);
+ declare
+ New_Args : constant Argument_List :=
+ (1 => new String'
+ (Name_Buffer (1 .. Name_Len)));
+
+ begin
+ Pid := Compile
+ (Path_Name,
+ Lib_File,
+ Args &
+ Output_Flag &
+ Object_File &
+ New_Args &
+ Configuration_Pragmas_Switch (Current_Project) &
+ The_Saved_Gcc_Switches.all);
+ end;
+
+ -- We have no switches from Gnatmake.Compiler.
+ -- We add to Args the saved gcc switches.
+
+ when Undefined =>
+ if Opt.Verbose_Mode then
+ Write_Str ("There are no switches.");
+ Write_Eol;
+ end if;
+
+ Pid := Compile
+ (Path_Name,
+ Lib_File,
+ Args & Output_Flag & Object_File &
+ Configuration_Pragmas_Switch (Current_Project) &
+ The_Saved_Gcc_Switches.all);
+ end case;
+ end if;
+ end;
+ end if;
+ end Collect_Arguments_And_Compile;
+
+ -------------
+ -- Compile --
+ -------------
+
+ function Compile (S : Name_Id; L : Name_Id; Args : Argument_List)
+ return Process_Id
+ is
+ Comp_Args : Argument_List (Args'First .. Args'Last + 7);
+ Comp_Next : Integer := Args'First;
+ Comp_Last : Integer;
+
+ function Ada_File_Name (Name : Name_Id) return Boolean;
+ -- Returns True if Name is the name of an ada source file
+ -- (i.e. suffix is .ads or .adb)
+
+ -------------------
+ -- Ada_File_Name --
+ -------------------
+
+ function Ada_File_Name (Name : Name_Id) return Boolean is
+ begin
+ Get_Name_String (Name);
+ return
+ Name_Len > 4
+ and then Name_Buffer (Name_Len - 3 .. Name_Len - 1) = ".ad"
+ and then (Name_Buffer (Name_Len) = 'b'
+ or else
+ Name_Buffer (Name_Len) = 's');
+ end Ada_File_Name;
+
+ -- Start of processing for Compile
+
+ begin
+ Comp_Args (Comp_Next) := Comp_Flag;
+ Comp_Next := Comp_Next + 1;
+
+ -- Optimize the simple case where the gcc command line looks like
+ -- gcc -c -I. ... -I- file.adb --into-> gcc -c ... file.adb
+
+ if Args (Args'First).all = "-I" & Normalized_CWD
+ and then Args (Args'Last).all = "-I-"
+ and then S = Strip_Directory (S)
+ then
+ Comp_Last := Comp_Next + Args'Length - 3;
+ Comp_Args (Comp_Next .. Comp_Last) :=
+ Args (Args'First + 1 .. Args'Last - 1);
+
+ else
+ Comp_Last := Comp_Next + Args'Length - 1;
+ Comp_Args (Comp_Next .. Comp_Last) := Args;
+ end if;
+
+ -- Set -gnatpg for predefined files (for this purpose the renamings
+ -- such as Text_IO do not count as predefined). Note that we strip
+ -- the directory name from the source file name becase the call to
+ -- Fname.Is_Predefined_File_Name cannot deal with directory prefixes.
+
+ declare
+ Fname : constant File_Name_Type := Strip_Directory (S);
+
+ begin
+ if Is_Predefined_File_Name (Fname, False) then
+ if Check_Readonly_Files then
+ Comp_Last := Comp_Last + 1;
+ Comp_Args (Comp_Last) := GNAT_Flag;
+
+ else
+ Fail
+ ("not allowed to compile """ &
+ Get_Name_String (Fname) &
+ """; use -a switch.");
+ end if;
+ end if;
+ end;
+
+ -- Now check if the file name has one of the suffixes familiar to
+ -- the gcc driver. If this is not the case then add the ada flag
+ -- "-x ada".
+
+ if not Ada_File_Name (S) then
+ Comp_Last := Comp_Last + 1;
+ Comp_Args (Comp_Last) := Ada_Flag_1;
+ Comp_Last := Comp_Last + 1;
+ Comp_Args (Comp_Last) := Ada_Flag_2;
+ end if;
+
+ if L /= Strip_Directory (L) then
+
+ -- Build -o argument.
+
+ Get_Name_String (L);
+
+ for J in reverse 1 .. Name_Len loop
+ if Name_Buffer (J) = '.' then
+ Name_Len := J + Object_Suffix'Length - 1;
+ Name_Buffer (J .. Name_Len) := Object_Suffix;
+ exit;
+ end if;
+ end loop;
+
+ Comp_Last := Comp_Last + 1;
+ Comp_Args (Comp_Last) := Output_Flag;
+ Comp_Last := Comp_Last + 1;
+ Comp_Args (Comp_Last) := new String'(Name_Buffer (1 .. Name_Len));
+ end if;
+
+ Get_Name_String (S);
+
+ Comp_Last := Comp_Last + 1;
+ Comp_Args (Comp_Last) := new String'(Name_Buffer (1 .. Name_Len));
+
+ Display (Gcc.all, Comp_Args (Args'First .. Comp_Last));
+
+ if Gcc_Path = null then
+ Osint.Fail ("error, unable to locate " & Gcc.all);
+ end if;
+
+ return
+ GNAT.OS_Lib.Non_Blocking_Spawn
+ (Gcc_Path.all, Comp_Args (Args'First .. Comp_Last));
+ end Compile;
+
+ ----------------------------------
+ -- Configuration_Pragmas_Switch --
+ ----------------------------------
+
+ function Configuration_Pragmas_Switch
+ (For_Project : Project_Id)
+ return Argument_List
+ is
+ begin
+ Prj.Env.Create_Config_Pragmas_File (For_Project, Main_Project);
+
+ if Projects.Table (For_Project).Config_File_Name /= No_Name then
+ return
+ (1 => new String'("-gnatec" &
+ Get_Name_String
+ (Projects.Table (For_Project).Config_File_Name)));
+
+ else
+ return (1 .. 0 => null);
+ end if;
+ end Configuration_Pragmas_Switch;
+
+ ---------------
+ -- Debug_Msg --
+ ---------------
+
+ procedure Debug_Msg (S : String; N : Name_Id) is
+ begin
+ if Debug.Debug_Flag_W then
+ Write_Str (" ... ");
+ Write_Str (S);
+ Write_Str (" ");
+ Write_Name (N);
+ Write_Eol;
+ end if;
+ end Debug_Msg;
+
+ -----------------------
+ -- Get_Next_Good_ALI --
+ -----------------------
+
+ function Get_Next_Good_ALI return ALI_Id is
+ ALI : ALI_Id;
+
+ begin
+ pragma Assert (Good_ALI_Present);
+ ALI := Good_ALI.Table (Good_ALI.Last);
+ Good_ALI.Decrement_Last;
+ return ALI;
+ end Get_Next_Good_ALI;
+
+ ----------------------
+ -- Good_ALI_Present --
+ ----------------------
+
+ function Good_ALI_Present return Boolean is
+ begin
+ return Good_ALI.First <= Good_ALI.Last;
+ end Good_ALI_Present;
+
+ --------------------
+ -- Record_Failure --
+ --------------------
+
+ procedure Record_Failure
+ (File : File_Name_Type;
+ Unit : Unit_Name_Type;
+ Found : Boolean := True)
+ is
+ begin
+ Bad_Compilation.Increment_Last;
+ Bad_Compilation.Table (Bad_Compilation.Last) := (File, Unit, Found);
+ end Record_Failure;
+
+ ---------------------
+ -- Record_Good_ALI --
+ ---------------------
+
+ procedure Record_Good_ALI (A : ALI_Id) is
+ begin
+ Good_ALI.Increment_Last;
+ Good_ALI.Table (Good_ALI.Last) := A;
+ end Record_Good_ALI;
+
+ -- Start of processing for Compile_Sources
+
+ begin
+ pragma Assert (Args'First = 1);
+
+ -- Package and Queue initializations.
+
+ Good_ALI.Init;
+ Bad_Compilation.Init;
+ Output.Set_Standard_Error;
+ Init_Q;
+
+ if Initialize_ALI_Data then
+ Initialize_ALI;
+ Initialize_ALI_Source;
+ end if;
+
+ -- The following two flags affect the behavior of ALI.Set_Source_Table.
+ -- We set Opt.Check_Source_Files to True to ensure that source file
+ -- time stamps are checked, and we set Opt.All_Sources to False to
+ -- avoid checking the presence of the source files listed in the
+ -- source dependency section of an ali file (which would be a mistake
+ -- since the ali file may be obsolete).
+
+ Opt.Check_Source_Files := True;
+ Opt.All_Sources := False;
+
+ -- If the main source is marked, there is nothing to compile.
+ -- This can happen when we have several main subprograms.
+ -- For the first main, we always insert in the Q.
+
+ if not Is_Marked (Main_Source) then
+ Insert_Q (Main_Source);
+ Mark (Main_Source);
+ end if;
+
+ First_Compiled_File := No_File;
+ Most_Recent_Obj_File := No_File;
+ Main_Unit := False;
+
+ -- Keep looping until there is no more work to do (the Q is empty)
+ -- and all the outstanding compilations have terminated
+
+ Make_Loop : while not Empty_Q or else Outstanding_Compiles > 0 loop
+
+ -- If the user does not want to keep going in case of errors then
+ -- wait for the remaining outstanding compiles and then exit.
+
+ if Bad_Compilation_Count > 0 and then not Keep_Going then
+ while Outstanding_Compiles > 0 loop
+ Await_Compile
+ (Full_Source_File, Lib_File, Source_Unit, Compilation_OK);
+
+ if not Compilation_OK then
+ Record_Failure (Full_Source_File, Source_Unit);
+ end if;
+ end loop;
+
+ exit Make_Loop;
+ end if;
+
+ -- PHASE 1: Check if there is more work that we can do (ie the Q
+ -- is non empty). If there is, do it only if we have not yet used
+ -- up all the available processes.
+
+ if not Empty_Q and then Outstanding_Compiles < Max_Process then
+ Extract_From_Q (Source_File, Source_Unit);
+ Full_Source_File := Osint.Full_Source_Name (Source_File);
+ Lib_File := Osint.Lib_File_Name (Source_File);
+ Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File);
+
+ -- If the library file is an Ada library skip it
+
+ if Full_Lib_File /= No_File
+ and then In_Ada_Lib_Dir (Full_Lib_File)
+ then
+ Verbose_Msg (Lib_File, "is in an Ada library", Prefix => " ");
+
+ -- If the library file is a read-only library skip it
+
+ elsif Full_Lib_File /= No_File
+ and then not Check_Readonly_Files
+ and then Is_Readonly_Library (Full_Lib_File)
+ then
+ Verbose_Msg
+ (Lib_File, "is a read-only library", Prefix => " ");
+
+ -- The source file that we are checking cannot be located
+
+ elsif Full_Source_File = No_File then
+ Record_Failure (Source_File, Source_Unit, False);
+
+ -- Source and library files can be located but are internal
+ -- files
+
+ elsif not Check_Readonly_Files
+ and then Full_Lib_File /= No_File
+ and then Is_Internal_File_Name (Source_File)
+ then
+
+ if Force_Compilations then
+ Fail
+ ("not allowed to compile """ &
+ Get_Name_String (Source_File) &
+ """; use -a switch.");
+ end if;
+
+ Verbose_Msg
+ (Lib_File, "is an internal library", Prefix => " ");
+
+ -- The source file that we are checking can be located
+
+ else
+ -- Don't waste any time if we have to recompile anyway
+
+ Obj_Stamp := Empty_Time_Stamp;
+ Need_To_Compile := Force_Compilations;
+
+ if not Force_Compilations then
+ Check (Lib_File, ALI, Obj_File, Obj_Stamp);
+ Need_To_Compile := (ALI = No_ALI_Id);
+ end if;
+
+ if not Need_To_Compile then
+
+ -- The ALI file is up-to-date. Record its Id.
+
+ Record_Good_ALI (ALI);
+
+ -- Record the time stamp of the most recent object file
+ -- as long as no (re)compilations are needed.
+
+ if First_Compiled_File = No_File
+ and then (Most_Recent_Obj_File = No_File
+ or else Obj_Stamp > Most_Recent_Obj_Stamp)
+ then
+ Most_Recent_Obj_File := Obj_File;
+ Most_Recent_Obj_Stamp := Obj_Stamp;
+ end if;
+
+ else
+ -- Is this the first file we have to compile?
+
+ if First_Compiled_File = No_File then
+ First_Compiled_File := Full_Source_File;
+ Most_Recent_Obj_File := No_File;
+
+ if Do_Not_Execute then
+ exit Make_Loop;
+ end if;
+ end if;
+
+ if In_Place_Mode then
+
+ -- If the library file was not found, then save the
+ -- library file near the source file.
+
+ if Full_Lib_File = No_File then
+ Get_Name_String (Full_Source_File);
+
+ for J in reverse 1 .. Name_Len loop
+ if Name_Buffer (J) = '.' then
+ Name_Buffer (J + 1 .. J + 3) := "ali";
+ Name_Len := J + 3;
+ exit;
+ end if;
+ end loop;
+
+ Lib_File := Name_Find;
+
+ -- If the library file was found, then save the
+ -- library file in the same place.
+
+ else
+ Lib_File := Full_Lib_File;
+ end if;
+
+ end if;
+
+ -- Check for special compilation flags
+
+ Arg_Index := 0;
+ Get_Name_String (Source_File);
+
+ -- Start the compilation and record it. We can do this
+ -- because there is at least one free process.
+
+ Collect_Arguments_And_Compile;
+
+ -- Make sure we could successfully start the compilation
+
+ if Pid = Invalid_Pid then
+ Record_Failure (Full_Source_File, Source_Unit);
+ else
+ Add_Process
+ (Pid, Full_Source_File, Lib_File, Source_Unit);
+ end if;
+ end if;
+ end if;
+ end if;
+
+ -- PHASE 2: Now check if we should wait for a compilation to
+ -- finish. This is the case if all the available processes are
+ -- busy compiling sources or there is nothing else to do
+ -- (that is the Q is empty and there are no good ALIs to process).
+
+ if Outstanding_Compiles = Max_Process
+ or else (Empty_Q
+ and then not Good_ALI_Present
+ and then Outstanding_Compiles > 0)
+ then
+ Await_Compile
+ (Full_Source_File, Lib_File, Source_Unit, Compilation_OK);
+
+ if not Compilation_OK then
+ Record_Failure (Full_Source_File, Source_Unit);
+
+ else
+ -- Re-read the updated library file
+
+ Text := Read_Library_Info (Lib_File);
+
+ -- If no ALI file was generated by this compilation nothing
+ -- more to do, otherwise scan the ali file and record it.
+ -- If the scan fails, a previous ali file is inconsistent with
+ -- the unit just compiled.
+
+ if Text /= null then
+ ALI :=
+ Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True);
+
+ if ALI = No_ALI_Id then
+ Inform
+ (Lib_File, "incompatible ALI file, please recompile");
+ Record_Failure (Full_Source_File, Source_Unit);
+ else
+ Free (Text);
+ Record_Good_ALI (ALI);
+ end if;
+
+ -- If we could not read the ALI file that was just generated
+ -- then there could be a problem reading either the ALI or the
+ -- corresponding object file (if Opt.Check_Object_Consistency
+ -- is set Read_Library_Info checks that the time stamp of the
+ -- object file is more recent than that of the ALI). For an
+ -- example of problems caught by this test see [6625-009].
+
+ else
+ Inform
+ (Lib_File,
+ "WARNING: ALI or object file not found after compile");
+ Record_Failure (Full_Source_File, Source_Unit);
+ end if;
+ end if;
+ end if;
+
+ exit Make_Loop when Unique_Compile;
+
+ -- PHASE 3: Check if we recorded good ALI files. If yes process
+ -- them now in the order in which they have been recorded. There
+ -- are two occasions in which we record good ali files. The first is
+ -- in phase 1 when, after scanning an existing ALI file we realise
+ -- it is up-to-date, the second instance is after a successful
+ -- compilation.
+
+ while Good_ALI_Present loop
+ ALI := Get_Next_Good_ALI;
+
+ -- If we are processing the library file corresponding to the
+ -- main source file check if this source can be a main unit.
+
+ if ALIs.Table (ALI).Sfile = Main_Source then
+ Main_Unit := ALIs.Table (ALI).Main_Program /= None;
+ end if;
+
+ -- The following adds the standard library (s-stalib) to the
+ -- list of files to be handled by gnatmake: this file and any
+ -- files it depends on are always included in every bind,
+ -- except in No_Run_Time mode, even if they are not
+ -- in the explicit dependency list.
+
+ -- However, to avoid annoying output about s-stalib.ali being
+ -- read only, when "-v" is used, we add the standard library
+ -- only when "-a" is used.
+
+ if Need_To_Check_Standard_Library then
+ Need_To_Check_Standard_Library := False;
+
+ if not ALIs.Table (ALI).No_Run_Time then
+ declare
+ Sfile : Name_Id;
+
+ begin
+ Name_Len := Standard_Library_Package_Body_Name'Length;
+ Name_Buffer (1 .. Name_Len) :=
+ Standard_Library_Package_Body_Name;
+ Sfile := Name_Enter;
+
+ if not Is_Marked (Sfile) then
+ Insert_Q (Sfile);
+ Mark (Sfile);
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- Now insert in the Q the unmarked source files (i.e. those
+ -- which have neever been inserted in the Q and hence never
+ -- considered).
+
+ for J in
+ ALIs.Table (ALI).First_Unit .. ALIs.Table (ALI).Last_Unit
+ loop
+ for K in
+ Units.Table (J).First_With .. Units.Table (J).Last_With
+ loop
+ Sfile := Withs.Table (K).Sfile;
+
+ if Sfile = No_File then
+ Debug_Msg ("Skipping generic:", Withs.Table (K).Uname);
+
+ elsif Is_Marked (Sfile) then
+ Debug_Msg ("Skipping marked file:", Sfile);
+
+ elsif not Check_Readonly_Files
+ and then Is_Internal_File_Name (Sfile)
+ then
+ Debug_Msg ("Skipping internal file:", Sfile);
+
+ else
+ Insert_Q (Sfile, Withs.Table (K).Uname);
+ Mark (Sfile);
+ end if;
+ end loop;
+ end loop;
+ end loop;
+
+ if Opt.Display_Compilation_Progress then
+ Write_Str ("completed ");
+ Write_Int (Int (Q_Front));
+ Write_Str (" out of ");
+ Write_Int (Int (Q.Last));
+ Write_Str (" (");
+ Write_Int (Int ((Q_Front * 100) / (Q.Last - Q.First)));
+ Write_Str ("%)...");
+ Write_Eol;
+ end if;
+ end loop Make_Loop;
+
+ Compilation_Failures := Bad_Compilation_Count;
+
+ -- Compilation is finished
+
+ -- Delete any temporary configuration pragma file
+
+ if Main_Project /= No_Project then
+ declare
+ Success : Boolean;
+
+ begin
+ for Project in 1 .. Projects.Last loop
+ if Projects.Table (Project).Config_File_Temp then
+ if Opt.Verbose_Mode then
+ Write_Str ("Deleting temp configuration file """);
+ Write_Str (Get_Name_String
+ (Projects.Table (Project).Config_File_Name));
+ Write_Line ("""");
+ end if;
+
+ Delete_File
+ (Name => Get_Name_String
+ (Projects.Table (Project).Config_File_Name),
+ Success => Success);
+
+ -- Make sure that we don't have a config file for this
+ -- project, in case when there are several mains.
+ -- In this case, we will recreate another config file:
+ -- we cannot reuse the one that we just deleted!
+
+ Projects.Table (Project).Config_Checked := False;
+ Projects.Table (Project).Config_File_Name := No_Name;
+ Projects.Table (Project).Config_File_Temp := False;
+ end if;
+ end loop;
+ end;
+ end if;
+
+ end Compile_Sources;
+
+ -------------
+ -- Display --
+ -------------
+
+ procedure Display (Program : String; Args : Argument_List) is
+ begin
+ pragma Assert (Args'First = 1);
+
+ if Display_Executed_Programs then
+ Write_Str (Program);
+
+ for J in Args'Range loop
+ Write_Str (" ");
+ Write_Str (Args (J).all);
+ end loop;
+
+ Write_Eol;
+ end if;
+ end Display;
+
+ ----------------------
+ -- Display_Commands --
+ ----------------------
+
+ procedure Display_Commands (Display : Boolean := True) is
+ begin
+ Display_Executed_Programs := Display;
+ end Display_Commands;
+
+ -------------
+ -- Empty_Q --
+ -------------
+
+ function Empty_Q return Boolean is
+ begin
+ if Debug.Debug_Flag_P then
+ Write_Str (" Q := [");
+
+ for J in Q_Front .. Q.Last - 1 loop
+ Write_Str (" ");
+ Write_Name (Q.Table (J).File);
+ Write_Eol;
+ Write_Str (" ");
+ end loop;
+
+ Write_Str ("]");
+ Write_Eol;
+ end if;
+
+ return Q_Front >= Q.Last;
+ end Empty_Q;
+
+ ---------------------
+ -- Extract_Failure --
+ ---------------------
+
+ procedure Extract_Failure
+ (File : out File_Name_Type;
+ Unit : out Unit_Name_Type;
+ Found : out Boolean)
+ is
+ begin
+ File := Bad_Compilation.Table (Bad_Compilation.Last).File;
+ Unit := Bad_Compilation.Table (Bad_Compilation.Last).Unit;
+ Found := Bad_Compilation.Table (Bad_Compilation.Last).Found;
+ Bad_Compilation.Decrement_Last;
+ end Extract_Failure;
+
+ --------------------
+ -- Extract_From_Q --
+ --------------------
+
+ procedure Extract_From_Q
+ (Source_File : out File_Name_Type;
+ Source_Unit : out Unit_Name_Type)
+ is
+ File : constant File_Name_Type := Q.Table (Q_Front).File;
+ Unit : constant Unit_Name_Type := Q.Table (Q_Front).Unit;
+
+ begin
+ if Debug.Debug_Flag_Q then
+ Write_Str (" Q := Q - [ ");
+ Write_Name (File);
+ Write_Str (" ]");
+ Write_Eol;
+ end if;
+
+ Q_Front := Q_Front + 1;
+ Source_File := File;
+ Source_Unit := Unit;
+ end Extract_From_Q;
+
+ --------------
+ -- Gnatmake --
+ --------------
+
+ procedure Gnatmake is
+ Main_Source_File : File_Name_Type;
+ -- The source file containing the main compilation unit
+
+ Compilation_Failures : Natural;
+
+ Is_Main_Unit : Boolean;
+ -- Set to True by Compile_Sources if the Main_Source_File can be a
+ -- main unit.
+
+ Main_ALI_File : File_Name_Type;
+ -- The ali file corresponding to Main_Source_File
+
+ Executable : File_Name_Type := No_File;
+ -- The file name of an executable
+
+ Non_Std_Executable : Boolean := False;
+ -- Non_Std_Executable is set to True when there is a possibility
+ -- that the linker will not choose the correct executable file name.
+
+ Executable_Obsolete : Boolean := False;
+ -- Executable_Obsolete is set to True for the first obsolete main
+ -- and is never reset to False. Any subsequent main will always
+ -- be rebuild (if we rebuild mains), even in the case when it is not
+ -- really necessary, because it is too hard to decide.
+
+ begin
+ Make.Initialize;
+
+ if Hostparm.Java_VM then
+ Gcc := new String'("jgnat");
+ Gnatbind := new String'("jgnatbind");
+ Gnatlink := new String '("jgnatlink");
+
+ -- Do not check for an object file (".o") when compiling to
+ -- Java bytecode since ".class" files are generated instead.
+
+ Opt.Check_Object_Consistency := False;
+ end if;
+
+ if Opt.Verbose_Mode then
+ Write_Eol;
+ Write_Str ("GNATMAKE ");
+ Write_Str (Gnatvsn.Gnat_Version_String);
+ Write_Str (" Copyright 1995-2001 Free Software Foundation, Inc.");
+ Write_Eol;
+ end if;
+
+ -- If no mains have been specified on the command line,
+ -- and we are using a project file, we either find the main(s)
+ -- in the attribute Main of the main project, or we put all
+ -- the sources of the project file as mains.
+
+ if Main_Project /= No_Project and then Osint.Number_Of_Files = 0 then
+ Name_Len := 4;
+ Name_Buffer (1 .. 4) := "main";
+
+ declare
+ Main_Id : constant Name_Id := Name_Find;
+
+ Mains : constant Prj.Variable_Value :=
+ Prj.Util.Value_Of
+ (Variable_Name => Main_Id,
+ In_Variables =>
+ Projects.Table (Main_Project).Decl.Attributes);
+
+ Value : String_List_Id := Mains.Values;
+
+ begin
+ -- The attribute Main is an empty list or not specified,
+ -- or else gnatmake was invoked with the switch "-u".
+
+ if Value = Prj.Nil_String or else Unique_Compile then
+
+ -- First make sure that the binder and the linker
+ -- will not be invoked.
+
+ Opt.Compile_Only := True;
+
+ -- Put all the sources in the queue
+
+ Insert_Project_Sources
+ (The_Project => Main_Project, Into_Q => False);
+
+ else
+ -- The attribute Main is not an empty list.
+ -- Put all the main subprograms in the list as if there were
+ -- specified on the command line.
+
+ while Value /= Prj.Nil_String loop
+ String_To_Name_Buffer (String_Elements.Table (Value).Value);
+ Osint.Add_File (Name_Buffer (1 .. Name_Len));
+ Value := String_Elements.Table (Value).Next;
+ end loop;
+
+ end if;
+ end;
+
+ end if;
+
+ -- Output usage information if no files. Note that this can happen
+ -- in the case of a project file that contains only subunits.
+
+ if Osint.Number_Of_Files = 0 then
+ Makeusg;
+ Exit_Program (E_Fatal);
+
+ end if;
+
+ -- If -l was specified behave as if -n was specified
+
+ if Opt.List_Dependencies then
+ Opt.Do_Not_Execute := True;
+ end if;
+
+ -- Note that Osint.Next_Main_Source will always return the (possibly
+ -- abbreviated file) without any directory information.
+
+ Main_Source_File := Next_Main_Source;
+
+ if Project_File_Name = null then
+ Add_Switch ("-I-", Compiler, And_Save => True);
+ Add_Switch ("-I-", Binder, And_Save => True);
+ end if;
+
+ if Opt.Look_In_Primary_Dir then
+
+ Add_Switch
+ ("-I" &
+ Normalize_Directory_Name
+ (Get_Primary_Src_Search_Directory.all).all,
+ Compiler, Append_Switch => False,
+ And_Save => False);
+
+ Add_Switch ("-aO" & Normalized_CWD,
+ Binder,
+ Append_Switch => False,
+ And_Save => False);
+ end if;
+
+ -- If the user wants a program without a main subprogram, add the
+ -- appropriate switch to the binder.
+
+ if Opt.No_Main_Subprogram then
+ Add_Switch ("-z", Binder, And_Save => True);
+ end if;
+
+ if Main_Project /= No_Project then
+
+ -- Find the file name of the main unit
+
+ declare
+ Main_Source_File_Name : constant String :=
+ Get_Name_String (Main_Source_File);
+ Main_Unit_File_Name : constant String :=
+ Prj.Env.File_Name_Of_Library_Unit_Body
+ (Name => Main_Source_File_Name,
+ Project => Main_Project);
+
+ The_Packages : constant Package_Id :=
+ Projects.Table (Main_Project).Decl.Packages;
+
+ Gnatmake : constant Prj.Package_Id :=
+ Prj.Util.Value_Of
+ (Name => Name_Gnatmake,
+ In_Packages => The_Packages);
+
+ Binder_Package : constant Prj.Package_Id :=
+ Prj.Util.Value_Of
+ (Name => Name_Gnatbind,
+ In_Packages => The_Packages);
+
+ Linker_Package : constant Prj.Package_Id :=
+ Prj.Util.Value_Of
+ (Name => Name_Gnatlink,
+ In_Packages => The_Packages);
+
+ begin
+ -- We fail if we cannot find the main source file
+ -- as an immediate source of the main project file.
+
+ if Main_Unit_File_Name = "" then
+ Fail ('"' & Main_Source_File_Name &
+ """ is not a unit of project " &
+ Project_File_Name.all & ".");
+ else
+ -- Remove any directory information from the main
+ -- source file name.
+
+ declare
+ Pos : Natural := Main_Unit_File_Name'Last;
+
+ begin
+ loop
+ exit when Pos < Main_Unit_File_Name'First or else
+ Main_Unit_File_Name (Pos) = Directory_Separator;
+ Pos := Pos - 1;
+ end loop;
+
+ Name_Len := Main_Unit_File_Name'Last - Pos;
+
+ Name_Buffer (1 .. Name_Len) :=
+ Main_Unit_File_Name
+ (Pos + 1 .. Main_Unit_File_Name'Last);
+
+ Main_Source_File := Name_Find;
+
+ -- We only output the main source file if there is only one
+
+ if Opt.Verbose_Mode and then Osint.Number_Of_Files = 1 then
+ Write_Str ("Main source file: """);
+ Write_Str (Main_Unit_File_Name
+ (Pos + 1 .. Main_Unit_File_Name'Last));
+ Write_Line (""".");
+ end if;
+ end;
+ end if;
+
+ -- If there is a package gnatmake in the main project file, add
+ -- the switches from it. We also add the switches from packages
+ -- gnatbind and gnatlink, if any.
+
+ if Gnatmake /= No_Package then
+
+ -- If there is only one main, we attempt to get the gnatmake
+ -- switches for this main (if any). If there are no specific
+ -- switch for this particular main, get the general gnatmake
+ -- switches (if any).
+
+ if Osint.Number_Of_Files = 1 then
+ if Opt.Verbose_Mode then
+ Write_Str ("Adding gnatmake switches for """);
+ Write_Str (Main_Unit_File_Name);
+ Write_Line (""".");
+ end if;
+
+ Add_Switches
+ (File_Name => Main_Unit_File_Name,
+ The_Package => Gnatmake,
+ Program => None);
+
+ else
+ -- If there are several mains, we always get the general
+ -- gnatmake switches (if any).
+
+ -- Note: As there is never a source with name " ",
+ -- we are guaranteed to always get the gneneral switches.
+
+ Add_Switches
+ (File_Name => " ",
+ The_Package => Gnatmake,
+ Program => None);
+ end if;
+
+ end if;
+
+ if Binder_Package /= No_Package then
+
+ -- If there is only one main, we attempt to get the gnatbind
+ -- switches for this main (if any). If there are no specific
+ -- switch for this particular main, get the general gnatbind
+ -- switches (if any).
+
+ if Osint.Number_Of_Files = 1 then
+ if Opt.Verbose_Mode then
+ Write_Str ("Adding binder switches for """);
+ Write_Str (Main_Unit_File_Name);
+ Write_Line (""".");
+ end if;
+
+ Add_Switches
+ (File_Name => Main_Unit_File_Name,
+ The_Package => Binder_Package,
+ Program => Binder);
+
+ else
+ -- If there are several mains, we always get the general
+ -- gnatbind switches (if any).
+
+ -- Note: As there is never a source with name " ",
+ -- we are guaranteed to always get the gneneral switches.
+
+ Add_Switches
+ (File_Name => " ",
+ The_Package => Binder_Package,
+ Program => Binder);
+ end if;
+
+ end if;
+
+ if Linker_Package /= No_Package then
+
+ -- If there is only one main, we attempt to get the
+ -- gnatlink switches for this main (if any). If there are
+ -- no specific switch for this particular main, we get the
+ -- general gnatlink switches (if any).
+
+ if Osint.Number_Of_Files = 1 then
+ if Opt.Verbose_Mode then
+ Write_Str ("Adding linker switches for""");
+ Write_Str (Main_Unit_File_Name);
+ Write_Line (""".");
+ end if;
+
+ Add_Switches
+ (File_Name => Main_Unit_File_Name,
+ The_Package => Linker_Package,
+ Program => Linker);
+
+ else
+ -- If there are several mains, we always get the general
+ -- gnatlink switches (if any).
+
+ -- Note: As there is never a source with name " ",
+ -- we are guaranteed to always get the general switches.
+
+ Add_Switches
+ (File_Name => " ",
+ The_Package => Linker_Package,
+ Program => Linker);
+ end if;
+ end if;
+ end;
+ end if;
+
+ Display_Commands (not Opt.Quiet_Output);
+
+ -- We now put in the Binder_Switches and Linker_Switches tables,
+ -- the binder and linker switches of the command line that have been
+ -- put in the Saved_ tables. If a project file was used, then the
+ -- command line switches will follow the project file switches.
+
+ for J in 1 .. Saved_Binder_Switches.Last loop
+ Add_Switch
+ (Saved_Binder_Switches.Table (J),
+ Binder,
+ And_Save => False);
+ end loop;
+
+ for J in 1 .. Saved_Linker_Switches.Last loop
+ Add_Switch
+ (Saved_Linker_Switches.Table (J),
+ Linker,
+ And_Save => False);
+ end loop;
+
+ -- If no project file is used, we just put the gcc switches
+ -- from the command line in the Gcc_Switches table.
+
+ if Main_Project = No_Project then
+ for J in 1 .. Saved_Gcc_Switches.Last loop
+ Add_Switch
+ (Saved_Gcc_Switches.Table (J),
+ Compiler,
+ And_Save => False);
+ end loop;
+
+ else
+ -- And we put the command line gcc switches in the variable
+ -- The_Saved_Gcc_Switches. They are going to be used later
+ -- in procedure Compile_Sources.
+
+ The_Saved_Gcc_Switches :=
+ new Argument_List (1 .. Saved_Gcc_Switches.Last + 1);
+
+ for J in 1 .. Saved_Gcc_Switches.Last loop
+ The_Saved_Gcc_Switches (J) := Saved_Gcc_Switches.Table (J);
+ end loop;
+
+ -- We never use gnat.adc when a project file is used
+
+ The_Saved_Gcc_Switches (The_Saved_Gcc_Switches'Last) :=
+ No_gnat_adc;
+ end if;
+
+ -- If there was a --GCC, --GNATBIND or --GNATLINK switch on
+ -- the command line, then we have to use it, even if there was
+ -- another switch in the project file.
+
+ if Saved_Gcc /= null then
+ Gcc := Saved_Gcc;
+ end if;
+
+ if Saved_Gnatbind /= null then
+ Gnatbind := Saved_Gnatbind;
+ end if;
+
+ if Saved_Gnatlink /= null then
+ Gnatlink := Saved_Gnatlink;
+ end if;
+
+ Gcc_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all);
+ Gnatbind_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatbind.all);
+ Gnatlink_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatlink.all);
+
+ -- Here is where the make process is started
+
+ -- We do the same process for each main
+
+ Multiple_Main_Loop : for N_File in 1 .. Osint.Number_Of_Files loop
+
+ Recursive_Compilation_Step : declare
+ Args : Argument_List (1 .. Gcc_Switches.Last);
+
+ First_Compiled_File : Name_Id;
+
+ Youngest_Obj_File : Name_Id;
+ Youngest_Obj_Stamp : Time_Stamp_Type;
+
+ Executable_Stamp : Time_Stamp_Type;
+ -- Executable is the final executable program.
+
+ begin
+ Executable := No_File;
+ Non_Std_Executable := False;
+
+ for J in 1 .. Gcc_Switches.Last loop
+ Args (J) := Gcc_Switches.Table (J);
+ end loop;
+
+ -- Look inside the linker switches to see if the name of the final
+ -- executable program was specified.
+
+ for J in Linker_Switches.First .. Linker_Switches.Last loop
+ if Linker_Switches.Table (J).all = Output_Flag.all then
+ pragma Assert (J < Linker_Switches.Last);
+
+ -- We cannot specify a single executable for several
+ -- main subprograms!
+
+ if Osint.Number_Of_Files > 1 then
+ Fail
+ ("cannot specify a single executable for several mains");
+ end if;
+
+ Name_Len := Linker_Switches.Table (J + 1)'Length;
+ Name_Buffer (1 .. Name_Len) :=
+ Linker_Switches.Table (J + 1).all;
+
+ -- If target has an executable suffix and it has not been
+ -- specified then it is added here.
+
+ if Executable_Suffix'Length /= 0
+ and then Linker_Switches.Table (J + 1)
+ (Name_Len - Executable_Suffix'Length + 1
+ .. Name_Len) /= Executable_Suffix
+ then
+ Name_Buffer (Name_Len + 1 ..
+ Name_Len + Executable_Suffix'Length) :=
+ Executable_Suffix;
+ Name_Len := Name_Len + Executable_Suffix'Length;
+ end if;
+
+ Executable := Name_Enter;
+
+ Verbose_Msg (Executable, "final executable");
+ end if;
+ end loop;
+
+ -- If the name of the final executable program was not specified
+ -- then construct it from the main input file.
+
+ if Executable = No_File then
+ if Main_Project = No_Project then
+ Executable :=
+ Executable_Name (Strip_Suffix (Main_Source_File));
+
+ else
+ -- If we are using a project file, we attempt to
+ -- remove the body (or spec) termination of the main
+ -- subprogram. We find it the the naming scheme of the
+ -- project file. This will avoid to generate an executable
+ -- "main.2" for a main subprogram "main.2.ada", when the
+ -- body termination is ".2.ada".
+
+ declare
+ Body_Append : constant String :=
+ Get_Name_String
+ (Projects.Table
+ (Main_Project).Naming.Body_Append);
+ Spec_Append : constant String :=
+ Get_Name_String
+ (Projects.Table
+ (Main_Project).
+ Naming.Specification_Append);
+
+ begin
+ Get_Name_String (Main_Source_File);
+
+ if Name_Len > Body_Append'Length
+ and then Name_Buffer
+ (Name_Len - Body_Append'Length + 1 .. Name_Len) =
+ Body_Append
+ then
+ -- We have found the body termination. We remove it
+ -- add the executable termination (if any) and set
+ -- Non_Std_Executable.
+
+ Name_Len := Name_Len - Body_Append'Length;
+ Executable := Executable_Name (Name_Find);
+ Non_Std_Executable := True;
+
+ elsif Name_Len > Spec_Append'Length
+ and then
+ Name_Buffer
+ (Name_Len - Spec_Append'Length + 1 .. Name_Len) =
+ Spec_Append
+ then
+ -- We have found the spec termination. We remove it,
+ -- add the executable termination (if any), and set
+ -- Non_Std_Executable.
+
+ Name_Len := Name_Len - Spec_Append'Length;
+ Executable := Executable_Name (Name_Find);
+ Non_Std_Executable := True;
+
+ else
+ Executable :=
+ Executable_Name (Strip_Suffix (Main_Source_File));
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- Now we invoke Compile_Sources for the current main
+
+ Compile_Sources
+ (Main_Source => Main_Source_File,
+ Args => Args,
+ First_Compiled_File => First_Compiled_File,
+ Most_Recent_Obj_File => Youngest_Obj_File,
+ Most_Recent_Obj_Stamp => Youngest_Obj_Stamp,
+ Main_Unit => Is_Main_Unit,
+ Compilation_Failures => Compilation_Failures,
+ Check_Readonly_Files => Opt.Check_Readonly_Files,
+ Do_Not_Execute => Opt.Do_Not_Execute,
+ Force_Compilations => Opt.Force_Compilations,
+ In_Place_Mode => Opt.In_Place_Mode,
+ Keep_Going => Opt.Keep_Going,
+ Initialize_ALI_Data => True,
+ Max_Process => Opt.Maximum_Processes);
+
+ if Opt.Verbose_Mode then
+ Write_Str ("End of compilation");
+ Write_Eol;
+ end if;
+
+ if Compilation_Failures /= 0 then
+ List_Bad_Compilations;
+ raise Compilation_Failed;
+ end if;
+
+ -- Regenerate libraries, if any and if object files
+ -- have been regenerated
+
+ if Main_Project /= No_Project
+ and then MLib.Tgt.Libraries_Are_Supported
+ then
+
+ for Proj in Projects.First .. Projects.Last loop
+
+ if Proj /= Main_Project
+ and then Projects.Table (Proj).Flag1
+ then
+ MLib.Prj.Build_Library (For_Project => Proj);
+ end if;
+
+ end loop;
+
+ end if;
+
+ if Opt.List_Dependencies then
+ if First_Compiled_File /= No_File then
+ Inform
+ (First_Compiled_File,
+ "must be recompiled. Can't generate dependence list.");
+ else
+ List_Depend;
+ end if;
+
+ elsif First_Compiled_File = No_File
+ and then Opt.Compile_Only
+ and then not Opt.Quiet_Output
+ and then Osint.Number_Of_Files = 1
+ then
+ if Unique_Compile then
+ Inform (Msg => "object up to date.");
+ else
+ Inform (Msg => "objects up to date.");
+ end if;
+
+ elsif Opt.Do_Not_Execute
+ and then First_Compiled_File /= No_File
+ then
+ Write_Name (First_Compiled_File);
+ Write_Eol;
+ end if;
+
+ -- Stop after compile step if any of:
+
+ -- 1) -n (Do_Not_Execute) specified
+
+ -- 2) -l (List_Dependencies) specified (also sets Do_Not_Execute
+ -- above, so this is probably superfluous).
+
+ -- 3) -c (Compile_Only) specified
+
+ -- 4) Made unit cannot be a main unit
+
+ if (Opt.Do_Not_Execute
+ or Opt.List_Dependencies
+ or Opt.Compile_Only
+ or not Is_Main_Unit)
+ and then not No_Main_Subprogram
+ then
+ if Osint.Number_Of_Files = 1 then
+ return;
+
+ else
+ goto Next_Main;
+ end if;
+ end if;
+
+ -- If the objects were up-to-date check if the executable file
+ -- is also up-to-date. For now always bind and link on the JVM
+ -- since there is currently no simple way to check the up-to-date
+ -- status of objects
+
+ if not Hostparm.Java_VM and then First_Compiled_File = No_File then
+ Executable_Stamp := File_Stamp (Executable);
+
+ -- Once Executable_Obsolete is set to True, it is never reset
+ -- to False, because it is too hard to accurately decide if
+ -- a subsequent main need to be rebuilt or not.
+
+ Executable_Obsolete :=
+ Executable_Obsolete
+ or else Youngest_Obj_Stamp > Executable_Stamp;
+
+ if not Executable_Obsolete then
+
+ -- If no Ada object files obsolete the executable, check
+ -- for younger or missing linker files.
+
+ Check_Linker_Options
+ (Executable_Stamp, Youngest_Obj_File, Youngest_Obj_Stamp);
+
+ Executable_Obsolete := Youngest_Obj_File /= No_File;
+ end if;
+
+ -- Return if the executable is up to date
+ -- and otherwise motivate the relink/rebind.
+
+ if not Executable_Obsolete then
+ if not Opt.Quiet_Output then
+ Inform (Executable, "up to date.");
+ end if;
+
+ if Osint.Number_Of_Files = 1 then
+ return;
+
+ else
+ goto Next_Main;
+ end if;
+ end if;
+
+ if Executable_Stamp (1) = ' ' then
+ Verbose_Msg (Executable, "missing.", Prefix => " ");
+
+ elsif Youngest_Obj_Stamp (1) = ' ' then
+ Verbose_Msg (Youngest_Obj_File, "missing.", Prefix => " ");
+
+ elsif Youngest_Obj_Stamp > Executable_Stamp then
+ Verbose_Msg (Youngest_Obj_File,
+ "(" & String (Youngest_Obj_Stamp) & ") newer than",
+ Executable, "(" & String (Executable_Stamp) & ")");
+
+ else
+ Verbose_Msg (Executable, "needs to be rebuild.",
+ Prefix => " ");
+
+ end if;
+ end if;
+ end Recursive_Compilation_Step;
+
+ -- If we are here, it means that we need to rebuilt the current
+ -- main. So we set Executable_Obsolete to True to make sure that
+ -- the subsequent mains will be rebuilt.
+
+ Executable_Obsolete := True;
+
+ Main_ALI_In_Place_Mode_Step :
+ declare
+ ALI_File : File_Name_Type;
+ Src_File : File_Name_Type;
+
+ begin
+ Src_File := Strip_Directory (Main_Source_File);
+ ALI_File := Lib_File_Name (Src_File);
+ Main_ALI_File := Full_Lib_File_Name (ALI_File);
+
+ -- When In_Place_Mode, the library file can be located in the
+ -- Main_Source_File directory which may not be present in the
+ -- library path. In this case, use the corresponding library file
+ -- name.
+
+ if Main_ALI_File = No_File and then Opt.In_Place_Mode then
+ Get_Name_String (Get_Directory (Full_Source_Name (Src_File)));
+ Get_Name_String_And_Append (ALI_File);
+ Main_ALI_File := Name_Find;
+ Main_ALI_File := Full_Lib_File_Name (Main_ALI_File);
+ end if;
+
+ pragma Assert (Main_ALI_File /= No_File);
+ end Main_ALI_In_Place_Mode_Step;
+
+ Bind_Step : declare
+ Args : Argument_List
+ (Binder_Switches.First .. Binder_Switches.Last);
+
+ begin
+ -- Get all the binder switches
+
+ for J in Binder_Switches.First .. Binder_Switches.Last loop
+ Args (J) := Binder_Switches.Table (J);
+ end loop;
+
+ if Main_Project /= No_Project then
+
+ -- Put all the source directories in ADA_INCLUDE_PATH,
+ -- and all the object directories in ADA_OBJECTS_PATH
+
+ Set_Ada_Paths (Main_Project, False);
+ end if;
+
+ Bind (Main_ALI_File, Args);
+ end Bind_Step;
+
+ Link_Step : declare
+ There_Are_Libraries : Boolean := False;
+ Linker_Switches_Last : constant Integer := Linker_Switches.Last;
+
+ begin
+
+ if Main_Project /= No_Project then
+
+ if MLib.Tgt.Libraries_Are_Supported then
+ Set_Libraries (Main_Project, There_Are_Libraries);
+ end if;
+
+ if There_Are_Libraries then
+
+ -- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir>
+
+ Linker_Switches.Increment_Last;
+ Linker_Switches.Table (Linker_Switches.Last) :=
+ new String'("-L" & MLib.Utl.Lib_Directory);
+ Linker_Switches.Increment_Last;
+ Linker_Switches.Table (Linker_Switches.Last) :=
+ new String'("-lgnarl");
+ Linker_Switches.Increment_Last;
+ Linker_Switches.Table (Linker_Switches.Last) :=
+ new String'("-lgnat");
+
+ declare
+ Option : constant String_Access :=
+ MLib.Tgt.Linker_Library_Path_Option
+ (MLib.Utl.Lib_Directory);
+
+ begin
+ if Option /= null then
+ Linker_Switches.Increment_Last;
+ Linker_Switches.Table (Linker_Switches.Last) := Option;
+ end if;
+
+ end;
+
+ end if;
+
+ -- Put the object directories in ADA_OBJECTS_PATH
+
+ Set_Ada_Paths (Main_Project, False);
+ end if;
+
+ declare
+ Args : Argument_List
+ (Linker_Switches.First .. Linker_Switches.Last + 2);
+
+ begin
+ -- Get all the linker switches
+
+ for J in Linker_Switches.First .. Linker_Switches.Last loop
+ Args (J) := Linker_Switches.Table (J);
+ end loop;
+
+ -- And invoke the linker
+
+ if Non_Std_Executable then
+ Args (Linker_Switches.Last + 1) := new String'("-o");
+ Args (Linker_Switches.Last + 2) :=
+ new String'(Get_Name_String (Executable));
+ Link (Main_ALI_File, Args);
+
+ else
+ Link
+ (Main_ALI_File,
+ Args (Linker_Switches.First .. Linker_Switches.Last));
+ end if;
+
+ end;
+
+ Linker_Switches.Set_Last (Linker_Switches_Last);
+ end Link_Step;
+
+ -- We go to here when we skip the bind and link steps.
+
+ <<Next_Main>>
+
+ -- We go to the next main, if we did not process the last one
+
+ if N_File < Osint.Number_Of_Files then
+ Main_Source_File := Next_Main_Source;
+
+ if Main_Project /= No_Project then
+
+ -- Find the file name of the main unit
+
+ declare
+ Main_Source_File_Name : constant String :=
+ Get_Name_String (Main_Source_File);
+
+ Main_Unit_File_Name : constant String :=
+ Prj.Env.
+ File_Name_Of_Library_Unit_Body
+ (Name => Main_Source_File_Name,
+ Project => Main_Project);
+
+ begin
+ -- We fail if we cannot find the main source file
+ -- as an immediate source of the main project file.
+
+ if Main_Unit_File_Name = "" then
+ Fail ('"' & Main_Source_File_Name &
+ """ is not a unit of project " &
+ Project_File_Name.all & ".");
+
+ else
+ -- Remove any directory information from the main
+ -- source file name.
+
+ declare
+ Pos : Natural := Main_Unit_File_Name'Last;
+
+ begin
+ loop
+ exit when Pos < Main_Unit_File_Name'First
+ or else
+ Main_Unit_File_Name (Pos) = Directory_Separator;
+ Pos := Pos - 1;
+ end loop;
+
+ Name_Len := Main_Unit_File_Name'Last - Pos;
+
+ Name_Buffer (1 .. Name_Len) :=
+ Main_Unit_File_Name
+ (Pos + 1 .. Main_Unit_File_Name'Last);
+
+ Main_Source_File := Name_Find;
+ end;
+ end if;
+ end;
+ end if;
+ end if;
+ end loop Multiple_Main_Loop;
+
+ Exit_Program (E_Success);
+
+ exception
+ when Bind_Failed =>
+ Osint.Fail ("*** bind failed.");
+
+ when Compilation_Failed =>
+ Exit_Program (E_Fatal);
+
+ when Link_Failed =>
+ Osint.Fail ("*** link failed.");
+
+ when X : others =>
+ Write_Line (Exception_Information (X));
+ Osint.Fail ("INTERNAL ERROR. Please report.");
+
+ end Gnatmake;
+
+ --------------------
+ -- In_Ada_Lib_Dir --
+ --------------------
+
+ function In_Ada_Lib_Dir (File : File_Name_Type) return Boolean is
+ D : constant Name_Id := Get_Directory (File);
+ B : constant Byte := Get_Name_Table_Byte (D);
+
+ begin
+ return (B and Ada_Lib_Dir) /= 0;
+ end In_Ada_Lib_Dir;
+
+ ------------
+ -- Inform --
+ ------------
+
+ procedure Inform (N : Name_Id := No_Name; Msg : String) is
+ begin
+ Osint.Write_Program_Name;
+
+ Write_Str (": ");
+
+ if N /= No_Name then
+ Write_Str ("""");
+ Write_Name (N);
+ Write_Str (""" ");
+ end if;
+
+ Write_Str (Msg);
+ Write_Eol;
+ end Inform;
+
+ ------------
+ -- Init_Q --
+ ------------
+
+ procedure Init_Q is
+ begin
+ First_Q_Initialization := False;
+ Q_Front := Q.First;
+ Q.Set_Last (Q.First);
+ end Init_Q;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ Next_Arg : Positive;
+
+ begin
+ -- Override default initialization of Check_Object_Consistency
+ -- since this is normally False for GNATBIND, but is True for
+ -- GNATMAKE since we do not need to check source consistency
+ -- again once GNATMAKE has looked at the sources to check.
+
+ Opt.Check_Object_Consistency := True;
+
+ -- Package initializations. The order of calls is important here.
+
+ Output.Set_Standard_Error;
+ Osint.Initialize (Osint.Make);
+
+ Gcc_Switches.Init;
+ Binder_Switches.Init;
+ Linker_Switches.Init;
+
+ Csets.Initialize;
+ Namet.Initialize;
+
+ Snames.Initialize;
+
+ Prj.Initialize;
+
+ Next_Arg := 1;
+ Scan_Args : while Next_Arg <= Argument_Count loop
+ Scan_Make_Arg (Argument (Next_Arg), And_Save => True);
+ Next_Arg := Next_Arg + 1;
+ end loop Scan_Args;
+
+ if Usage_Requested then
+ Makeusg;
+ end if;
+
+ -- Test for trailing -o switch
+
+ if Opt.Output_File_Name_Present
+ and then not Output_File_Name_Seen
+ then
+ Fail ("output file name missing after -o");
+ end if;
+
+ if Project_File_Name /= null then
+
+ -- A project file was specified by a -P switch
+
+ if Opt.Verbose_Mode then
+ Write_Eol;
+ Write_Str ("Parsing Project File """);
+ Write_Str (Project_File_Name.all);
+ Write_Str (""".");
+ Write_Eol;
+ end if;
+
+ -- Avoid looking in the current directory for ALI files
+
+ Opt.Look_In_Primary_Dir := False;
+
+ -- Set the project parsing verbosity to whatever was specified
+ -- by a possible -vP switch.
+
+ Prj.Pars.Set_Verbosity (To => Current_Verbosity);
+
+ -- Parse the project file.
+ -- If there is an error, Main_Project will still be No_Project.
+
+ Prj.Pars.Parse
+ (Project => Main_Project,
+ Project_File_Name => Project_File_Name.all);
+
+ if Main_Project = No_Project then
+ Fail ("""" & Project_File_Name.all &
+ """ processing failed");
+ end if;
+
+ if Opt.Verbose_Mode then
+ Write_Eol;
+ Write_Str ("Parsing of Project File """);
+ Write_Str (Project_File_Name.all);
+ Write_Str (""" is finished.");
+ Write_Eol;
+ end if;
+
+ -- We add the source directories and the object directories
+ -- to the search paths.
+
+ Add_Source_Directories (Main_Project);
+ Add_Object_Directories (Main_Project);
+
+ end if;
+
+ Osint.Add_Default_Search_Dirs;
+
+ -- Mark the GNAT libraries if needed.
+
+ -- Source file lookups should be cached for efficiency.
+ -- Source files are not supposed to change.
+
+ Osint.Source_File_Data (Cache => True);
+
+ -- Read gnat.adc file to initialize Fname.UF
+
+ Fname.UF.Initialize;
+
+ begin
+ Fname.SF.Read_Source_File_Name_Pragmas;
+
+ exception
+ when Err : SFN_Scan.Syntax_Error_In_GNAT_ADC =>
+ Osint.Fail (Exception_Message (Err));
+ end;
+
+ end Initialize;
+
+ -----------------------------------
+ -- Insert_Project_Sources_Into_Q --
+ -----------------------------------
+
+ procedure Insert_Project_Sources
+ (The_Project : Project_Id;
+ Into_Q : Boolean)
+ is
+ Unit : Com.Unit_Data;
+ Sfile : Name_Id;
+
+ begin
+ -- For all the sources in the project files,
+
+ for Id in Com.Units.First .. Com.Units.Last loop
+ Unit := Com.Units.Table (Id);
+ Sfile := No_Name;
+
+ -- If there is a source for the body,
+
+ if Unit.File_Names (Com.Body_Part).Name /= No_Name then
+
+ -- And it is a source of the specified project
+
+ if Unit.File_Names (Com.Body_Part).Project = The_Project then
+
+ -- If we don't have a spec, we cannot consider the source
+ -- if it is a subunit
+
+ if Unit.File_Names (Com.Specification).Name = No_Name then
+ declare
+ Src_Ind : Source_File_Index;
+
+ begin
+ Src_Ind := Sinput.L.Load_Source_File
+ (Unit.File_Names (Com.Body_Part).Name);
+
+ -- If it is a subunit, discard it
+
+ if Sinput.L.Source_File_Is_Subunit (Src_Ind) then
+ Sfile := No_Name;
+
+ else
+ Sfile := Unit.File_Names (Com.Body_Part).Name;
+ end if;
+ end;
+
+ else
+ Sfile := Unit.File_Names (Com.Body_Part).Name;
+ end if;
+ end if;
+
+ elsif Unit.File_Names (Com.Specification).Name /= No_Name
+ and then Unit.File_Names (Com.Specification).Project = The_Project
+ then
+ -- If there is no source for the body, but there is a source
+ -- for the spec, then we take this one.
+
+ Sfile := Unit.File_Names (Com.Specification).Name;
+ end if;
+
+ -- If Into_Q is True, we insert into the Q
+
+ if Into_Q then
+
+ -- For the first source inserted into the Q, we need
+ -- to initialize the Q, but not for the subsequent sources.
+
+ if First_Q_Initialization then
+ Init_Q;
+ end if;
+
+ -- And of course, we only insert in the Q if the source
+ -- is not marked.
+
+ if Sfile /= No_Name and then not Is_Marked (Sfile) then
+ Insert_Q (Sfile);
+ Mark (Sfile);
+ end if;
+
+ elsif Sfile /= No_Name then
+
+ -- If Into_Q is False, we add the source as it it were
+ -- specified on the command line.
+
+ Osint.Add_File (Get_Name_String (Sfile));
+ end if;
+ end loop;
+ end Insert_Project_Sources;
+
+ --------------
+ -- Insert_Q --
+ --------------
+
+ procedure Insert_Q
+ (Source_File : File_Name_Type;
+ Source_Unit : Unit_Name_Type := No_Name)
+ is
+ begin
+ if Debug.Debug_Flag_Q then
+ Write_Str (" Q := Q + [ ");
+ Write_Name (Source_File);
+ Write_Str (" ] ");
+ Write_Eol;
+ end if;
+
+ Q.Table (Q.Last).File := Source_File;
+ Q.Table (Q.Last).Unit := Source_Unit;
+ Q.Increment_Last;
+ end Insert_Q;
+
+ ----------------------------
+ -- Is_External_Assignment --
+ ----------------------------
+
+ function Is_External_Assignment (Argv : String) return Boolean is
+ Start : Positive := 3;
+ Finish : Natural := Argv'Last;
+ Equal_Pos : Natural;
+
+ begin
+ if Argv'Last < 5 then
+ return False;
+
+ elsif Argv (3) = '"' then
+ if Argv (Argv'Last) /= '"' or else Argv'Last < 7 then
+ return False;
+ else
+ Start := 4;
+ Finish := Argv'Last - 1;
+ end if;
+ end if;
+
+ Equal_Pos := Start;
+
+ while Equal_Pos <= Finish and then Argv (Equal_Pos) /= '=' loop
+ Equal_Pos := Equal_Pos + 1;
+ end loop;
+
+ if Equal_Pos = Start
+ or else Equal_Pos >= Finish
+ then
+ return False;
+
+ else
+ Prj.Ext.Add
+ (External_Name => Argv (Start .. Equal_Pos - 1),
+ Value => Argv (Equal_Pos + 1 .. Finish));
+ return True;
+ end if;
+ end Is_External_Assignment;
+
+ ---------------
+ -- Is_Marked --
+ ---------------
+
+ function Is_Marked (Source_File : File_Name_Type) return Boolean is
+ begin
+ return Get_Name_Table_Byte (Source_File) /= 0;
+ end Is_Marked;
+
+ ----------
+ -- Link --
+ ----------
+
+ procedure Link (ALI_File : File_Name_Type; Args : Argument_List) is
+ Link_Args : Argument_List (Args'First .. Args'Last + 1);
+ Success : Boolean;
+
+ begin
+ Link_Args (Args'Range) := Args;
+
+ Get_Name_String (ALI_File);
+ Link_Args (Args'Last + 1) := new String'(Name_Buffer (1 .. Name_Len));
+
+ Display (Gnatlink.all, Link_Args);
+
+ if Gnatlink_Path = null then
+ Osint.Fail ("error, unable to locate " & Gnatlink.all);
+ end if;
+
+ GNAT.OS_Lib.Spawn (Gnatlink_Path.all, Link_Args, Success);
+
+ if not Success then
+ raise Link_Failed;
+ end if;
+ end Link;
+
+ ---------------------------
+ -- List_Bad_Compilations --
+ ---------------------------
+
+ procedure List_Bad_Compilations is
+ begin
+ for J in Bad_Compilation.First .. Bad_Compilation.Last loop
+ if Bad_Compilation.Table (J).File = No_File then
+ null;
+ elsif not Bad_Compilation.Table (J).Found then
+ Inform (Bad_Compilation.Table (J).File, "not found");
+ else
+ Inform (Bad_Compilation.Table (J).File, "compilation error");
+ end if;
+ end loop;
+ end List_Bad_Compilations;
+
+ -----------------
+ -- List_Depend --
+ -----------------
+
+ procedure List_Depend is
+ Lib_Name : Name_Id;
+ Obj_Name : Name_Id;
+ Src_Name : Name_Id;
+
+ Len : Natural;
+ Line_Pos : Natural;
+ Line_Size : constant := 77;
+
+ begin
+ Set_Standard_Output;
+
+ for A in ALIs.First .. ALIs.Last loop
+ Lib_Name := ALIs.Table (A).Afile;
+
+ -- We have to provide the full library file name in In_Place_Mode
+
+ if Opt.In_Place_Mode then
+ Lib_Name := Full_Lib_File_Name (Lib_Name);
+ end if;
+
+ Obj_Name := Object_File_Name (Lib_Name);
+ Write_Name (Obj_Name);
+ Write_Str (" :");
+
+ Get_Name_String (Obj_Name);
+ Len := Name_Len;
+ Line_Pos := Len + 2;
+
+ for D in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop
+ Src_Name := Sdep.Table (D).Sfile;
+
+ if Is_Internal_File_Name (Src_Name)
+ and then not Check_Readonly_Files
+ then
+ null;
+ else
+ if not Opt.Quiet_Output then
+ Src_Name := Full_Source_Name (Src_Name);
+ end if;
+
+ Get_Name_String (Src_Name);
+ Len := Name_Len;
+
+ if Line_Pos + Len + 1 > Line_Size then
+ Write_Str (" \");
+ Write_Eol;
+ Line_Pos := 0;
+ end if;
+
+ Line_Pos := Line_Pos + Len + 1;
+
+ Write_Str (" ");
+ Write_Name (Src_Name);
+ end if;
+ end loop;
+
+ Write_Eol;
+ end loop;
+
+ Set_Standard_Error;
+ end List_Depend;
+
+ ----------
+ -- Mark --
+ ----------
+
+ procedure Mark (Source_File : File_Name_Type) is
+ begin
+ Set_Name_Table_Byte (Source_File, 1);
+ end Mark;
+
+ -------------------
+ -- Mark_Dir_Path --
+ -------------------
+
+ procedure Mark_Dir_Path
+ (Path : String_Access;
+ Mark : Lib_Mark_Type)
+ is
+ Dir : String_Access;
+
+ begin
+ if Path /= null then
+ Osint.Get_Next_Dir_In_Path_Init (Path);
+
+ loop
+ Dir := Osint.Get_Next_Dir_In_Path (Path);
+ exit when Dir = null;
+ Mark_Directory (Dir.all, Mark);
+ end loop;
+ end if;
+ end Mark_Dir_Path;
+
+ --------------------
+ -- Mark_Directory --
+ --------------------
+
+ procedure Mark_Directory
+ (Dir : String;
+ Mark : Lib_Mark_Type)
+ is
+ N : Name_Id;
+ B : Byte;
+
+ begin
+ -- Dir last character is supposed to be a directory separator.
+
+ Name_Len := Dir'Length;
+ Name_Buffer (1 .. Name_Len) := Dir;
+
+ if not Is_Directory_Separator (Name_Buffer (Name_Len)) then
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Directory_Separator;
+ end if;
+
+ -- Add flags to the already existing flags
+
+ N := Name_Find;
+ B := Get_Name_Table_Byte (N);
+ Set_Name_Table_Byte (N, B or Mark);
+ end Mark_Directory;
+
+ ----------------------
+ -- Object_File_Name --
+ ----------------------
+
+ function Object_File_Name (Source : String) return String is
+ Pos : Natural := Source'Last;
+
+ begin
+ while Pos >= Source'First and then
+ Source (Pos) /= '.' loop
+ Pos := Pos - 1;
+ end loop;
+
+ if Pos >= Source'First then
+ Pos := Pos - 1;
+ end if;
+
+ return Source (Source'First .. Pos) & Object_Suffix;
+ end Object_File_Name;
+
+ -------------------
+ -- Scan_Make_Arg --
+ -------------------
+
+ procedure Scan_Make_Arg (Argv : String; And_Save : Boolean) is
+ begin
+ pragma Assert (Argv'First = 1);
+
+ if Argv'Length = 0 then
+ return;
+ end if;
+
+ -- If the previous switch has set the Output_File_Name_Present
+ -- flag (that is we have seen a -o), then the next argument is
+ -- the name of the output executable.
+
+ if Opt.Output_File_Name_Present and then not Output_File_Name_Seen then
+ Output_File_Name_Seen := True;
+
+ if Argv (1) = Switch_Character or else Argv (1) = '-' then
+ Fail ("output file name missing after -o");
+ else
+ Add_Switch ("-o", Linker, And_Save => And_Save);
+
+ -- Automatically add the executable suffix if it has not been
+ -- specified explicitly.
+
+ if Executable_Suffix'Length /= 0
+ and then Argv (Argv'Last - Executable_Suffix'Length + 1
+ .. Argv'Last) /= Executable_Suffix
+ then
+ Add_Switch
+ (Argv & Executable_Suffix,
+ Linker,
+ And_Save => And_Save);
+ else
+ Add_Switch (Argv, Linker, And_Save => And_Save);
+ end if;
+ end if;
+
+ -- Then check if we are dealing with a -cargs, -bargs or -largs
+
+ elsif (Argv (1) = Switch_Character or else Argv (1) = '-')
+ and then (Argv (2 .. Argv'Last) = "cargs"
+ or else Argv (2 .. Argv'Last) = "bargs"
+ or else Argv (2 .. Argv'Last) = "largs")
+ then
+ if not File_Name_Seen then
+ Fail ("-cargs, -bargs, -largs ",
+ "must appear after unit or file name");
+ end if;
+
+ case Argv (2) is
+ when 'c' => Program_Args := Compiler;
+ when 'b' => Program_Args := Binder;
+ when 'l' => Program_Args := Linker;
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- A special test is needed for the -o switch within a -largs
+ -- since that is another way to specify the name of the final
+ -- executable.
+
+ elsif Program_Args = Linker
+ and then (Argv (1) = Switch_Character or else Argv (1) = '-')
+ and then Argv (2 .. Argv'Last) = "o"
+ then
+ Fail ("switch -o not allowed within a -largs. Use -o directly.");
+
+ -- Check to see if we are reading switches after a -cargs,
+ -- -bargs or -largs switch. If yes save it.
+
+ elsif Program_Args /= None then
+
+ -- Check to see if we are reading -I switches in order
+ -- to take into account in the src & lib search directories.
+
+ if Argv'Length > 2 and then Argv (1 .. 2) = "-I" then
+ if Argv (3 .. Argv'Last) = "-" then
+ Opt.Look_In_Primary_Dir := False;
+
+ elsif Program_Args = Compiler then
+ if Argv (3 .. Argv'Last) /= "-" then
+ Add_Src_Search_Dir (Argv (3 .. Argv'Last));
+
+ end if;
+
+ elsif Program_Args = Binder then
+ Add_Lib_Search_Dir (Argv (3 .. Argv'Last));
+
+ end if;
+ end if;
+
+ Add_Switch (Argv, Program_Args, And_Save => And_Save);
+
+ -- Handle non-default compiler, binder, linker
+
+ elsif Argv'Length > 2 and then Argv (1 .. 2) = "--" then
+ if Argv'Length > 6
+ and then Argv (1 .. 6) = "--GCC="
+ then
+ declare
+ Program_Args : Argument_List_Access :=
+ Argument_String_To_List
+ (Argv (7 .. Argv'Last));
+
+ begin
+ if And_Save then
+ Saved_Gcc := new String'(Program_Args.all (1).all);
+ else
+ Gcc := new String'(Program_Args.all (1).all);
+ end if;
+
+ for J in 2 .. Program_Args.all'Last loop
+ Add_Switch
+ (Program_Args.all (J).all,
+ Compiler,
+ And_Save => And_Save);
+ end loop;
+ end;
+
+ elsif Argv'Length > 11
+ and then Argv (1 .. 11) = "--GNATBIND="
+ then
+ declare
+ Program_Args : Argument_List_Access :=
+ Argument_String_To_List
+ (Argv (12 .. Argv'Last));
+
+ begin
+ if And_Save then
+ Saved_Gnatbind := new String'(Program_Args.all (1).all);
+ else
+ Gnatbind := new String'(Program_Args.all (1).all);
+ end if;
+
+ for J in 2 .. Program_Args.all'Last loop
+ Add_Switch
+ (Program_Args.all (J).all, Binder, And_Save => And_Save);
+ end loop;
+ end;
+
+ elsif Argv'Length > 11
+ and then Argv (1 .. 11) = "--GNATLINK="
+ then
+ declare
+ Program_Args : Argument_List_Access :=
+ Argument_String_To_List
+ (Argv (12 .. Argv'Last));
+ begin
+ if And_Save then
+ Saved_Gnatlink := new String'(Program_Args.all (1).all);
+ else
+ Gnatlink := new String'(Program_Args.all (1).all);
+ end if;
+
+ for J in 2 .. Program_Args.all'Last loop
+ Add_Switch (Program_Args.all (J).all, Linker);
+ end loop;
+ end;
+
+ else
+ Fail ("unknown switch: ", Argv);
+ end if;
+
+ -- If we have seen a regular switch process it
+
+ elsif Argv (1) = Switch_Character or else Argv (1) = '-' then
+
+ if Argv'Length = 1 then
+ Fail ("switch character cannot be followed by a blank");
+
+ -- -I-
+
+ elsif Argv (2 .. Argv'Last) = "I-" then
+ Opt.Look_In_Primary_Dir := False;
+
+ -- Forbid -?- or -??- where ? is any character
+
+ elsif (Argv'Length = 3 and then Argv (3) = '-')
+ or else (Argv'Length = 4 and then Argv (4) = '-')
+ then
+ Fail ("trailing ""-"" at the end of ", Argv, " forbidden.");
+
+ -- -Idir
+
+ elsif Argv (2) = 'I' then
+ Add_Src_Search_Dir (Argv (3 .. Argv'Last));
+ Add_Lib_Search_Dir (Argv (3 .. Argv'Last));
+ Add_Switch (Argv, Compiler, And_Save => And_Save);
+ Add_Switch ("-aO" & Argv (3 .. Argv'Last),
+ Binder,
+ And_Save => And_Save);
+
+ -- No need to pass any source dir to the binder
+ -- since gnatmake call it with the -x flag
+ -- (ie do not check source time stamp)
+
+ -- -aIdir (to gcc this is like a -I switch)
+
+ elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aI" then
+ Add_Src_Search_Dir (Argv (4 .. Argv'Last));
+ Add_Switch ("-I" & Argv (4 .. Argv'Last),
+ Compiler,
+ And_Save => And_Save);
+
+ -- -aOdir
+
+ elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aO" then
+ Add_Lib_Search_Dir (Argv (4 .. Argv'Last));
+ Add_Switch (Argv, Binder, And_Save => And_Save);
+
+ -- -aLdir (to gnatbind this is like a -aO switch)
+
+ elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aL" then
+ Mark_Directory (Argv (4 .. Argv'Last), Ada_Lib_Dir);
+ Add_Lib_Search_Dir (Argv (4 .. Argv'Last));
+ Add_Switch ("-aO" & Argv (4 .. Argv'Last),
+ Binder,
+ And_Save => And_Save);
+
+ -- -Adir (to gnatbind this is like a -aO switch, to gcc like a -I)
+
+ elsif Argv (2) = 'A' then
+ Mark_Directory (Argv (3 .. Argv'Last), Ada_Lib_Dir);
+ Add_Src_Search_Dir (Argv (3 .. Argv'Last));
+ Add_Lib_Search_Dir (Argv (3 .. Argv'Last));
+ Add_Switch ("-I" & Argv (3 .. Argv'Last),
+ Compiler,
+ And_Save => And_Save);
+ Add_Switch ("-aO" & Argv (3 .. Argv'Last),
+ Binder,
+ And_Save => And_Save);
+
+ -- -Ldir
+
+ elsif Argv (2) = 'L' then
+ Add_Switch (Argv, Linker, And_Save => And_Save);
+
+ -- For -gxxxxx,-pg : give the switch to both the compiler and the
+ -- linker (except for -gnatxxx which is only for the compiler)
+
+ elsif
+ (Argv (2) = 'g' and then (Argv'Last < 5
+ or else Argv (2 .. 5) /= "gnat"))
+ or else Argv (2 .. Argv'Last) = "pg"
+ then
+ Add_Switch (Argv, Compiler, And_Save => And_Save);
+ Add_Switch (Argv, Linker, And_Save => And_Save);
+
+ -- -d
+
+ elsif Argv (2) = 'd'
+ and then Argv'Last = 2
+ then
+ Opt.Display_Compilation_Progress := True;
+
+ -- -j (need to save the result)
+
+ elsif Argv (2) = 'j' then
+ Scan_Make_Switches (Argv);
+
+ if And_Save then
+ Saved_Maximum_Processes := Maximum_Processes;
+ end if;
+
+ -- -m
+
+ elsif Argv (2) = 'm'
+ and then Argv'Last = 2
+ then
+ Opt.Minimal_Recompilation := True;
+
+ -- -u
+
+ elsif Argv (2) = 'u'
+ and then Argv'Last = 2
+ then
+ Unique_Compile := True;
+ Opt.Compile_Only := True;
+
+ -- -Pprj (only once, and only on the command line)
+
+ elsif Argv'Last > 2
+ and then Argv (2) = 'P'
+ then
+ if Project_File_Name /= null then
+ Fail ("cannot have several project files specified");
+
+ elsif not And_Save then
+
+ -- It could be a tool other than gnatmake (i.e, gnatdist)
+ -- or a -P switch inside a project file.
+
+ Fail
+ ("either the tool is not ""project-aware"" or " &
+ "a project file is specified inside a project file");
+
+ else
+ Project_File_Name := new String' (Argv (3 .. Argv'Last));
+ end if;
+
+ -- -S (Assemble)
+
+ -- Since no object file is created, don't check object
+ -- consistency.
+
+ elsif Argv (2) = 'S'
+ and then Argv'Last = 2
+ then
+ Opt.Check_Object_Consistency := False;
+ Add_Switch (Argv, Compiler, And_Save => And_Save);
+
+ -- -vPx (verbosity of the parsing of the project files)
+
+ elsif Argv'Last = 4
+ and then Argv (2 .. 3) = "vP"
+ and then Argv (4) in '0' .. '2'
+ then
+ if And_Save then
+ case Argv (4) is
+ when '0' =>
+ Current_Verbosity := Prj.Default;
+ when '1' =>
+ Current_Verbosity := Prj.Medium;
+ when '2' =>
+ Current_Verbosity := Prj.High;
+ when others =>
+ null;
+ end case;
+ end if;
+
+ -- -Wx (need to save the result)
+
+ elsif Argv (2) = 'W' then
+ Scan_Make_Switches (Argv);
+
+ if And_Save then
+ Saved_WC_Encoding_Method := Wide_Character_Encoding_Method;
+ Saved_WC_Encoding_Method_Set := True;
+ end if;
+
+ -- -Xext=val (External assignment)
+
+ elsif Argv (2) = 'X'
+ and then Is_External_Assignment (Argv)
+ then
+ -- Is_External_Assignment has side effects
+ -- when it returns True;
+
+ null;
+
+ -- If -gnath is present, then generate the usage information
+ -- right now for the compiler, and do not pass this option
+ -- on to the compiler calls.
+
+ elsif Argv = "-gnath" then
+ null;
+
+ -- By default all switches with more than one character
+ -- or one character switches which are not in 'a' .. 'z'
+ -- are passed to the compiler, unless we are dealing
+ -- with a -jnum switch or a debug switch (starts with 'd')
+
+ elsif Argv'Length > 5
+ and then Argv (2 .. 5) = "gnat"
+ and then Argv (6) = 'c'
+ then
+ Add_Switch (Argv, Compiler, And_Save => And_Save);
+ Opt.Operating_Mode := Opt.Check_Semantics;
+ Opt.Check_Object_Consistency := False;
+ Opt.Compile_Only := True;
+
+ elsif Argv (2 .. Argv'Last) = "nostdlib" then
+
+ -- Don't pass -nostdlib to gnatlink, it will disable
+ -- linking with all standard library files.
+
+ Opt.No_Stdlib := True;
+ Add_Switch (Argv, Binder, And_Save => And_Save);
+
+ elsif Argv (2 .. Argv'Last) = "nostdinc" then
+ Opt.No_Stdinc := True;
+ Add_Switch (Argv, Compiler, And_Save => And_Save);
+ Add_Switch (Argv, Binder, And_Save => And_Save);
+
+ elsif Argv (2) /= 'd'
+ and then Argv (2 .. Argv'Last) /= "M"
+ and then (Argv'Length > 2 or else Argv (2) not in 'a' .. 'z')
+ then
+ Add_Switch (Argv, Compiler, And_Save => And_Save);
+
+ -- All other options are handled by Scan_Make_Switches
+
+ else
+ Scan_Make_Switches (Argv);
+ end if;
+
+ -- If not a switch it must be a file name
+
+ else
+ File_Name_Seen := True;
+ Set_Main_File_Name (Argv);
+ end if;
+ end Scan_Make_Arg;
+
+ -------------------
+ -- Set_Ada_Paths --
+ -------------------
+
+ procedure Set_Ada_Paths
+ (For_Project : Prj.Project_Id;
+ Including_Libraries : Boolean)
+ is
+ New_Ada_Include_Path : constant String_Access :=
+ Prj.Env.Ada_Include_Path (For_Project);
+
+ New_Ada_Objects_Path : constant String_Access :=
+ Prj.Env.Ada_Objects_Path
+ (For_Project, Including_Libraries);
+
+ begin
+ -- If ADA_INCLUDE_PATH needs to be changed (we are not using the same
+ -- project file), set the new ADA_INCLUDE_PATH
+
+ if New_Ada_Include_Path /= Current_Ada_Include_Path then
+ Current_Ada_Include_Path := New_Ada_Include_Path;
+
+ if Original_Ada_Include_Path'Length = 0 then
+ Setenv ("ADA_INCLUDE_PATH",
+ New_Ada_Include_Path.all);
+
+ else
+ -- If there existed an ADA_INCLUDE_PATH at the invocation of
+ -- gnatmake, concatenate new ADA_INCLUDE_PATH with the original.
+
+ Setenv ("ADA_INCLUDE_PATH",
+ Original_Ada_Include_Path.all &
+ Path_Separator &
+ New_Ada_Include_Path.all);
+ end if;
+
+ if Opt.Verbose_Mode then
+ declare
+ Include_Path : constant String_Access :=
+ Getenv ("ADA_INCLUDE_PATH");
+
+ begin
+ -- Display the new ADA_INCLUDE_PATH
+
+ Write_Str ("ADA_INCLUDE_PATH = """);
+ Prj.Util.Write_Str
+ (S => Include_Path.all,
+ Max_Length => Max_Line_Length,
+ Separator => Path_Separator);
+ Write_Str ("""");
+ Write_Eol;
+ end;
+ end if;
+ end if;
+
+ -- If ADA_OBJECTS_PATH needs to be changed (we are not using the same
+ -- project file), set the new ADA_OBJECTS_PATH
+
+ if New_Ada_Objects_Path /= Current_Ada_Objects_Path then
+ Current_Ada_Objects_Path := New_Ada_Objects_Path;
+
+ if Original_Ada_Objects_Path'Length = 0 then
+ Setenv ("ADA_OBJECTS_PATH",
+ New_Ada_Objects_Path.all);
+
+ else
+ -- If there existed an ADA_OBJECTS_PATH at the invocation of
+ -- gnatmake, concatenate new ADA_OBJECTS_PATH with the original.
+
+ Setenv ("ADA_OBJECTS_PATH",
+ Original_Ada_Objects_Path.all &
+ Path_Separator &
+ New_Ada_Objects_Path.all);
+ end if;
+
+ if Opt.Verbose_Mode then
+ declare
+ Objects_Path : constant String_Access :=
+ Getenv ("ADA_OBJECTS_PATH");
+
+ begin
+ -- Display the new ADA_OBJECTS_PATH
+
+ Write_Str ("ADA_OBJECTS_PATH = """);
+ Prj.Util.Write_Str
+ (S => Objects_Path.all,
+ Max_Length => Max_Line_Length,
+ Separator => Path_Separator);
+ Write_Str ("""");
+ Write_Eol;
+ end;
+ end if;
+ end if;
+
+ end Set_Ada_Paths;
+
+ ---------------------
+ -- Set_Library_For --
+ ---------------------
+
+ procedure Set_Library_For
+ (Project : Project_Id;
+ There_Are_Libraries : in out Boolean)
+ is
+ begin
+ -- Case of library project
+
+ if Projects.Table (Project).Library then
+ There_Are_Libraries := True;
+
+ -- Add the -L switch
+
+ Linker_Switches.Increment_Last;
+ Linker_Switches.Table (Linker_Switches.Last) :=
+ new String'("-L" &
+ Get_Name_String
+ (Projects.Table (Project).Library_Dir));
+
+ -- Add the -l switch
+
+ Linker_Switches.Increment_Last;
+ Linker_Switches.Table (Linker_Switches.Last) :=
+ new String'("-l" &
+ Get_Name_String
+ (Projects.Table (Project).Library_Name));
+
+ -- Add the Wl,-rpath switch if library non static
+
+ if Projects.Table (Project).Library_Kind /= Static then
+ declare
+ Option : constant String_Access :=
+ MLib.Tgt.Linker_Library_Path_Option
+ (Get_Name_String
+ (Projects.Table (Project).Library_Dir));
+
+ begin
+ if Option /= null then
+ Linker_Switches.Increment_Last;
+ Linker_Switches.Table (Linker_Switches.Last) :=
+ Option;
+ end if;
+
+ end;
+
+ end if;
+
+ end if;
+ end Set_Library_For;
+
+ ------------
+ -- Unmark --
+ ------------
+
+ procedure Unmark (Source_File : File_Name_Type) is
+ begin
+ Set_Name_Table_Byte (Source_File, 0);
+ end Unmark;
+
+ -----------------
+ -- Verbose_Msg --
+ -----------------
+
+ procedure Verbose_Msg
+ (N1 : Name_Id;
+ S1 : String;
+ N2 : Name_Id := No_Name;
+ S2 : String := "";
+ Prefix : String := " -> ")
+ is
+ begin
+ if not Opt.Verbose_Mode then
+ return;
+ end if;
+
+ Write_Str (Prefix);
+ Write_Str ("""");
+ Write_Name (N1);
+ Write_Str (""" ");
+ Write_Str (S1);
+
+ if N2 /= No_Name then
+ Write_Str (" """);
+ Write_Name (N2);
+ Write_Str (""" ");
+ end if;
+
+ Write_Str (S2);
+ Write_Eol;
+ end Verbose_Msg;
+
+end Make;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M A K E --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.21 $
+-- --
+-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- The following package implements the facilities to recursively
+-- compile (a la make), bind and/or link a set of sources. This package
+-- gives the individual routines for performing such tasks as well as
+-- the routine gnatmake below that puts it all together.
+
+with GNAT.OS_Lib; use GNAT.OS_Lib; -- defines Argument_List
+with Table;
+with Types; use Types;
+
+package Make is
+
+ -- The 3 following packages are used to store gcc, gnatbind and gnatbl
+ -- switches passed on the gnatmake or gnatdist command line.
+ -- Note that the lower bounds definitely need to be 1 to match the
+ -- requirement that the argument array prepared for Spawn must have
+ -- a lower bound of 1.
+
+ package Gcc_Switches is new Table.Table (
+ Table_Component_Type => String_Access,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 20,
+ Table_Increment => 100,
+ Table_Name => "Make.Gcc_Switches");
+
+ package Binder_Switches is new Table.Table (
+ Table_Component_Type => String_Access,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 20,
+ Table_Increment => 100,
+ Table_Name => "Make.Binder_Switches");
+
+ package Linker_Switches is new Table.Table (
+ Table_Component_Type => String_Access,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 20,
+ Table_Increment => 100,
+ Table_Name => "Make.Linker_Switches");
+
+ procedure Display_Commands (Display : Boolean := True);
+ -- The default behavior of Make commands (Compile_Sources, Bind, Link)
+ -- is to display them on stderr. This behavior can be changed repeatedly
+ -- by invoking this procedure.
+
+ -- If a compilation, bind or link failed one of the following 3 exceptions
+ -- is raised. These need to be handled by the calling routines.
+
+ Compilation_Failed : exception;
+ -- Raised by Compile_Sources if a compilation failed.
+
+ Bind_Failed : exception;
+ -- Raised by Bind below if the bind failed.
+
+ Link_Failed : exception;
+ -- Raised by Link below if the link failed.
+
+ procedure Bind (ALI_File : File_Name_Type; Args : Argument_List);
+ -- Binds ALI_File. Args are the arguments to pass to the binder.
+ -- Args must have a lower bound of 1.
+
+ procedure Link (ALI_File : File_Name_Type; Args : Argument_List);
+ -- Links ALI_File. Args are the arguments to pass to the linker.
+ -- Args must have a lower bound of 1.
+
+ procedure Initialize;
+ -- Performs default and package initialization. Therefore,
+ -- Compile_Sources can be called by an external unit.
+
+ procedure Scan_Make_Arg (Argv : String; And_Save : Boolean);
+ -- Scan make arguments. Argv is a single argument to be processed.
+
+ procedure Extract_Failure
+ (File : out File_Name_Type;
+ Unit : out Unit_Name_Type;
+ Found : out Boolean);
+ -- Extracts the first failure report from Bad_Compilation table.
+
+ procedure Compile_Sources
+ (Main_Source : File_Name_Type;
+ Args : Argument_List;
+ First_Compiled_File : out Name_Id;
+ Most_Recent_Obj_File : out Name_Id;
+ Most_Recent_Obj_Stamp : out Time_Stamp_Type;
+ Main_Unit : out Boolean;
+ Compilation_Failures : out Natural;
+ Check_Readonly_Files : Boolean := False;
+ Do_Not_Execute : Boolean := False;
+ Force_Compilations : Boolean := False;
+ Keep_Going : Boolean := False;
+ In_Place_Mode : Boolean := False;
+ Initialize_ALI_Data : Boolean := True;
+ Max_Process : Positive := 1);
+ -- Compile_Sources will recursively compile all the sources needed by
+ -- Main_Source. Before calling this routine make sure Namet has been
+ -- initialized. This routine can be called repeatedly with different
+ -- Main_Source file as long as all the source (-I flags), library
+ -- (-B flags) and ada library (-A flags) search paths between calls are
+ -- *exactly* the same. The default directory must also be the same.
+ --
+ -- Args contains the arguments to use during the compilations.
+ -- The lower bound of Args must be 1.
+ --
+ -- First_Compiled_File is set to the name of the first file that is
+ -- compiled or that needs to be compiled. This is set to No_Name if no
+ -- compilations were needed.
+ --
+ -- Most_Recent_Obj_File is set to the full name of the most recent
+ -- object file found when no compilations are needed, that is when
+ -- First_Compiled_File is set to No_Name. When First_Compiled_File
+ -- is set then Most_Recent_Obj_File is set to No_Name.
+ --
+ -- Most_Recent_Obj_Stamp is the time stamp of Most_Recent_Obj_File.
+ --
+ -- Main_Unit is set to True if Main_Source can be a main unit.
+ -- If Do_Not_Execute is False and First_Compiled_File /= No_Name
+ -- the value of Main_Unit is always False.
+ -- Is this used any more??? It is certainly not used by gnatmake???
+ --
+ -- Compilation_Failures is a count of compilation failures. This count
+ -- is used to extract compilation failure reports with Extract_Failure.
+ --
+ -- Check_Readonly_Files set it to True to compile source files
+ -- which library files are read-only. When compiling GNAT predefined
+ -- files the "-gnatg" flag is used.
+ --
+ -- Do_Not_Execute set it to True to find out the first source that
+ -- needs to be recompiled, but without recompiling it. This file is
+ -- saved in First_Compiled_File.
+ --
+ -- Force_Compilations forces all compilations no matter what but
+ -- recompiles read-only files only if Check_Readonly_Files
+ -- is set.
+ --
+ -- Keep_Going when True keep compiling even in the presence of
+ -- compilation errors.
+ --
+ -- In_Place_Mode when True save library/object files in their object
+ -- directory if they already exist; otherwise, in the source directory.
+ --
+ -- Initialize_ALI_Data set it to True when you want to intialize ALI
+ -- data-structures. This is what you should do most of the time.
+ -- (especially the first time around when you call this routine).
+ -- This parameter is set to False to preserve previously recorded
+ -- ALI file data.
+ --
+ -- Max_Process is the maximum number of processes that should be spawned
+ -- to carry out compilations.
+ --
+ -- Flags in Package Opt Affecting Compile_Sources
+ -- -----------------------------------------------
+ --
+ -- Check_Object_Consistency set it to False to omit all consistency
+ -- checks between an .ali file and its corresponding object file.
+ -- When this flag is set to true, every time an .ali is read,
+ -- package Osint checks that the corresponding object file
+ -- exists and is more recent than the .ali.
+ --
+ -- Use of Name Table Info
+ -- ----------------------
+ --
+ -- All file names manipulated by Compile_Sources are entered into the
+ -- Names table. The Byte field of a source file is used to mark it.
+ --
+ -- Calling Compile_Sources Several Times
+ -- -------------------------------------
+ --
+ -- Upon return from Compile_Sources all the ALI data structures are left
+ -- intact for further browsing. HOWEVER upon entry to this routine ALI
+ -- data structures are re-initialized if parameter Initialize_ALI_Data
+ -- above is set to true. Typically this is what you want the first time
+ -- you call Compile_Sources. You should not load an ali file, call this
+ -- routine with flag Initialize_ALI_Data set to True and then expect
+ -- that ALI information to be around after the call. Note that the first
+ -- time you call Compile_Sources you better set Initialize_ALI_Data to
+ -- True unless you have called Initialize_ALI yourself.
+ --
+ -- Compile_Sources ALGORITHM : Compile_Sources (Main_Source)
+ -- -------------------------
+ --
+ -- 1. Insert Main_Source in a Queue (Q) and mark it.
+ --
+ -- 2. Let unit.adb be the file at the head of the Q. If unit.adb is
+ -- missing but its corresponding ali file is in an Ada library directory
+ -- (see below) then, remove unit.adb from the Q and goto step 4.
+ -- Otherwise, look at the files under the D (dependency) section of
+ -- unit.ali. If unit.ali does not exist or some of the time stamps do
+ -- not match, (re)compile unit.adb.
+ --
+ -- An Ada library directory is a directory containing Ada specs, ali
+ -- and object files but no source files for the bodies. An Ada library
+ -- directory is communicated to gnatmake by means of some switch so that
+ -- gnatmake can skip the sources whole ali are in that directory.
+ -- There are two reasons for skipping the sources in this case. Firstly,
+ -- Ada libraries typically come without full sources but binding and
+ -- linking against those libraries is still possible. Secondly, it would
+ -- be very wasteful for gnatmake to systematically check the consistency
+ -- of every external Ada library used in a program. The binder is
+ -- already in charge of catching any potential inconsistencies.
+ --
+ -- 3. Look into the W section of unit.ali and insert into the Q all
+ -- unmarked source files. Mark all files newly inserted in the Q.
+ -- Specifically, assuming that the W section looks like
+ --
+ -- W types%s types.adb types.ali
+ -- W unchecked_deallocation%s
+ -- W xref_tab%s xref_tab.adb xref_tab.ali
+ --
+ -- Then xref_tab.adb and types.adb are inserted in the Q if they are not
+ -- already marked.
+ -- Note that there is no file listed under W unchecked_deallocation%s
+ -- so no generic body should ever be explicitely compiled (unless the
+ -- Main_Source at the start was a generic body).
+ --
+ -- 4. Repeat steps 2 and 3 above until the Q is empty
+ --
+ -- Note that the above algorithm works because the units withed in
+ -- subunits are transitively included in the W section (with section) of
+ -- the main unit. Likewise the withed units in a generic body needed
+ -- during a compilation are also transitively included in the W section
+ -- of the originally compiled file.
+
+ procedure Gnatmake;
+ -- The driver of gnatmake. This routine puts it all together.
+ -- This utility can be used to automatically (re)compile (using
+ -- Compile_Sources), bind (using Bind) and link (using Link) a set of
+ -- ada sources. For more information on gnatmake and its precise usage
+ -- please refer to the gnat documentation.
+ --
+ -- Flags in Package Opt Affecting Gnatmake
+ -- ---------------------------------------
+ --
+ -- Check_Readonly_Files: True when -a present in command line
+ -- Check_Object_Consistency: Set to True by Gnatmake
+ -- Compile_Only: True when -c present in command line
+ -- Force_Compilations: True when -f present in command line
+ -- Maximum_Processes: Number of processes given by -jnum
+ -- Keep_Going: True when -k present in command line
+ -- List_Dependencies: True when -l present in command line
+ -- Do_Not_Execute True when -n present in command line
+ -- Quiet_Output: True when -q present in command line
+ -- Minimal_Recompilation: True when -m present in command line
+ -- Verbose_Mode: True when -v present in command line
+
+end Make;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M A K E U S G --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.14 $
+-- --
+-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Osint; use Osint;
+with Output; use Output;
+with Usage;
+
+procedure Makeusg is
+
+ procedure Write_Switch_Char;
+ -- Write two spaces followed by appropriate switch character
+
+ procedure Write_Switch_Char is
+ begin
+ Write_Str (" ");
+ Write_Char (Switch_Character);
+ end Write_Switch_Char;
+
+-- Start of processing for Makeusg
+
+begin
+ -- Usage line
+
+ Write_Str ("Usage: ");
+ Osint.Write_Program_Name;
+ Write_Str (" opts name ");
+ Write_Str ("{[-cargs opts] [-bargs opts] [-largs opts]}");
+ Write_Eol;
+ Write_Eol;
+ Write_Str (" name is a file name from which you can omit the");
+ Write_Str (" .adb or .ads suffix");
+ Write_Eol;
+ Write_Eol;
+
+ -- GNATMAKE switches
+
+ Write_Str ("gnatmake switches:");
+ Write_Eol;
+
+ -- Line for -a
+
+ Write_Switch_Char;
+ Write_Str ("a Consider all files, even readonly ali files");
+ Write_Eol;
+
+ -- Line for -c
+
+ Write_Switch_Char;
+ Write_Str ("c Compile only, do not bind and link");
+ Write_Eol;
+
+ -- Line for -f
+
+ Write_Switch_Char;
+ Write_Str ("f Force recompilations of non predefined units");
+ Write_Eol;
+
+ -- Line for -i
+
+ Write_Switch_Char;
+ Write_Str ("i In place. Replace existing ali file, ");
+ Write_Str ("or put it with source");
+ Write_Eol;
+
+ -- Line for -jnnn
+
+ Write_Switch_Char;
+ Write_Str ("jnum Use nnn processes to compile");
+ Write_Eol;
+
+ -- Line for -k
+
+ Write_Switch_Char;
+ Write_Str ("k Keep going after compilation errors");
+ Write_Eol;
+
+ -- Line for -m
+
+ Write_Switch_Char;
+ Write_Str ("m Minimal recompilation");
+ Write_Eol;
+
+ -- Line for -M
+
+ Write_Switch_Char;
+ Write_Str ("M List object file dependences for Makefile");
+ Write_Eol;
+
+ -- Line for -n
+
+ Write_Switch_Char;
+ Write_Str ("n Check objects up to date, output next file ");
+ Write_Str ("to compile if not");
+ Write_Eol;
+
+ -- Line for -o
+
+ Write_Switch_Char;
+ Write_Str ("o name Choose an alternate executable name");
+ Write_Eol;
+
+ -- Line for -P
+
+ Write_Switch_Char;
+ Write_Str ("Pproj Use GNAT Project File proj");
+ Write_Eol;
+
+ -- Line for -q
+
+ Write_Switch_Char;
+ Write_Str ("q Be quiet/terse");
+ Write_Eol;
+
+ -- Line for -s
+
+ Write_Switch_Char;
+ Write_Str ("s Recompile if compiler switches have changed");
+ Write_Eol;
+
+ -- Line for -u
+
+ Write_Switch_Char;
+ Write_Str ("u Unique compilation. Only compile the given file.");
+ Write_Eol;
+
+ -- Line for -v
+
+ Write_Switch_Char;
+ Write_Str ("v Display reasons for all (re)compilations");
+ Write_Eol;
+
+ -- Line for -vPx
+
+ Write_Switch_Char;
+ Write_Str ("vPx Specify verbosity when parsing GNAT Project Files");
+ Write_Eol;
+
+ -- Line for -X
+
+ Write_Switch_Char;
+ Write_Str ("Xnm=val Specify an external reference for GNAT Project Files");
+ Write_Eol;
+
+ -- Line for -z
+
+ Write_Switch_Char;
+ Write_Str ("z No main subprogram (zero main)");
+ Write_Eol;
+ Write_Eol;
+
+ Write_Str (" --GCC=command Use this gcc command");
+ Write_Eol;
+
+ Write_Str (" --GNATBIND=command Use this gnatbind command");
+ Write_Eol;
+
+ Write_Str (" --GNATLINK=command Use this gnatlink command");
+ Write_Eol;
+ Write_Eol;
+
+ -- Source and Library search path switches
+
+ Write_Str ("Source and Library search path switches:");
+ Write_Eol;
+
+ -- Line for -aL
+
+ Write_Switch_Char;
+ Write_Str ("aLdir Skip missing library sources if ali in dir");
+ Write_Eol;
+
+ -- Line for -A
+
+ Write_Switch_Char;
+ Write_Str ("Adir like -aLdir -aIdir");
+ Write_Eol;
+
+ -- Line for -aO switch
+
+ Write_Switch_Char;
+ Write_Str ("aOdir Specify library/object files search path");
+ Write_Eol;
+
+ -- Line for -aI switch
+
+ Write_Switch_Char;
+ Write_Str ("aIdir Specify source files search path");
+ Write_Eol;
+
+ -- Line for -I switch
+
+ Write_Switch_Char;
+ Write_Str ("Idir Like -aIdir -aOdir");
+ Write_Eol;
+
+ -- Line for -I- switch
+
+ Write_Switch_Char;
+ Write_Str ("I- Don't look for sources & library files");
+ Write_Str (" in the default directory");
+ Write_Eol;
+
+ -- Line for -L
+
+ Write_Switch_Char;
+ Write_Str ("Ldir Look for program libraries also in dir");
+ Write_Eol;
+
+ -- Line for -nostdinc
+
+ Write_Switch_Char;
+ Write_Str ("nostdinc Don't look for sources");
+ Write_Str (" in the system default directory");
+ Write_Eol;
+
+ -- Line for -nostdlib
+
+ Write_Switch_Char;
+ Write_Str ("nostdlib Don't look for library files");
+ Write_Str (" in the system default directory");
+ Write_Eol;
+ Write_Eol;
+
+ -- General Compiler, Binder, Linker switches
+
+ Write_Str ("To pass an arbitrary switch to the Compiler, ");
+ Write_Str ("Binder or Linker:");
+ Write_Eol;
+
+ -- Line for -cargs
+
+ Write_Switch_Char;
+ Write_Str ("cargs opts opts are passed to the compiler");
+ Write_Eol;
+
+ -- Line for -bargs
+
+ Write_Switch_Char;
+ Write_Str ("bargs opts opts are passed to the binder");
+ Write_Eol;
+
+ -- Line for -largs
+
+ Write_Switch_Char;
+ Write_Str ("largs opts opts are passed to the linker");
+ Write_Eol;
+
+ -- Add usage information for gcc
+
+ Usage;
+
+end Makeusg;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M A K E U S G --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 1992-1998 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Procedure to output usage information for gnatmake
+
+procedure Makeusg;
+-- Output gnatmake usage information
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- M A T H _ L I B --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This body is specifically for using an Ada interface to C math.h to get
+-- the computation engine. Many special cases are handled locally to avoid
+-- unnecessary calls. This is not a "strict" implementation, but takes full
+-- advantage of the C functions, e.g. in providing interface to hardware
+-- provided versions of the elementary functions.
+
+-- A known weakness is that on the x86, all computation is done in Double,
+-- which means that a lot of accuracy is lost for the Long_Long_Float case.
+
+-- Uses functions sqrt, exp, log, pow, sin, asin, cos, acos, tan, atan,
+-- sinh, cosh, tanh from C library via math.h
+
+-- This is an adaptation of Ada.Numerics.Generic_Elementary_Functions that
+-- provides a compatible body for the DEC Math_Lib package.
+
+with Ada.Numerics.Aux;
+use type Ada.Numerics.Aux.Double;
+with Ada.Numerics; use Ada.Numerics;
+
+package body Math_Lib is
+
+ Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755;
+
+ Two_Pi : constant Real'Base := 2.0 * Pi;
+ Half_Pi : constant Real'Base := Pi / 2.0;
+ Fourth_Pi : constant Real'Base := Pi / 4.0;
+ Epsilon : constant Real'Base := Real'Base'Epsilon;
+ IEpsilon : constant Real'Base := 1.0 / Epsilon;
+
+ subtype Double is Aux.Double;
+
+ DEpsilon : constant Double := Double (Epsilon);
+ DIEpsilon : constant Double := Double (IEpsilon);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Arctan
+ (Y : Real;
+ A : Real := 1.0)
+ return Real;
+
+ function Arctan
+ (Y : Real;
+ A : Real := 1.0;
+ Cycle : Real)
+ return Real;
+
+ function Exact_Remainder
+ (A : Real;
+ Y : Real)
+ return Real;
+ -- Computes exact remainder of A divided by Y
+
+ function Half_Log_Epsilon return Real;
+ -- Function to provide constant: 0.5 * Log (Epsilon)
+
+ function Local_Atan
+ (Y : Real;
+ A : Real := 1.0)
+ return Real;
+ -- Common code for arc tangent after cyele reduction
+
+ function Log_Inverse_Epsilon return Real;
+ -- Function to provide constant: Log (1.0 / Epsilon)
+
+ function Square_Root_Epsilon return Real;
+ -- Function to provide constant: Sqrt (Epsilon)
+
+ ----------
+ -- "**" --
+ ----------
+
+ function "**" (A1, A2 : Real) return Real is
+
+ begin
+ if A1 = 0.0
+ and then A2 = 0.0
+ then
+ raise Argument_Error;
+
+ elsif A1 < 0.0 then
+ raise Argument_Error;
+
+ elsif A2 = 0.0 then
+ return 1.0;
+
+ elsif A1 = 0.0 then
+ if A2 < 0.0 then
+ raise Constraint_Error;
+ else
+ return 0.0;
+ end if;
+
+ elsif A1 = 1.0 then
+ return 1.0;
+
+ elsif A2 = 1.0 then
+ return A1;
+
+ else
+ begin
+ if A2 = 2.0 then
+ return A1 * A1;
+ else
+ return
+ Real (Aux.pow (Double (A1), Double (A2)));
+ end if;
+
+ exception
+ when others =>
+ raise Constraint_Error;
+ end;
+ end if;
+ end "**";
+
+ ------------
+ -- Arccos --
+ ------------
+
+ -- Natural cycle
+
+ function Arccos (A : Real) return Real is
+ Temp : Real'Base;
+
+ begin
+ if abs A > 1.0 then
+ raise Argument_Error;
+
+ elsif abs A < Square_Root_Epsilon then
+ return Pi / 2.0 - A;
+
+ elsif A = 1.0 then
+ return 0.0;
+
+ elsif A = -1.0 then
+ return Pi;
+ end if;
+
+ Temp := Real (Aux.acos (Double (A)));
+
+ if Temp < 0.0 then
+ Temp := Pi + Temp;
+ end if;
+
+ return Temp;
+ end Arccos;
+
+ -- Arbitrary cycle
+
+ function Arccos (A, Cycle : Real) return Real is
+ Temp : Real'Base;
+
+ begin
+ if Cycle <= 0.0 then
+ raise Argument_Error;
+
+ elsif abs A > 1.0 then
+ raise Argument_Error;
+
+ elsif abs A < Square_Root_Epsilon then
+ return Cycle / 4.0;
+
+ elsif A = 1.0 then
+ return 0.0;
+
+ elsif A = -1.0 then
+ return Cycle / 2.0;
+ end if;
+
+ Temp := Arctan (Sqrt (1.0 - A * A) / A, 1.0, Cycle);
+
+ if Temp < 0.0 then
+ Temp := Cycle / 2.0 + Temp;
+ end if;
+
+ return Temp;
+ end Arccos;
+
+ -------------
+ -- Arccosh --
+ -------------
+
+ function Arccosh (A : Real) return Real is
+ begin
+ -- Return Log (A - Sqrt (A * A - 1.0)); double valued,
+ -- only positive value returned
+ -- What is this comment ???
+
+ if A < 1.0 then
+ raise Argument_Error;
+
+ elsif A < 1.0 + Square_Root_Epsilon then
+ return A - 1.0;
+
+ elsif abs A > 1.0 / Square_Root_Epsilon then
+ return Log (A) + Log_Two;
+
+ else
+ return Log (A + Sqrt (A * A - 1.0));
+ end if;
+ end Arccosh;
+
+ ------------
+ -- Arccot --
+ ------------
+
+ -- Natural cycle
+
+ function Arccot
+ (A : Real;
+ Y : Real := 1.0)
+ return Real
+ is
+ begin
+ -- Just reverse arguments
+
+ return Arctan (Y, A);
+ end Arccot;
+
+ -- Arbitrary cycle
+
+ function Arccot
+ (A : Real;
+ Y : Real := 1.0;
+ Cycle : Real)
+ return Real
+ is
+ begin
+ -- Just reverse arguments
+
+ return Arctan (Y, A, Cycle);
+ end Arccot;
+
+ -------------
+ -- Arccoth --
+ -------------
+
+ function Arccoth (A : Real) return Real is
+ begin
+ if abs A = 1.0 then
+ raise Constraint_Error;
+
+ elsif abs A < 1.0 then
+ raise Argument_Error;
+
+ elsif abs A > 1.0 / Epsilon then
+ return 0.0;
+
+ else
+ return 0.5 * Log ((1.0 + A) / (A - 1.0));
+ end if;
+ end Arccoth;
+
+ ------------
+ -- Arcsin --
+ ------------
+
+ -- Natural cycle
+
+ function Arcsin (A : Real) return Real is
+ begin
+ if abs A > 1.0 then
+ raise Argument_Error;
+
+ elsif abs A < Square_Root_Epsilon then
+ return A;
+
+ elsif A = 1.0 then
+ return Pi / 2.0;
+
+ elsif A = -1.0 then
+ return -Pi / 2.0;
+ end if;
+
+ return Real (Aux.asin (Double (A)));
+ end Arcsin;
+
+ -- Arbitrary cycle
+
+ function Arcsin (A, Cycle : Real) return Real is
+ begin
+ if Cycle <= 0.0 then
+ raise Argument_Error;
+
+ elsif abs A > 1.0 then
+ raise Argument_Error;
+
+ elsif A = 0.0 then
+ return A;
+
+ elsif A = 1.0 then
+ return Cycle / 4.0;
+
+ elsif A = -1.0 then
+ return -Cycle / 4.0;
+ end if;
+
+ return Arctan (A / Sqrt (1.0 - A * A), 1.0, Cycle);
+ end Arcsin;
+
+ -------------
+ -- Arcsinh --
+ -------------
+
+ function Arcsinh (A : Real) return Real is
+ begin
+ if abs A < Square_Root_Epsilon then
+ return A;
+
+ elsif A > 1.0 / Square_Root_Epsilon then
+ return Log (A) + Log_Two;
+
+ elsif A < -1.0 / Square_Root_Epsilon then
+ return -(Log (-A) + Log_Two);
+
+ elsif A < 0.0 then
+ return -Log (abs A + Sqrt (A * A + 1.0));
+
+ else
+ return Log (A + Sqrt (A * A + 1.0));
+ end if;
+ end Arcsinh;
+
+ ------------
+ -- Arctan --
+ ------------
+
+ -- Natural cycle
+
+ function Arctan
+ (Y : Real;
+ A : Real := 1.0)
+ return Real
+ is
+ begin
+ if A = 0.0
+ and then Y = 0.0
+ then
+ raise Argument_Error;
+
+ elsif Y = 0.0 then
+ if A > 0.0 then
+ return 0.0;
+ else -- A < 0.0
+ return Pi;
+ end if;
+
+ elsif A = 0.0 then
+ if Y > 0.0 then
+ return Half_Pi;
+ else -- Y < 0.0
+ return -Half_Pi;
+ end if;
+
+ else
+ return Local_Atan (Y, A);
+ end if;
+ end Arctan;
+
+ -- Arbitrary cycle
+
+ function Arctan
+ (Y : Real;
+ A : Real := 1.0;
+ Cycle : Real)
+ return Real
+ is
+ begin
+ if Cycle <= 0.0 then
+ raise Argument_Error;
+
+ elsif A = 0.0
+ and then Y = 0.0
+ then
+ raise Argument_Error;
+
+ elsif Y = 0.0 then
+ if A > 0.0 then
+ return 0.0;
+ else -- A < 0.0
+ return Cycle / 2.0;
+ end if;
+
+ elsif A = 0.0 then
+ if Y > 0.0 then
+ return Cycle / 4.0;
+ else -- Y < 0.0
+ return -Cycle / 4.0;
+ end if;
+
+ else
+ return Local_Atan (Y, A) * Cycle / Two_Pi;
+ end if;
+ end Arctan;
+
+ -------------
+ -- Arctanh --
+ -------------
+
+ function Arctanh (A : Real) return Real is
+ begin
+ if abs A = 1.0 then
+ raise Constraint_Error;
+
+ elsif abs A > 1.0 then
+ raise Argument_Error;
+
+ elsif abs A < Square_Root_Epsilon then
+ return A;
+
+ else
+ return 0.5 * Log ((1.0 + A) / (1.0 - A));
+ end if;
+ end Arctanh;
+
+ ---------
+ -- Cos --
+ ---------
+
+ -- Natural cycle
+
+ function Cos (A : Real) return Real is
+ begin
+ if A = 0.0 then
+ return 1.0;
+
+ elsif abs A < Square_Root_Epsilon then
+ return 1.0;
+
+ end if;
+
+ return Real (Aux.Cos (Double (A)));
+ end Cos;
+
+ -- Arbitrary cycle
+
+ function Cos (A, Cycle : Real) return Real is
+ T : Real'Base;
+
+ begin
+ if Cycle <= 0.0 then
+ raise Argument_Error;
+
+ elsif A = 0.0 then
+ return 1.0;
+ end if;
+
+ T := Exact_Remainder (abs (A), Cycle) / Cycle;
+
+ if T = 0.25
+ or else T = 0.75
+ or else T = -0.25
+ or else T = -0.75
+ then
+ return 0.0;
+
+ elsif T = 0.5 or T = -0.5 then
+ return -1.0;
+ end if;
+
+ return Real (Aux.Cos (Double (T * Two_Pi)));
+ end Cos;
+
+ ----------
+ -- Cosh --
+ ----------
+
+ function Cosh (A : Real) return Real is
+ begin
+ if abs A < Square_Root_Epsilon then
+ return 1.0;
+
+ elsif abs A > Log_Inverse_Epsilon then
+ return Exp ((abs A) - Log_Two);
+ end if;
+
+ return Real (Aux.cosh (Double (A)));
+
+ exception
+ when others =>
+ raise Constraint_Error;
+ end Cosh;
+
+ ---------
+ -- Cot --
+ ---------
+
+ -- Natural cycle
+
+ function Cot (A : Real) return Real is
+ begin
+ if A = 0.0 then
+ raise Constraint_Error;
+
+ elsif abs A < Square_Root_Epsilon then
+ return 1.0 / A;
+ end if;
+
+ return Real (1.0 / Real'Base (Aux.tan (Double (A))));
+ end Cot;
+
+ -- Arbitrary cycle
+
+ function Cot (A, Cycle : Real) return Real is
+ T : Real'Base;
+
+ begin
+ if Cycle <= 0.0 then
+ raise Argument_Error;
+
+ elsif A = 0.0 then
+ raise Constraint_Error;
+
+ elsif abs A < Square_Root_Epsilon then
+ return 1.0 / A;
+ end if;
+
+ T := Exact_Remainder (A, Cycle) / Cycle;
+
+ if T = 0.0 or T = 0.5 or T = -0.5 then
+ raise Constraint_Error;
+ else
+ return Cos (T * Two_Pi) / Sin (T * Two_Pi);
+ end if;
+ end Cot;
+
+ ----------
+ -- Coth --
+ ----------
+
+ function Coth (A : Real) return Real is
+ begin
+ if A = 0.0 then
+ raise Constraint_Error;
+
+ elsif A < Half_Log_Epsilon then
+ return -1.0;
+
+ elsif A > -Half_Log_Epsilon then
+ return 1.0;
+
+ elsif abs A < Square_Root_Epsilon then
+ return 1.0 / A;
+ end if;
+
+ return Real (1.0 / Real'Base (Aux.tanh (Double (A))));
+ end Coth;
+
+ ---------------------
+ -- Exact_Remainder --
+ ---------------------
+
+ function Exact_Remainder
+ (A : Real;
+ Y : Real)
+ return Real
+ is
+ Denominator : Real'Base := abs A;
+ Divisor : Real'Base := abs Y;
+ Reducer : Real'Base;
+ Sign : Real'Base := 1.0;
+
+ begin
+ if Y = 0.0 then
+ raise Constraint_Error;
+
+ elsif A = 0.0 then
+ return 0.0;
+
+ elsif A = Y then
+ return 0.0;
+
+ elsif Denominator < Divisor then
+ return A;
+ end if;
+
+ while Denominator >= Divisor loop
+
+ -- Put divisors mantissa with denominators exponent to make reducer
+
+ Reducer := Divisor;
+
+ begin
+ while Reducer * 1_048_576.0 < Denominator loop
+ Reducer := Reducer * 1_048_576.0;
+ end loop;
+
+ exception
+ when others => null;
+ end;
+
+ begin
+ while Reducer * 1_024.0 < Denominator loop
+ Reducer := Reducer * 1_024.0;
+ end loop;
+
+ exception
+ when others => null;
+ end;
+
+ begin
+ while Reducer * 2.0 < Denominator loop
+ Reducer := Reducer * 2.0;
+ end loop;
+
+ exception
+ when others => null;
+ end;
+
+ Denominator := Denominator - Reducer;
+ end loop;
+
+ if A < 0.0 then
+ return -Denominator;
+ else
+ return Denominator;
+ end if;
+ end Exact_Remainder;
+
+ ---------
+ -- Exp --
+ ---------
+
+ function Exp (A : Real) return Real is
+ Result : Real'Base;
+
+ begin
+ if A = 0.0 then
+ return 1.0;
+
+ else
+ Result := Real (Aux.Exp (Double (A)));
+
+ -- The check here catches the case of Exp returning IEEE infinity
+
+ if Result > Real'Last then
+ raise Constraint_Error;
+ else
+ return Result;
+ end if;
+ end if;
+ end Exp;
+
+ ----------------------
+ -- Half_Log_Epsilon --
+ ----------------------
+
+ -- Cannot precompute this constant, because this is required to be a
+ -- pure package, which allows no state. A pity, but no way around it!
+
+ function Half_Log_Epsilon return Real is
+ begin
+ return Real (0.5 * Real'Base (Aux.Log (DEpsilon)));
+ end Half_Log_Epsilon;
+
+ ----------------
+ -- Local_Atan --
+ ----------------
+
+ function Local_Atan
+ (Y : Real;
+ A : Real := 1.0)
+ return Real
+ is
+ Z : Real'Base;
+ Raw_Atan : Real'Base;
+
+ begin
+ if abs Y > abs A then
+ Z := abs (A / Y);
+ else
+ Z := abs (Y / A);
+ end if;
+
+ if Z < Square_Root_Epsilon then
+ Raw_Atan := Z;
+
+ elsif Z = 1.0 then
+ Raw_Atan := Pi / 4.0;
+
+ elsif Z < Square_Root_Epsilon then
+ Raw_Atan := Z;
+
+ else
+ Raw_Atan := Real'Base (Aux.Atan (Double (Z)));
+ end if;
+
+ if abs Y > abs A then
+ Raw_Atan := Half_Pi - Raw_Atan;
+ end if;
+
+ if A > 0.0 then
+ if Y > 0.0 then
+ return Raw_Atan;
+ else -- Y < 0.0
+ return -Raw_Atan;
+ end if;
+
+ else -- A < 0.0
+ if Y > 0.0 then
+ return Pi - Raw_Atan;
+ else -- Y < 0.0
+ return -(Pi - Raw_Atan);
+ end if;
+ end if;
+ end Local_Atan;
+
+ ---------
+ -- Log --
+ ---------
+
+ -- Natural base
+
+ function Log (A : Real) return Real is
+ begin
+ if A < 0.0 then
+ raise Argument_Error;
+
+ elsif A = 0.0 then
+ raise Constraint_Error;
+
+ elsif A = 1.0 then
+ return 0.0;
+ end if;
+
+ return Real (Aux.Log (Double (A)));
+ end Log;
+
+ -- Arbitrary base
+
+ function Log (A, Base : Real) return Real is
+ begin
+ if A < 0.0 then
+ raise Argument_Error;
+
+ elsif Base <= 0.0 or else Base = 1.0 then
+ raise Argument_Error;
+
+ elsif A = 0.0 then
+ raise Constraint_Error;
+
+ elsif A = 1.0 then
+ return 0.0;
+ end if;
+
+ return Real (Aux.Log (Double (A)) / Aux.Log (Double (Base)));
+ end Log;
+
+ -------------------------
+ -- Log_Inverse_Epsilon --
+ -------------------------
+
+ -- Cannot precompute this constant, because this is required to be a
+ -- pure package, which allows no state. A pity, but no way around it!
+
+ function Log_Inverse_Epsilon return Real is
+ begin
+ return Real (Aux.Log (DIEpsilon));
+ end Log_Inverse_Epsilon;
+
+ ---------
+ -- Sin --
+ ---------
+
+ -- Natural cycle
+
+ function Sin (A : Real) return Real is
+ begin
+ if abs A < Square_Root_Epsilon then
+ return A;
+ end if;
+
+ return Real (Aux.Sin (Double (A)));
+ end Sin;
+
+ -- Arbitrary cycle
+
+ function Sin (A, Cycle : Real) return Real is
+ T : Real'Base;
+
+ begin
+ if Cycle <= 0.0 then
+ raise Argument_Error;
+
+ elsif A = 0.0 then
+ return A;
+ end if;
+
+ T := Exact_Remainder (A, Cycle) / Cycle;
+
+ if T = 0.0 or T = 0.5 or T = -0.5 then
+ return 0.0;
+
+ elsif T = 0.25 or T = -0.75 then
+ return 1.0;
+
+ elsif T = -0.25 or T = 0.75 then
+ return -1.0;
+
+ end if;
+
+ return Real (Aux.Sin (Double (T * Two_Pi)));
+ end Sin;
+
+ ----------
+ -- Sinh --
+ ----------
+
+ function Sinh (A : Real) return Real is
+ begin
+ if abs A < Square_Root_Epsilon then
+ return A;
+
+ elsif A > Log_Inverse_Epsilon then
+ return Exp (A - Log_Two);
+
+ elsif A < -Log_Inverse_Epsilon then
+ return -Exp ((-A) - Log_Two);
+ end if;
+
+ return Real (Aux.Sinh (Double (A)));
+
+ exception
+ when others =>
+ raise Constraint_Error;
+ end Sinh;
+
+ -------------------------
+ -- Square_Root_Epsilon --
+ -------------------------
+
+ -- Cannot precompute this constant, because this is required to be a
+ -- pure package, which allows no state. A pity, but no way around it!
+
+ function Square_Root_Epsilon return Real is
+ begin
+ return Real (Aux.Sqrt (DEpsilon));
+ end Square_Root_Epsilon;
+
+ ----------
+ -- Sqrt --
+ ----------
+
+ function Sqrt (A : Real) return Real is
+ begin
+ if A < 0.0 then
+ raise Argument_Error;
+
+ -- Special case Sqrt (0.0) to preserve possible minus sign per IEEE
+
+ elsif A = 0.0 then
+ return A;
+
+ -- Sqrt (1.0) must be exact for good complex accuracy
+
+ elsif A = 1.0 then
+ return 1.0;
+
+ end if;
+
+ return Real (Aux.Sqrt (Double (A)));
+ end Sqrt;
+
+ ---------
+ -- Tan --
+ ---------
+
+ -- Natural cycle
+
+ function Tan (A : Real) return Real is
+ begin
+ if abs A < Square_Root_Epsilon then
+ return A;
+
+ elsif abs A = Pi / 2.0 then
+ raise Constraint_Error;
+ end if;
+
+ return Real (Aux.tan (Double (A)));
+ end Tan;
+
+ -- Arbitrary cycle
+
+ function Tan (A, Cycle : Real) return Real is
+ T : Real'Base;
+
+ begin
+ if Cycle <= 0.0 then
+ raise Argument_Error;
+
+ elsif A = 0.0 then
+ return A;
+ end if;
+
+ T := Exact_Remainder (A, Cycle) / Cycle;
+
+ if T = 0.25
+ or else T = 0.75
+ or else T = -0.25
+ or else T = -0.75
+ then
+ raise Constraint_Error;
+
+ else
+ return Sin (T * Two_Pi) / Cos (T * Two_Pi);
+ end if;
+ end Tan;
+
+ ----------
+ -- Tanh --
+ ----------
+
+ function Tanh (A : Real) return Real is
+ begin
+ if A < Half_Log_Epsilon then
+ return -1.0;
+
+ elsif A > -Half_Log_Epsilon then
+ return 1.0;
+
+ elsif abs A < Square_Root_Epsilon then
+ return A;
+ end if;
+
+ return Real (Aux.tanh (Double (A)));
+ end Tanh;
+
+ ----------------------------
+ -- DEC-Specific functions --
+ ----------------------------
+
+ function LOG10 (A : REAL) return REAL is
+ begin
+ return Log (A, 10.0);
+ end LOG10;
+
+ function LOG2 (A : REAL) return REAL is
+ begin
+ return Log (A, 2.0);
+ end LOG2;
+
+ function ASIN (A : REAL) return REAL renames Arcsin;
+ function ACOS (A : REAL) return REAL renames Arccos;
+
+ function ATAN (A : REAL) return REAL is
+ begin
+ return Arctan (A, 1.0);
+ end ATAN;
+
+ function ATAN2 (A1, A2 : REAL) return REAL renames Arctan;
+
+ function SIND (A : REAL) return REAL is
+ begin
+ return Sin (A, 360.0);
+ end SIND;
+
+ function COSD (A : REAL) return REAL is
+ begin
+ return Cos (A, 360.0);
+ end COSD;
+
+ function TAND (A : REAL) return REAL is
+ begin
+ return Tan (A, 360.0);
+ end TAND;
+
+ function ASIND (A : REAL) return REAL is
+ begin
+ return Arcsin (A, 360.0);
+ end ASIND;
+
+ function ACOSD (A : REAL) return REAL is
+ begin
+ return Arccos (A, 360.0);
+ end ACOSD;
+
+ function Arctan (A : REAL) return REAL is
+ begin
+ return Arctan (A, 1.0, 360.0);
+ end Arctan;
+
+ function ATAND (A : REAL) return REAL is
+ begin
+ return Arctan (A, 1.0, 360.0);
+ end ATAND;
+
+ function ATAN2D (A1, A2 : REAL) return REAL is
+ begin
+ return Arctan (A1, A2, 360.0);
+ end ATAN2D;
+
+end Math_Lib;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M D L L --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides the core high level routines used by GNATDLL
+-- to build Windows DLL
+
+with Ada.Text_IO;
+
+with MDLL.Tools;
+with MDLL.Files;
+
+package body MDLL is
+
+ use Ada;
+ use GNAT;
+
+ ---------------------------
+ -- Build_Dynamic_Library --
+ ---------------------------
+
+ procedure Build_Dynamic_Library
+ (Ofiles : in Argument_List;
+ Afiles : in Argument_List;
+ Options : in Argument_List;
+ Bargs_Options : in Argument_List;
+ Largs_Options : in Argument_List;
+ Lib_Filename : in String;
+ Def_Filename : in String;
+ Lib_Address : in String := "";
+ Build_Import : in Boolean := False;
+ Relocatable : in Boolean := False)
+ is
+
+ use type OS_Lib.Argument_List;
+
+ Base_Filename : constant String := MDLL.Files.Ext_To (Lib_Filename);
+
+ Def_File : aliased String := Def_Filename;
+ Jnk_File : aliased String := Base_Filename & ".jnk";
+ Bas_File : aliased String := Base_Filename & ".base";
+ Dll_File : aliased String := Base_Filename & ".dll";
+ Exp_File : aliased String := Base_Filename & ".exp";
+ Lib_File : aliased String := "lib" & Base_Filename & ".a";
+
+ Bas_Opt : aliased String := "-Wl,--base-file," & Bas_File;
+ Lib_Opt : aliased String := "-mdll";
+ Out_Opt : aliased String := "-o";
+
+ All_Options : constant Argument_List := Options & Largs_Options;
+
+
+ procedure Build_Reloc_DLL;
+ -- build a relocatable DLL with only objects file specified.
+ -- this use the well known 5 steps build. (see GNAT User's Guide).
+
+ procedure Ada_Build_Reloc_DLL;
+ -- build a relocatable DLL with Ada code.
+ -- this use the well known 5 steps build. (see GNAT User's Guide).
+
+ procedure Build_Non_Reloc_DLL;
+ -- build a non relocatable DLL containing no Ada code.
+
+ procedure Ada_Build_Non_Reloc_DLL;
+ -- build a non relocatable DLL with Ada code.
+
+ ---------------------
+ -- Build_Reloc_DLL --
+ ---------------------
+
+ procedure Build_Reloc_DLL is
+
+ -- objects plus the export table (.exp) file
+
+ Objects_Exp_File : OS_Lib.Argument_List
+ := Exp_File'Unchecked_Access & Ofiles;
+
+ begin
+ if not Quiet then
+ Text_IO.Put_Line ("building relocatable DLL...");
+ Text_IO.Put ("make " & Dll_File);
+
+ if Build_Import then
+ Text_IO.Put_Line (" and " & Lib_File);
+ else
+ Text_IO.New_Line;
+ end if;
+ end if;
+
+ -- 1) build base file with objects files.
+
+ Tools.Gcc (Output_File => Jnk_File,
+ Files => Ofiles,
+ Options => All_Options,
+ Base_File => Bas_File,
+ Build_Lib => True);
+
+ -- 2) build exp from base file.
+
+ Tools.Dlltool (Def_File, Dll_File, Lib_File,
+ Base_File => Bas_File,
+ Exp_Table => Exp_File,
+ Build_Import => False);
+
+ -- 3) build base file with exp file and objects files.
+
+ Tools.Gcc (Output_File => Jnk_File,
+ Files => Objects_Exp_File,
+ Options => All_Options,
+ Base_File => Bas_File,
+ Build_Lib => True);
+
+ -- 4) build new exp from base file and the lib file (.a)
+
+ Tools.Dlltool (Def_File, Dll_File, Lib_File,
+ Base_File => Bas_File,
+ Exp_Table => Exp_File,
+ Build_Import => Build_Import);
+
+ -- 5) build the dynamic library
+
+ Tools.Gcc (Output_File => Dll_File,
+ Files => Objects_Exp_File,
+ Options => All_Options,
+ Build_Lib => True);
+
+ Tools.Delete_File (Exp_File);
+ Tools.Delete_File (Bas_File);
+ Tools.Delete_File (Jnk_File);
+
+ exception
+ when others =>
+ Tools.Delete_File (Exp_File);
+ Tools.Delete_File (Bas_File);
+ Tools.Delete_File (Jnk_File);
+ raise;
+ end Build_Reloc_DLL;
+
+ -------------------------
+ -- Ada_Build_Reloc_DLL --
+ -------------------------
+
+ procedure Ada_Build_Reloc_DLL is
+ begin
+ if not Quiet then
+ Text_IO.Put_Line ("Building relocatable DLL...");
+ Text_IO.Put ("make " & Dll_File);
+
+ if Build_Import then
+ Text_IO.Put_Line (" and " & Lib_File);
+ else
+ Text_IO.New_Line;
+ end if;
+ end if;
+
+ -- 1) build base file with objects files.
+
+ Tools.Gnatbind (Afiles, Options & Bargs_Options);
+
+ declare
+ Params : OS_Lib.Argument_List :=
+ Out_Opt'Unchecked_Access & Jnk_File'Unchecked_Access &
+ Lib_Opt'Unchecked_Access &
+ Bas_Opt'Unchecked_Access & Ofiles & All_Options;
+ begin
+ Tools.Gnatlink (Afiles (Afiles'Last).all,
+ Params);
+ end;
+
+ -- 2) build exp from base file.
+
+ Tools.Dlltool (Def_File, Dll_File, Lib_File,
+ Base_File => Bas_File,
+ Exp_Table => Exp_File,
+ Build_Import => False);
+
+ -- 3) build base file with exp file and objects files.
+
+ Tools.Gnatbind (Afiles, Options & Bargs_Options);
+
+ declare
+ Params : OS_Lib.Argument_List :=
+ Out_Opt'Unchecked_Access & Jnk_File'Unchecked_Access &
+ Lib_Opt'Unchecked_Access &
+ Bas_Opt'Unchecked_Access &
+ Exp_File'Unchecked_Access &
+ Ofiles &
+ All_Options;
+ begin
+ Tools.Gnatlink (Afiles (Afiles'Last).all,
+ Params);
+ end;
+
+ -- 4) build new exp from base file and the lib file (.a)
+
+ Tools.Dlltool (Def_File, Dll_File, Lib_File,
+ Base_File => Bas_File,
+ Exp_Table => Exp_File,
+ Build_Import => Build_Import);
+
+ -- 5) build the dynamic library
+
+ Tools.Gnatbind (Afiles, Options & Bargs_Options);
+
+ declare
+ Params : OS_Lib.Argument_List :=
+ Out_Opt'Unchecked_Access & Dll_File'Unchecked_Access &
+ Lib_Opt'Unchecked_Access &
+ Exp_File'Unchecked_Access &
+ Ofiles &
+ All_Options;
+ begin
+ Tools.Gnatlink (Afiles (Afiles'Last).all,
+ Params);
+ end;
+
+ Tools.Delete_File (Exp_File);
+ Tools.Delete_File (Bas_File);
+ Tools.Delete_File (Jnk_File);
+
+ exception
+ when others =>
+ Tools.Delete_File (Exp_File);
+ Tools.Delete_File (Bas_File);
+ Tools.Delete_File (Jnk_File);
+ raise;
+ end Ada_Build_Reloc_DLL;
+
+ -------------------------
+ -- Build_Non_Reloc_DLL --
+ -------------------------
+
+ procedure Build_Non_Reloc_DLL is
+ begin
+ if not Quiet then
+ Text_IO.Put_Line ("building non relocatable DLL...");
+ Text_IO.Put ("make " & Dll_File &
+ " using address " & Lib_Address);
+
+ if Build_Import then
+ Text_IO.Put_Line (" and " & Lib_File);
+ else
+ Text_IO.New_Line;
+ end if;
+ end if;
+
+ -- build exp table and the lib .a file.
+
+ Tools.Dlltool (Def_File, Dll_File, Lib_File,
+ Exp_Table => Exp_File,
+ Build_Import => Build_Import);
+
+ -- build the DLL
+
+ Tools.Gcc (Output_File => Dll_File,
+ Files => Exp_File'Unchecked_Access & Ofiles,
+ Options => All_Options,
+ Build_Lib => True);
+
+ Tools.Delete_File (Exp_File);
+
+ exception
+ when others =>
+ Tools.Delete_File (Exp_File);
+ raise;
+ end Build_Non_Reloc_DLL;
+
+ -----------------------------
+ -- Ada_Build_Non_Reloc_DLL --
+ -----------------------------
+
+ -- build a non relocatable DLL with Ada code.
+
+ procedure Ada_Build_Non_Reloc_DLL is
+ begin
+ if not Quiet then
+ Text_IO.Put_Line ("building non relocatable DLL...");
+ Text_IO.Put ("make " & Dll_File &
+ " using address " & Lib_Address);
+
+ if Build_Import then
+ Text_IO.Put_Line (" and " & Lib_File);
+ else
+ Text_IO.New_Line;
+ end if;
+ end if;
+
+ -- build exp table and the lib .a file.
+
+ Tools.Dlltool (Def_File, Dll_File, Lib_File,
+ Exp_Table => Exp_File,
+ Build_Import => Build_Import);
+
+ -- build the DLL
+
+ Tools.Gnatbind (Afiles, Options & Bargs_Options);
+
+ declare
+ Params : OS_Lib.Argument_List :=
+ Out_Opt'Unchecked_Access & Dll_File'Unchecked_Access &
+ Lib_Opt'Unchecked_Access &
+ Exp_File'Unchecked_Access &
+ Ofiles &
+ All_Options;
+ begin
+ Tools.Gnatlink (Afiles (Afiles'Last).all,
+ Params);
+ end;
+
+ Tools.Delete_File (Exp_File);
+
+ exception
+ when others =>
+ Tools.Delete_File (Exp_File);
+ raise;
+ end Ada_Build_Non_Reloc_DLL;
+
+ begin
+ case Relocatable is
+
+ when True =>
+ if Afiles'Length = 0 then
+ Build_Reloc_DLL;
+ else
+ Ada_Build_Reloc_DLL;
+ end if;
+
+ when False =>
+ if Afiles'Length = 0 then
+ Build_Non_Reloc_DLL;
+ else
+ Ada_Build_Non_Reloc_DLL;
+ end if;
+
+ end case;
+ end Build_Dynamic_Library;
+
+ --------------------------
+ -- Build_Import_Library --
+ --------------------------
+
+ procedure Build_Import_Library (Lib_Filename : in String;
+ Def_Filename : in String) is
+
+ procedure Build_Import_Library (Def_Base_Filename : in String);
+ -- build an import library.
+ -- this is to build only a .a library to link against a DLL.
+
+ Base_Filename : constant String := MDLL.Files.Ext_To (Lib_Filename);
+
+ --------------------------
+ -- Build_Import_Library --
+ --------------------------
+
+ procedure Build_Import_Library (Def_Base_Filename : in String) is
+
+ Def_File : String renames Def_Filename;
+ Dll_File : constant String := Def_Base_Filename & ".dll";
+ Lib_File : constant String := "lib" & Base_Filename & ".a";
+
+ begin
+
+ if not Quiet then
+ Text_IO.Put_Line ("Building import library...");
+ Text_IO.Put_Line ("make " & Lib_File &
+ " to use dynamic library " & Dll_File);
+ end if;
+
+ Tools.Dlltool (Def_File, Dll_File, Lib_File,
+ Build_Import => True);
+ end Build_Import_Library;
+
+ begin
+ -- if the library has the form lib<name>.a then the def file should
+ -- be <name>.def and the DLL to link against <name>.dll
+ -- this is a Windows convention and we try as much as possible to
+ -- follow the platform convention.
+
+ if Lib_Filename'Length > 3 and then Lib_Filename (1 .. 3) = "lib" then
+ Build_Import_Library (Base_Filename (4 .. Base_Filename'Last));
+ else
+ Build_Import_Library (Base_Filename);
+ end if;
+ end Build_Import_Library;
+
+end MDLL;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M D L L --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides the core high level routines used by GNATDLL
+-- to build Windows DLL
+
+with GNAT.OS_Lib;
+
+package MDLL is
+
+ subtype Argument_List is GNAT.OS_Lib.Argument_List;
+ subtype Argument_List_Access is GNAT.OS_Lib.Argument_List_Access;
+
+ Null_Argument_List : constant Argument_List := (1 .. 0 => new String'(""));
+
+ Null_Argument_List_Access : Argument_List_Access
+ := new Argument_List (1 .. 0);
+
+ Tools_Error : exception;
+
+ Verbose : Boolean := False;
+ Quiet : Boolean := False;
+
+ -- Kill_Suffix is used by dlltool to know whether or not the @nn suffix
+ -- should be removed from the exported names. When Kill_Suffix is set to
+ -- True then dlltool -k option is used.
+
+ Kill_Suffix : Boolean := False;
+
+ procedure Build_Dynamic_Library (Ofiles : in Argument_List;
+ Afiles : in Argument_List;
+ Options : in Argument_List;
+ Bargs_Options : in Argument_List;
+ Largs_Options : in Argument_List;
+ Lib_Filename : in String;
+ Def_Filename : in String;
+ Lib_Address : in String := "";
+ Build_Import : in Boolean := False;
+ Relocatable : in Boolean := False);
+ -- build a DLL and the import library to link against the DLL.
+ -- this function handles relocatable and non relocatable DLL.
+ -- If the Afiles argument list contains some Ada units then it will
+ -- generate the right adainit and adafinal and integrate it in the DLL.
+ -- If the Afiles argument list is empty (there is only some object files
+ -- provided) then it will not try to build a binder file. This is ok to
+ -- build DLL containing no Ada code.
+
+ procedure Build_Import_Library (Lib_Filename : in String;
+ Def_Filename : in String);
+ -- Build an import library (.a) from a definition files. An import library
+ -- is needed to link against a DLL.
+
+end MDLL;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M D L L . F I L E S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Simple services used by GNATDLL to deal with Filename extension.
+
+with Ada.Strings.Fixed;
+
+package body MDLL.Files is
+
+ use Ada;
+
+ -------------
+ -- Get_Ext --
+ -------------
+
+ function Get_Ext (Filename : in String)
+ return String
+ is
+ use Strings.Fixed;
+ I : constant Natural := Index (Filename, ".", Strings.Backward);
+ begin
+ if I = 0 then
+ return "";
+ else
+ return Filename (I .. Filename'Last);
+ end if;
+ end Get_Ext;
+
+ ------------
+ -- Is_Ali --
+ ------------
+
+ function Is_Ali (Filename : in String)
+ return Boolean is
+ begin
+ return Get_Ext (Filename) = ".ali";
+ end Is_Ali;
+
+ ------------
+ -- Is_Obj --
+ ------------
+
+ function Is_Obj (Filename : in String)
+ return Boolean
+ is
+ Ext : constant String := Get_Ext (Filename);
+ begin
+ return Ext = ".o" or else Ext = ".obj";
+ end Is_Obj;
+
+ ------------
+ -- Ext_To --
+ ------------
+
+ function Ext_To (Filename : in String;
+ New_Ext : in String := No_Ext)
+ return String
+ is
+ use Strings.Fixed;
+ I : constant Natural := Index (Filename, ".", Strings.Backward);
+ begin
+ if I = 0 then
+ return Filename;
+ else
+ if New_Ext = "" then
+ return Head (Filename, I - 1);
+ else
+ return Head (Filename, I - 1) & '.' & New_Ext;
+ end if;
+ end if;
+ end Ext_To;
+
+end MDLL.Files;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M D L L . F I L E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 1992-1999 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Simple services used by GNATDLL to deal with Filename extension.
+
+package MDLL.Files is
+
+ No_Ext : constant String := "";
+
+ function Get_Ext (Filename : in String)
+ return String;
+ -- return filename's extention.
+
+ function Is_Ali (Filename : in String)
+ return Boolean;
+ -- test if Filename is an Ada library file (.ali).
+
+ function Is_Obj (Filename : in String)
+ return Boolean;
+ -- test if Filename is an object file (.o or .obj).
+
+ function Ext_To (Filename : in String;
+ New_Ext : in String := No_Ext)
+ return String;
+ -- return Filename with the extention change to New_Ext.
+
+end MDLL.Files;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M D L L . T O O L S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Interface to externals tools used to build DLL and import libraries
+
+with Ada.Text_IO;
+with Ada.Exceptions;
+with Ada.Unchecked_Deallocation;
+
+with Sdefault;
+
+package body MDLL.Tools is
+
+ use Ada;
+ use GNAT;
+
+ Dlltool_Name : constant String := "dlltool";
+ Dlltool_Exec : OS_Lib.String_Access;
+
+ Gcc_Name : constant String := "gcc";
+ Gcc_Exec : OS_Lib.String_Access;
+
+ Gnatbind_Name : constant String := "gnatbind";
+ Gnatbind_Exec : OS_Lib.String_Access;
+
+ Gnatlink_Name : constant String := "gnatlink";
+ Gnatlink_Exec : OS_Lib.String_Access;
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (OS_Lib.Argument_List,
+ OS_Lib.Argument_List_Access);
+
+ procedure Print_Command (Tool_Name : in String;
+ Arguments : in OS_Lib.Argument_List);
+ -- display the command runned when in Verbose mode
+
+ -------------------
+ -- Print_Command --
+ -------------------
+
+ procedure Print_Command (Tool_Name : in String;
+ Arguments : in OS_Lib.Argument_List) is
+ begin
+ if Verbose then
+ Text_IO.Put (Tool_Name);
+ for K in Arguments'Range loop
+ Text_IO.Put (" " & Arguments (K).all);
+ end loop;
+ Text_IO.New_Line;
+ end if;
+ end Print_Command;
+
+ -----------------
+ -- Delete_File --
+ -----------------
+
+ procedure Delete_File (Filename : in String) is
+ File : constant String := Filename & ASCII.Nul;
+ Sucess : Boolean;
+ begin
+ OS_Lib.Delete_File (File'Address, Sucess);
+ end Delete_File;
+
+ -------------
+ -- Dlltool --
+ -------------
+
+ procedure Dlltool (Def_Filename : in String;
+ DLL_Name : in String;
+ Library : in String;
+ Exp_Table : in String := "";
+ Base_File : in String := "";
+ Build_Import : in Boolean)
+ is
+
+ Arguments : OS_Lib.Argument_List (1 .. 11);
+ A : Positive;
+
+ Success : Boolean;
+
+ Def_Opt : aliased String := "--def";
+ Def_V : aliased String := Def_Filename;
+ Dll_Opt : aliased String := "--dllname";
+ Dll_V : aliased String := DLL_Name;
+ Lib_Opt : aliased String := "--output-lib";
+ Lib_V : aliased String := Library;
+ Exp_Opt : aliased String := "--output-exp";
+ Exp_V : aliased String := Exp_Table;
+ Bas_Opt : aliased String := "--base-file";
+ Bas_V : aliased String := Base_File;
+ No_Suf_Opt : aliased String := "-k";
+ begin
+ Arguments (1 .. 4) := (1 => Def_Opt'Unchecked_Access,
+ 2 => Def_V'Unchecked_Access,
+ 3 => Dll_Opt'Unchecked_Access,
+ 4 => Dll_V'Unchecked_Access);
+ A := 4;
+
+ if Kill_Suffix then
+ A := A + 1;
+ Arguments (A) := No_Suf_Opt'Unchecked_Access;
+ end if;
+
+ if Library /= "" and then Build_Import then
+ A := A + 1;
+ Arguments (A) := Lib_Opt'Unchecked_Access;
+ A := A + 1;
+ Arguments (A) := Lib_V'Unchecked_Access;
+ end if;
+
+ if Exp_Table /= "" then
+ A := A + 1;
+ Arguments (A) := Exp_Opt'Unchecked_Access;
+ A := A + 1;
+ Arguments (A) := Exp_V'Unchecked_Access;
+ end if;
+
+ if Base_File /= "" then
+ A := A + 1;
+ Arguments (A) := Bas_Opt'Unchecked_Access;
+ A := A + 1;
+ Arguments (A) := Bas_V'Unchecked_Access;
+ end if;
+
+ Print_Command ("dlltool", Arguments (1 .. A));
+
+ OS_Lib.Spawn (Dlltool_Exec.all, Arguments (1 .. A), Success);
+
+ if not Success then
+ Exceptions.Raise_Exception (Tools_Error'Identity,
+ Dlltool_Name & " execution error.");
+ end if;
+
+ end Dlltool;
+
+ ---------
+ -- Gcc --
+ ---------
+
+ procedure Gcc (Output_File : in String;
+ Files : in Argument_List;
+ Options : in Argument_List;
+ Base_File : in String := "";
+ Build_Lib : in Boolean := False)
+ is
+ use Sdefault;
+
+ Arguments : OS_Lib.Argument_List
+ (1 .. 5 + Files'Length + Options'Length);
+ A : Natural := 0;
+
+ Success : Boolean;
+ C_Opt : aliased String := "-c";
+ Out_Opt : aliased String := "-o";
+ Out_V : aliased String := Output_File;
+ Bas_Opt : aliased String := "-Wl,--base-file," & Base_File;
+ Lib_Opt : aliased String := "-mdll";
+ Lib_Dir : aliased String := "-L" & Object_Dir_Default_Name.all;
+
+ begin
+ A := A + 1;
+ if Build_Lib then
+ Arguments (A) := Lib_Opt'Unchecked_Access;
+ else
+ Arguments (A) := C_Opt'Unchecked_Access;
+ end if;
+
+ A := A + 1;
+ Arguments (A .. A + 2) := (Out_Opt'Unchecked_Access,
+ Out_V'Unchecked_Access,
+ Lib_Dir'Unchecked_Access);
+ A := A + 2;
+
+ if Base_File /= "" then
+ A := A + 1;
+ Arguments (A) := Bas_Opt'Unchecked_Access;
+ end if;
+
+ A := A + 1;
+ Arguments (A .. A + Files'Length - 1) := Files;
+ A := A + Files'Length - 1;
+
+ if Build_Lib then
+ A := A + 1;
+ Arguments (A .. A + Options'Length - 1) := Options;
+ A := A + Options'Length - 1;
+ else
+ declare
+ Largs : Argument_List (Options'Range);
+ L : Natural := Largs'First - 1;
+ begin
+ for K in Options'Range loop
+ if Options (K) (1 .. 2) /= "-l" then
+ L := L + 1;
+ Largs (L) := Options (K);
+ end if;
+ end loop;
+ A := A + 1;
+ Arguments (A .. A + L - 1) := Largs (1 .. L);
+ A := A + L - 1;
+ end;
+ end if;
+
+ Print_Command ("gcc", Arguments (1 .. A));
+
+ OS_Lib.Spawn (Gcc_Exec.all, Arguments (1 .. A), Success);
+
+ if not Success then
+ Exceptions.Raise_Exception (Tools_Error'Identity,
+ Gcc_Name & " execution error.");
+ end if;
+ end Gcc;
+
+ --------------
+ -- Gnatbind --
+ --------------
+
+ procedure Gnatbind (Alis : in Argument_List;
+ Args : in Argument_List := Null_Argument_List)
+ is
+ Arguments : OS_Lib.Argument_List (1 .. 1 + Alis'Length + Args'Length);
+ Success : Boolean;
+
+ No_Main_Opt : aliased String := "-n";
+
+ begin
+ Arguments (1) := No_Main_Opt'Unchecked_Access;
+ Arguments (2 .. 1 + Alis'Length) := Alis;
+ Arguments (2 + Alis'Length .. Arguments'Last) := Args;
+
+ Print_Command ("gnatbind", Arguments);
+
+ OS_Lib.Spawn (Gnatbind_Exec.all, Arguments, Success);
+
+ if not Success then
+ Exceptions.Raise_Exception (Tools_Error'Identity,
+ Gnatbind_Name & " execution error.");
+ end if;
+ end Gnatbind;
+
+ --------------
+ -- Gnatlink --
+ --------------
+
+ procedure Gnatlink (Ali : in String;
+ Args : in Argument_List := Null_Argument_List)
+ is
+ Arguments : OS_Lib.Argument_List (1 .. 1 + Args'Length);
+ Success : Boolean;
+
+ Ali_Name : aliased String := Ali;
+
+ begin
+ Arguments (1) := Ali_Name'Unchecked_Access;
+ Arguments (2 .. Arguments'Last) := Args;
+
+ Print_Command ("gnatlink", Arguments);
+
+ OS_Lib.Spawn (Gnatlink_Exec.all, Arguments, Success);
+
+ if not Success then
+ Exceptions.Raise_Exception (Tools_Error'Identity,
+ Gnatlink_Name & " execution error.");
+ end if;
+ end Gnatlink;
+
+ ------------
+ -- Locate --
+ ------------
+
+ procedure Locate is
+ use type OS_Lib.String_Access;
+ begin
+ -- dlltool
+
+ Dlltool_Exec := OS_Lib.Locate_Exec_On_Path (Dlltool_Name);
+
+ if Dlltool_Exec = null then
+ Exceptions.Raise_Exception (Tools_Error'Identity,
+ Dlltool_Name & " not found in path");
+ elsif Verbose then
+ Text_IO.Put_Line ("using " & Dlltool_Exec.all);
+ end if;
+
+ -- gcc
+
+ Gcc_Exec := OS_Lib.Locate_Exec_On_Path (Gcc_Name);
+
+ if Gcc_Exec = null then
+ Exceptions.Raise_Exception (Tools_Error'Identity,
+ Gcc_Name & " not found in path");
+ elsif Verbose then
+ Text_IO.Put_Line ("using " & Gcc_Exec.all);
+ end if;
+
+ -- gnatbind
+
+ Gnatbind_Exec := OS_Lib.Locate_Exec_On_Path (Gnatbind_Name);
+
+ if Gnatbind_Exec = null then
+ Exceptions.Raise_Exception (Tools_Error'Identity,
+ Gnatbind_Name & " not found in path");
+ elsif Verbose then
+ Text_IO.Put_Line ("using " & Gnatbind_Exec.all);
+ end if;
+
+ -- gnatlink
+
+ Gnatlink_Exec := OS_Lib.Locate_Exec_On_Path (Gnatlink_Name);
+
+ if Gnatlink_Exec = null then
+ Exceptions.Raise_Exception (Tools_Error'Identity,
+ Gnatlink_Name & " not found in path");
+ elsif Verbose then
+ Text_IO.Put_Line ("using " & Gnatlink_Exec.all);
+ Text_IO.New_Line;
+ end if;
+
+ end Locate;
+
+end MDLL.Tools;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M D L L . T O O L S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Interface to externals tools used to build DLL and import libraries
+
+package MDLL.Tools is
+
+ procedure Delete_File (Filename : in String);
+ -- delete the file filename from the file system.
+
+ procedure Dlltool (Def_Filename : in String;
+ DLL_Name : in String;
+ Library : in String;
+ Exp_Table : in String := "";
+ Base_File : in String := "";
+ Build_Import : in Boolean);
+ -- run dlltool binary.
+ -- this tools is used to build an import library and an export table
+
+ procedure Gcc (Output_File : in String;
+ Files : in Argument_List;
+ Options : in Argument_List;
+ Base_File : in String := "";
+ Build_Lib : in Boolean := False);
+ -- run gcc binary.
+
+ procedure Gnatbind (Alis : in Argument_List;
+ Args : in Argument_List := Null_Argument_List);
+ -- run gnatbind binary to build the binder program.
+ -- it runs the command : gnatbind -n alis... to build the binder program.
+
+ procedure Gnatlink (Ali : in String;
+ Args : in Argument_List := Null_Argument_List);
+ -- run gnatlink binary.
+ -- it runs the command : gnatlink ali arg1 arg2...
+
+ procedure Locate;
+ -- look for the needed tools in the path and record the full path for each
+ -- one in a variable.
+
+end MDLL.Tools;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M E M R O O T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.16 $
+-- --
+-- Copyright (C) 1997-2001 Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with GNAT.Table;
+with GNAT.HTable; use GNAT.HTable;
+with Ada.Text_IO; use Ada.Text_IO;
+
+package body Memroot is
+
+ -------------
+ -- Name_Id --
+ -------------
+
+ package Chars is new GNAT.Table (
+ Table_Component_Type => Character,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 10_000,
+ Table_Increment => 100);
+ -- The actual character container for names
+
+ type Name is record
+ First, Last : Integer;
+ end record;
+
+ package Names is new GNAT.Table (
+ Table_Component_Type => Name,
+ Table_Index_Type => Name_Id,
+ Table_Low_Bound => 0,
+ Table_Initial => 400,
+ Table_Increment => 100);
+
+ type Name_Range is range 1 .. 1023;
+
+ function Name_Eq (N1, N2 : Name) return Boolean;
+ -- compare 2 names
+
+ function H (N : Name) return Name_Range;
+
+ package Name_HTable is new GNAT.HTable.Simple_HTable (
+ Header_Num => Name_Range,
+ Element => Name_Id,
+ No_Element => No_Name_Id,
+ Key => Name,
+ Hash => H,
+ Equal => Name_Eq);
+
+ --------------
+ -- Frame_Id --
+ --------------
+
+ type Frame is record
+ Name, File, Line : Name_Id;
+ end record;
+
+ function Image
+ (F : Frame_Id;
+ Max_Fil : Integer;
+ Max_Lin : Integer)
+ return String;
+ -- Returns an image for F containing the file name, the Line number,
+ -- and the subprogram name. When possible, spaces are inserted between
+ -- the line number and the subprogram name in order to align images of the
+ -- same frame. Alignement is cimputed with Max_Fil & Max_Lin representing
+ -- the max number of character in a filename or length in a given frame.
+
+ package Frames is new GNAT.Table (
+ Table_Component_Type => Frame,
+ Table_Index_Type => Frame_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 400,
+ Table_Increment => 100);
+
+ type Frame_Range is range 1 .. 513;
+ function H (N : Frame) return Frame_Range;
+
+ package Frame_HTable is new GNAT.HTable.Simple_HTable (
+ Header_Num => Frame_Range,
+ Element => Frame_Id,
+ No_Element => No_Frame_Id,
+ Key => Frame,
+ Hash => H,
+ Equal => "=");
+
+ -------------
+ -- Root_Id --
+ -------------
+
+ type Root is record
+ First, Last : Integer;
+ Nb_Alloc : Integer;
+ Alloc_Size : Storage_Count;
+ High_Water_Mark : Storage_Count;
+ end record;
+
+ package Frames_In_Root is new GNAT.Table (
+ Table_Component_Type => Frame_Id,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 400,
+ Table_Increment => 100);
+
+ package Roots is new GNAT.Table (
+ Table_Component_Type => Root,
+ Table_Index_Type => Root_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 200,
+ Table_Increment => 100);
+ type Root_Range is range 1 .. 513;
+
+ function Root_Eq (N1, N2 : Root) return Boolean;
+ function H (B : Root) return Root_Range;
+
+ package Root_HTable is new GNAT.HTable.Simple_HTable (
+ Header_Num => Root_Range,
+ Element => Root_Id,
+ No_Element => No_Root_Id,
+ Key => Root,
+ Hash => H,
+ Equal => Root_Eq);
+
+ ----------------
+ -- Alloc_Size --
+ ----------------
+
+ function Alloc_Size (B : Root_Id) return Storage_Count is
+ begin
+ return Roots.Table (B).Alloc_Size;
+ end Alloc_Size;
+
+ -----------------
+ -- Enter_Frame --
+ -----------------
+
+ function Enter_Frame (Name, File, Line : Name_Id) return Frame_Id is
+ Res : Frame_Id;
+
+ begin
+ Frames.Increment_Last;
+ Frames.Table (Frames.Last) := Frame'(Name, File, Line);
+ Res := Frame_HTable.Get (Frames.Table (Frames.Last));
+
+ if Res /= No_Frame_Id then
+ Frames.Decrement_Last;
+ return Res;
+
+ else
+ Frame_HTable.Set (Frames.Table (Frames.Last), Frames.Last);
+ return Frames.Last;
+ end if;
+ end Enter_Frame;
+
+ ----------------
+ -- Enter_Name --
+ ----------------
+
+ function Enter_Name (S : String) return Name_Id is
+ Old_L : constant Integer := Chars.Last;
+ Len : constant Integer := S'Length;
+ F : constant Integer := Chars.Allocate (Len);
+ Res : Name_Id;
+
+ begin
+ Chars.Table (F .. F + Len - 1) := Chars.Table_Type (S);
+ Names.Increment_Last;
+ Names.Table (Names.Last) := Name'(F, F + Len - 1);
+ Res := Name_HTable.Get (Names.Table (Names.Last));
+
+ if Res /= No_Name_Id then
+ Names.Decrement_Last;
+ Chars.Set_Last (Old_L);
+ return Res;
+
+ else
+ Name_HTable.Set (Names.Table (Names.Last), Names.Last);
+ return Names.Last;
+ end if;
+ end Enter_Name;
+
+ ----------------
+ -- Enter_Root --
+ ----------------
+
+ function Enter_Root (Fr : Frame_Array) return Root_Id is
+ Old_L : constant Integer := Frames_In_Root.Last;
+ Len : constant Integer := Fr'Length;
+ F : constant Integer := Frames_In_Root.Allocate (Len);
+ Res : Root_Id;
+
+ begin
+ Frames_In_Root.Table (F .. F + Len - 1) :=
+ Frames_In_Root.Table_Type (Fr);
+ Roots.Increment_Last;
+ Roots.Table (Roots.Last) := Root'(F, F + Len - 1, 0, 0, 0);
+ Res := Root_HTable.Get (Roots.Table (Roots.Last));
+
+ if Res /= No_Root_Id then
+ Frames_In_Root.Set_Last (Old_L);
+ Roots.Decrement_Last;
+ return Res;
+
+ else
+ Root_HTable.Set (Roots.Table (Roots.Last), Roots.Last);
+ return Roots.Last;
+ end if;
+ end Enter_Root;
+
+ ---------------
+ -- Frames_Of --
+ ---------------
+
+ function Frames_Of (B : Root_Id) return Frame_Array is
+ begin
+ return Frame_Array (
+ Frames_In_Root.Table (Roots.Table (B).First .. Roots.Table (B).Last));
+ end Frames_Of;
+
+ ---------------
+ -- Get_First --
+ ---------------
+
+ function Get_First return Root_Id is
+ begin
+ return Root_HTable.Get_First;
+ end Get_First;
+
+ --------------
+ -- Get_Next --
+ --------------
+
+ function Get_Next return Root_Id is
+ begin
+ return Root_HTable.Get_Next;
+ end Get_Next;
+
+ -------
+ -- H --
+ -------
+
+ function H (B : Root) return Root_Range is
+
+ type Uns is mod 2 ** 32;
+
+ function Rotate_Left (Value : Uns; Amount : Natural) return Uns;
+ pragma Import (Intrinsic, Rotate_Left);
+
+ Tmp : Uns := 0;
+
+ begin
+ for J in B.First .. B.Last loop
+ Tmp := Rotate_Left (Tmp, 1) + Uns (Frames_In_Root.Table (J));
+ end loop;
+
+ return Root_Range'First
+ + Root_Range'Base (Tmp mod Root_Range'Range_Length);
+ end H;
+
+ function H (N : Name) return Name_Range is
+ function H is new Hash (Name_Range);
+
+ begin
+ return H (String (Chars.Table (N.First .. N.Last)));
+ end H;
+
+ function H (N : Frame) return Frame_Range is
+ begin
+ return Frame_Range (1 + (7 * N.Name + 13 * N.File + 17 * N.Line)
+ mod Frame_Range'Range_Length);
+ end H;
+
+ ---------------------
+ -- High_Water_Mark --
+ ---------------------
+
+ function High_Water_Mark (B : Root_Id) return Storage_Count is
+ begin
+ return Roots.Table (B).High_Water_Mark;
+ end High_Water_Mark;
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image (N : Name_Id) return String is
+ Nam : Name renames Names.Table (N);
+
+ begin
+ return String (Chars.Table (Nam.First .. Nam.Last));
+ end Image;
+
+ function Image
+ (F : Frame_Id;
+ Max_Fil : Integer;
+ Max_Lin : Integer)
+ return String is
+
+ Fram : Frame renames Frames.Table (F);
+ Fil : Name renames Names.Table (Fram.File);
+ Lin : Name renames Names.Table (Fram.Line);
+ Nam : Name renames Names.Table (Fram.Name);
+
+ Fil_Len : constant Integer := Fil.Last - Fil.First + 1;
+ Lin_Len : constant Integer := Lin.Last - Lin.First + 1;
+
+ use type Chars.Table_Type;
+
+ Spaces : constant String (1 .. 80) := (1 .. 80 => ' ');
+
+ begin
+ return String (Chars.Table (Fil.First .. Fil.Last))
+ & ':'
+ & String (Chars.Table (Lin.First .. Lin.Last))
+ & Spaces (1 .. 1 + Max_Fil - Fil_Len + Max_Lin - Lin_Len)
+ & String (Chars.Table (Nam.First .. Nam.Last));
+ end Image;
+
+ -------------
+ -- Name_Eq --
+ -------------
+
+ function Name_Eq (N1, N2 : Name) return Boolean is
+ use type Chars.Table_Type;
+ begin
+ return
+ Chars.Table (N1.First .. N1.Last) = Chars.Table (N2.First .. N2.Last);
+ end Name_Eq;
+
+ --------------
+ -- Nb_Alloc --
+ --------------
+
+ function Nb_Alloc (B : Root_Id) return Integer is
+ begin
+ return Roots.Table (B).Nb_Alloc;
+ end Nb_Alloc;
+
+ --------------
+ -- Print_BT --
+ --------------
+
+ procedure Print_BT (B : Root_Id) is
+ Max_Col_Width : constant := 35;
+ -- Largest filename length for which backtraces will be
+ -- properly aligned. Frames containing longer names won't be
+ -- truncated but they won't be properly aligned either.
+
+ F : constant Frame_Array := Frames_Of (B);
+
+ Max_Fil : Integer;
+ Max_Lin : Integer;
+
+ begin
+ Max_Fil := 0;
+ Max_Lin := 0;
+
+ for J in F'Range loop
+ declare
+ Fram : Frame renames Frames.Table (F (J));
+ Fil : Name renames Names.Table (Fram.File);
+ Lin : Name renames Names.Table (Fram.Line);
+
+ begin
+ Max_Fil := Integer'Max (Max_Fil, Fil.Last - Fil.First + 1);
+ Max_Lin := Integer'Max (Max_Lin, Lin.Last - Lin.First + 1);
+ end;
+ end loop;
+
+ Max_Fil := Integer'Min (Max_Fil, Max_Col_Width);
+
+ for J in F'Range loop
+ Put (" ");
+ Put_Line (Image (F (J), Max_Fil, Max_Lin));
+ end loop;
+ end Print_BT;
+
+ -------------
+ -- Read_BT --
+ -------------
+
+ function Read_BT (BT_Depth : Integer; FT : File_Type) return Root_Id is
+ Max_Line : constant Integer := 500;
+ Curs1 : Integer;
+ Curs2 : Integer;
+ Line : String (1 .. Max_Line);
+ Last : Integer := 0;
+ Frames : Frame_Array (1 .. BT_Depth);
+ F : Integer := Frames'First;
+ Nam : Name_Id;
+ Fil : Name_Id;
+ Lin : Name_Id;
+
+ No_File : Boolean := False;
+ Main_Found : Boolean := False;
+
+ procedure Find_File;
+ -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
+ -- the file name. The file name may not be on the current line since
+ -- a frame may be printed on more than one line when there is a lot
+ -- of parameters or names are long, so this subprogram can read new
+ -- lines of input.
+
+ procedure Find_Line;
+ -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
+ -- the line number.
+
+ procedure Find_Name;
+ -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
+ -- the subprogram name.
+
+ procedure Gmem_Read_BT_Frame (Buf : out String; Last : out Natural);
+ -- GMEM functionality binding
+
+ ---------------
+ -- Find_File --
+ ---------------
+
+ procedure Find_File is
+ Match_Parent : Integer;
+
+ begin
+ -- Skip parameters
+
+ Curs1 := Curs2 + 3;
+ Match_Parent := 1;
+ while Curs1 <= Last loop
+ if Line (Curs1) = '(' then
+ Match_Parent := Match_Parent + 1;
+ elsif Line (Curs1) = ')' then
+ Match_Parent := Match_Parent - 1;
+ exit when Match_Parent = 0;
+ end if;
+
+ Curs1 := Curs1 + 1;
+ end loop;
+
+ -- Skip " at "
+
+ Curs1 := Curs1 + 5;
+
+ if Curs1 >= Last then
+
+ -- Maybe the file reference is on one of the next lines
+
+ Read : loop
+ Get_Line (FT, Line, Last);
+
+ -- If we have another Frame or if the backtrace is finished
+ -- the file reference was just missing
+
+ if Last <= 1 or else Line (1) = '#' then
+ No_File := True;
+ Curs2 := Curs1 - 1;
+ return;
+
+ else
+ Curs1 := 1;
+ while Curs1 <= Last - 2 loop
+ if Line (Curs1) = '(' then
+ Match_Parent := Match_Parent + 1;
+ elsif Line (Curs1) = ')' then
+ Match_Parent := Match_Parent - 1;
+ end if;
+
+ if Match_Parent = 0
+ and then Line (Curs1 .. Curs1 + 1) = "at"
+ then
+ Curs1 := Curs1 + 3;
+ exit Read;
+ end if;
+
+ Curs1 := Curs1 + 1;
+ end loop;
+ end if;
+ end loop Read;
+ end if;
+
+ -- Let's assume that the filename length is greater than 1
+ -- it simplifies dealing with the potential drive ':' on
+ -- windows systems
+
+ Curs2 := Curs1 + 1;
+ while Line (Curs2 + 1) /= ':' loop Curs2 := Curs2 + 1; end loop;
+ end Find_File;
+
+ ---------------
+ -- Find_Line --
+ ---------------
+
+ procedure Find_Line is
+ begin
+ Curs1 := Curs2 + 2;
+ Curs2 := Last;
+ if Curs2 - Curs1 > 5 then
+ raise Constraint_Error;
+ end if;
+ end Find_Line;
+
+ ---------------
+ -- Find_Name --
+ ---------------
+
+ procedure Find_Name is
+ begin
+ Curs1 := 3;
+
+ -- Skip Frame #
+
+ while Line (Curs1) /= ' ' loop Curs1 := Curs1 + 1; end loop;
+
+ -- Skip spaces
+
+ while Line (Curs1) = ' ' loop Curs1 := Curs1 + 1; end loop;
+
+ Curs2 := Curs1;
+ while Line (Curs2 + 1) /= ' ' loop Curs2 := Curs2 + 1; end loop;
+ end Find_Name;
+
+ ------------------------
+ -- Gmem_Read_BT_Frame --
+ ------------------------
+
+ procedure Gmem_Read_BT_Frame (Buf : out String; Last : out Natural) is
+ procedure Read_BT_Frame (buf : System.Address);
+ pragma Import (C, Read_BT_Frame, "__gnat_gmem_read_bt_frame");
+
+ function Strlen (chars : System.Address) return Natural;
+ pragma Import (C, Strlen, "strlen");
+
+ S : String (1 .. 1000);
+ begin
+ Read_BT_Frame (S'Address);
+ Last := Strlen (S'Address);
+ Buf (1 .. Last) := S (1 .. Last);
+ end Gmem_Read_BT_Frame;
+
+ -- Start of processing for Read_BT
+
+ begin
+
+ if Gmem_Mode then
+ Gmem_Read_BT_Frame (Line, Last);
+ else
+ Line (1) := ' ';
+ while Line (1) /= '#' loop
+ Get_Line (FT, Line, Last);
+ end loop;
+ end if;
+
+ while Last >= 1 and then Line (1) = '#' and then not Main_Found loop
+ if F <= BT_Depth then
+ Find_Name;
+ Nam := Enter_Name (Line (Curs1 .. Curs2));
+ Main_Found := Line (Curs1 .. Curs2) = "main";
+
+ Find_File;
+
+ if No_File then
+ Fil := No_Name_Id;
+ Lin := No_Name_Id;
+ else
+ Fil := Enter_Name (Line (Curs1 .. Curs2));
+
+ Find_Line;
+ Lin := Enter_Name (Line (Curs1 .. Curs2));
+ end if;
+
+ Frames (F) := Enter_Frame (Nam, Fil, Lin);
+ F := F + 1;
+ end if;
+
+ if No_File then
+
+ -- If no file reference was found, the next line has already
+ -- been read because, it may sometimes be found on the next
+ -- line
+
+ No_File := False;
+
+ else
+ if Gmem_Mode then
+ Gmem_Read_BT_Frame (Line, Last);
+ else
+ Get_Line (FT, Line, Last);
+ exit when End_Of_File (FT);
+ end if;
+ end if;
+
+ end loop;
+
+ return Enter_Root (Frames (1 .. F - 1));
+ end Read_BT;
+
+ -------------
+ -- Root_Eq --
+ -------------
+
+ function Root_Eq (N1, N2 : Root) return Boolean is
+ use type Frames_In_Root.Table_Type;
+
+ begin
+ return
+ Frames_In_Root.Table (N1.First .. N1.Last)
+ = Frames_In_Root.Table (N2.First .. N2.Last);
+ end Root_Eq;
+
+ --------------------
+ -- Set_Alloc_Size --
+ --------------------
+
+ procedure Set_Alloc_Size (B : Root_Id; V : Storage_Count) is
+ begin
+ Roots.Table (B).Alloc_Size := V;
+ end Set_Alloc_Size;
+
+ -------------------------
+ -- Set_High_Water_Mark --
+ -------------------------
+
+ procedure Set_High_Water_Mark (B : Root_Id; V : Storage_Count) is
+ begin
+ Roots.Table (B).High_Water_Mark := V;
+ end Set_High_Water_Mark;
+
+ ------------------
+ -- Set_Nb_Alloc --
+ ------------------
+
+ procedure Set_Nb_Alloc (B : Root_Id; V : Integer) is
+ begin
+ Roots.Table (B).Nb_Alloc := V;
+ end Set_Nb_Alloc;
+
+begin
+ -- Initialize name for No_Name_ID
+
+ Names.Increment_Last;
+ Names.Table (Names.Last) := Name'(1, 0);
+end Memroot;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M E M R O O T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- Copyright (C) 1997-2001 Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package offers basic types that deal with gdb backtraces related
+-- to memory allocation. A memory root (root_id) is a backtrace
+-- referencing the actual point of allocation along with counters
+-- recording various information concerning allocation at this root.
+
+-- A back trace is composed of Frames (Frame_Id) which themselves are
+-- nothing else than a subprogram call at a source location which can be
+-- represented by three strings: subprogram name, file name and line
+-- number. All the needed strings are entered in a table and referenced
+-- through a Name_Id in order to avoid duplication.
+
+with System.Storage_Elements; use System.Storage_Elements;
+with Ada.Text_IO; use Ada.Text_IO;
+
+package Memroot is
+
+ -- Work with instrumented allocation routines
+ Gmem_Mode : Boolean := False;
+
+ -- Simple abstract type for names. A name is a sequence of letters.
+
+ type Name_Id is new Natural;
+ No_Name_Id : constant Name_Id := 0;
+
+ function Enter_Name (S : String) return Name_Id;
+ function Image (N : Name_Id) return String;
+
+ -- Simple abstract type for a backtrace frame. A frame is composed by
+ -- a subprogram name, a file name and a line reference.
+
+ type Frame_Id is new Natural;
+ No_Frame_Id : constant Frame_Id := 0;
+
+ function Enter_Frame (Name, File, Line : Name_Id) return Frame_Id;
+
+ type Frame_Array is array (Natural range <>) of Frame_Id;
+
+ -- Simple abstract type for an allocation root. It is composed by a set
+ -- of frames, the number of allocation, the total size of allocated
+ -- memory, and the high water mark. An iterator is also provided to
+ -- iterate over all the entered allocation roots.
+
+ type Root_Id is new Natural;
+ No_Root_Id : constant Root_Id := 0;
+
+ function Read_BT (BT_Depth : Integer; FT : File_Type) return Root_Id;
+ -- Read a backtrace from file FT whose maximum frame number is given by
+ -- BT_Depth and returns the corresponding Allocation root.
+
+ function Enter_Root (Fr : Frame_Array) return Root_Id;
+ -- Create an allocation root from the frames that compose it
+
+ function Frames_Of (B : Root_Id) return Frame_Array;
+ -- Retreives the Frames of the root's backtrace
+
+ procedure Print_BT (B : Root_Id);
+ -- Prints on standard out the backtrace associated with the root B
+
+ function Get_First return Root_Id;
+ function Get_Next return Root_Id;
+ -- Iterator to iterate over roots
+
+ procedure Set_Nb_Alloc (B : Root_Id; V : Integer);
+ function Nb_Alloc (B : Root_Id) return Integer;
+ -- Access and modify the number of allocation counter associated with
+ -- this allocation root. If the value is negative, it means that this is
+ -- not an allocation root but a deallocation root (this can only happen
+ -- in erroneous situations where there are more frees than allocations).
+
+ procedure Set_Alloc_Size (B : Root_Id; V : Storage_Count);
+ function Alloc_Size (B : Root_Id) return Storage_Count;
+ -- Access and modify the total allocated memory counter associated with
+ -- this allocation root.
+
+ procedure Set_High_Water_Mark (B : Root_Id; V : Storage_Count);
+ function High_Water_Mark (B : Root_Id) return Storage_Count;
+ -- Access and modify the high water mark associated with this
+ -- allocation root. The high water mark is the maximum value, over
+ -- time, of the Alloc_Size.
+
+end Memroot;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M E M O R Y --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 2001 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This version contains allocation tracking capability.
+-- The object file corresponding to this instrumented version is to be found
+-- in libgmem.
+-- When enabled, the subsystem logs all the calls to __gnat_malloc and
+-- __gnat_free. This log can then be processed by gnatmem to detect
+-- dynamic memory leaks.
+--
+-- To use this functionality, you must compile your application with -g
+-- and then link with this object file:
+--
+-- gnatmake -g program -largs -lgmem
+--
+-- After compilation, you may use your program as usual except that upon
+-- completion, it will generate in the current directory the file gmem.out.
+--
+-- You can then investigate for possible memory leaks and mismatch by calling
+-- gnatmem with this file as an input:
+--
+-- gnatmem -i gmem.out program
+--
+-- See gnatmem section in the GNAT User's Guide for more details.
+--
+-- NOTE: This capability is currently supported on the following targets:
+--
+-- Windows
+-- Linux
+-- HP-UX
+-- Irix
+-- Solaris
+-- Tru64
+
+pragma Source_File_Name (System.Memory, Body_File_Name => "memtrack.adb");
+
+with Ada.Exceptions;
+with System.Soft_Links;
+with System.Traceback;
+
+package body System.Memory is
+
+ use Ada.Exceptions;
+ use System.Soft_Links;
+ use System.Traceback;
+
+ function c_malloc (Size : size_t) return System.Address;
+ pragma Import (C, c_malloc, "malloc");
+
+ procedure c_free (Ptr : System.Address);
+ pragma Import (C, c_free, "free");
+
+ function c_realloc
+ (Ptr : System.Address; Size : size_t) return System.Address;
+ pragma Import (C, c_realloc, "realloc");
+
+ type File_Ptr is new System.Address;
+
+ function fopen (Path : String; Mode : String) return File_Ptr;
+ pragma Import (C, fopen);
+
+ procedure fwrite
+ (Ptr : System.Address;
+ Size : size_t;
+ Nmemb : size_t;
+ Stream : File_Ptr);
+
+ procedure fwrite
+ (Str : String;
+ Size : size_t;
+ Nmemb : size_t;
+ Stream : File_Ptr);
+ pragma Import (C, fwrite);
+
+ procedure fputc (C : Integer; Stream : File_Ptr);
+ pragma Import (C, fputc);
+
+ procedure fclose (Stream : File_Ptr);
+ pragma Import (C, fclose);
+
+ procedure Finalize;
+ -- Replace the default __gnat_finalize to properly close the log file.
+ pragma Export (C, Finalize, "__gnat_finalize");
+
+ Address_Size : constant := System.Address'Max_Size_In_Storage_Elements;
+ -- Size in bytes of a pointer
+
+ Max_Call_Stack : constant := 200;
+ -- Maximum number of frames supported
+
+ Skip_Frame : constant := 1;
+ -- Number of frames to remove from the call stack to hide functions from
+ -- this unit.
+
+ Tracebk : aliased array (0 .. Max_Call_Stack) of System.Address;
+ Num_Calls : aliased Integer := 0;
+ -- Store the current call stack from Alloc and Free
+
+ Gmemfname : constant String := "gmem.out" & ASCII.NUL;
+ -- Allocation log of a program is saved in a file gmem.out
+ -- ??? What about Ada.Command_Line.Command_Name & ".out" instead of static
+ -- gmem.out
+
+ Gmemfile : File_Ptr;
+ -- Global C file pointer to the allocation log
+
+ procedure Gmem_Initialize;
+ -- Initialization routine; opens the file and writes a header string. This
+ -- header string is used as a magic-tag to know if the .out file is to be
+ -- handled by GDB or by the GMEM (instrumented malloc/free) implementation.
+
+ -----------
+ -- Alloc --
+ -----------
+
+ function Alloc (Size : size_t) return System.Address is
+ Result : aliased System.Address;
+ Actual_Size : aliased size_t := Size;
+
+ begin
+ if Size = size_t'Last then
+ Raise_Exception (Storage_Error'Identity, "object too large");
+ end if;
+
+ -- Change size from zero to non-zero. We still want a proper pointer
+ -- for the zero case because pointers to zero length objects have to
+ -- be distinct, but we can't just go ahead and allocate zero bytes,
+ -- since some malloc's return zero for a zero argument.
+
+ if Size = 0 then
+ Actual_Size := 1;
+ end if;
+
+ Lock_Task.all;
+
+ Result := c_malloc (Actual_Size);
+
+ -- Logs allocation call
+ -- format is:
+ -- 'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
+
+ Gmem_Initialize;
+ Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls);
+ Num_Calls := Num_Calls - Skip_Frame;
+ fputc (Character'Pos ('A'), Gmemfile);
+ fwrite (Result'Address, Address_Size, 1, Gmemfile);
+ fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
+ Gmemfile);
+ fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
+ Gmemfile);
+ fwrite (Tracebk (Skip_Frame)'Address, Address_Size, size_t (Num_Calls),
+ Gmemfile);
+
+ Unlock_Task.all;
+
+ if Result = System.Null_Address then
+ Raise_Exception (Storage_Error'Identity, "heap exhausted");
+ end if;
+
+ return Result;
+ end Alloc;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ Needs_Init : Boolean := True;
+ -- Reset after first call to Gmem_Initialize
+
+ procedure Finalize is
+ begin
+ if not Needs_Init then
+ fclose (Gmemfile);
+ end if;
+ end Finalize;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (Ptr : System.Address) is
+ Addr : aliased constant System.Address := Ptr;
+ begin
+ Lock_Task.all;
+
+ -- Logs deallocation call
+ -- format is:
+ -- 'D' <mem addr> <len backtrace> <addr1> ... <addrn>
+
+ Gmem_Initialize;
+ Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls);
+ Num_Calls := Num_Calls - Skip_Frame;
+ fputc (Character'Pos ('D'), Gmemfile);
+ fwrite (Addr'Address, Address_Size, 1, Gmemfile);
+ fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
+ Gmemfile);
+ fwrite (Tracebk (Skip_Frame)'Address, Address_Size, size_t (Num_Calls),
+ Gmemfile);
+
+ c_free (Ptr);
+
+ Unlock_Task.all;
+ end Free;
+
+ ---------------------
+ -- Gmem_Initialize --
+ ---------------------
+
+ procedure Gmem_Initialize is
+ begin
+ if Needs_Init then
+ Needs_Init := False;
+ Gmemfile := fopen (Gmemfname, "wb" & ASCII.NUL);
+ fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, Gmemfile);
+ end if;
+ end Gmem_Initialize;
+
+ -------------
+ -- Realloc --
+ -------------
+
+ function Realloc
+ (Ptr : System.Address; Size : size_t) return System.Address
+ is
+ Result : System.Address;
+ begin
+ if Size = size_t'Last then
+ Raise_Exception (Storage_Error'Identity, "object too large");
+ end if;
+
+ Abort_Defer.all;
+ Result := c_realloc (Ptr, Size);
+ Abort_Undefer.all;
+
+ if Result = System.Null_Address then
+ Raise_Exception (Storage_Error'Identity, "heap exhausted");
+ end if;
+
+ return Result;
+ end Realloc;
+
+end System.Memory;
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * M I S C *
+ * *
+ * C Implementation File *
+ * *
+ * $Revision: 1.3 $
+ * *
+ * Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write *
+ * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
+ * MA 02111-1307, USA. *
+ * *
+ * As a special exception, if you link this file with other files to *
+ * produce an executable, this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not however invalidate any other reasons why the executable *
+ * file might be covered by the GNU Public License. *
+ * *
+ * GNAT was originally developed by the GNAT team at New York University. *
+ * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ * *
+ ****************************************************************************/
+
+/* This file contains parts of the compiler that are required for interfacing
+ with GCC but otherwise do nothing and parts of Gigi that need to know
+ about RTL. */
+
+#include "config.h"
+#include "system.h"
+#include "tree.h"
+#include "rtl.h"
+#include "errors.h"
+#include "diagnostic.h"
+#include "expr.h"
+#include "ggc.h"
+#include "flags.h"
+#include "insn-flags.h"
+#include "insn-config.h"
+#include "recog.h"
+#include "toplev.h"
+#include "output.h"
+#include "except.h"
+#include "tm_p.h"
+
+#include "ada.h"
+#include "types.h"
+#include "atree.h"
+#include "elists.h"
+#include "namet.h"
+#include "nlists.h"
+#include "stringt.h"
+#include "uintp.h"
+#include "fe.h"
+#include "sinfo.h"
+#include "einfo.h"
+#include "ada-tree.h"
+#include "gigi.h"
+
+extern FILE *asm_out_file;
+extern int save_argc;
+extern char **save_argv;
+
+/* Tables describing GCC tree codes used only by GNAT.
+
+ Table indexed by tree code giving a string containing a character
+ classifying the tree code. Possibilities are
+ t, d, s, c, r, <, 1 and 2. See cp-tree.def for details. */
+
+#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
+
+char gnat_tree_code_type[] = {
+ 'x',
+#include "ada-tree.def"
+};
+#undef DEFTREECODE
+
+/* Table indexed by tree code giving number of expression
+ operands beyond the fixed part of the node structure.
+ Not used for types or decls. */
+
+#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
+
+int gnat_tree_code_length[] = {
+ 0,
+#include "ada-tree.def"
+};
+#undef DEFTREECODE
+
+/* Names of tree components.
+ Used for printing out the tree and error messages. */
+#define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
+
+const char *gnat_tree_code_name[] = {
+ "@@dummy",
+#include "ada-tree.def"
+};
+#undef DEFTREECODE
+
+/* Structure giving our language-specific hooks. */
+struct lang_hooks lang_hooks = {gnat_init, 0, gnat_init_options,
+ gnat_decode_option, 0};
+
+/* gnat standard argc argv */
+
+extern int gnat_argc;
+extern char **gnat_argv;
+
+/* Global Variables Expected by gcc: */
+
+const char * const language_string = "GNU Ada";
+int flag_traditional; /* Used by dwarfout.c. */
+int ggc_p = 1;
+
+static void internal_error_function PARAMS ((const char *, va_list *));
+static rtx gnat_expand_expr PARAMS ((tree, rtx, enum machine_mode,
+ enum expand_modifier));
+static tree gnat_expand_constant PARAMS ((tree));
+static void gnat_adjust_rli PARAMS ((record_layout_info));
+
+#if defined(MIPS_DEBUGGING_INFO) && defined(DWARF2_DEBUGGING_INFO)
+static char *convert_ada_name_to_qualified_name PARAMS ((char *));
+#endif
+\f
+/* Routines Expected by gcc: */
+
+/* For most front-ends, this is the parser for the language. For us, we
+ process the GNAT tree. */
+
+#define Set_Jmpbuf_Address system__soft_links__set_jmpbuf_address_soft
+extern void Set_Jmpbuf_Address (void *);
+
+/* Declare functions we use as part of startup. */
+extern void __gnat_initialize PARAMS((void));
+extern void adainit PARAMS((void));
+extern void _ada_gnat1drv PARAMS((void));
+
+int
+yyparse ()
+{
+ /* Make up what Gigi uses as a jmpbuf. */
+ size_t jmpbuf[10];
+
+ /* call the target specific initializations */
+ __gnat_initialize();
+
+ /* Call the front-end elaboration procedures */
+ adainit ();
+
+ /* Set up to catch unhandled exceptions. */
+ if (__builtin_setjmp (jmpbuf))
+ {
+ Set_Jmpbuf_Address (0);
+ abort ();
+ }
+
+ /* This is only really needed in longjmp/setjmp mode exceptions
+ but we don't know any easy way to tell what mode the host is
+ compiled in, and it is harmless to do it unconditionally */
+
+ Set_Jmpbuf_Address (jmpbuf);
+
+ immediate_size_expand = 1;
+
+ /* Call the front end */
+ _ada_gnat1drv ();
+
+ Set_Jmpbuf_Address (0);
+ return 0;
+}
+
+/* Decode all the language specific options that cannot be decoded by GCC.
+ The option decoding phase of GCC calls this routine on the flags that
+ it cannot decode. This routine returns 1 if it is successful, otherwise
+ it returns 0. */
+
+int
+gnat_decode_option (argc, argv)
+ int argc ATTRIBUTE_UNUSED;
+ char **argv;
+{
+ char *p = argv[0];
+ int i;
+
+ if (!strncmp (p, "-I", 2))
+ {
+ /* Pass the -I switches as-is. */
+ gnat_argv[gnat_argc] = p;
+ gnat_argc ++;
+ return 1;
+ }
+
+ else if (!strncmp (p, "-gant", 5))
+ {
+ char *q = (char *) xmalloc (strlen (p) + 1);
+
+ warning ("`-gnat' misspelled as `-gant'");
+ strcpy (q, p);
+ q[2] = 'n', q[3] = 'a';
+ p = q;
+ return 1;
+ }
+
+ else if (!strncmp (p, "-gnat", 5))
+ {
+ /* Recopy the switches without the 'gnat' prefix */
+
+ gnat_argv[gnat_argc] = (char *) xmalloc (strlen (p) - 3);
+ gnat_argv[gnat_argc][0] = '-';
+ strcpy (gnat_argv[gnat_argc] + 1, p + 5);
+ gnat_argc ++;
+ if (p[5] == 'O')
+ for (i = 1; i < save_argc - 1; i++)
+ if (!strncmp (save_argv[i], "-gnatO", 6))
+ if (save_argv[++i][0] != '-')
+ {
+ /* Preserve output filename as GCC doesn't save it for GNAT. */
+ gnat_argv[gnat_argc] = save_argv[i];
+ gnat_argc++;
+ break;
+ }
+
+ return 1;
+ }
+
+ /* Ignore -W flags since people may want to use the same flags for all
+ languages. */
+ else if (p[0] == '-' && p[1] == 'W' && p[2] != 0)
+ return 1;
+
+ return 0;
+}
+
+/* Initialize for option processing. */
+
+void
+gnat_init_options ()
+{
+ /* Initialize gnat_argv with save_argv size */
+ gnat_argv = (char **) xmalloc ((save_argc + 1) * sizeof (gnat_argv[0]));
+ gnat_argv [0] = save_argv[0]; /* name of the command */
+ gnat_argc = 1;
+}
+
+void
+lang_mark_tree (t)
+ tree t;
+{
+ switch (TREE_CODE (t))
+ {
+ case FUNCTION_TYPE:
+ ggc_mark_tree (TYPE_CI_CO_LIST (t));
+ return;
+
+ case INTEGER_TYPE:
+ if (TYPE_MODULAR_P (t))
+ ggc_mark_tree (TYPE_MODULUS (t));
+ else if (TYPE_VAX_FLOATING_POINT_P (t))
+ ;
+ else if (TYPE_HAS_ACTUAL_BOUNDS_P (t))
+ ggc_mark_tree (TYPE_ACTUAL_BOUNDS (t));
+ else
+ ggc_mark_tree (TYPE_INDEX_TYPE (t));
+ return;
+
+ case ENUMERAL_TYPE:
+ ggc_mark_tree (TYPE_RM_SIZE_ENUM (t));
+ return;
+
+ case ARRAY_TYPE:
+ ggc_mark_tree (TYPE_ACTUAL_BOUNDS (t));
+ return;
+
+ case RECORD_TYPE: case UNION_TYPE: case QUAL_UNION_TYPE:
+ /* This is really TYPE_UNCONSTRAINED_ARRAY for fat pointers. */
+ ggc_mark_tree (TYPE_ADA_SIZE (t));
+ return;
+
+ case CONST_DECL:
+ ggc_mark_tree (DECL_CONST_CORRESPONDING_VAR (t));
+ return;
+
+ case FIELD_DECL:
+ ggc_mark_tree (DECL_ORIGINAL_FIELD (t));
+ return;
+
+ default:
+ return;
+ }
+}
+
+/* Here we have the function to handle the compiler error processing in GCC.
+ Do this only if VPRINTF is available. */
+
+#if defined(HAVE_VPRINTF)
+#define DO_INTERNAL_ERROR_FUNCTION
+
+static void
+internal_error_function (msgid, ap)
+ const char *msgid;
+ va_list *ap;
+{
+ char buffer[1000]; /* Assume this is big enough. */
+ char *p;
+ String_Template temp;
+ Fat_Pointer fp;
+
+ vsprintf (buffer, msgid, *ap);
+
+ /* Go up to the first newline. */
+ for (p = buffer; *p != 0; p++)
+ if (*p == '\n')
+ {
+ *p = '\0';
+ break;
+ }
+
+ temp.Low_Bound = 1, temp.High_Bound = strlen (buffer);
+ fp.Array = buffer, fp.Bounds = &temp;
+
+ Current_Error_Node = error_gnat_node;
+ Compiler_Abort (fp, -1);
+}
+#endif
+
+/* Perform all the initialization steps that are language-specific. */
+
+void
+gnat_init ()
+{
+ /* Add the input filename as the last argument. */
+ gnat_argv [gnat_argc] = (char *) input_filename;
+ gnat_argc++;
+ gnat_argv [gnat_argc] = 0;
+
+#ifdef DO_INTERNAL_ERROR_FUNCTION
+ set_internal_error_function (internal_error_function);
+#endif
+
+ /* Show that REFERENCE_TYPEs are internal and should be Pmode. */
+ internal_reference_types ();
+
+ /* Show we don't use the common language attributes. */
+ lang_attribute_common = 0;
+
+ set_lang_adjust_rli (gnat_adjust_rli);
+
+#if defined(MIPS_DEBUGGING_INFO) && defined(DWARF2_DEBUGGING_INFO)
+ dwarf2out_set_demangle_name_func (convert_ada_name_to_qualified_name);
+#endif
+}
+
+/* Return a short string identifying this language to the debugger. */
+
+const char *
+lang_identify ()
+{
+ return "ada";
+}
+
+/* If DECL has a cleanup, build and return that cleanup here.
+ This is a callback called by expand_expr. */
+
+tree
+maybe_build_cleanup (decl)
+ tree decl ATTRIBUTE_UNUSED;
+{
+ /* There are no cleanups in C. */
+ return NULL_TREE;
+}
+
+/* Print any language-specific compilation statistics. */
+
+void
+print_lang_statistics ()
+{}
+
+void
+lang_print_xnode (file, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+}
+
+/* integrate_decl_tree calls this function, but since we don't use the
+ DECL_LANG_SPECIFIC field, this is a no-op. */
+
+void
+copy_lang_decl (node)
+ tree node ATTRIBUTE_UNUSED;
+{
+}
+
+/* Hooks for print-tree.c: */
+
+void
+print_lang_decl (file, node, indent)
+ FILE *file;
+ tree node;
+ int indent;
+{
+ switch (TREE_CODE (node))
+ {
+ case CONST_DECL:
+ print_node (file, "const_corresponding_var",
+ DECL_CONST_CORRESPONDING_VAR (node), indent + 4);
+ break;
+
+ case FIELD_DECL:
+ print_node (file, "original field", DECL_ORIGINAL_FIELD (node),
+ indent + 4);
+ break;
+
+ default:
+ break;
+ }
+}
+
+void
+print_lang_type (file, node, indent)
+ FILE *file;
+ tree node;
+ int indent;
+{
+ switch (TREE_CODE (node))
+ {
+ case FUNCTION_TYPE:
+ print_node (file, "ci_co_list", TYPE_CI_CO_LIST (node), indent + 4);
+ break;
+
+ case ENUMERAL_TYPE:
+ print_node (file, "RM size", TYPE_RM_SIZE_ENUM (node), indent + 4);
+ break;
+
+ case INTEGER_TYPE:
+ if (TYPE_MODULAR_P (node))
+ print_node (file, "modulus", TYPE_MODULUS (node), indent + 4);
+ else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
+ print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
+ indent + 4);
+ else if (TYPE_VAX_FLOATING_POINT_P (node))
+ ;
+ else
+ print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
+
+ print_node (file, "RM size", TYPE_RM_SIZE_INT (node), indent + 4);
+ break;
+
+ case ARRAY_TYPE:
+ print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4);
+ break;
+
+ case RECORD_TYPE:
+ if (TYPE_IS_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
+ print_node (file, "unconstrained array",
+ TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
+ else
+ print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
+ break;
+
+ case UNION_TYPE:
+ case QUAL_UNION_TYPE:
+ print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
+ break;
+
+ default:
+ break;
+ }
+}
+
+void
+print_lang_identifier (file, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{}
+
+/* Expands GNAT-specific GCC tree nodes. The only ones we support
+ here are TRANSFORM_EXPR, UNCHECKED_CONVERT_EXPR, ALLOCATE_EXPR,
+ USE_EXPR and NULL_EXPR. */
+
+static rtx
+gnat_expand_expr (exp, target, tmode, modifier)
+ tree exp;
+ rtx target;
+ enum machine_mode tmode;
+ enum expand_modifier modifier;
+{
+ tree type = TREE_TYPE (exp);
+ tree inner_type;
+ tree new;
+ rtx result;
+ int align_ok;
+
+ /* Update EXP to be the new expression to expand. */
+
+ switch (TREE_CODE (exp))
+ {
+ case TRANSFORM_EXPR:
+ gnat_to_code (TREE_COMPLEXITY (exp));
+ return const0_rtx;
+ break;
+
+ case UNCHECKED_CONVERT_EXPR:
+ inner_type = TREE_TYPE (TREE_OPERAND (exp, 0));
+
+ /* The alignment is OK if the flag saying it is OK is set in either
+ type, if the inner type is already maximally aligned, if the
+ new type is no more strictly aligned than the old type, or
+ if byte accesses are not slow. */
+ align_ok = (! SLOW_BYTE_ACCESS
+ || TYPE_ALIGN_OK_P (type) || TYPE_ALIGN_OK_P (inner_type)
+ || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
+ || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type));
+
+ /* If we're converting between an aggregate and non-aggregate type
+ and we have a MEM TARGET, we can't use it, since MEM_IN_STRUCT_P
+ would be set incorrectly. */
+ if (target != 0 && GET_CODE (target) == MEM
+ && (MEM_IN_STRUCT_P (target) != AGGREGATE_TYPE_P (inner_type)))
+ target = 0;
+
+ /* If the input and output are both the same mode (usually BLKmode),
+ just return the expanded input since we want just the bits. But
+ we can't do this if the output is more strictly aligned than
+ the input or if the type is BLKmode and the sizes differ. */
+ if (TYPE_MODE (type) == TYPE_MODE (inner_type)
+ && align_ok
+ && ! (TYPE_MODE (type) == BLKmode
+ && ! operand_equal_p (TYPE_SIZE (type),
+ TYPE_SIZE (inner_type), 0)))
+ {
+ new = TREE_OPERAND (exp, 0);
+
+ /* If the new type is less strictly aligned than the inner type,
+ make a new type with the less strict alignment just for
+ code generation purposes of this node. If it is a decl,
+ we can't change the type, so make a NOP_EXPR. */
+ if (TYPE_ALIGN (type) != TYPE_ALIGN (inner_type))
+ {
+ tree copy_type = copy_node (inner_type);
+
+ TYPE_ALIGN (copy_type) = TYPE_ALIGN (type);
+ if (DECL_P (new))
+ new = build1 (NOP_EXPR, copy_type, new);
+ else
+ {
+ /* If NEW is a constant, it might be coming from a CONST_DECL
+ and hence shared. */
+ if (TREE_CONSTANT (new))
+ new = copy_node (new);
+
+ TREE_TYPE (new) = copy_type;
+ }
+ }
+ }
+
+ /* If either mode is BLKmode, memory will be involved, so do this
+ via pointer punning. Likewise, this doesn't work if there
+ is an alignment issue. But we must do it for types that are known
+ to be aligned properly. */
+ else if ((TYPE_MODE (type) == BLKmode
+ || TYPE_MODE (inner_type) == BLKmode)
+ && align_ok)
+ {
+ new = build_unary_op (INDIRECT_REF, NULL_TREE,
+ convert
+ (build_pointer_type (type),
+ build_unary_op (ADDR_EXPR, NULL_TREE,
+ TREE_OPERAND (exp, 0))));
+ result = expand_expr (new, target, tmode, modifier);
+
+ if (GET_CODE (result) != MEM)
+ gigi_abort (204);
+
+ /* Since this is really the underlying object, set the flags from
+ the underlying type.
+
+ ??? Note that this is very dubious because it may change the
+ attributes for a temporary location, which is not allowed. */
+ set_mem_alias_set (result, 0);
+ set_mem_attributes (result, TREE_OPERAND (exp, 0), 0);
+ return result;
+ }
+
+ /* Otherwise make a union of the two types, convert to the union, and
+ extract the other value. */
+ else
+ {
+ tree union_type, in_field, out_field;
+
+ /* If this is inside the LHS of an assignment, this would generate
+ bad code, so abort. */
+ if (TREE_ADDRESSABLE (exp))
+ gigi_abort (202);
+
+ union_type = make_node (UNION_TYPE);
+ in_field = create_field_decl (get_identifier ("in"),
+ inner_type, union_type, 0, 0, 0, 0);
+ out_field = create_field_decl (get_identifier ("out"),
+ type, union_type, 0, 0, 0, 0);
+
+ TYPE_FIELDS (union_type) = chainon (in_field, out_field);
+ layout_type (union_type);
+
+ /* Though this is a "union", we can treat its size as that of
+ the output type in case the size of the input type is variable.
+ If the output size is a variable, use the input size. */
+ TYPE_SIZE (union_type) = TYPE_SIZE (type);
+ TYPE_SIZE_UNIT (union_type) = TYPE_SIZE (type);
+ if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST
+ && TREE_CODE (TYPE_SIZE (inner_type)) == INTEGER_CST)
+ {
+ TYPE_SIZE (union_type) = TYPE_SIZE (inner_type);
+ TYPE_SIZE_UNIT (union_type) = TYPE_SIZE_UNIT (inner_type);
+ }
+
+ new = build (COMPONENT_REF, type,
+ build1 (CONVERT_EXPR, union_type,
+ TREE_OPERAND (exp, 0)),
+ out_field);
+ }
+
+ result = expand_expr (new, target, tmode, modifier);
+
+ if (GET_CODE (result) == MEM)
+ {
+ /* Update so it looks like this is of the proper type. */
+ set_mem_alias_set (result, 0);
+ set_mem_attributes (result, exp, 0);
+ }
+ return result;
+
+ case NULL_EXPR:
+ expand_expr (TREE_OPERAND (exp, 0), const0_rtx, VOIDmode, 0);
+
+ /* We aren't going to be doing anything with this memory, but allocate
+ it anyway. If it's variable size, make a bogus address. */
+ if (! host_integerp (TYPE_SIZE_UNIT (type), 1))
+ return gen_rtx_MEM (BLKmode, virtual_stack_vars_rtx);
+ else
+ return assign_temp (type, 0, TREE_ADDRESSABLE (exp), 1);
+
+ case ALLOCATE_EXPR:
+ return
+ allocate_dynamic_stack_space
+ (expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, TYPE_MODE (sizetype),
+ EXPAND_NORMAL),
+ NULL_RTX, tree_low_cst (TREE_OPERAND (exp, 1), 1));
+
+ case USE_EXPR:
+ if (target != const0_rtx)
+ gigi_abort (203);
+
+ /* First write a volatile ASM_INPUT to prevent anything from being
+ moved. */
+ result = gen_rtx_ASM_INPUT (VOIDmode, "");
+ MEM_VOLATILE_P (result) = 1;
+ emit_insn (result);
+
+ result = expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, VOIDmode,
+ modifier);
+ emit_insn (gen_rtx_USE (VOIDmode, result));
+ return target;
+
+ case GNAT_NOP_EXPR:
+ return expand_expr (build1 (NOP_EXPR, type, TREE_OPERAND (exp, 0)),
+ target, tmode, modifier);
+
+ case UNCONSTRAINED_ARRAY_REF:
+ /* If we are evaluating just for side-effects, just evaluate our
+ operand. Otherwise, abort since this code should never appear
+ in a tree to be evaluated (objects aren't unconstrained). */
+ if (target == const0_rtx || TREE_CODE (type) == VOID_TYPE)
+ return expand_expr (TREE_OPERAND (exp, 0), const0_rtx,
+ VOIDmode, modifier);
+
+ /* ... fall through ... */
+
+ default:
+ gigi_abort (201);
+ }
+
+ return expand_expr (new, target, tmode, modifier);
+}
+
+/* Transform a constant into a form that the language-independent code
+ can handle. */
+
+static tree
+gnat_expand_constant (exp)
+ tree exp;
+{
+ /* If this is an unchecked conversion that does not change the size of the
+ object, return the operand since the underlying constant is still
+ the same. Otherwise, return our operand. */
+ if (TREE_CODE (exp) == UNCHECKED_CONVERT_EXPR
+ && operand_equal_p (TYPE_SIZE_UNIT (TREE_TYPE (exp)),
+ TYPE_SIZE_UNIT (TREE_TYPE (TREE_OPERAND (exp, 0))),
+ 1))
+ return TREE_OPERAND (exp, 0);
+
+ return exp;
+}
+
+/* Adjusts the RLI used to layout a record after all the fields have been
+ added. We only handle the packed case and cause it to use the alignment
+ that will pad the record at the end. */
+
+static void
+gnat_adjust_rli (rli)
+ record_layout_info rli;
+{
+ if (TYPE_PACKED (rli->t))
+ rli->record_align = rli->unpadded_align;
+}
+
+/* Make a TRANSFORM_EXPR to later expand GNAT_NODE into code. */
+
+tree
+make_transform_expr (gnat_node)
+ Node_Id gnat_node;
+{
+ tree gnu_result = build (TRANSFORM_EXPR, void_type_node);
+
+ TREE_SIDE_EFFECTS (gnu_result) = 1;
+ TREE_COMPLEXITY (gnu_result) = gnat_node;
+ return gnu_result;
+}
+\f
+/* Update the setjmp buffer BUF with the current stack pointer. We assume
+ here that a __builtin_setjmp was done to BUF. */
+
+void
+update_setjmp_buf (buf)
+ tree buf;
+{
+ enum machine_mode sa_mode = Pmode;
+ rtx stack_save;
+
+#ifdef HAVE_save_stack_nonlocal
+ if (HAVE_save_stack_nonlocal)
+ sa_mode = insn_operand_mode[(int) CODE_FOR_save_stack_nonlocal][0];
+#endif
+#ifdef STACK_SAVEAREA_MODE
+ sa_mode = STACK_SAVEAREA_MODE (SAVE_NONLOCAL);
+#endif
+
+ stack_save
+ = gen_rtx_MEM (sa_mode,
+ memory_address
+ (sa_mode,
+ plus_constant (expand_expr
+ (build_unary_op (ADDR_EXPR, NULL_TREE, buf),
+ NULL_RTX, VOIDmode, 0),
+ 2 * GET_MODE_SIZE (Pmode))));
+
+#ifdef HAVE_setjmp
+ if (HAVE_setjmp)
+ emit_insn (gen_setjmp ());
+#endif
+
+ emit_stack_save (SAVE_NONLOCAL, &stack_save, NULL_RTX);
+}
+\f
+/* See if DECL has an RTL that is indirect via a pseudo-register or a
+ memory location and replace it with an indirect reference if so.
+ This improves the debugger's ability to display the value. */
+
+void
+adjust_decl_rtl (decl)
+ tree decl;
+{
+ tree new_type;
+
+ /* If this decl is already indirect, don't do anything. This should
+ mean that the decl cannot be indirect, but there's no point in
+ adding an abort to check that. */
+ if (TREE_CODE (decl) != CONST_DECL
+ && ! DECL_BY_REF_P (decl)
+ && (GET_CODE (DECL_RTL (decl)) == MEM
+ && (GET_CODE (XEXP (DECL_RTL (decl), 0)) == MEM
+ || (GET_CODE (XEXP (DECL_RTL (decl), 0)) == REG
+ && (REGNO (XEXP (DECL_RTL (decl), 0))
+ > LAST_VIRTUAL_REGISTER))))
+ /* We can't do this if the reference type's mode is not the same
+ as the current mode, which means this may not work on mixed 32/64
+ bit systems. */
+ && (new_type = build_reference_type (TREE_TYPE (decl))) != 0
+ && TYPE_MODE (new_type) == GET_MODE (XEXP (DECL_RTL (decl), 0))
+ /* If this is a PARM_DECL, we can only do it if DECL_INCOMING_RTL
+ is also an indirect and of the same mode and if the object is
+ readonly, the latter condition because we don't want to upset the
+ handling of CICO_LIST. */
+ && (TREE_CODE (decl) != PARM_DECL
+ || (GET_CODE (DECL_INCOMING_RTL (decl)) == MEM
+ && (TYPE_MODE (new_type)
+ == GET_MODE (XEXP (DECL_INCOMING_RTL (decl), 0)))
+ && TREE_READONLY (decl))))
+ {
+ new_type
+ = build_qualified_type (new_type,
+ (TYPE_QUALS (new_type) | TYPE_QUAL_CONST));
+
+ DECL_POINTS_TO_READONLY_P (decl) = TREE_READONLY (decl);
+ DECL_BY_REF_P (decl) = 1;
+ SET_DECL_RTL (decl, XEXP (DECL_RTL (decl), 0));
+ TREE_TYPE (decl) = new_type;
+ DECL_MODE (decl) = TYPE_MODE (new_type);
+ DECL_ALIGN (decl) = TYPE_ALIGN (new_type);
+ DECL_SIZE (decl) = TYPE_SIZE (new_type);
+
+ if (TREE_CODE (decl) == PARM_DECL)
+ DECL_INCOMING_RTL (decl) = XEXP (DECL_INCOMING_RTL (decl), 0);
+
+ /* If DECL_INITIAL was set, it should be updated to show that
+ the decl is initialized to the address of that thing.
+ Otherwise, just set it to the address of this decl.
+ It needs to be set so that GCC does not think the decl is
+ unused. */
+ DECL_INITIAL (decl)
+ = build1 (ADDR_EXPR, new_type,
+ DECL_INITIAL (decl) != 0 ? DECL_INITIAL (decl) : decl);
+ }
+}
+\f
+/* Record the current code position in GNAT_NODE. */
+
+void
+record_code_position (gnat_node)
+ Node_Id gnat_node;
+{
+ if (global_bindings_p ())
+ {
+ /* Make a dummy entry so multiple things at the same location don't
+ end up in the same place. */
+ add_pending_elaborations (NULL_TREE, NULL_TREE);
+ save_gnu_tree (gnat_node, get_elaboration_location (), 1);
+ }
+ else
+ /* Always emit another insn in case marking the last insn
+ addressable needs some fixups and also for above reason. */
+ save_gnu_tree (gnat_node,
+ build (RTL_EXPR, void_type_node, NULL_TREE,
+ (tree) emit_note (0, NOTE_INSN_DELETED)),
+ 1);
+}
+
+/* Insert the code for GNAT_NODE at the position saved for that node. */
+
+void
+insert_code_for (gnat_node)
+ Node_Id gnat_node;
+{
+ if (global_bindings_p ())
+ {
+ push_pending_elaborations ();
+ gnat_to_code (gnat_node);
+ Check_Elaboration_Code_Allowed (gnat_node);
+ insert_elaboration_list (get_gnu_tree (gnat_node));
+ pop_pending_elaborations ();
+ }
+ else
+ {
+ rtx insns;
+
+ start_sequence ();
+ mark_all_temps_used ();
+ gnat_to_code (gnat_node);
+ insns = get_insns ();
+ end_sequence ();
+ emit_insns_after (insns, RTL_EXPR_RTL (get_gnu_tree (gnat_node)));
+ }
+}
+
+/* Performs whatever initialization steps needed by the language-dependent
+ lexical analyzer.
+
+ Define the additional tree codes here. This isn't the best place to put
+ it, but it's where g++ does it. */
+
+const char *
+init_parse (filename)
+ const char *filename;
+{
+ lang_expand_expr = gnat_expand_expr;
+ lang_expand_constant = gnat_expand_constant;
+
+ memcpy ((char *) (tree_code_type + (int) LAST_AND_UNUSED_TREE_CODE),
+ (char *) gnat_tree_code_type,
+ ((LAST_GNAT_TREE_CODE - (int) LAST_AND_UNUSED_TREE_CODE)
+ * sizeof (char *)));
+
+ memcpy ((char *) (tree_code_length + (int) LAST_AND_UNUSED_TREE_CODE),
+ (char *) gnat_tree_code_length,
+ ((LAST_GNAT_TREE_CODE - (int) LAST_AND_UNUSED_TREE_CODE)
+ * sizeof (int)));
+
+ memcpy ((char *) (tree_code_name + (int) LAST_AND_UNUSED_TREE_CODE),
+ (char *) gnat_tree_code_name,
+ ((LAST_GNAT_TREE_CODE - (int) LAST_AND_UNUSED_TREE_CODE)
+ * sizeof (char *)));
+
+ return filename;
+}
+
+void
+finish_parse ()
+{
+}
+
+/* Sets some debug flags for the parsed. It does nothing here. */
+
+void
+set_yydebug (value)
+ int value ATTRIBUTE_UNUSED;
+{
+}
+
+#if 0
+
+/* Return the alignment for GNAT_TYPE. */
+
+unsigned int
+get_type_alignment (gnat_type)
+ Entity_Id gnat_type;
+{
+ return TYPE_ALIGN (gnat_to_gnu_type (gnat_type)) / BITS_PER_UNIT;
+}
+#endif
+
+/* Get the alias set corresponding to a type or expression. */
+
+HOST_WIDE_INT
+lang_get_alias_set (type)
+ tree type;
+{
+ /* If this is a padding type, use the type of the first field. */
+ if (TREE_CODE (type) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (type))
+ return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
+
+ return -1;
+}
+
+/* GNU_TYPE is a type. Determine if it should be passed by reference by
+ default. */
+
+int
+default_pass_by_ref (gnu_type)
+ tree gnu_type;
+{
+ CUMULATIVE_ARGS cum;
+
+ INIT_CUMULATIVE_ARGS (cum, NULL_TREE, NULL_RTX, 0);
+
+ /* We pass aggregates by reference if they are sufficiently large. The
+ choice of constant here is somewhat arbitrary. We also pass by
+ reference if the target machine would either pass or return by
+ reference. Strictly speaking, we need only check the return if this
+ is an In Out parameter, but it's probably best to err on the side of
+ passing more things by reference. */
+ return (0
+#ifdef FUNCTION_ARG_PASS_BY_REFERENCE
+ || FUNCTION_ARG_PASS_BY_REFERENCE (cum, TYPE_MODE (gnu_type),
+ gnu_type, 1)
+#endif
+ || RETURN_IN_MEMORY (gnu_type)
+ || (AGGREGATE_TYPE_P (gnu_type)
+ && (! host_integerp (TYPE_SIZE (gnu_type), 1)
+ || 0 < compare_tree_int (TYPE_SIZE (gnu_type),
+ 8 * TYPE_ALIGN (gnu_type)))));
+}
+
+/* GNU_TYPE is the type of a subprogram parameter. Determine from the type if
+ it should be passed by reference. */
+
+int
+must_pass_by_ref (gnu_type)
+ tree gnu_type;
+{
+ /* We pass only unconstrained objects, those required by the language
+ to be passed by reference, and objects of variable size. The latter
+ is more efficient, avoids problems with variable size temporaries,
+ and does not produce compatibility problems with C, since C does
+ not have such objects. */
+ return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
+ || (AGGREGATE_TYPE_P (gnu_type) && TYPE_BY_REFERENCE_P (gnu_type))
+ || (TYPE_SIZE (gnu_type) != 0
+ && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST));
+}
+\f
+#if defined(MIPS_DEBUGGING_INFO) && defined(DWARF2_DEBUGGING_INFO)
+
+/* Convert NAME, which is possibly an Ada name, back to standard Ada
+ notation for SGI Workshop. */
+
+static char *
+convert_ada_name_to_qualified_name (name)
+ char *name;
+{
+ int len = strlen (name);
+ char *new_name = xstrdup (name);
+ char *buf;
+ int i, start;
+ char *qual_name_suffix = 0;
+ char *p;
+
+ if (len <= 3 || use_gnu_debug_info_extensions)
+ {
+ free (new_name);
+ return name;
+ }
+
+ /* Find the position of the first "__" after the first character of
+ NAME. This is the same as calling strstr except that we can't assume
+ the host has that function. We start after the first character so
+ we don't eliminate leading "__": these are emitted only by C
+ programs and are not qualified names */
+ for (p = (char *) index (&name[1], '_'); p != 0;
+ p = (char *) index (p+1, '_'))
+ if (p[1] == '_')
+ {
+ qual_name_suffix = p;
+ break;
+ }
+
+ if (qual_name_suffix == 0)
+ {
+ free (new_name);
+ return name;
+ }
+
+ start = qual_name_suffix - name;
+ buf = new_name + start;
+
+ for (i = start; i < len; i++)
+ {
+ if (name[i] == '_' && name[i + 1] == '_')
+ {
+ if (islower (name[i + 2]))
+ {
+ *buf++ = '.';
+ *buf++ = name[i + 2];
+ i += 2;
+ }
+ else if (name[i + 2] == '_' && islower (name[i + 3]))
+ {
+ /* convert foo___c___XVN to foo.c___XVN */
+ *buf++ = '.';
+ *buf++ = name[i + 3];
+ i += 3;
+ }
+ else if (name[i + 2] == 'T')
+ {
+ /* convert foo__TtypeS to foo.__TTypeS */
+ *buf++ = '.';
+ *buf++ = '_';
+ *buf++ = '_';
+ *buf++ = 'T';
+ i += 3;
+ }
+ else
+ *buf++ = name[i];
+ }
+ else
+ *buf++ = name[i];
+ }
+
+ *buf = 0;
+ return new_name;
+}
+#endif
+
+/* Emit a label UNITNAME_LABEL and specify that it is part of source
+ file FILENAME. If this is being written for SGI's Workshop
+ debugger, and we are writing Dwarf2 debugging information, add
+ additional debug info. */
+
+void
+emit_unit_label (unitname_label, filename)
+ char *unitname_label;
+ char *filename ATTRIBUTE_UNUSED;
+{
+ ASM_GLOBALIZE_LABEL (asm_out_file, unitname_label);
+ ASM_OUTPUT_LABEL (asm_out_file, unitname_label);
+}
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . F I L --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 2001, Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a set of routines to deal with file extensions
+
+with Ada.Strings.Fixed;
+with MLib.Tgt;
+
+package body MLib.Fil is
+
+ use Ada;
+
+ package Target renames MLib.Tgt;
+
+ ------------
+ -- Ext_To --
+ ------------
+
+ function Ext_To
+ (Filename : String;
+ New_Ext : String := "")
+ return String
+ is
+ use Strings.Fixed;
+ J : constant Natural :=
+ Index (Source => Filename,
+ Pattern => ".",
+ Going => Strings.Backward);
+
+ begin
+ if J = 0 then
+ if New_Ext = "" then
+ return Filename;
+ else
+ return Filename & "." & New_Ext;
+ end if;
+
+ else
+ if New_Ext = "" then
+ return Head (Filename, J - 1);
+ else
+ return Head (Filename, J - 1) & '.' & New_Ext;
+ end if;
+ end if;
+ end Ext_To;
+
+ -------------
+ -- Get_Ext --
+ -------------
+
+ function Get_Ext (Filename : in String) return String is
+ use Strings.Fixed;
+
+ J : constant Natural :=
+ Index (Source => Filename,
+ Pattern => ".",
+ Going => Strings.Backward);
+
+ begin
+ if J = 0 then
+ return "";
+ else
+ return Filename (J .. Filename'Last);
+ end if;
+ end Get_Ext;
+
+ ----------------
+ -- Is_Archive --
+ ----------------
+
+ function Is_Archive (Filename : String) return Boolean is
+ Ext : constant String := Get_Ext (Filename);
+
+ begin
+ return Target.Is_Archive_Ext (Ext);
+ end Is_Archive;
+
+ ----------
+ -- Is_C --
+ ----------
+
+ function Is_C (Filename : in String) return Boolean is
+ Ext : constant String := Get_Ext (Filename);
+
+ begin
+ return Target.Is_C_Ext (Ext);
+ end Is_C;
+
+ ------------
+ -- Is_Obj --
+ ------------
+
+ function Is_Obj (Filename : in String) return Boolean is
+ Ext : constant String := Get_Ext (Filename);
+
+ begin
+ return Target.Is_Object_Ext (Ext);
+ end Is_Obj;
+
+end MLib.Fil;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . F I L --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 2001, Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a set of routines to deal with file extensions
+
+package MLib.Fil is
+
+ function Ext_To
+ (Filename : String;
+ New_Ext : String := "")
+ return String;
+ -- Return Filename with the extention change to New_Ext.
+
+ function Get_Ext (Filename : in String) return String;
+ -- Return extention of filename.
+
+ function Is_Archive (Filename : String) return Boolean;
+ -- Test if filename is an archive
+
+ function Is_C (Filename : in String) return Boolean;
+ -- Test if Filename is a C file
+
+ function Is_Obj (Filename : in String) return Boolean;
+ -- Test if Filename is an object file
+
+end MLib.Fil;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . P R J --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 2001, Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Characters.Handling;
+
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with MLib.Fil;
+with MLib.Tgt;
+with Opt;
+with Output; use Output;
+with Osint; use Osint;
+with Namet; use Namet;
+with Table;
+with Types; use Types;
+
+package body MLib.Prj is
+
+ package Files renames MLib.Fil;
+ package Target renames MLib.Tgt;
+
+ -- List of objects to put inside the library
+
+ Object_Files : Argument_List_Access;
+ package Objects is new Table.Table
+ (Table_Name => "Mlib.Prj.Objects",
+ Table_Component_Type => String_Access,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 50,
+ Table_Increment => 50);
+
+ -- List of non-Ada object files
+
+ Foreign_Objects : Argument_List_Access;
+ package Foreigns is new Table.Table
+ (Table_Name => "Mlib.Prj.Foreigns",
+ Table_Component_Type => String_Access,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 20,
+ Table_Increment => 20);
+
+ -- List of ALI files
+
+ Ali_Files : Argument_List_Access;
+ package Alis is new Table.Table
+ (Table_Name => "Mlib.Prj.Alis",
+ Table_Component_Type => String_Access,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 50,
+ Table_Increment => 50);
+
+ -- List of options set in the command line.
+
+ Options : Argument_List_Access;
+ package Opts is new Table.Table
+ (Table_Name => "Mlib.Prj.Opts",
+ Table_Component_Type => String_Access,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 5,
+ Table_Increment => 5);
+
+ type Build_Mode_State is
+ (None, Static, Dynamic, Relocatable);
+
+ procedure Check (Filename : String);
+ -- Check if filename is a regular file. Fail if it is not.
+
+ procedure Check_Context;
+ -- Check each object files in table Object_Files
+ -- Fail if any of them is not a regular file
+
+ procedure Reset_Tables;
+ -- Make sure that all the above tables are empty
+ -- (Objects, Foreign_Objects, Ali_Files, Options)
+
+ -------------------
+ -- Build_Library --
+ -------------------
+
+ procedure Build_Library (For_Project : Project_Id) is
+ Data : constant Project_Data := Projects.Table (For_Project);
+
+ Project_Name : constant String :=
+ Get_Name_String (Data.Name);
+
+ Lib_Filename : String_Access;
+ Lib_Dirpath : String_Access := new String'(".");
+ DLL_Address : String_Access := new String'(Target.Default_DLL_Address);
+ Lib_Version : String_Access := new String'("");
+
+ The_Build_Mode : Build_Mode_State := None;
+
+ begin
+ Reset_Tables;
+
+ -- Fail if project is not a library project
+
+ if not Data.Library then
+ Fail ("project """, Project_Name, """ has no library");
+ end if;
+
+ Lib_Dirpath := new String'(Get_Name_String (Data.Library_Dir));
+ Lib_Filename := new String'(Get_Name_String (Data.Library_Name));
+
+ case Data.Library_Kind is
+ when Static =>
+ The_Build_Mode := Static;
+
+ when Dynamic =>
+ The_Build_Mode := Dynamic;
+
+ when Relocatable =>
+ The_Build_Mode := Relocatable;
+
+ if Target.PIC_Option /= "" then
+ Opts.Increment_Last;
+ Opts.Table (Opts.Last) := new String'(Target.PIC_Option);
+ end if;
+ end case;
+
+ -- Get the library version, if any
+
+ if Data.Lib_Internal_Name /= No_Name then
+ Lib_Version := new String'(Get_Name_String (Data.Lib_Internal_Name));
+ end if;
+
+ -- Add the objects found in the object directory
+
+ declare
+ Object_Dir : Dir_Type;
+ Filename : String (1 .. 255);
+ Last : Natural;
+ Object_Dir_Path : constant String :=
+ Get_Name_String (Data.Object_Directory);
+ begin
+ Open (Dir => Object_Dir, Dir_Name => Object_Dir_Path);
+
+ -- For all entries in the object directory
+
+ loop
+ Read (Object_Dir, Filename, Last);
+
+ exit when Last = 0;
+
+ -- Check if it is an object file
+
+ if Files.Is_Obj (Filename (1 .. Last)) then
+ -- record this object file
+
+ Objects.Increment_Last;
+ Objects.Table (Objects.Last) :=
+ new String' (Object_Dir_Path & Directory_Separator &
+ Filename (1 .. Last));
+
+ if Is_Regular_File
+ (Object_Dir_Path &
+ Files.Ext_To (Object_Dir_Path &
+ Filename (1 .. Last), "ali"))
+ then
+ -- Record the corresponding ali file
+
+ Alis.Increment_Last;
+ Alis.Table (Alis.Last) :=
+ new String' (Object_Dir_Path &
+ Files.Ext_To
+ (Filename (1 .. Last), "ali"));
+
+ else
+ -- The object file is a foreign object file
+
+ Foreigns.Increment_Last;
+ Foreigns.Table (Foreigns.Last) :=
+ new String'(Object_Dir_Path &
+ Filename (1 .. Last));
+
+ end if;
+ end if;
+ end loop;
+
+ Close (Dir => Object_Dir);
+
+ exception
+ when Directory_Error =>
+ Fail ("cannot find object directory """,
+ Get_Name_String (Data.Object_Directory),
+ """");
+ end;
+
+ -- We want to link some Ada files, so we need to link with
+ -- the GNAT runtime (libgnat & libgnarl)
+
+ if The_Build_Mode = Dynamic or else The_Build_Mode = Relocatable then
+ Opts.Increment_Last;
+ Opts.Table (Opts.Last) := new String' ("-lgnarl");
+ Opts.Increment_Last;
+ Opts.Table (Opts.Last) := new String' ("-lgnat");
+ end if;
+
+ Object_Files :=
+ new Argument_List'(Argument_List (Objects.Table (1 .. Objects.Last)));
+
+ Foreign_Objects :=
+ new Argument_List'(Argument_List
+ (Foreigns.Table (1 .. Foreigns.Last)));
+
+ Ali_Files :=
+ new Argument_List'(Argument_List (Alis.Table (1 .. Alis.Last)));
+
+ Options :=
+ new Argument_List'(Argument_List (Opts.Table (1 .. Opts.Last)));
+
+ -- We fail if there are no object to put in the library
+ -- (Ada or foreign objects)
+
+ if Object_Files'Length = 0 then
+ Fail ("no object files");
+
+ end if;
+
+ if not Opt.Quiet_Output then
+ Write_Eol;
+ Write_Str ("building ");
+ Write_Str (Ada.Characters.Handling.To_Lower
+ (Build_Mode_State'Image (The_Build_Mode)));
+ Write_Str (" library for project ");
+ Write_Line (Project_Name);
+ Write_Eol;
+ end if;
+
+ -- We check that all object files are regular files
+
+ Check_Context;
+
+ -- And we call the procedure to build the library,
+ -- depending on the build mode
+
+ case The_Build_Mode is
+ when Dynamic | Relocatable =>
+ Target.Build_Dynamic_Library
+ (Ofiles => Object_Files.all,
+ Foreign => Foreign_Objects.all,
+ Afiles => Ali_Files.all,
+ Options => Options.all,
+ Lib_Filename => Lib_Filename.all,
+ Lib_Dir => Lib_Dirpath.all,
+ Lib_Address => DLL_Address.all,
+ Lib_Version => Lib_Version.all,
+ Relocatable => The_Build_Mode = Relocatable);
+
+ when Static =>
+ MLib.Build_Library
+ (Object_Files.all,
+ Ali_Files.all,
+ Lib_Filename.all,
+ Lib_Dirpath.all);
+
+ when None =>
+ null;
+ end case;
+
+ -- We need to copy the ALI files from the object directory
+ -- to the library directory, so that the linker find them
+ -- there, and does not need to look in the object directory
+ -- where it would also find the object files; and we don't want
+ -- that: we want the linker to use the library.
+
+ Target.Copy_ALI_Files
+ (From => Projects.Table (For_Project).Object_Directory,
+ To => Projects.Table (For_Project).Library_Dir);
+
+ end Build_Library;
+
+ -----------
+ -- Check --
+ -----------
+
+ procedure Check (Filename : String) is
+ begin
+ if not Is_Regular_File (Filename) then
+ Fail (Filename, " not found.");
+
+ end if;
+ end Check;
+
+ -------------------
+ -- Check_Context --
+ -------------------
+
+ procedure Check_Context is
+ begin
+ -- check that each object file exist
+
+ for F in Object_Files'Range loop
+ Check (Object_Files (F).all);
+ end loop;
+ end Check_Context;
+
+ ------------------
+ -- Reset_Tables --
+ ------------------
+
+ procedure Reset_Tables is
+ begin
+ Objects.Init;
+ Foreigns.Init;
+ Alis.Init;
+ Opts.Init;
+ end Reset_Tables;
+
+end MLib.Prj;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . P R J --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 2001, Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package builds a library for a library project file
+
+with Prj; use Prj;
+
+package MLib.Prj is
+
+ procedure Build_Library (For_Project : Project_Id);
+ -- Build the library of library project For_Project
+ -- Fails if For_Project is not a library project file
+
+end MLib.Prj;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . T G T --
+-- (Default Version) --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 2001, Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the default version which does not support libraries.
+-- All subprograms are dummies, because they are never called,
+-- except Libraries_Are_Supported which returns False.
+
+package body MLib.Tgt is
+
+ -----------------
+ -- Archive_Ext --
+ -----------------
+
+ function Archive_Ext return String is
+ begin
+ return "";
+ end Archive_Ext;
+
+ -----------------
+ -- Base_Option --
+ -----------------
+
+ function Base_Option return String is
+ begin
+ return "";
+ end Base_Option;
+
+ ---------------------------
+ -- Build_Dynamic_Library --
+ ---------------------------
+
+ procedure Build_Dynamic_Library
+ (Ofiles : Argument_List;
+ Foreign : Argument_List;
+ Afiles : Argument_List;
+ Options : Argument_List;
+ Lib_Filename : String;
+ Lib_Dir : String;
+ Lib_Address : String := "";
+ Lib_Version : String := "";
+ Relocatable : Boolean := False)
+ is
+ begin
+ null;
+ end Build_Dynamic_Library;
+
+ --------------------
+ -- Copy_ALI_Files --
+ --------------------
+
+ procedure Copy_ALI_Files
+ (From : Name_Id;
+ To : Name_Id)
+ is
+ begin
+ null;
+ end Copy_ALI_Files;
+
+ -------------------------
+ -- Default_DLL_Address --
+ -------------------------
+
+ function Default_DLL_Address return String is
+ begin
+ return "";
+ end Default_DLL_Address;
+
+ -------------
+ -- 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;
+
+ -------------------
+ -- Is_Object_Ext --
+ -------------------
+
+ function Is_Object_Ext (Ext : String) return Boolean is
+ begin
+ return False;
+ end Is_Object_Ext;
+
+ --------------
+ -- Is_C_Ext --
+ --------------
+
+ function Is_C_Ext (Ext : String) return Boolean is
+ begin
+ return False;
+ end Is_C_Ext;
+
+ --------------------
+ -- Is_Archive_Ext --
+ --------------------
+
+ function Is_Archive_Ext (Ext : String) return Boolean is
+ begin
+ return False;
+ end Is_Archive_Ext;
+
+ -------------
+ -- Libgnat --
+ -------------
+
+ function Libgnat return String is
+ begin
+ return "libgnat.a";
+ end Libgnat;
+
+ -----------------------------
+ -- Libraries_Are_Supported --
+ -----------------------------
+
+ function Libraries_Are_Supported return Boolean is
+ begin
+ return False;
+ end Libraries_Are_Supported;
+
+ --------------------------------
+ -- Linker_Library_Path_Option --
+ --------------------------------
+
+ function Linker_Library_Path_Option
+ (Directory : String)
+ return String_Access
+ is
+ begin
+ return null;
+ end Linker_Library_Path_Option;
+
+ ----------------
+ -- Object_Ext --
+ ----------------
+
+ function Object_Ext return String is
+ begin
+ return "";
+ end Object_Ext;
+
+ ----------------
+ -- PIC_Option --
+ ----------------
+
+ function PIC_Option return String is
+ begin
+ return "";
+ end PIC_Option;
+
+end MLib.Tgt;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . T G T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 2001, Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a set of target dependent routines to build
+-- static, dynamic and shared libraries.
+
+-- There are several versions for the body of this package.
+
+-- In the default version, libraries are not supported, so function
+-- Libraries_Are_Supported returns False.
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Types; use Types;
+
+package MLib.Tgt is
+
+ function Libraries_Are_Supported return Boolean;
+ -- Indicates if building libraries by gnatmake and gnatmlib
+ -- are supported by the GNAT implementation for the OS.
+
+ function Default_DLL_Address return String;
+ -- default address for non relocatable DLL
+
+ function Dynamic_Option return String;
+ -- gcc option to create a dynamic library
+
+ function Base_Option return String;
+
+ function Libgnat return String;
+ -- System dependent static GNAT library
+
+ function Archive_Ext return String;
+ -- System dependent static library extension
+
+ function Object_Ext return String;
+ -- System dependent object extension
+
+ function DLL_Ext return String;
+ -- System dependent dynamic library extension
+
+ function PIC_Option return String;
+ -- Position independent code option
+
+ function Is_Object_Ext (Ext : String) return Boolean;
+ -- Returns True iff Ext is an object file extension
+
+ function Is_C_Ext (Ext : String) return Boolean;
+ -- Returns True iff Ext is a C file extension.
+
+ function Is_Archive_Ext (Ext : String) return Boolean;
+ -- Returns True iff Ext is an extension for a library
+
+ procedure Copy_ALI_Files
+ (From : Name_Id;
+ To : Name_Id);
+ -- Copy all ALI files from directory From to directory To
+
+ function Linker_Library_Path_Option
+ (Directory : String)
+ return String_Access;
+ -- Linker option to specify the library directory path
+
+ procedure Build_Dynamic_Library
+ (Ofiles : Argument_List;
+ Foreign : Argument_List;
+ Afiles : Argument_List;
+ Options : Argument_List;
+ Lib_Filename : String;
+ Lib_Dir : String;
+ Lib_Address : String := "";
+ Lib_Version : String := "";
+ Relocatable : Boolean := False);
+ -- Build a dynamic/relocatable library
+
+end MLib.Tgt;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . U T L --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.3 $
+-- --
+-- Copyright (C) 2001, Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with MLib.Fil;
+with MLib.Tgt;
+with Namet; use Namet;
+with Opt;
+with Osint; use Osint;
+with Output; use Output;
+
+package body MLib.Utl is
+
+ use GNAT;
+
+ package Files renames MLib.Fil;
+ package Target renames MLib.Tgt;
+
+ Initialized : Boolean := False;
+
+ Gcc_Name : constant String := "gcc";
+ Gcc_Exec : OS_Lib.String_Access;
+
+ Ar_Name : constant String := "ar";
+ Ar_Exec : OS_Lib.String_Access;
+
+ Ranlib_Name : constant String := "ranlib";
+ Ranlib_Exec : OS_Lib.String_Access;
+
+ procedure Initialize;
+ -- Look for the tools in the path and record the full path for each one
+
+ --------
+ -- Ar --
+ --------
+
+ procedure Ar (Output_File : String; Objects : Argument_List) is
+ Create_Add_Opt : OS_Lib.String_Access := new String' ("cr");
+
+ Full_Output_File : constant String :=
+ Files.Ext_To (Output_File, Target.Archive_Ext);
+
+ Arguments : OS_Lib.Argument_List (1 .. 2 + Objects'Length);
+ Success : Boolean;
+
+ begin
+ Initialize;
+
+ Arguments (1) := Create_Add_Opt; -- "ar cr ..."
+ Arguments (2) := new String'(Full_Output_File);
+ Arguments (3 .. Arguments'Last) := Objects;
+
+ Delete_File (Full_Output_File);
+
+ if not Opt.Quiet_Output then
+ Write_Str (Ar_Name);
+
+ for J in Arguments'Range loop
+ Write_Char (' ');
+ Write_Str (Arguments (J).all);
+ end loop;
+
+ Write_Eol;
+ end if;
+
+ OS_Lib.Spawn (Ar_Exec.all, Arguments, Success);
+
+ if not Success then
+ Fail (Ar_Name, " execution error.");
+ end if;
+
+ -- If we have found ranlib, run it over the library
+
+ if Ranlib_Exec /= null then
+ if not Opt.Quiet_Output then
+ Write_Str (Ranlib_Name);
+ Write_Char (' ');
+ Write_Line (Arguments (2).all);
+ end if;
+
+ OS_Lib.Spawn (Ranlib_Exec.all, (1 => Arguments (2)), Success);
+
+ if not Success then
+ Fail (Ranlib_Name, " execution error.");
+ end if;
+ end if;
+ end Ar;
+
+ -----------------
+ -- Delete_File --
+ -----------------
+
+ procedure Delete_File (Filename : in String) is
+ File : constant String := Filename & ASCII.Nul;
+ Success : Boolean;
+
+ begin
+ OS_Lib.Delete_File (File'Address, Success);
+
+ if Opt.Verbose_Mode then
+ if Success then
+ Write_Str ("deleted ");
+
+ else
+ Write_Str ("could not delete ");
+ end if;
+
+ Write_Line (Filename);
+ end if;
+ end Delete_File;
+
+ ---------
+ -- Gcc --
+ ---------
+
+ procedure Gcc
+ (Output_File : String;
+ Objects : Argument_List;
+ Options : Argument_List;
+ Base_File : String := "")
+ is
+ Arguments : OS_Lib.Argument_List
+ (1 .. 7 + Objects'Length + Options'Length);
+
+ A : Natural := 0;
+ Success : Boolean;
+ Out_Opt : OS_Lib.String_Access := new String' ("-o");
+ Out_V : OS_Lib.String_Access := new String' (Output_File);
+ Lib_Dir : OS_Lib.String_Access := new String' ("-L" & Lib_Directory);
+ Lib_Opt : OS_Lib.String_Access := new String' (Target.Dynamic_Option);
+
+ begin
+ Initialize;
+
+ if Lib_Opt'Length /= 0 then
+ A := A + 1;
+ Arguments (A) := Lib_Opt;
+ end if;
+
+ A := A + 1;
+ Arguments (A) := Out_Opt;
+ A := A + 1;
+ Arguments (A) := Out_V;
+
+ A := A + 1;
+ Arguments (A) := Lib_Dir;
+
+ A := A + Options'Length;
+ Arguments (A - Options'Length + 1 .. A) := Options;
+
+ A := A + Objects'Length;
+ Arguments (A - Objects'Length + 1 .. A) := Objects;
+
+ if not Opt.Quiet_Output then
+ Write_Str (Gcc_Exec.all);
+
+ for J in 1 .. A loop
+ Write_Char (' ');
+ Write_Str (Arguments (J).all);
+ end loop;
+
+ Write_Eol;
+ end if;
+
+ OS_Lib.Spawn (Gcc_Exec.all, Arguments (1 .. A), Success);
+
+ if not Success then
+ Fail (Gcc_Name, " execution error");
+ end if;
+ end Gcc;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ use type OS_Lib.String_Access;
+
+ begin
+ if not Initialized then
+ Initialized := True;
+
+ -- gcc
+
+ Gcc_Exec := OS_Lib.Locate_Exec_On_Path (Gcc_Name);
+
+ if Gcc_Exec = null then
+
+ Fail (Gcc_Name, " not found in path");
+
+ elsif Opt.Verbose_Mode then
+ Write_Str ("found ");
+ Write_Line (Gcc_Exec.all);
+ end if;
+
+ -- ar
+
+ Ar_Exec := OS_Lib.Locate_Exec_On_Path (Ar_Name);
+
+ if Ar_Exec = null then
+
+ Fail (Ar_Name, " not found in path");
+
+ elsif Opt.Verbose_Mode then
+ Write_Str ("found ");
+ Write_Line (Ar_Exec.all);
+ end if;
+
+ -- ranlib
+
+ Ranlib_Exec := OS_Lib.Locate_Exec_On_Path (Ranlib_Name);
+
+ if Ranlib_Exec /= null and then Opt.Verbose_Mode then
+ Write_Str ("found ");
+ Write_Line (Ranlib_Exec.all);
+ end if;
+
+ end if;
+
+ end Initialize;
+
+ -------------------
+ -- Lib_Directory --
+ -------------------
+
+ function Lib_Directory return String is
+ Libgnat : constant String := Target.Libgnat;
+
+ begin
+ Name_Len := Libgnat'Length;
+ Name_Buffer (1 .. Name_Len) := Libgnat;
+ Get_Name_String (Find_File (Name_Enter, Library));
+
+ -- Remove libgnat.a
+
+ return Name_Buffer (1 .. Name_Len - Libgnat'Length);
+ end Lib_Directory;
+
+end MLib.Utl;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . U T L --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 2001, Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides an easy way of calling various tools such as gcc,
+-- ar, etc...
+
+package MLib.Utl is
+
+ procedure Delete_File (Filename : in String);
+ -- Delete the file Filename.
+
+ procedure Gcc
+ (Output_File : String;
+ Objects : Argument_List;
+ Options : Argument_List;
+ Base_File : String := "");
+ -- Invoke gcc to create a library.
+
+ procedure Ar
+ (Output_File : String;
+ Objects : Argument_List);
+ -- Run ar to move all the binaries inside the archive.
+ -- If ranlib is on the path, run it also.
+
+ function Lib_Directory return String;
+ -- Return the directory containing libgnat.
+
+end MLib.Utl;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1999-2001, Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Opt;
+with Osint; use Osint;
+with Output; use Output;
+with MLib.Utl;
+
+package body MLib is
+
+ package Tools renames MLib.Utl;
+
+ -------------------
+ -- Build_Library --
+ -------------------
+
+ procedure Build_Library
+ (Ofiles : Argument_List;
+ Afiles : Argument_List;
+ Output_File : String;
+ Output_Dir : String)
+ is
+ use GNAT.OS_Lib;
+
+ begin
+ if not Opt.Quiet_Output then
+ Write_Line ("building a library...");
+ Write_Str (" make ");
+ Write_Line (Output_File);
+ end if;
+
+ Tools.Ar (Output_Dir & "/lib" & Output_File & ".a", Objects => Ofiles);
+
+ end Build_Library;
+
+ ------------------------
+ -- Check_Library_Name --
+ ------------------------
+
+ procedure Check_Library_Name (Name : String) is
+ begin
+ if Name'Length = 0 then
+ Fail ("library name cannot be empty");
+ end if;
+
+ if Name'Length > Max_Characters_In_Library_Name then
+ Fail ("illegal library name """,
+ Name,
+ """: too long");
+ end if;
+
+ if not Is_Letter (Name (Name'First)) then
+ Fail ("illegal library name """,
+ Name,
+ """: should start with a letter");
+ end if;
+
+ for Index in Name'Range loop
+ if not Is_Alphanumeric (Name (Index)) then
+ Fail ("illegal library name """,
+ Name,
+ """: should include only letters and digits");
+ end if;
+ end loop;
+ end Check_Library_Name;
+
+end MLib;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1999-2001, Ada Core Technologies, 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 2, 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 COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides the core high level routines used by GNATMLIB
+-- and GNATMAKE to build libraries
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+package MLib is
+
+ Tools_Error : exception;
+ -- ??? needs comment
+
+ Max_Characters_In_Library_Name : constant := 20;
+ -- ??? needs comment
+
+ procedure Check_Library_Name (Name : String);
+ -- Verify that the name of a library has the following characteristics
+ -- - starts with a letter
+ -- - includes only letters and digits
+ -- - contains not more than Max_Characters_In_Library_Name characters
+
+ procedure Build_Library
+ (Ofiles : Argument_List;
+ Afiles : Argument_List;
+ Output_File : String;
+ Output_Dir : String);
+ -- Build a static library from a set of object files
+
+end MLib;
projects / gcc.git / commitdiff