diff options
Diffstat (limited to 'lang/gcc3-ada/files')
| -rw-r--r-- | lang/gcc3-ada/files/4netbsdintnam.ads | 117 | ||||
| -rw-r--r-- | lang/gcc3-ada/files/5netbsdintman.adb | 101 | ||||
| -rw-r--r-- | lang/gcc3-ada/files/5netbsdosinte.adb | 144 | ||||
| -rw-r--r-- | lang/gcc3-ada/files/5netbsdosinte.ads | 620 | ||||
| -rw-r--r-- | lang/gcc3-ada/files/5netbsdparame.adb | 79 | ||||
| -rw-r--r-- | lang/gcc3-ada/files/5netbsdsystem.ads | 139 | ||||
| -rw-r--r-- | lang/gcc3-ada/files/5netbsdtaprop.adb | 1062 | ||||
| -rw-r--r-- | lang/gcc3-ada/files/5netbsdtasinf.ads | 143 | ||||
| -rw-r--r-- | lang/gcc3-ada/files/5netbsdtpopse.adb | 52 | ||||
| -rw-r--r-- | lang/gcc3-ada/files/7netbsdtpopsp.adb | 89 | ||||
| -rw-r--r-- | lang/gcc3-ada/files/ada_lwp_self.c | 6 | ||||
| -rw-r--r-- | lang/gcc3-ada/files/adasignal.c | 34 | ||||
| -rw-r--r-- | lang/gcc3-ada/files/gcc3.mk | 8 |
13 files changed, 0 insertions, 2594 deletions
diff --git a/lang/gcc3-ada/files/4netbsdintnam.ads b/lang/gcc3-ada/files/4netbsdintnam.ads deleted file mode 100644 index 98f9576799d..00000000000 --- a/lang/gcc3-ada/files/4netbsdintnam.ads +++ /dev/null @@ -1,117 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- -- --- Copyright (C) 1991-2002 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. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a NetBSD version of this package. --- -with System.OS_Interface; --- used for names of interrupts - -package Ada.Interrupts.Names is - - -- Beware that the mapping of names to signals may be - -- many-to-one. There may be aliases. Also, for all - -- signal names that are not supported on the current system - -- the value of the corresponding constant will be zero. - - Sighup : constant Interrupt_ID := System.OS_Interface.sighup; - -- hangup - Sigint : constant Interrupt_ID := System.OS_Interface.sigint; - -- interrupt (rubout) - Sigquit : constant Interrupt_ID := System.OS_Interface.sigquit; - -- quit (ASCD FS) - Sigill : constant Interrupt_ID := System.OS_Interface.sigill; - -- illegal instruction (not reset) - Sigtrap : constant Interrupt_ID := System.OS_Interface.sigtrap; - -- trace trap (not reset) - Sigiot : constant Interrupt_ID := System.OS_Interface.sigiot; - -- IOT instruction - Sigabrt : constant Interrupt_ID := System.OS_Interface.sigabrt; - -- used by abort,-- replace SIGIOT in the future - Sigemt : constant Interrupt_ID := System.OS_Interface.sigemt; - -- EMT instruction - Sigfpe : constant Interrupt_ID := System.OS_Interface.sigfpe; - -- floating point exception - Sigkill : constant Interrupt_ID := System.OS_Interface.sigkill; - -- kill (cannot be caught or ignored) - Sigbus : constant Interrupt_ID := System.OS_Interface.sigbus; - -- bus error - Sigsegv : constant Interrupt_ID := System.OS_Interface.sigsegv; - -- segmentation violation - Sigsys : constant Interrupt_ID := System.OS_Interface.sigsys; - -- bad argument to system call - Sigpipe : constant Interrupt_ID := System.OS_Interface.sigpipe; - -- write on a pipe with-- no one to read it - Sigalrm : constant Interrupt_ID := System.OS_Interface.sigalrm; - -- alarm clock - Sigterm : constant Interrupt_ID := System.OS_Interface.sigterm; - -- software termination signal from kill - Sigusr1 : constant Interrupt_ID := System.OS_Interface.sigusr1; - -- user defined signal 1 - Sigusr2 : constant Interrupt_ID := System.OS_Interface.sigusr2; - -- user defined signal 2 - Sigcld : constant Interrupt_ID := System.OS_Interface.sigchld; - -- child status change - Sigchld : constant Interrupt_ID := System.OS_Interface.sigchld; - -- 4.3BSD's/POSIX name for SIGCLD - Sigwinch : constant Interrupt_ID := System.OS_Interface.sigwinch; - -- window size change - Sigurg : constant Interrupt_ID := System.OS_Interface.sigurg; - -- urgent condition on IO channel - Sigpoll : constant Interrupt_ID := System.OS_Interface.sigio; - -- pollable event occurred - Sigio : constant Interrupt_ID := System.OS_Interface.sigio; - -- input/output possible,-- SIGPOLL alias (Solaris) - Sigstop : constant Interrupt_ID := System.OS_Interface.sigstop; - -- stop (cannot be caught or ignored) - Sigtstp : constant Interrupt_ID := System.OS_Interface.sigtstp; - -- user stop requested from tty - Sigcont : constant Interrupt_ID := System.OS_Interface.sigcont; - -- stopped process has been continued - Sigttin : constant Interrupt_ID := System.OS_Interface.sigttin; - -- background tty read attempted - Sigttou : constant Interrupt_ID := System.OS_Interface.sigttou; - -- background tty write attempted - Sigvtalrm : constant Interrupt_ID := System.OS_Interface.sigvtalrm; - -- virtual timer expired - Sigprof : constant Interrupt_ID := System.OS_Interface.sigprof; - -- profiling timer expired - Sigxcpu : constant Interrupt_ID := System.OS_Interface.sigxcpu; - -- CPU time limit exceeded - Sigxfsz : constant Interrupt_ID := System.OS_Interface.sigxfsz; - -- filesize limit exceeded - Sigpwr : constant Interrupt_ID := System.OS_Interface.sigpwr; - -- power-fail restart - Siginfo : constant Interrupt_ID := System.OS_Interface.siginfo; - -end Ada.Interrupts.Names; diff --git a/lang/gcc3-ada/files/5netbsdintman.adb b/lang/gcc3-ada/files/5netbsdintman.adb deleted file mode 100644 index 844e6b52033..00000000000 --- a/lang/gcc3-ada/files/5netbsdintman.adb +++ /dev/null @@ -1,101 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- -- --- -- --- Copyright (C) 1992-2002 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. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a NetBSD 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"); - - -- Nothing needs to be done on this platform. - - procedure Initialize_Interrupts is - begin - null; - end Initialize_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/lang/gcc3-ada/files/5netbsdosinte.adb b/lang/gcc3-ada/files/5netbsdosinte.adb deleted file mode 100644 index 8e0d3f086d1..00000000000 --- a/lang/gcc3-ada/files/5netbsdosinte.adb +++ /dev/null @@ -1,144 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- -- --- -- --- 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 NetBSD 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; - - 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_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) - return int - is - begin - -- Dummy until function is included in run-time - return 0; - end pthread_setschedparam; - - ----------------- - -- 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/lang/gcc3-ada/files/5netbsdosinte.ads b/lang/gcc3-ada/files/5netbsdosinte.ads deleted file mode 100644 index 8c04d94b927..00000000000 --- a/lang/gcc3-ada/files/5netbsdosinte.ads +++ /dev/null @@ -1,620 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- -- --- -- --- 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. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- 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 ("-lposix"); - 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"); - - EPERM : constant := 1; -- Operation not permitted - ENOENT : constant := 2; -- No such file or directory - ESRCH : constant := 3; -- No such process - EINTR : constant := 4; -- Interrupted system call - EIO : constant := 5; -- Input/output error - ENXIO : constant := 6; -- Device not configured - E2BIG : constant := 7; -- Argument list too long - ENOEXEC : constant := 8; -- Exec format error - EBADF : constant := 9; -- Bad file descriptor - ECHILD : constant := 10; -- No child processes - EDEADLK : constant := 11; -- Resource deadlock avoided - ENOMEM : constant := 12; -- Cannot allocate memory - EACCES : constant := 13; -- Permission denied - EFAULT : constant := 14; -- Bad address - ENOTBLK : constant := 15; -- Block device required - EBUSY : constant := 16; -- Device busy - EEXIST : constant := 17; -- File exists - EXDEV : constant := 18; -- Cross-device link - ENODEV : constant := 19; - ENOTDIR : constant := 20; -- Not a directory - EISDIR : constant := 21; -- Is a directory - EINVAL : constant := 22; -- Invalid argument - ENFILE : constant := 23; - EMFILE : constant := 24; -- Too many open files - ENOTTY : constant := 25; - ETXTBSY : constant := 26; -- Text file busy - EFBIG : constant := 27; -- File too large - ENOSPC : constant := 28; -- No space left on device - ESPIPE : constant := 29; -- Illegal seek - EROFS : constant := 30; -- Read-only file system - EMLINK : constant := 31; -- Too many links - EPIPE : constant := 32; -- Broken pipe - EDOM : constant := 33; - ERANGE : constant := 34; - EAGAIN : constant := 35; - EWOULDBLOCK : constant := EAGAIN; -- Operation would block - EINPROGRESS : constant := 36; -- Operation now in progress - EALREADY : constant := 37; - ENOTSOCK : constant := 38; - EDESTADDRREQ : constant := 39; - EMSGSIZE : constant := 40; -- Message too long - EPROTOTYPE : constant := 41; - ENOPROTOOPT : constant := 42; -- Protocol not available - EPROTONOSUPPORT : constant := 43; -- Protocol not supported - ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported - EOPNOTSUPP : constant := 45; -- Operation not supported - EPFNOSUPPORT : constant := 46; - EAFNOSUPPORT : constant := 47; - EADDRINUSE : constant := 48; -- Address already in use - EADDRNOTAVAIL : constant := 49; - ENETDOWN : constant := 50; -- Network is down - ENETUNREACH : constant := 51; -- Network is unreachable - ENETRESET : constant := 52; - ECONNABORTED : constant := 53; - ECONNRESET : constant := 54; -- Connection reset by peer - ENOBUFS : constant := 55; -- No buffer space available - EISCONN : constant := 56; - ENOTCONN : constant := 57; -- Socket is not connected - ESHUTDOWN : constant := 58; - ETOOMANYREFS : constant := 59; - ETIMEDOUT : constant := 60; -- Operation timed out - ECONNREFUSED : constant := 61; -- Connection refused - ELOOP : constant := 62; - ENAMETOOLONG : constant := 63; -- File name too long - EHOSTDOWN : constant := 64; -- Host is down - EHOSTUNREACH : constant := 65; -- No route to host - ENOTEMPTY : constant := 66; -- Directory not empty - EPROCLIM : constant := 67; -- Too many processes - EUSERS : constant := 68; -- Too many users - EDQUOT : constant := 69; -- Disc quota exceeded - ESTALE : constant := 70; -- Stale NFS file handle - EREMOTE : constant := 71; - EBADRPC : constant := 72; -- RPC struct is bad - ERPCMISMATCH : constant := 73; -- RPC version wrong - EPROGUNAVAIL : constant := 74; -- RPC prog. not avail - EPROGMISMATCH : constant := 75; -- Program version wrong - EPROCUNAVAIL : constant := 76; -- Bad procedure for program - ENOLCK : constant := 77; -- No locks available - ENOSYS : constant := 78; -- Function not implemented - EFTYPE : constant := 79; - EAUTH : constant := 80; -- Authentication error - ENEEDAUTH : constant := 81; -- Need authenticator - EIDRM : constant := 82; -- Identifier removed - ENOMSG : constant := 83; -- No message of desired type - EOVERFLOW : constant := 84; - EILSEQ : constant := 85; -- Illegal byte sequence - ENOTSUP : constant := 86; -- Not supported - ECANCELED : constant := 87; -- Operation canceled - EBADMSG : constant := 88; -- Bad or Corrupt message - ENODATA : constant := 89; -- No message available - ENOSR : constant := 90; -- No STREAM resources - ENOSTR : constant := 91; -- Not a STREAM - ETIME : constant := 92; -- STREAM ioctl timeout - ELAST : constant := 92; -- Must equal largest errno - - ------------- - -- 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 - sigquit : constant := 3; -- quit - sigill : constant := 4; -- illegal instruction (not reset when caught) - sigtrap : constant := 5; -- trace trap (not reset when caught) - sigabrt : constant := 6; -- abort() - sigiot : constant := sigabrt; -- compatibility - 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; -- sendable stop signal not from tty - sigtstp : constant := 18; -- stop signal from tty - sigcont : constant := 19; -- continue a stopped process - sigchld : constant := 20; -- to parent on child stop or exit - sigttin : constant := 21; -- to readers pgrp upon background tty read - sigttou : constant := 22; -- like TTIN for output if (tp->t_local<OSTOP) - sigio : constant := 23; -- input/output possible signal - sigxcpu : constant := 24; -- exceeded CPU time limit - sigxfsz : constant := 25; -- exceeded file size limit - sigvtalrm : constant := 26; -- virtual time alarm - sigprof : constant := 27; -- profiling time alarm - sigwinch : constant := 28; -- window size changes - siginfo : constant := 29; -- information request - sigusr1 : constant := 30; -- user defined signal 1 - sigusr2 : constant := 31; -- user defined signal 2 - sigpwr : constant := 32; -- power fail/restart (not reset when caught) - sigwaiting : constant := 0; -- process's lwps blocked (Solaris) - sigcancel : constant := 0; -- thread cancellation signal (libthread) - - type signal_set is array (Natural range <>) of Signal; - - Unmasked : constant signal_set := (sigkill, sigill, sigprof, sigtrap, - sigpwr); - - -- Following signals should not be disturbed. - -- See c-posix-signals.c in FLORIST - Reserved : constant signal_set := (sigalrm, sigbus, sigill, sigsegv, - sigfpe, sigabrt, sigkill, sigstop); - - -- PTHREAD_SIGMASK(3) - SIG_BLOCK : constant := 1; - SIG_SETMASK : constant := 3; - SIG_UNBLOCK : constant := 2; - - type sigset_t is private; - type sigset_t_ptr is access all sigset_t; - - -- Binding to macros defined in <signal.h> - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "adasigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "adasigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "adasigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "adasigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "adasigemptyset"); - - 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_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, "adasigaction"); - - ---------- - -- Time -- - ---------- - - type clockid_t is new int; - CLOCK_REALTIME : constant := 0; - - 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"); - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int; - pragma Import (C, clock_gettime, "clock_gettime"); - - - --------- - -- LWP -- - --------- - - type lwpid_t is new long; - - function lwp_self return System.Address; - pragma Import (C, lwp_self, "ada_lwp_self"); - - - ------------------------- - -- 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; - subtype cond_t is pthread_cond_t; - - 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, "adasigwait"); - - 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; - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int; - - type struct_sched_param is record - sched_priority : int; - end record; - for struct_sched_param use record - sched_priority at 0 range 0 .. 31; - end record; - pragma Convention (C, struct_sched_param); - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) - return int; - -- Does not exist yet - we provide a dummy - -- 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; - for timespec use record - tv_sec at 0 range 0 .. 31; - tv_nsec at 4 range 0 .. 31; - 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 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/lang/gcc3-ada/files/5netbsdparame.adb b/lang/gcc3-ada/files/5netbsdparame.adb deleted file mode 100644 index 027db72e58d..00000000000 --- a/lang/gcc3-ada/files/5netbsdparame.adb +++ /dev/null @@ -1,79 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- B o d y -- --- -- --- -- --- 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. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- 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 8318976; - end Default_Stack_Size; - - ------------------------ - -- Minimum_Stack_Size -- - ------------------------ - - function Minimum_Stack_Size return Size_Type is - - thr_min_stack : constant Size_Type := 1160; - -- 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/lang/gcc3-ada/files/5netbsdsystem.ads b/lang/gcc3-ada/files/5netbsdsystem.ads deleted file mode 100644 index 7acc87ff749..00000000000 --- a/lang/gcc3-ada/files/5netbsdsystem.ads +++ /dev/null @@ -1,139 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (Default Version) -- --- -- --- $Revision: 1.1 $ --- -- --- Copyright (C) 1992-2000 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 := 1.0; - - -- Storage-related Declarations - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -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; - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := False; - Command_Line_Args : constant Boolean := True; - Denorm : constant Boolean := True; - Fractional_Fixed_Ops : 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 := 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/lang/gcc3-ada/files/5netbsdtaprop.adb b/lang/gcc3-ada/files/5netbsdtaprop.adb deleted file mode 100644 index 603b1b00048..00000000000 --- a/lang/gcc3-ada/files/5netbsdtaprop.adb +++ /dev/null @@ -1,1062 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- -- --- -- --- 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. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- 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 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. - - Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. - -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - - 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 - - begin - null; - end Stack_Guard; - - -------------------- - -- Get_Thread_Id -- - -------------------- - - function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is - begin - return T.Common.LL.Thread; - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_ID renames Specific.Self; - - --------------------- - -- Initialize_Lock -- - --------------------- - - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Initialize_TCB and the Storage_Error is - -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) - -- used in RTS is initialized before any status change of RTS. - -- Therefore 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; Global_Lock : Boolean := False) - is - Result : Interfaces.C.int; - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_lock (L); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - procedure Write_Lock (T : Task_ID) is - Result : Interfaces.C.int; - begin - if not Single_Lock then - Result := pthread_mutex_lock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock (L : 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; Global_Lock : Boolean := False) is - Result : Interfaces.C.int; - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0); - end if; - end Unlock; - - procedure Unlock (T : Task_ID) is - Result : Interfaces.C.int; - begin - if not Single_Lock then - Result := pthread_mutex_unlock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Unlock; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep - (Self_ID : Task_ID; - Reason : System.Tasking.Task_States) - is - Result : Interfaces.C.int; - begin - if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; - - -- EINTR is not considered a failure. - - pragma Assert (Result = 0 or else Result = EINTR); - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - -- This is for use within the run-time system, so abort is - -- assumed to be already deferred, and the caller should be - -- holding its own ATCB lock. - - procedure Timed_Sleep - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - 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; - - if Single_Lock then - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, - Request'Access); - - else - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, - Request'Access); - end if; - - 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; - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID); - - 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); - - 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; - - if Single_Lock then - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, Request'Access); - else - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Request'Access); - end if; - - 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 Single_Lock then - Unlock_RTS; - end if; - - 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_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_RTS; - - for J in Known_Tasks'Range loop - if Known_Tasks (J) = null then - Known_Tasks (J) := Self_ID; - Self_ID.Known_Tasks_Index := J; - exit; - end if; - end loop; - - Unlock_RTS; - end Enter_Task; - - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - - ---------------------- - -- Initialize_TCB -- - ---------------------- - - procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is - Mutex_Attr : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - Cond_Attr : aliased pthread_condattr_t; - - begin - -- Give the task a unique serial number. - - Self_ID.Serial_Number := Next_Serial_Number; - Next_Serial_Number := Next_Serial_Number + 1; - pragma Assert (Next_Serial_Number /= 0); - - if not Single_Lock then - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := pthread_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); - end if; - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result = 0 then - Succeeded := True; - else - if not Single_Lock then - Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Succeeded := False; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_ID; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) - is - Attributes : aliased pthread_attr_t; - Adjusted_Stack_Size : Interfaces.C.size_t; - Result : Interfaces.C.int; - - 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_setdetachstate - (Attributes'Access, PTHREAD_CREATE_DETACHED); - pragma Assert (Result = 0); - - 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; - - 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 - if not Single_Lock then - Result := pthread_mutex_destroy (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_cond_destroy (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - - if T.Known_Tasks_Index /= -1 then - Known_Tasks (T.Known_Tasks_Index) := null; - end if; - - Free (Tmp); - 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_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) return Boolean is - 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 (Single_RTS_Lock'Access, RTS_Lock_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/lang/gcc3-ada/files/5netbsdtasinf.ads b/lang/gcc3-ada/files/5netbsdtasinf.ads deleted file mode 100644 index fdd93c95beb..00000000000 --- a/lang/gcc3-ada/files/5netbsdtasinf.ads +++ /dev/null @@ -1,143 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T A S K _ I N F O -- --- -- --- S p e c -- --- -- --- -- --- 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. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the definitions and routines associated with the --- implementation of the Task_Info pragma. - --- This is the NetBSD (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 NetBSD implementation of the GNU Low-Level Interface (GNULLI) - -- implements each Ada task as a NetBSD thread. The NetBSD thread - -- library distributes threads across one or more LWPs (Light Weight - -- Process) that are members of the same process. NetBSD 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/lang/gcc3-ada/files/5netbsdtpopse.adb b/lang/gcc3-ada/files/5netbsdtpopse.adb deleted file mode 100644 index acf53db789b..00000000000 --- a/lang/gcc3-ada/files/5netbsdtpopse.adb +++ /dev/null @@ -1,52 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SELF -- --- -- --- B o d y -- --- -- --- -- --- 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 NetBSD/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 := pthread_getspecific (ATCB_Key, Temp'Unchecked_Access); - pragma Assert (Result = 0); - return To_Task_ID (Temp); -end Self; diff --git a/lang/gcc3-ada/files/7netbsdtpopsp.adb b/lang/gcc3-ada/files/7netbsdtpopsp.adb deleted file mode 100644 index bc6318400ac..00000000000 --- a/lang/gcc3-ada/files/7netbsdtpopsp.adb +++ /dev/null @@ -1,89 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- --- -- --- B o d y -- --- -- --- -- --- 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 NetBSD 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/lang/gcc3-ada/files/ada_lwp_self.c b/lang/gcc3-ada/files/ada_lwp_self.c deleted file mode 100644 index c4b205c60ca..00000000000 --- a/lang/gcc3-ada/files/ada_lwp_self.c +++ /dev/null @@ -1,6 +0,0 @@ -/* Binding to _lwp_self for the Ada RTS */ -#include <lwp.h> - -lwpid_t ada_lwp_self(void) { - return _lwp_self(); -} diff --git a/lang/gcc3-ada/files/adasignal.c b/lang/gcc3-ada/files/adasignal.c deleted file mode 100644 index ce6cafc3b7c..00000000000 --- a/lang/gcc3-ada/files/adasignal.c +++ /dev/null @@ -1,34 +0,0 @@ -#include <signal.h> - -/* <signal.h> defines macros for a number of - signal handling functions. Bindings are - provided here, that expand the macros, - for use by the Ada RTS. */ - -int adasigaddset(sigset_t *set, int signo) { - return sigaddset(set, signo); -} - -int adasigdelset(sigset_t *set, int signo) { - return sigdelset(set, signo); -} - -int adasigemptyset(sigset_t *set) { - return sigemptyset(set); -} - -int adasigfillset(sigset_t *set) { - return sigfillset(set); -} - -int adasigismember(sigset_t *set, int signo) { - return sigismember(set, signo); -} - -int adasigaction(int sig, const struct sigaction *act, struct sigaction *oact) { - return sigaction(sig, act, oact); -} - -int adasigwait(const sigset_t *set, int *sig) { - return sigwait(set, sig); -} diff --git a/lang/gcc3-ada/files/gcc3.mk b/lang/gcc3-ada/files/gcc3.mk deleted file mode 100644 index ffe9d97f168..00000000000 --- a/lang/gcc3-ada/files/gcc3.mk +++ /dev/null @@ -1,8 +0,0 @@ -# $NetBSD: gcc3.mk,v 1.1 2003/12/08 18:33:53 drochner Exp $ -# -# make configuration file for @PKGNAME@ - -CC= @GCC_PREFIX@/bin/cc -CPP= @GCC_PREFIX@/bin/cpp -CXX= @GCC_PREFIX@/bin/c++ -ADAC= @GCC_PREFIX@/bin/gcc |