diff options
177 files changed, 68905 insertions, 0 deletions
diff --git a/gcc/ada/51osinte.adb b/gcc/ada/51osinte.adb new file mode 100644 index 00000000000..c212f506714 --- /dev/null +++ b/gcc/ada/51osinte.adb @@ -0,0 +1,177 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/51osinte.ads b/gcc/ada/51osinte.ads new file mode 100644 index 00000000000..80b2b95fe13 --- /dev/null +++ b/gcc/ada/51osinte.ads @@ -0,0 +1,597 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/52osinte.adb b/gcc/ada/52osinte.adb new file mode 100644 index 00000000000..19014f3fe1c --- /dev/null +++ b/gcc/ada/52osinte.adb @@ -0,0 +1,594 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/52osinte.ads b/gcc/ada/52osinte.ads new file mode 100644 index 00000000000..5986e55cf38 --- /dev/null +++ b/gcc/ada/52osinte.ads @@ -0,0 +1,556 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/52system.ads b/gcc/ada/52system.ads new file mode 100644 index 00000000000..0ba9d6a5e6c --- /dev/null +++ b/gcc/ada/52system.ads @@ -0,0 +1,151 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/53osinte.ads b/gcc/ada/53osinte.ads new file mode 100644 index 00000000000..2b7c6d9d2ae --- /dev/null +++ b/gcc/ada/53osinte.ads @@ -0,0 +1,543 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/54osinte.ads b/gcc/ada/54osinte.ads new file mode 100644 index 00000000000..7737c064ac7 --- /dev/null +++ b/gcc/ada/54osinte.ads @@ -0,0 +1,534 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5amastop.adb b/gcc/ada/5amastop.adb new file mode 100644 index 00000000000..5eac869a052 --- /dev/null +++ b/gcc/ada/5amastop.adb @@ -0,0 +1,174 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5aosinte.adb b/gcc/ada/5aosinte.adb new file mode 100644 index 00000000000..4637b6a6f55 --- /dev/null +++ b/gcc/ada/5aosinte.adb @@ -0,0 +1,116 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5aosinte.ads b/gcc/ada/5aosinte.ads new file mode 100644 index 00000000000..8a1ee3b4a39 --- /dev/null +++ b/gcc/ada/5aosinte.ads @@ -0,0 +1,535 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5asystem.ads b/gcc/ada/5asystem.ads new file mode 100644 index 00000000000..f777d2b916b --- /dev/null +++ b/gcc/ada/5asystem.ads @@ -0,0 +1,229 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5ataprop.adb b/gcc/ada/5ataprop.adb new file mode 100644 index 00000000000..ac19d7b78b4 --- /dev/null +++ b/gcc/ada/5ataprop.adb @@ -0,0 +1,997 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5atasinf.ads b/gcc/ada/5atasinf.ads new file mode 100644 index 00000000000..4ddf7a97e11 --- /dev/null +++ b/gcc/ada/5atasinf.ads @@ -0,0 +1,117 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5ataspri.ads b/gcc/ada/5ataspri.ads new file mode 100644 index 00000000000..13d637974f4 --- /dev/null +++ b/gcc/ada/5ataspri.ads @@ -0,0 +1,96 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5atpopsp.adb b/gcc/ada/5atpopsp.adb new file mode 100644 index 00000000000..ada9ee92dcb --- /dev/null +++ b/gcc/ada/5atpopsp.adb @@ -0,0 +1,279 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5avxwork.ads b/gcc/ada/5avxwork.ads new file mode 100644 index 00000000000..eb8612ebe44 --- /dev/null +++ b/gcc/ada/5avxwork.ads @@ -0,0 +1,110 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5bosinte.adb b/gcc/ada/5bosinte.adb new file mode 100644 index 00000000000..79062bb407b --- /dev/null +++ b/gcc/ada/5bosinte.adb @@ -0,0 +1,155 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5bosinte.ads b/gcc/ada/5bosinte.ads new file mode 100644 index 00000000000..febce55b836 --- /dev/null +++ b/gcc/ada/5bosinte.ads @@ -0,0 +1,582 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5bsystem.ads b/gcc/ada/5bsystem.ads new file mode 100644 index 00000000000..677db87fd40 --- /dev/null +++ b/gcc/ada/5bsystem.ads @@ -0,0 +1,151 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5cosinte.ads b/gcc/ada/5cosinte.ads new file mode 100644 index 00000000000..5c57e2c47af --- /dev/null +++ b/gcc/ada/5cosinte.ads @@ -0,0 +1,584 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5dosinte.ads b/gcc/ada/5dosinte.ads new file mode 100644 index 00000000000..a1d86b607d9 --- /dev/null +++ b/gcc/ada/5dosinte.ads @@ -0,0 +1,539 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5esystem.ads b/gcc/ada/5esystem.ads new file mode 100644 index 00000000000..052776374d8 --- /dev/null +++ b/gcc/ada/5esystem.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5etpopse.adb b/gcc/ada/5etpopse.adb new file mode 100644 index 00000000000..a5c1cf34a3c --- /dev/null +++ b/gcc/ada/5etpopse.adb @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5fintman.adb b/gcc/ada/5fintman.adb new file mode 100644 index 00000000000..919562dfc5a --- /dev/null +++ b/gcc/ada/5fintman.adb @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5fosinte.ads b/gcc/ada/5fosinte.ads new file mode 100644 index 00000000000..6e5973d9e21 --- /dev/null +++ b/gcc/ada/5fosinte.ads @@ -0,0 +1,524 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5fsystem.ads b/gcc/ada/5fsystem.ads new file mode 100644 index 00000000000..dca9f664a58 --- /dev/null +++ b/gcc/ada/5fsystem.ads @@ -0,0 +1,153 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5ftaprop.adb b/gcc/ada/5ftaprop.adb new file mode 100644 index 00000000000..c9213f2b0fc --- /dev/null +++ b/gcc/ada/5ftaprop.adb @@ -0,0 +1,998 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5ftasinf.ads b/gcc/ada/5ftasinf.ads new file mode 100644 index 00000000000..8faecacb6a6 --- /dev/null +++ b/gcc/ada/5ftasinf.ads @@ -0,0 +1,142 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5ginterr.adb b/gcc/ada/5ginterr.adb new file mode 100644 index 00000000000..c4db14c98a7 --- /dev/null +++ b/gcc/ada/5ginterr.adb @@ -0,0 +1,666 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5gintman.adb b/gcc/ada/5gintman.adb new file mode 100644 index 00000000000..ad3ef44169f --- /dev/null +++ b/gcc/ada/5gintman.adb @@ -0,0 +1,115 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5gmastop.adb b/gcc/ada/5gmastop.adb new file mode 100644 index 00000000000..9dd0bad83b4 --- /dev/null +++ b/gcc/ada/5gmastop.adb @@ -0,0 +1,420 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5gosinte.ads b/gcc/ada/5gosinte.ads new file mode 100644 index 00000000000..7b9c0cc04ea --- /dev/null +++ b/gcc/ada/5gosinte.ads @@ -0,0 +1,698 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5gproinf.adb b/gcc/ada/5gproinf.adb new file mode 100644 index 00000000000..2f821a1c67e --- /dev/null +++ b/gcc/ada/5gproinf.adb @@ -0,0 +1,223 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5gproinf.ads b/gcc/ada/5gproinf.ads new file mode 100644 index 00000000000..070e0b2ad06 --- /dev/null +++ b/gcc/ada/5gproinf.ads @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5gsystem.ads b/gcc/ada/5gsystem.ads new file mode 100644 index 00000000000..e97781786ae --- /dev/null +++ b/gcc/ada/5gsystem.ads @@ -0,0 +1,153 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5gtaprop.adb b/gcc/ada/5gtaprop.adb new file mode 100644 index 00000000000..0ec29dfb2c3 --- /dev/null +++ b/gcc/ada/5gtaprop.adb @@ -0,0 +1,968 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5gtasinf.adb b/gcc/ada/5gtasinf.adb new file mode 100644 index 00000000000..b56675072b6 --- /dev/null +++ b/gcc/ada/5gtasinf.adb @@ -0,0 +1,270 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5gtasinf.ads b/gcc/ada/5gtasinf.ads new file mode 100644 index 00000000000..08955d8f0a7 --- /dev/null +++ b/gcc/ada/5gtasinf.ads @@ -0,0 +1,272 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5gtpgetc.adb b/gcc/ada/5gtpgetc.adb new file mode 100644 index 00000000000..2d6edd8a29f --- /dev/null +++ b/gcc/ada/5gtpgetc.adb @@ -0,0 +1,210 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5hosinte.adb b/gcc/ada/5hosinte.adb new file mode 100644 index 00000000000..753c041942a --- /dev/null +++ b/gcc/ada/5hosinte.adb @@ -0,0 +1,561 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5hosinte.ads b/gcc/ada/5hosinte.ads new file mode 100644 index 00000000000..665715d1377 --- /dev/null +++ b/gcc/ada/5hosinte.ads @@ -0,0 +1,491 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5hparame.ads b/gcc/ada/5hparame.ads new file mode 100644 index 00000000000..cdce2ba334d --- /dev/null +++ b/gcc/ada/5hparame.ads @@ -0,0 +1,135 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5hsystem.ads b/gcc/ada/5hsystem.ads new file mode 100644 index 00000000000..fef7ae9f3f3 --- /dev/null +++ b/gcc/ada/5hsystem.ads @@ -0,0 +1,226 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5htaprop.adb b/gcc/ada/5htaprop.adb new file mode 100644 index 00000000000..95e5c3cec11 --- /dev/null +++ b/gcc/ada/5htaprop.adb @@ -0,0 +1,1002 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5htaspri.ads b/gcc/ada/5htaspri.ads new file mode 100644 index 00000000000..9bb0c20563c --- /dev/null +++ b/gcc/ada/5htaspri.ads @@ -0,0 +1,92 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5htraceb.adb b/gcc/ada/5htraceb.adb new file mode 100644 index 00000000000..cbc6680f123 --- /dev/null +++ b/gcc/ada/5htraceb.adb @@ -0,0 +1,601 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; + diff --git a/gcc/ada/5iosinte.adb b/gcc/ada/5iosinte.adb new file mode 100644 index 00000000000..fd47dda7261 --- /dev/null +++ b/gcc/ada/5iosinte.adb @@ -0,0 +1,130 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5iosinte.ads b/gcc/ada/5iosinte.ads new file mode 100644 index 00000000000..571cea2869f --- /dev/null +++ b/gcc/ada/5iosinte.ads @@ -0,0 +1,519 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5itaprop.adb b/gcc/ada/5itaprop.adb new file mode 100644 index 00000000000..bc4b7d33efc --- /dev/null +++ b/gcc/ada/5itaprop.adb @@ -0,0 +1,1044 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5itaspri.ads b/gcc/ada/5itaspri.ads new file mode 100644 index 00000000000..0360c2999a1 --- /dev/null +++ b/gcc/ada/5itaspri.ads @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5ksystem.ads b/gcc/ada/5ksystem.ads new file mode 100644 index 00000000000..d3d9a66f609 --- /dev/null +++ b/gcc/ada/5ksystem.ads @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5kvxwork.ads b/gcc/ada/5kvxwork.ads new file mode 100644 index 00000000000..85cbe3d8021 --- /dev/null +++ b/gcc/ada/5kvxwork.ads @@ -0,0 +1,121 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5lintman.adb b/gcc/ada/5lintman.adb new file mode 100644 index 00000000000..5361af7f281 --- /dev/null +++ b/gcc/ada/5lintman.adb @@ -0,0 +1,357 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5lml-tgt.adb b/gcc/ada/5lml-tgt.adb new file mode 100644 index 00000000000..973243da1a0 --- /dev/null +++ b/gcc/ada/5lml-tgt.adb @@ -0,0 +1,343 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5losinte.ads b/gcc/ada/5losinte.ads new file mode 100644 index 00000000000..9a1e6c5ca53 --- /dev/null +++ b/gcc/ada/5losinte.ads @@ -0,0 +1,594 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5lsystem.ads b/gcc/ada/5lsystem.ads new file mode 100644 index 00000000000..9ec0bbc6321 --- /dev/null +++ b/gcc/ada/5lsystem.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5mosinte.ads b/gcc/ada/5mosinte.ads new file mode 100644 index 00000000000..571317af383 --- /dev/null +++ b/gcc/ada/5mosinte.ads @@ -0,0 +1,562 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5mvxwork.ads b/gcc/ada/5mvxwork.ads new file mode 100644 index 00000000000..2daf08ca222 --- /dev/null +++ b/gcc/ada/5mvxwork.ads @@ -0,0 +1,103 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5ninmaop.adb b/gcc/ada/5ninmaop.adb new file mode 100644 index 00000000000..11787bbf928 --- /dev/null +++ b/gcc/ada/5ninmaop.adb @@ -0,0 +1,194 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5nintman.adb b/gcc/ada/5nintman.adb new file mode 100644 index 00000000000..4b4a34c9346 --- /dev/null +++ b/gcc/ada/5nintman.adb @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5nosinte.ads b/gcc/ada/5nosinte.ads new file mode 100644 index 00000000000..c854786c2ba --- /dev/null +++ b/gcc/ada/5nosinte.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5ntaprop.adb b/gcc/ada/5ntaprop.adb new file mode 100644 index 00000000000..fa28e368920 --- /dev/null +++ b/gcc/ada/5ntaprop.adb @@ -0,0 +1,434 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5ntaspri.ads b/gcc/ada/5ntaspri.ads new file mode 100644 index 00000000000..e51b948c7a2 --- /dev/null +++ b/gcc/ada/5ntaspri.ads @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5ointerr.adb b/gcc/ada/5ointerr.adb new file mode 100644 index 00000000000..31726f2acbc --- /dev/null +++ b/gcc/ada/5ointerr.adb @@ -0,0 +1,303 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5omastop.adb b/gcc/ada/5omastop.adb new file mode 100644 index 00000000000..129ea81d705 --- /dev/null +++ b/gcc/ada/5omastop.adb @@ -0,0 +1,592 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5oosinte.adb b/gcc/ada/5oosinte.adb new file mode 100644 index 00000000000..b5686b31548 --- /dev/null +++ b/gcc/ada/5oosinte.adb @@ -0,0 +1,256 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5oosinte.ads b/gcc/ada/5oosinte.ads new file mode 100644 index 00000000000..70d6bb2518e --- /dev/null +++ b/gcc/ada/5oosinte.ads @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5oosprim.adb b/gcc/ada/5oosprim.adb new file mode 100644 index 00000000000..0531bdec522 --- /dev/null +++ b/gcc/ada/5oosprim.adb @@ -0,0 +1,175 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5oparame.adb b/gcc/ada/5oparame.adb new file mode 100644 index 00000000000..44d24ea5d2a --- /dev/null +++ b/gcc/ada/5oparame.adb @@ -0,0 +1,85 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5osystem.ads b/gcc/ada/5osystem.ads new file mode 100644 index 00000000000..f5110ed20f3 --- /dev/null +++ b/gcc/ada/5osystem.ads @@ -0,0 +1,151 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5otaprop.adb b/gcc/ada/5otaprop.adb new file mode 100644 index 00000000000..3fd7229a79e --- /dev/null +++ b/gcc/ada/5otaprop.adb @@ -0,0 +1,1066 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5otaspri.ads b/gcc/ada/5otaspri.ads new file mode 100644 index 00000000000..dd4fc9e9016 --- /dev/null +++ b/gcc/ada/5otaspri.ads @@ -0,0 +1,110 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5posinte.ads b/gcc/ada/5posinte.ads new file mode 100644 index 00000000000..8e2a8ace0a0 --- /dev/null +++ b/gcc/ada/5posinte.ads @@ -0,0 +1,567 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5posprim.adb b/gcc/ada/5posprim.adb new file mode 100644 index 00000000000..72130a0becc --- /dev/null +++ b/gcc/ada/5posprim.adb @@ -0,0 +1,139 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5pvxwork.ads b/gcc/ada/5pvxwork.ads new file mode 100644 index 00000000000..47deae2da5b --- /dev/null +++ b/gcc/ada/5pvxwork.ads @@ -0,0 +1,103 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5qosinte.adb b/gcc/ada/5qosinte.adb new file mode 100644 index 00000000000..fd7e4525199 --- /dev/null +++ b/gcc/ada/5qosinte.adb @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5qosinte.ads b/gcc/ada/5qosinte.ads new file mode 100644 index 00000000000..7bc4d2c8088 --- /dev/null +++ b/gcc/ada/5qosinte.ads @@ -0,0 +1,188 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5qparame.ads b/gcc/ada/5qparame.ads new file mode 100644 index 00000000000..776f7ca9744 --- /dev/null +++ b/gcc/ada/5qparame.ads @@ -0,0 +1,136 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5qstache.adb b/gcc/ada/5qstache.adb new file mode 100644 index 00000000000..54c8e6752e3 --- /dev/null +++ b/gcc/ada/5qstache.adb @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5qtaprop.adb b/gcc/ada/5qtaprop.adb new file mode 100644 index 00000000000..00cfe90c07f --- /dev/null +++ b/gcc/ada/5qtaprop.adb @@ -0,0 +1,1777 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5qtaspri.ads b/gcc/ada/5qtaspri.ads new file mode 100644 index 00000000000..6c1866d1976 --- /dev/null +++ b/gcc/ada/5qtaspri.ads @@ -0,0 +1,139 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5qvxwork.ads b/gcc/ada/5qvxwork.ads new file mode 100644 index 00000000000..7f3bd8c2393 --- /dev/null +++ b/gcc/ada/5qvxwork.ads @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5rosinte.adb b/gcc/ada/5rosinte.adb new file mode 100644 index 00000000000..8fb59c494c9 --- /dev/null +++ b/gcc/ada/5rosinte.adb @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5rosinte.ads b/gcc/ada/5rosinte.ads new file mode 100644 index 00000000000..3bbadf19ef2 --- /dev/null +++ b/gcc/ada/5rosinte.ads @@ -0,0 +1,527 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5rparame.adb b/gcc/ada/5rparame.adb new file mode 100644 index 00000000000..761284df071 --- /dev/null +++ b/gcc/ada/5rparame.adb @@ -0,0 +1,82 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5sintman.adb b/gcc/ada/5sintman.adb new file mode 100644 index 00000000000..24f68edea17 --- /dev/null +++ b/gcc/ada/5sintman.adb @@ -0,0 +1,224 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5smastop.adb b/gcc/ada/5smastop.adb new file mode 100644 index 00000000000..4dfc8ad8b22 --- /dev/null +++ b/gcc/ada/5smastop.adb @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5sosinte.adb b/gcc/ada/5sosinte.adb new file mode 100644 index 00000000000..fffc3fdad8e --- /dev/null +++ b/gcc/ada/5sosinte.adb @@ -0,0 +1,100 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5sosinte.ads b/gcc/ada/5sosinte.ads new file mode 100644 index 00000000000..490ec600c7f --- /dev/null +++ b/gcc/ada/5sosinte.ads @@ -0,0 +1,561 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5sparame.adb b/gcc/ada/5sparame.adb new file mode 100644 index 00000000000..30d6cc9324c --- /dev/null +++ b/gcc/ada/5sparame.adb @@ -0,0 +1,82 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5ssystem.ads b/gcc/ada/5ssystem.ads new file mode 100644 index 00000000000..2f30306e808 --- /dev/null +++ b/gcc/ada/5ssystem.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5staprop.adb b/gcc/ada/5staprop.adb new file mode 100644 index 00000000000..3815b5fb751 --- /dev/null +++ b/gcc/ada/5staprop.adb @@ -0,0 +1,1939 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5stasinf.adb b/gcc/ada/5stasinf.adb new file mode 100644 index 00000000000..c940af1a93a --- /dev/null +++ b/gcc/ada/5stasinf.adb @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5stasinf.ads b/gcc/ada/5stasinf.ads new file mode 100644 index 00000000000..dba3b189f5a --- /dev/null +++ b/gcc/ada/5stasinf.ads @@ -0,0 +1,144 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5staspri.ads b/gcc/ada/5staspri.ads new file mode 100644 index 00000000000..ee71fe0cba1 --- /dev/null +++ b/gcc/ada/5staspri.ads @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5stpopse.adb b/gcc/ada/5stpopse.adb new file mode 100644 index 00000000000..c041c16489e --- /dev/null +++ b/gcc/ada/5stpopse.adb @@ -0,0 +1,196 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5svxwork.ads b/gcc/ada/5svxwork.ads new file mode 100644 index 00000000000..9ddae2f8145 --- /dev/null +++ b/gcc/ada/5svxwork.ads @@ -0,0 +1,111 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5tosinte.ads b/gcc/ada/5tosinte.ads new file mode 100644 index 00000000000..b95708a8e5b --- /dev/null +++ b/gcc/ada/5tosinte.ads @@ -0,0 +1,660 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5uintman.adb b/gcc/ada/5uintman.adb new file mode 100644 index 00000000000..9b11d3baa8e --- /dev/null +++ b/gcc/ada/5uintman.adb @@ -0,0 +1,269 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5uosinte.ads b/gcc/ada/5uosinte.ads new file mode 100644 index 00000000000..352777c77f0 --- /dev/null +++ b/gcc/ada/5uosinte.ads @@ -0,0 +1,555 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5vasthan.adb b/gcc/ada/5vasthan.adb new file mode 100644 index 00000000000..25ef26854cf --- /dev/null +++ b/gcc/ada/5vasthan.adb @@ -0,0 +1,603 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5vinmaop.adb b/gcc/ada/5vinmaop.adb new file mode 100644 index 00000000000..0077a248161 --- /dev/null +++ b/gcc/ada/5vinmaop.adb @@ -0,0 +1,280 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5vinterr.adb b/gcc/ada/5vinterr.adb new file mode 100644 index 00000000000..cb974377a97 --- /dev/null +++ b/gcc/ada/5vinterr.adb @@ -0,0 +1,1292 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5vintman.adb b/gcc/ada/5vintman.adb new file mode 100644 index 00000000000..e47b5351c3c --- /dev/null +++ b/gcc/ada/5vintman.adb @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5vintman.ads b/gcc/ada/5vintman.ads new file mode 100644 index 00000000000..046c870975d --- /dev/null +++ b/gcc/ada/5vintman.ads @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5vmastop.adb b/gcc/ada/5vmastop.adb new file mode 100644 index 00000000000..6cdcd38f373 --- /dev/null +++ b/gcc/ada/5vmastop.adb @@ -0,0 +1,373 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5vosinte.adb b/gcc/ada/5vosinte.adb new file mode 100644 index 00000000000..34e821524b1 --- /dev/null +++ b/gcc/ada/5vosinte.adb @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5vosinte.ads b/gcc/ada/5vosinte.ads new file mode 100644 index 00000000000..890547c38dd --- /dev/null +++ b/gcc/ada/5vosinte.ads @@ -0,0 +1,642 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5vosprim.adb b/gcc/ada/5vosprim.adb new file mode 100644 index 00000000000..cde0e3b49d0 --- /dev/null +++ b/gcc/ada/5vosprim.adb @@ -0,0 +1,196 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5vosprim.ads b/gcc/ada/5vosprim.ads new file mode 100644 index 00000000000..bcdca5d705a --- /dev/null +++ b/gcc/ada/5vosprim.ads @@ -0,0 +1,105 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5vparame.ads b/gcc/ada/5vparame.ads new file mode 100644 index 00000000000..2788e6620c7 --- /dev/null +++ b/gcc/ada/5vparame.ads @@ -0,0 +1,136 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5vsystem.ads b/gcc/ada/5vsystem.ads new file mode 100644 index 00000000000..41cebb1e749 --- /dev/null +++ b/gcc/ada/5vsystem.ads @@ -0,0 +1,236 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5vtaprop.adb b/gcc/ada/5vtaprop.adb new file mode 100644 index 00000000000..d3891c84b77 --- /dev/null +++ b/gcc/ada/5vtaprop.adb @@ -0,0 +1,915 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5vtaspri.ads b/gcc/ada/5vtaspri.ads new file mode 100644 index 00000000000..fb744912f8e --- /dev/null +++ b/gcc/ada/5vtaspri.ads @@ -0,0 +1,108 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5vtpopde.adb b/gcc/ada/5vtpopde.adb new file mode 100644 index 00000000000..5da5cde38d6 --- /dev/null +++ b/gcc/ada/5vtpopde.adb @@ -0,0 +1,144 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5vtpopde.ads b/gcc/ada/5vtpopde.ads new file mode 100644 index 00000000000..0ab769fff70 --- /dev/null +++ b/gcc/ada/5vtpopde.ads @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5vvaflop.adb b/gcc/ada/5vvaflop.adb new file mode 100644 index 00000000000..606b08bad2b --- /dev/null +++ b/gcc/ada/5vvaflop.adb @@ -0,0 +1,623 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5wgloloc.adb b/gcc/ada/5wgloloc.adb new file mode 100644 index 00000000000..5edcddb67e2 --- /dev/null +++ b/gcc/ada/5wgloloc.adb @@ -0,0 +1,114 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5wintman.adb b/gcc/ada/5wintman.adb new file mode 100644 index 00000000000..7e8acb989fa --- /dev/null +++ b/gcc/ada/5wintman.adb @@ -0,0 +1,81 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5wmemory.adb b/gcc/ada/5wmemory.adb new file mode 100644 index 00000000000..77e42e5b773 --- /dev/null +++ b/gcc/ada/5wmemory.adb @@ -0,0 +1,229 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5wosinte.ads b/gcc/ada/5wosinte.ads new file mode 100644 index 00000000000..50a68ffecb4 --- /dev/null +++ b/gcc/ada/5wosinte.ads @@ -0,0 +1,437 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5wosprim.adb b/gcc/ada/5wosprim.adb new file mode 100644 index 00000000000..a86325a8b69 --- /dev/null +++ b/gcc/ada/5wosprim.adb @@ -0,0 +1,228 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5wsystem.ads b/gcc/ada/5wsystem.ads new file mode 100644 index 00000000000..70e11949afd --- /dev/null +++ b/gcc/ada/5wsystem.ads @@ -0,0 +1,201 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5wtaprop.adb b/gcc/ada/5wtaprop.adb new file mode 100644 index 00000000000..850ddb696b8 --- /dev/null +++ b/gcc/ada/5wtaprop.adb @@ -0,0 +1,1113 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5wtaspri.ads b/gcc/ada/5wtaspri.ads new file mode 100644 index 00000000000..02cefc4e198 --- /dev/null +++ b/gcc/ada/5wtaspri.ads @@ -0,0 +1,101 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5ysystem.ads b/gcc/ada/5ysystem.ads new file mode 100644 index 00000000000..ca3d9e52c9a --- /dev/null +++ b/gcc/ada/5ysystem.ads @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5zinterr.adb b/gcc/ada/5zinterr.adb new file mode 100644 index 00000000000..5e428f26c08 --- /dev/null +++ b/gcc/ada/5zinterr.adb @@ -0,0 +1,1658 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5zintman.adb b/gcc/ada/5zintman.adb new file mode 100644 index 00000000000..2f58cc2b86f --- /dev/null +++ b/gcc/ada/5zintman.adb @@ -0,0 +1,295 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5zosinte.adb b/gcc/ada/5zosinte.adb new file mode 100644 index 00000000000..c578234c712 --- /dev/null +++ b/gcc/ada/5zosinte.adb @@ -0,0 +1,831 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5zosinte.ads b/gcc/ada/5zosinte.ads new file mode 100644 index 00000000000..f0777793005 --- /dev/null +++ b/gcc/ada/5zosinte.ads @@ -0,0 +1,555 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5zosprim.adb b/gcc/ada/5zosprim.adb new file mode 100644 index 00000000000..b327f92bba7 --- /dev/null +++ b/gcc/ada/5zosprim.adb @@ -0,0 +1,146 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5zparame.ads b/gcc/ada/5zparame.ads new file mode 100644 index 00000000000..e515df18354 --- /dev/null +++ b/gcc/ada/5zparame.ads @@ -0,0 +1,135 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5zsystem.ads b/gcc/ada/5zsystem.ads new file mode 100644 index 00000000000..3bdb5688a1d --- /dev/null +++ b/gcc/ada/5zsystem.ads @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/5ztaprop.adb b/gcc/ada/5ztaprop.adb new file mode 100644 index 00000000000..b543ae23b33 --- /dev/null +++ b/gcc/ada/5ztaprop.adb @@ -0,0 +1,1065 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/6vcpp.adb b/gcc/ada/6vcpp.adb new file mode 100644 index 00000000000..40dac7bb8dc --- /dev/null +++ b/gcc/ada/6vcpp.adb @@ -0,0 +1,338 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/6vcstrea.adb b/gcc/ada/6vcstrea.adb new file mode 100644 index 00000000000..858a10cfb3b --- /dev/null +++ b/gcc/ada/6vcstrea.adb @@ -0,0 +1,183 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/6vinterf.ads b/gcc/ada/6vinterf.ads new file mode 100644 index 00000000000..cfdd49b2c7d --- /dev/null +++ b/gcc/ada/6vinterf.ads @@ -0,0 +1,174 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/7sinmaop.adb b/gcc/ada/7sinmaop.adb new file mode 100644 index 00000000000..a920b371055 --- /dev/null +++ b/gcc/ada/7sinmaop.adb @@ -0,0 +1,356 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/7sintman.adb b/gcc/ada/7sintman.adb new file mode 100644 index 00000000000..2e0a85ca894 --- /dev/null +++ b/gcc/ada/7sintman.adb @@ -0,0 +1,242 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/7sosinte.adb b/gcc/ada/7sosinte.adb new file mode 100644 index 00000000000..4d2dfa1ccf1 --- /dev/null +++ b/gcc/ada/7sosinte.adb @@ -0,0 +1,366 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/7sosprim.adb b/gcc/ada/7sosprim.adb new file mode 100644 index 00000000000..a8eee2ae87c --- /dev/null +++ b/gcc/ada/7sosprim.adb @@ -0,0 +1,156 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/7staprop.adb b/gcc/ada/7staprop.adb new file mode 100644 index 00000000000..7c2dbe82be7 --- /dev/null +++ b/gcc/ada/7staprop.adb @@ -0,0 +1,1108 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/7staspri.ads b/gcc/ada/7staspri.ads new file mode 100644 index 00000000000..4cfd2fd4568 --- /dev/null +++ b/gcc/ada/7staspri.ads @@ -0,0 +1,94 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/7stpopsp.adb b/gcc/ada/7stpopsp.adb new file mode 100644 index 00000000000..03fcdedaca8 --- /dev/null +++ b/gcc/ada/7stpopsp.adb @@ -0,0 +1,91 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/7straceb.adb b/gcc/ada/7straceb.adb new file mode 100644 index 00000000000..08c672c8d76 --- /dev/null +++ b/gcc/ada/7straceb.adb @@ -0,0 +1,100 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/86numaux.adb b/gcc/ada/86numaux.adb new file mode 100644 index 00000000000..f6e1f4c7686 --- /dev/null +++ b/gcc/ada/86numaux.adb @@ -0,0 +1,595 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/86numaux.ads b/gcc/ada/86numaux.ads new file mode 100644 index 00000000000..e1c3bb377fe --- /dev/null +++ b/gcc/ada/86numaux.ads @@ -0,0 +1,86 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/9drpc.adb b/gcc/ada/9drpc.adb new file mode 100644 index 00000000000..8f749fa51da --- /dev/null +++ b/gcc/ada/9drpc.adb @@ -0,0 +1,1053 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/Make-lang.in b/gcc/ada/Make-lang.in new file mode 100644 index 00000000000..a3c8606675e --- /dev/null +++ b/gcc/ada/Make-lang.in @@ -0,0 +1,647 @@ +# 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 = + +# 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 + +# 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: + +# 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) + +# 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 + +# 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: + +# 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 diff --git a/gcc/ada/Makefile.adalib b/gcc/ada/Makefile.adalib new file mode 100644 index 00000000000..f96c4ee54c1 --- /dev/null +++ b/gcc/ada/Makefile.adalib @@ -0,0 +1,112 @@ +# 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)\" $< diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in new file mode 100644 index 00000000000..d5f44a94b9d --- /dev/null +++ b/gcc/ada/Makefile.in @@ -0,0 +1,4749 @@ +# 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@ + +# Now figure out from those variables how to compile and link. + + +# 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: + +# 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) diff --git a/gcc/ada/machcode.ads b/gcc/ada/machcode.ads new file mode 100644 index 00000000000..ee20a9634e5 --- /dev/null +++ b/gcc/ada/machcode.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb new file mode 100644 index 00000000000..945dd20ce56 --- /dev/null +++ b/gcc/ada/make.adb @@ -0,0 +1,4455 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/make.ads b/gcc/ada/make.ads new file mode 100644 index 00000000000..587f71d6a55 --- /dev/null +++ b/gcc/ada/make.ads @@ -0,0 +1,274 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/makeusg.adb b/gcc/ada/makeusg.adb new file mode 100644 index 00000000000..d06eb1fa2cc --- /dev/null +++ b/gcc/ada/makeusg.adb @@ -0,0 +1,277 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/makeusg.ads b/gcc/ada/makeusg.ads new file mode 100644 index 00000000000..80d433f1a2f --- /dev/null +++ b/gcc/ada/makeusg.ads @@ -0,0 +1,32 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 diff --git a/gcc/ada/math_lib.adb b/gcc/ada/math_lib.adb new file mode 100644 index 00000000000..b7345c0e974 --- /dev/null +++ b/gcc/ada/math_lib.adb @@ -0,0 +1,1029 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/mdll.adb b/gcc/ada/mdll.adb new file mode 100644 index 00000000000..b0fca0293c3 --- /dev/null +++ b/gcc/ada/mdll.adb @@ -0,0 +1,410 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/mdll.ads b/gcc/ada/mdll.ads new file mode 100644 index 00000000000..2a13be1830b --- /dev/null +++ b/gcc/ada/mdll.ads @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/mdllfile.adb b/gcc/ada/mdllfile.adb new file mode 100644 index 00000000000..9aad7e117a0 --- /dev/null +++ b/gcc/ada/mdllfile.adb @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/mdllfile.ads b/gcc/ada/mdllfile.ads new file mode 100644 index 00000000000..ca6a222c724 --- /dev/null +++ b/gcc/ada/mdllfile.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/mdlltool.adb b/gcc/ada/mdlltool.adb new file mode 100644 index 00000000000..fee7218c5be --- /dev/null +++ b/gcc/ada/mdlltool.adb @@ -0,0 +1,346 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/mdlltool.ads b/gcc/ada/mdlltool.ads new file mode 100644 index 00000000000..0e9b55c9aff --- /dev/null +++ b/gcc/ada/mdlltool.ads @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/memroot.adb b/gcc/ada/memroot.adb new file mode 100644 index 00000000000..d8db62b751b --- /dev/null +++ b/gcc/ada/memroot.adb @@ -0,0 +1,663 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/memroot.ads b/gcc/ada/memroot.ads new file mode 100644 index 00000000000..38ef645e519 --- /dev/null +++ b/gcc/ada/memroot.ads @@ -0,0 +1,109 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/memtrack.adb b/gcc/ada/memtrack.adb new file mode 100644 index 00000000000..7938de5714d --- /dev/null +++ b/gcc/ada/memtrack.adb @@ -0,0 +1,278 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/misc.c b/gcc/ada/misc.c new file mode 100644 index 00000000000..365bc0abfab --- /dev/null +++ b/gcc/ada/misc.c @@ -0,0 +1,1098 @@ +/**************************************************************************** + * * + * 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 + +/* 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; +} + +/* 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); +} + +/* 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); + } +} + +/* 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)); +} + +#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); +} diff --git a/gcc/ada/mlib-fil.adb b/gcc/ada/mlib-fil.adb new file mode 100644 index 00000000000..eac9c1deb03 --- /dev/null +++ b/gcc/ada/mlib-fil.adb @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/mlib-fil.ads b/gcc/ada/mlib-fil.ads new file mode 100644 index 00000000000..b4d4701b94f --- /dev/null +++ b/gcc/ada/mlib-fil.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb new file mode 100644 index 00000000000..13c62ee2c16 --- /dev/null +++ b/gcc/ada/mlib-prj.adb @@ -0,0 +1,339 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/mlib-prj.ads b/gcc/ada/mlib-prj.ads new file mode 100644 index 00000000000..cfc90a9dbc9 --- /dev/null +++ b/gcc/ada/mlib-prj.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/mlib-tgt.adb b/gcc/ada/mlib-tgt.adb new file mode 100644 index 00000000000..2a25aef1ae9 --- /dev/null +++ b/gcc/ada/mlib-tgt.adb @@ -0,0 +1,187 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/mlib-tgt.ads b/gcc/ada/mlib-tgt.ads new file mode 100644 index 00000000000..a40619d0075 --- /dev/null +++ b/gcc/ada/mlib-tgt.ads @@ -0,0 +1,100 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/mlib-utl.adb b/gcc/ada/mlib-utl.adb new file mode 100644 index 00000000000..5b4f1f0fe46 --- /dev/null +++ b/gcc/ada/mlib-utl.adb @@ -0,0 +1,263 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/mlib-utl.ads b/gcc/ada/mlib-utl.ads new file mode 100644 index 00000000000..64330f0a7cd --- /dev/null +++ b/gcc/ada/mlib-utl.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/mlib.adb b/gcc/ada/mlib.adb new file mode 100644 index 00000000000..db0cca90019 --- /dev/null +++ b/gcc/ada/mlib.adb @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/mlib.ads b/gcc/ada/mlib.ads new file mode 100644 index 00000000000..7b4be16b993 --- /dev/null +++ b/gcc/ada/mlib.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; |