diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2006-02-15 09:27:57 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2006-02-15 09:27:57 +0000 |
| commit | 781d92c8873c51c988ccca82594906894fd0cd80 (patch) | |
| tree | 4c429698f12bb7247b399c1a25e4593c6efebb47 /gcc/ada | |
| parent | 562d71e815ab06366be965829e291b264cfdd7b5 (diff) | |
| download | gcc-781d92c8873c51c988ccca82594906894fd0cd80.tar.gz | |
* a-intnam-os2.ads, a-intnam-unixware.ads, g-soccon-unixware.ads,
g-soliop-unixware.ads, i-os2err.ads, i-os2lib.adb, i-os2lib.ads,
i-os2syn.ads, i-os2thr.ads, s-intman-irix-athread.adb,
s-osinte-aix-fsu.ads, s-osinte-fsu.adb, s-parame-os2.adb,
s-osinte-irix-athread.ads, s-osinte-linux-fsu.ads, s-osinte-os2.adb,
s-osinte-os2.ads, s-osinte-solaris-fsu.ads, s-osinte-unixware.adb,
s-osinte-unixware.ads, s-osprim-os2.adb, s-taprop-irix-athread.adb,
s-taprop-os2.adb, s-tasinf-irix-athread.adb, s-tasinf-irix-athread.ads,
s-taspri-os2.ads, system-os2.ads, system-unixware.ads: Removed,
no longer used.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@111021 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
28 files changed, 0 insertions, 9510 deletions
diff --git a/gcc/ada/a-intnam-os2.ads b/gcc/ada/a-intnam-os2.ads deleted file mode 100644 index 9f1099b0da3..00000000000 --- a/gcc/ada/a-intnam-os2.ads +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2005, AdaCore -- --- -- --- 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 an OS/2 version of this package - --- This target-dependent package spec contains names of interrupts --- supported by the local system. - --- This is a stub, for systems that do not support interrupts (or signals) - -package Ada.Interrupts.Names is -end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-unixware.ads b/gcc/ada/a-intnam-unixware.ads deleted file mode 100644 index ff8a6c801c4..00000000000 --- a/gcc/ada/a-intnam-unixware.ads +++ /dev/null @@ -1,164 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 SCO UnixWare version of this package - --- The following signals are reserved by the run time: - --- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, --- SIGWAITING, SIGLWP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGSTOP, SIGKILL - --- The pragma Unreserve_All_Interrupts affects the following signal(s): - --- SIGINT: made available for Ada handler - -with System.OS_Interface; --- 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. - - 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 := -- used by abort, - System.OS_Interface.SIGABRT; -- 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 := -- write on a pipe with - System.OS_Interface.SIGPIPE; -- no one to read it - - SIGALRM : constant Interrupt_ID := - System.OS_Interface.SIGALRM; -- alarm clock - - SIGTERM : constant Interrupt_ID := - System.OS_Interface.SIGTERM; -- software termination signal from kill - - 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.SIGCLD; -- child status change - - SIGCHLD : constant Interrupt_ID := - System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD - - SIGPWR : constant Interrupt_ID := - System.OS_Interface.SIGPWR; -- power-fail restart - - 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.SIGPOLL; -- pollable event occurred - - SIGIO : constant Interrupt_ID := -- input/output possible, - System.OS_Interface.SIGIO; -- 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 - - SIGWAITING : constant Interrupt_ID := - System.OS_Interface.SIGWAITING; -- process's lwps blocked (Solaris) - - SIGLWP : constant Interrupt_ID := - System.OS_Interface.SIGLWP; -- used by thread library (Solaris) - - SIGAIO : constant Interrupt_ID := - System.OS_Interface.SIGAIO; -- Asynchronous I/O signal - -end Ada.Interrupts.Names; diff --git a/gcc/ada/g-soccon-unixware.ads b/gcc/ada/g-soccon-unixware.ads deleted file mode 100644 index 148989e0325..00000000000 --- a/gcc/ada/g-soccon-unixware.ads +++ /dev/null @@ -1,161 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . C O N S T A N T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 provides target dependent definitions of constant for use --- by the GNAT.Sockets package (g-socket.ads). This package should not be --- directly with'ed by an applications program. - --- This is the version for UnixWare --- Do not edit this file by hand, instead edit and re-run gen-soccon.c - -package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 27; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 2; -- Stream socket - SOCK_DGRAM : constant := 1; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 125; -- Address already in use - EADDRNOTAVAIL : constant := 126; -- Cannot assign address - EAFNOSUPPORT : constant := 124; -- Addr family not supported - EALREADY : constant := 149; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 130; -- Connection aborted - ECONNREFUSED : constant := 146; -- Connection refused - ECONNRESET : constant := 131; -- Connection reset by peer - EDESTADDRREQ : constant := 96; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 147; -- Host is down - EHOSTUNREACH : constant := 148; -- No route to host - EINPROGRESS : constant := 150; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 133; -- Socket already connected - ELOOP : constant := 90; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 97; -- Message too long - ENAMETOOLONG : constant := 78; -- Name too long - ENETDOWN : constant := 127; -- Network is down - ENETRESET : constant := 129; -- Disconn. on network reset - ENETUNREACH : constant := 128; -- Network is unreachable - ENOBUFS : constant := 132; -- No buffer space available - ENOPROTOOPT : constant := 99; -- Protocol not available - ENOTCONN : constant := 134; -- Socket not connected - ENOTSOCK : constant := 95; -- Operation on non socket - EOPNOTSUPP : constant := 122; -- Operation not supported - EPFNOSUPPORT : constant := 123; -- Unknown protocol family - EPROTONOSUPPORT : constant := 120; -- Unknown protocol - EPROTOTYPE : constant := 98; -- Unknown protocol type - ESHUTDOWN : constant := 143; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported - ETIMEDOUT : constant := 145; -- Connection timed out - ETOOMANYREFS : constant := 144; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_ERROR : constant := 4103; -- Get/clear error status - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - IP_ADD_MEMBERSHIP : constant := 11; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 12; -- Leave a multicast group - IP_MULTICAST_TTL : constant := 16; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 10; -- Set/get mcast loopback - -end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soliop-unixware.ads b/gcc/ada/g-soliop-unixware.ads deleted file mode 100644 index 4f42edc3be4..00000000000 --- a/gcc/ada/g-soliop-unixware.ads +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2005, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 is used to provide target specific linker_options for the --- support of scokets as required by the package GNAT.Sockets. - --- This is the UnixWare version of this package - -package GNAT.Sockets.Linker_Options is -private - pragma Linker_Options ("-lnsl"); - pragma Linker_Options ("-lsocket"); -end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/i-os2err.ads b/gcc/ada/i-os2err.ads deleted file mode 100644 index f837224ae6b..00000000000 --- a/gcc/ada/i-os2err.ads +++ /dev/null @@ -1,655 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . O S 2 L I B . E R R O R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1993-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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. -- --- -- ------------------------------------------------------------------------------- - --- Definition of values for OS/2 error returns - -package Interfaces.OS2Lib.Errors is - pragma Preelaborate; - - NO_ERROR : constant := 0; - ERROR_INVALID_FUNCTION : constant := 1; - ERROR_FILE_NOT_FOUND : constant := 2; - ERROR_PATH_NOT_FOUND : constant := 3; - ERROR_TOO_MANY_OPEN_FILES : constant := 4; - ERROR_ACCESS_DENIED : constant := 5; - ERROR_INVALID_HANDLE : constant := 6; - ERROR_ARENA_TRASHED : constant := 7; - ERROR_NOT_ENOUGH_MEMORY : constant := 8; - ERROR_INVALID_BLOCK : constant := 9; - ERROR_BAD_ENVIRONMENT : constant := 10; - ERROR_BAD_FORMAT : constant := 11; - ERROR_INVALID_ACCESS : constant := 12; - ERROR_INVALID_DATA : constant := 13; - ERROR_INVALID_DRIVE : constant := 15; - ERROR_CURRENT_DIRECTORY : constant := 16; - ERROR_NOT_SAME_DEVICE : constant := 17; - ERROR_NO_MORE_FILES : constant := 18; - ERROR_WRITE_PROTECT : constant := 19; - ERROR_BAD_UNIT : constant := 20; - ERROR_NOT_READY : constant := 21; - ERROR_BAD_COMMAND : constant := 22; - ERROR_CRC : constant := 23; - ERROR_BAD_LENGTH : constant := 24; - ERROR_SEEK : constant := 25; - ERROR_NOT_DOS_DISK : constant := 26; - ERROR_SECTOR_NOT_FOUND : constant := 27; - ERROR_OUT_OF_PAPER : constant := 28; - ERROR_WRITE_FAULT : constant := 29; - ERROR_READ_FAULT : constant := 30; - ERROR_GEN_FAILURE : constant := 31; - ERROR_SHARING_VIOLATION : constant := 32; - ERROR_LOCK_VIOLATION : constant := 33; - ERROR_WRONG_DISK : constant := 34; - ERROR_FCB_UNAVAILABLE : constant := 35; - ERROR_SHARING_BUFFER_EXCEEDED : constant := 36; - ERROR_CODE_PAGE_MISMATCHED : constant := 37; - ERROR_HANDLE_EOF : constant := 38; - ERROR_HANDLE_DISK_FULL : constant := 39; - ERROR_NOT_SUPPORTED : constant := 50; - ERROR_REM_NOT_LIST : constant := 51; - ERROR_DUP_NAME : constant := 52; - ERROR_BAD_NETPATH : constant := 53; - ERROR_NETWORK_BUSY : constant := 54; - ERROR_DEV_NOT_EXIST : constant := 55; - ERROR_TOO_MANY_CMDS : constant := 56; - ERROR_ADAP_HDW_ERR : constant := 57; - ERROR_BAD_NET_RESP : constant := 58; - ERROR_UNEXP_NET_ERR : constant := 59; - ERROR_BAD_REM_ADAP : constant := 60; - ERROR_PRINTQ_FULL : constant := 61; - ERROR_NO_SPOOL_SPACE : constant := 62; - ERROR_PRINT_CANCELLED : constant := 63; - ERROR_NETNAME_DELETED : constant := 64; - ERROR_NETWORK_ACCESS_DENIED : constant := 65; - ERROR_BAD_DEV_TYPE : constant := 66; - ERROR_BAD_NET_NAME : constant := 67; - ERROR_TOO_MANY_NAMES : constant := 68; - ERROR_TOO_MANY_SESS : constant := 69; - ERROR_SHARING_PAUSED : constant := 70; - ERROR_REQ_NOT_ACCEP : constant := 71; - ERROR_REDIR_PAUSED : constant := 72; - ERROR_SBCS_ATT_WRITE_PROT : constant := 73; - ERROR_SBCS_GENERAL_FAILURE : constant := 74; - ERROR_XGA_OUT_MEMORY : constant := 75; - ERROR_FILE_EXISTS : constant := 80; - ERROR_DUP_FCB : constant := 81; - ERROR_CANNOT_MAKE : constant := 82; - ERROR_FAIL_I24 : constant := 83; - ERROR_OUT_OF_STRUCTURES : constant := 84; - ERROR_ALREADY_ASSIGNED : constant := 85; - ERROR_INVALID_PASSWORD : constant := 86; - ERROR_INVALID_PARAMETER : constant := 87; - ERROR_NET_WRITE_FAULT : constant := 88; - ERROR_NO_PROC_SLOTS : constant := 89; - ERROR_NOT_FROZEN : constant := 90; - ERROR_SYS_COMP_NOT_LOADED : constant := 90; - ERR_TSTOVFL : constant := 91; - ERR_TSTDUP : constant := 92; - ERROR_NO_ITEMS : constant := 93; - ERROR_INTERRUPT : constant := 95; - ERROR_DEVICE_IN_USE : constant := 99; - ERROR_TOO_MANY_SEMAPHORES : constant := 100; - ERROR_EXCL_SEM_ALREADY_OWNED : constant := 101; - ERROR_SEM_IS_SET : constant := 102; - ERROR_TOO_MANY_SEM_REQUESTS : constant := 103; - ERROR_INVALID_AT_INTERRUPT_TIME : constant := 104; - ERROR_SEM_OWNER_DIED : constant := 105; - ERROR_SEM_USER_LIMIT : constant := 106; - ERROR_DISK_CHANGE : constant := 107; - ERROR_DRIVE_LOCKED : constant := 108; - ERROR_BROKEN_PIPE : constant := 109; - ERROR_OPEN_FAILED : constant := 110; - ERROR_BUFFER_OVERFLOW : constant := 111; - ERROR_DISK_FULL : constant := 112; - ERROR_NO_MORE_SEARCH_HANDLES : constant := 113; - ERROR_INVALID_TARGET_HANDLE : constant := 114; - ERROR_PROTECTION_VIOLATION : constant := 115; - ERROR_VIOKBD_REQUEST : constant := 116; - ERROR_INVALID_CATEGORY : constant := 117; - ERROR_INVALID_VERIFY_SWITCH : constant := 118; - ERROR_BAD_DRIVER_LEVEL : constant := 119; - ERROR_CALL_NOT_IMPLEMENTED : constant := 120; - ERROR_SEM_TIMEOUT : constant := 121; - ERROR_INSUFFICIENT_BUFFER : constant := 122; - ERROR_INVALID_NAME : constant := 123; - ERROR_INVALID_LEVEL : constant := 124; - ERROR_NO_VOLUME_LABEL : constant := 125; - ERROR_MOD_NOT_FOUND : constant := 126; - ERROR_PROC_NOT_FOUND : constant := 127; - ERROR_WAIT_NO_CHILDREN : constant := 128; - ERROR_CHILD_NOT_COMPLETE : constant := 129; - ERROR_DIRECT_ACCESS_HANDLE : constant := 130; - ERROR_NEGATIVE_SEEK : constant := 131; - ERROR_SEEK_ON_DEVICE : constant := 132; - ERROR_IS_JOIN_TARGET : constant := 133; - ERROR_IS_JOINED : constant := 134; - ERROR_IS_SUBSTED : constant := 135; - ERROR_NOT_JOINED : constant := 136; - ERROR_NOT_SUBSTED : constant := 137; - ERROR_JOIN_TO_JOIN : constant := 138; - ERROR_SUBST_TO_SUBST : constant := 139; - ERROR_JOIN_TO_SUBST : constant := 140; - ERROR_SUBST_TO_JOIN : constant := 141; - ERROR_BUSY_DRIVE : constant := 142; - ERROR_SAME_DRIVE : constant := 143; - ERROR_DIR_NOT_ROOT : constant := 144; - ERROR_DIR_NOT_EMPTY : constant := 145; - ERROR_IS_SUBST_PATH : constant := 146; - ERROR_IS_JOIN_PATH : constant := 147; - ERROR_PATH_BUSY : constant := 148; - ERROR_IS_SUBST_TARGET : constant := 149; - ERROR_SYSTEM_TRACE : constant := 150; - ERROR_INVALID_EVENT_COUNT : constant := 151; - ERROR_TOO_MANY_MUXWAITERS : constant := 152; - ERROR_INVALID_LIST_FORMAT : constant := 153; - ERROR_LABEL_TOO_LONG : constant := 154; - ERROR_TOO_MANY_TCBS : constant := 155; - ERROR_SIGNAL_REFUSED : constant := 156; - ERROR_DISCARDED : constant := 157; - ERROR_NOT_LOCKED : constant := 158; - ERROR_BAD_THREADID_ADDR : constant := 159; - ERROR_BAD_ARGUMENTS : constant := 160; - ERROR_BAD_PATHNAME : constant := 161; - ERROR_SIGNAL_PENDING : constant := 162; - ERROR_UNCERTAIN_MEDIA : constant := 163; - ERROR_MAX_THRDS_REACHED : constant := 164; - ERROR_MONITORS_NOT_SUPPORTED : constant := 165; - ERROR_UNC_DRIVER_NOT_INSTALLED : constant := 166; - ERROR_LOCK_FAILED : constant := 167; - ERROR_SWAPIO_FAILED : constant := 168; - ERROR_SWAPIN_FAILED : constant := 169; - ERROR_BUSY : constant := 170; - ERROR_CANCEL_VIOLATION : constant := 173; - ERROR_ATOMIC_LOCK_NOT_SUPPORTED : constant := 174; - ERROR_READ_LOCKS_NOT_SUPPORTED : constant := 175; - ERROR_INVALID_SEGMENT_NUMBER : constant := 180; - ERROR_INVALID_CALLGATE : constant := 181; - ERROR_INVALID_ORDINAL : constant := 182; - ERROR_ALREADY_EXISTS : constant := 183; - ERROR_NO_CHILD_PROCESS : constant := 184; - ERROR_CHILD_ALIVE_NOWAIT : constant := 185; - ERROR_INVALID_FLAG_NUMBER : constant := 186; - ERROR_SEM_NOT_FOUND : constant := 187; - ERROR_INVALID_STARTING_CODESEG : constant := 188; - ERROR_INVALID_STACKSEG : constant := 189; - ERROR_INVALID_MODULETYPE : constant := 190; - ERROR_INVALID_EXE_SIGNATURE : constant := 191; - ERROR_EXE_MARKED_INVALID : constant := 192; - ERROR_BAD_EXE_FORMAT : constant := 193; - ERROR_ITERATED_DATA_EXCEEDS_64k : constant := 194; - ERROR_INVALID_MINALLOCSIZE : constant := 195; - ERROR_DYNLINK_FROM_INVALID_RING : constant := 196; - ERROR_IOPL_NOT_ENABLED : constant := 197; - ERROR_INVALID_SEGDPL : constant := 198; - ERROR_AUTODATASEG_EXCEEDS_64k : constant := 199; - ERROR_RING2SEG_MUST_BE_MOVABLE : constant := 200; - ERROR_RELOC_CHAIN_XEEDS_SEGLIM : constant := 201; - ERROR_INFLOOP_IN_RELOC_CHAIN : constant := 202; - ERROR_ENVVAR_NOT_FOUND : constant := 203; - ERROR_NOT_CURRENT_CTRY : constant := 204; - ERROR_NO_SIGNAL_SENT : constant := 205; - ERROR_FILENAME_EXCED_RANGE : constant := 206; - ERROR_RING2_STACK_IN_USE : constant := 207; - ERROR_META_EXPANSION_TOO_LONG : constant := 208; - ERROR_INVALID_SIGNAL_NUMBER : constant := 209; - ERROR_THREAD_1_INACTIVE : constant := 210; - ERROR_INFO_NOT_AVAIL : constant := 211; - ERROR_LOCKED : constant := 212; - ERROR_BAD_DYNALINK : constant := 213; - ERROR_TOO_MANY_MODULES : constant := 214; - ERROR_NESTING_NOT_ALLOWED : constant := 215; - ERROR_CANNOT_SHRINK : constant := 216; - ERROR_ZOMBIE_PROCESS : constant := 217; - ERROR_STACK_IN_HIGH_MEMORY : constant := 218; - ERROR_INVALID_EXITROUTINE_RING : constant := 219; - ERROR_GETBUF_FAILED : constant := 220; - ERROR_FLUSHBUF_FAILED : constant := 221; - ERROR_TRANSFER_TOO_LONG : constant := 222; - ERROR_FORCENOSWAP_FAILED : constant := 223; - ERROR_SMG_NO_TARGET_WINDOW : constant := 224; - ERROR_NO_CHILDREN : constant := 228; - ERROR_INVALID_SCREEN_GROUP : constant := 229; - ERROR_BAD_PIPE : constant := 230; - ERROR_PIPE_BUSY : constant := 231; - ERROR_NO_DATA : constant := 232; - ERROR_PIPE_NOT_CONNECTED : constant := 233; - ERROR_MORE_DATA : constant := 234; - ERROR_VC_DISCONNECTED : constant := 240; - ERROR_CIRCULARITY_REQUESTED : constant := 250; - ERROR_DIRECTORY_IN_CDS : constant := 251; - ERROR_INVALID_FSD_NAME : constant := 252; - ERROR_INVALID_PATH : constant := 253; - ERROR_INVALID_EA_NAME : constant := 254; - ERROR_EA_LIST_INCONSISTENT : constant := 255; - ERROR_EA_LIST_TOO_LONG : constant := 256; - ERROR_NO_META_MATCH : constant := 257; - ERROR_FINDNOTIFY_TIMEOUT : constant := 258; - ERROR_NO_MORE_ITEMS : constant := 259; - ERROR_SEARCH_STRUC_REUSED : constant := 260; - ERROR_CHAR_NOT_FOUND : constant := 261; - ERROR_TOO_MUCH_STACK : constant := 262; - ERROR_INVALID_ATTR : constant := 263; - ERROR_INVALID_STARTING_RING : constant := 264; - ERROR_INVALID_DLL_INIT_RING : constant := 265; - ERROR_CANNOT_COPY : constant := 266; - ERROR_DIRECTORY : constant := 267; - ERROR_OPLOCKED_FILE : constant := 268; - ERROR_OPLOCK_THREAD_EXISTS : constant := 269; - ERROR_VOLUME_CHANGED : constant := 270; - ERROR_FINDNOTIFY_HANDLE_IN_USE : constant := 271; - ERROR_FINDNOTIFY_HANDLE_CLOSED : constant := 272; - ERROR_NOTIFY_OBJECT_REMOVED : constant := 273; - ERROR_ALREADY_SHUTDOWN : constant := 274; - ERROR_EAS_DIDNT_FIT : constant := 275; - ERROR_EA_FILE_CORRUPT : constant := 276; - ERROR_EA_TABLE_FULL : constant := 277; - ERROR_INVALID_EA_HANDLE : constant := 278; - ERROR_NO_CLUSTER : constant := 279; - ERROR_CREATE_EA_FILE : constant := 280; - ERROR_CANNOT_OPEN_EA_FILE : constant := 281; - ERROR_EAS_NOT_SUPPORTED : constant := 282; - ERROR_NEED_EAS_FOUND : constant := 283; - ERROR_DUPLICATE_HANDLE : constant := 284; - ERROR_DUPLICATE_NAME : constant := 285; - ERROR_EMPTY_MUXWAIT : constant := 286; - ERROR_MUTEX_OWNED : constant := 287; - ERROR_NOT_OWNER : constant := 288; - ERROR_PARAM_TOO_SMALL : constant := 289; - ERROR_TOO_MANY_HANDLES : constant := 290; - ERROR_TOO_MANY_OPENS : constant := 291; - ERROR_WRONG_TYPE : constant := 292; - ERROR_UNUSED_CODE : constant := 293; - ERROR_THREAD_NOT_TERMINATED : constant := 294; - ERROR_INIT_ROUTINE_FAILED : constant := 295; - ERROR_MODULE_IN_USE : constant := 296; - ERROR_NOT_ENOUGH_WATCHPOINTS : constant := 297; - ERROR_TOO_MANY_POSTS : constant := 298; - ERROR_ALREADY_POSTED : constant := 299; - ERROR_ALREADY_RESET : constant := 300; - ERROR_SEM_BUSY : constant := 301; - ERROR_INVALID_PROCID : constant := 303; - ERROR_INVALID_PDELTA : constant := 304; - ERROR_NOT_DESCENDANT : constant := 305; - ERROR_NOT_SESSION_MANAGER : constant := 306; - ERROR_INVALID_PCLASS : constant := 307; - ERROR_INVALID_SCOPE : constant := 308; - ERROR_INVALID_THREADID : constant := 309; - ERROR_DOSSUB_SHRINK : constant := 310; - ERROR_DOSSUB_NOMEM : constant := 311; - ERROR_DOSSUB_OVERLAP : constant := 312; - ERROR_DOSSUB_BADSIZE : constant := 313; - ERROR_DOSSUB_BADFLAG : constant := 314; - ERROR_DOSSUB_BADSELECTOR : constant := 315; - ERROR_MR_MSG_TOO_LONG : constant := 316; - MGS_MR_MSG_TOO_LONG : constant := 316; - ERROR_MR_MID_NOT_FOUND : constant := 317; - ERROR_MR_UN_ACC_MSGF : constant := 318; - ERROR_MR_INV_MSGF_FORMAT : constant := 319; - ERROR_MR_INV_IVCOUNT : constant := 320; - ERROR_MR_UN_PERFORM : constant := 321; - ERROR_TS_WAKEUP : constant := 322; - ERROR_TS_SEMHANDLE : constant := 323; - ERROR_TS_NOTIMER : constant := 324; - ERROR_TS_HANDLE : constant := 326; - ERROR_TS_DATETIME : constant := 327; - ERROR_SYS_INTERNAL : constant := 328; - ERROR_QUE_CURRENT_NAME : constant := 329; - ERROR_QUE_PROC_NOT_OWNED : constant := 330; - ERROR_QUE_PROC_OWNED : constant := 331; - ERROR_QUE_DUPLICATE : constant := 332; - ERROR_QUE_ELEMENT_NOT_EXIST : constant := 333; - ERROR_QUE_NO_MEMORY : constant := 334; - ERROR_QUE_INVALID_NAME : constant := 335; - ERROR_QUE_INVALID_PRIORITY : constant := 336; - ERROR_QUE_INVALID_HANDLE : constant := 337; - ERROR_QUE_LINK_NOT_FOUND : constant := 338; - ERROR_QUE_MEMORY_ERROR : constant := 339; - ERROR_QUE_PREV_AT_END : constant := 340; - ERROR_QUE_PROC_NO_ACCESS : constant := 341; - ERROR_QUE_EMPTY : constant := 342; - ERROR_QUE_NAME_NOT_EXIST : constant := 343; - ERROR_QUE_NOT_INITIALIZED : constant := 344; - ERROR_QUE_UNABLE_TO_ACCESS : constant := 345; - ERROR_QUE_UNABLE_TO_ADD : constant := 346; - ERROR_QUE_UNABLE_TO_INIT : constant := 347; - ERROR_VIO_INVALID_MASK : constant := 349; - ERROR_VIO_PTR : constant := 350; - ERROR_VIO_APTR : constant := 351; - ERROR_VIO_RPTR : constant := 352; - ERROR_VIO_CPTR : constant := 353; - ERROR_VIO_LPTR : constant := 354; - ERROR_VIO_MODE : constant := 355; - ERROR_VIO_WIDTH : constant := 356; - ERROR_VIO_ATTR : constant := 357; - ERROR_VIO_ROW : constant := 358; - ERROR_VIO_COL : constant := 359; - ERROR_VIO_TOPROW : constant := 360; - ERROR_VIO_BOTROW : constant := 361; - ERROR_VIO_RIGHTCOL : constant := 362; - ERROR_VIO_LEFTCOL : constant := 363; - ERROR_SCS_CALL : constant := 364; - ERROR_SCS_VALUE : constant := 365; - ERROR_VIO_WAIT_FLAG : constant := 366; - ERROR_VIO_UNLOCK : constant := 367; - ERROR_SGS_NOT_SESSION_MGR : constant := 368; - ERROR_SMG_INVALID_SGID : constant := 369; - ERROR_SMG_INVALID_SESSION_ID : constant := 369; - ERROR_SMG_NOSG : constant := 370; - ERROR_SMG_NO_SESSIONS : constant := 370; - ERROR_SMG_GRP_NOT_FOUND : constant := 371; - ERROR_SMG_SESSION_NOT_FOUND : constant := 371; - ERROR_SMG_SET_TITLE : constant := 372; - ERROR_KBD_PARAMETER : constant := 373; - ERROR_KBD_NO_DEVICE : constant := 374; - ERROR_KBD_INVALID_IOWAIT : constant := 375; - ERROR_KBD_INVALID_LENGTH : constant := 376; - ERROR_KBD_INVALID_ECHO_MASK : constant := 377; - ERROR_KBD_INVALID_INPUT_MASK : constant := 378; - ERROR_MON_INVALID_PARMS : constant := 379; - ERROR_MON_INVALID_DEVNAME : constant := 380; - ERROR_MON_INVALID_HANDLE : constant := 381; - ERROR_MON_BUFFER_TOO_SMALL : constant := 382; - ERROR_MON_BUFFER_EMPTY : constant := 383; - ERROR_MON_DATA_TOO_LARGE : constant := 384; - ERROR_MOUSE_NO_DEVICE : constant := 385; - ERROR_MOUSE_INV_HANDLE : constant := 386; - ERROR_MOUSE_INV_PARMS : constant := 387; - ERROR_MOUSE_CANT_RESET : constant := 388; - ERROR_MOUSE_DISPLAY_PARMS : constant := 389; - ERROR_MOUSE_INV_MODULE : constant := 390; - ERROR_MOUSE_INV_ENTRY_PT : constant := 391; - ERROR_MOUSE_INV_MASK : constant := 392; - NO_ERROR_MOUSE_NO_DATA : constant := 393; - NO_ERROR_MOUSE_PTR_DRAWN : constant := 394; - ERROR_INVALID_FREQUENCY : constant := 395; - ERROR_NLS_NO_COUNTRY_FILE : constant := 396; - ERROR_NLS_OPEN_FAILED : constant := 397; - ERROR_NLS_NO_CTRY_CODE : constant := 398; - ERROR_NO_COUNTRY_OR_CODEPAGE : constant := 398; - ERROR_NLS_TABLE_TRUNCATED : constant := 399; - ERROR_NLS_BAD_TYPE : constant := 400; - ERROR_NLS_TYPE_NOT_FOUND : constant := 401; - ERROR_VIO_SMG_ONLY : constant := 402; - ERROR_VIO_INVALID_ASCIIZ : constant := 403; - ERROR_VIO_DEREGISTER : constant := 404; - ERROR_VIO_NO_POPUP : constant := 405; - ERROR_VIO_EXISTING_POPUP : constant := 406; - ERROR_KBD_SMG_ONLY : constant := 407; - ERROR_KBD_INVALID_ASCIIZ : constant := 408; - ERROR_KBD_INVALID_MASK : constant := 409; - ERROR_KBD_REGISTER : constant := 410; - ERROR_KBD_DEREGISTER : constant := 411; - ERROR_MOUSE_SMG_ONLY : constant := 412; - ERROR_MOUSE_INVALID_ASCIIZ : constant := 413; - ERROR_MOUSE_INVALID_MASK : constant := 414; - ERROR_MOUSE_REGISTER : constant := 415; - ERROR_MOUSE_DEREGISTER : constant := 416; - ERROR_SMG_BAD_ACTION : constant := 417; - ERROR_SMG_INVALID_CALL : constant := 418; - ERROR_SCS_SG_NOTFOUND : constant := 419; - ERROR_SCS_NOT_SHELL : constant := 420; - ERROR_VIO_INVALID_PARMS : constant := 421; - ERROR_VIO_FUNCTION_OWNED : constant := 422; - ERROR_VIO_RETURN : constant := 423; - ERROR_SCS_INVALID_FUNCTION : constant := 424; - ERROR_SCS_NOT_SESSION_MGR : constant := 425; - ERROR_VIO_REGISTER : constant := 426; - ERROR_VIO_NO_MODE_THREAD : constant := 427; - ERROR_VIO_NO_SAVE_RESTORE_THD : constant := 428; - ERROR_VIO_IN_BG : constant := 429; - ERROR_VIO_ILLEGAL_DURING_POPUP : constant := 430; - ERROR_SMG_NOT_BASESHELL : constant := 431; - ERROR_SMG_BAD_STATUSREQ : constant := 432; - ERROR_QUE_INVALID_WAIT : constant := 433; - ERROR_VIO_LOCK : constant := 434; - ERROR_MOUSE_INVALID_IOWAIT : constant := 435; - ERROR_VIO_INVALID_HANDLE : constant := 436; - ERROR_VIO_ILLEGAL_DURING_LOCK : constant := 437; - ERROR_VIO_INVALID_LENGTH : constant := 438; - ERROR_KBD_INVALID_HANDLE : constant := 439; - ERROR_KBD_NO_MORE_HANDLE : constant := 440; - ERROR_KBD_CANNOT_CREATE_KCB : constant := 441; - ERROR_KBD_CODEPAGE_LOAD_INCOMPL : constant := 442; - ERROR_KBD_INVALID_CODEPAGE_ID : constant := 443; - ERROR_KBD_NO_CODEPAGE_SUPPORT : constant := 444; - ERROR_KBD_FOCUS_REQUIRED : constant := 445; - ERROR_KBD_FOCUS_ALREADY_ACTIVE : constant := 446; - ERROR_KBD_KEYBOARD_BUSY : constant := 447; - ERROR_KBD_INVALID_CODEPAGE : constant := 448; - ERROR_KBD_UNABLE_TO_FOCUS : constant := 449; - ERROR_SMG_SESSION_NON_SELECT : constant := 450; - ERROR_SMG_SESSION_NOT_FOREGRND : constant := 451; - ERROR_SMG_SESSION_NOT_PARENT : constant := 452; - ERROR_SMG_INVALID_START_MODE : constant := 453; - ERROR_SMG_INVALID_RELATED_OPT : constant := 454; - ERROR_SMG_INVALID_BOND_OPTION : constant := 455; - ERROR_SMG_INVALID_SELECT_OPT : constant := 456; - ERROR_SMG_START_IN_BACKGROUND : constant := 457; - ERROR_SMG_INVALID_STOP_OPTION : constant := 458; - ERROR_SMG_BAD_RESERVE : constant := 459; - ERROR_SMG_PROCESS_NOT_PARENT : constant := 460; - ERROR_SMG_INVALID_DATA_LENGTH : constant := 461; - ERROR_SMG_NOT_BOUND : constant := 462; - ERROR_SMG_RETRY_SUB_ALLOC : constant := 463; - ERROR_KBD_DETACHED : constant := 464; - ERROR_VIO_DETACHED : constant := 465; - ERROR_MOU_DETACHED : constant := 466; - ERROR_VIO_FONT : constant := 467; - ERROR_VIO_USER_FONT : constant := 468; - ERROR_VIO_BAD_CP : constant := 469; - ERROR_VIO_NO_CP : constant := 470; - ERROR_VIO_NA_CP : constant := 471; - ERROR_INVALID_CODE_PAGE : constant := 472; - ERROR_CPLIST_TOO_SMALL : constant := 473; - ERROR_CP_NOT_MOVED : constant := 474; - ERROR_MODE_SWITCH_INIT : constant := 475; - ERROR_CODE_PAGE_NOT_FOUND : constant := 476; - ERROR_UNEXPECTED_SLOT_RETURNED : constant := 477; - ERROR_SMG_INVALID_TRACE_OPTION : constant := 478; - ERROR_VIO_INTERNAL_RESOURCE : constant := 479; - ERROR_VIO_SHELL_INIT : constant := 480; - ERROR_SMG_NO_HARD_ERRORS : constant := 481; - ERROR_CP_SWITCH_INCOMPLETE : constant := 482; - ERROR_VIO_TRANSPARENT_POPUP : constant := 483; - ERROR_CRITSEC_OVERFLOW : constant := 484; - ERROR_CRITSEC_UNDERFLOW : constant := 485; - ERROR_VIO_BAD_RESERVE : constant := 486; - ERROR_INVALID_ADDRESS : constant := 487; - ERROR_ZERO_SELECTORS_REQUESTED : constant := 488; - ERROR_NOT_ENOUGH_SELECTORS_AVA : constant := 489; - ERROR_INVALID_SELECTOR : constant := 490; - ERROR_SMG_INVALID_PROGRAM_TYPE : constant := 491; - ERROR_SMG_INVALID_PGM_CONTROL : constant := 492; - ERROR_SMG_INVALID_INHERIT_OPT : constant := 493; - ERROR_VIO_EXTENDED_SG : constant := 494; - ERROR_VIO_NOT_PRES_MGR_SG : constant := 495; - ERROR_VIO_SHIELD_OWNED : constant := 496; - ERROR_VIO_NO_MORE_HANDLES : constant := 497; - ERROR_VIO_SEE_ERROR_LOG : constant := 498; - ERROR_VIO_ASSOCIATED_DC : constant := 499; - ERROR_KBD_NO_CONSOLE : constant := 500; - ERROR_MOUSE_NO_CONSOLE : constant := 501; - ERROR_MOUSE_INVALID_HANDLE : constant := 502; - ERROR_SMG_INVALID_DEBUG_PARMS : constant := 503; - ERROR_KBD_EXTENDED_SG : constant := 504; - ERROR_MOU_EXTENDED_SG : constant := 505; - ERROR_SMG_INVALID_ICON_FILE : constant := 506; - ERROR_TRC_PID_NON_EXISTENT : constant := 507; - ERROR_TRC_COUNT_ACTIVE : constant := 508; - ERROR_TRC_SUSPENDED_BY_COUNT : constant := 509; - ERROR_TRC_COUNT_INACTIVE : constant := 510; - ERROR_TRC_COUNT_REACHED : constant := 511; - ERROR_NO_MC_TRACE : constant := 512; - ERROR_MC_TRACE : constant := 513; - ERROR_TRC_COUNT_ZERO : constant := 514; - ERROR_SMG_TOO_MANY_DDS : constant := 515; - ERROR_SMG_INVALID_NOTIFICATION : constant := 516; - ERROR_LF_INVALID_FUNCTION : constant := 517; - ERROR_LF_NOT_AVAIL : constant := 518; - ERROR_LF_SUSPENDED : constant := 519; - ERROR_LF_BUF_TOO_SMALL : constant := 520; - ERROR_LF_BUFFER_CORRUPTED : constant := 521; - ERROR_LF_BUFFER_FULL : constant := 521; - ERROR_LF_INVALID_DAEMON : constant := 522; - ERROR_LF_INVALID_RECORD : constant := 522; - ERROR_LF_INVALID_TEMPL : constant := 523; - ERROR_LF_INVALID_SERVICE : constant := 523; - ERROR_LF_GENERAL_FAILURE : constant := 524; - ERROR_LF_INVALID_ID : constant := 525; - ERROR_LF_INVALID_HANDLE : constant := 526; - ERROR_LF_NO_ID_AVAIL : constant := 527; - ERROR_LF_TEMPLATE_AREA_FULL : constant := 528; - ERROR_LF_ID_IN_USE : constant := 529; - ERROR_MOU_NOT_INITIALIZED : constant := 530; - ERROR_MOUINITREAL_DONE : constant := 531; - ERROR_DOSSUB_CORRUPTED : constant := 532; - ERROR_MOUSE_CALLER_NOT_SUBSYS : constant := 533; - ERROR_ARITHMETIC_OVERFLOW : constant := 534; - ERROR_TMR_NO_DEVICE : constant := 535; - ERROR_TMR_INVALID_TIME : constant := 536; - ERROR_PVW_INVALID_ENTITY : constant := 537; - ERROR_PVW_INVALID_ENTITY_TYPE : constant := 538; - ERROR_PVW_INVALID_SPEC : constant := 539; - ERROR_PVW_INVALID_RANGE_TYPE : constant := 540; - ERROR_PVW_INVALID_COUNTER_BLK : constant := 541; - ERROR_PVW_INVALID_TEXT_BLK : constant := 542; - ERROR_PRF_NOT_INITIALIZED : constant := 543; - ERROR_PRF_ALREADY_INITIALIZED : constant := 544; - ERROR_PRF_NOT_STARTED : constant := 545; - ERROR_PRF_ALREADY_STARTED : constant := 546; - ERROR_PRF_TIMER_OUT_OF_RANGE : constant := 547; - ERROR_PRF_TIMER_RESET : constant := 548; - ERROR_VDD_LOCK_USEAGE_DENIED : constant := 639; - ERROR_TIMEOUT : constant := 640; - ERROR_VDM_DOWN : constant := 641; - ERROR_VDM_LIMIT : constant := 642; - ERROR_VDD_NOT_FOUND : constant := 643; - ERROR_INVALID_CALLER : constant := 644; - ERROR_PID_MISMATCH : constant := 645; - ERROR_INVALID_VDD_HANDLE : constant := 646; - ERROR_VLPT_NO_SPOOLER : constant := 647; - ERROR_VCOM_DEVICE_BUSY : constant := 648; - ERROR_VLPT_DEVICE_BUSY : constant := 649; - ERROR_NESTING_TOO_DEEP : constant := 650; - ERROR_VDD_MISSING : constant := 651; - ERROR_BIDI_INVALID_LENGTH : constant := 671; - ERROR_BIDI_INVALID_INCREMENT : constant := 672; - ERROR_BIDI_INVALID_COMBINATION : constant := 673; - ERROR_BIDI_INVALID_RESERVED : constant := 674; - ERROR_BIDI_INVALID_EFFECT : constant := 675; - ERROR_BIDI_INVALID_CSDREC : constant := 676; - ERROR_BIDI_INVALID_CSDSTATE : constant := 677; - ERROR_BIDI_INVALID_LEVEL : constant := 678; - ERROR_BIDI_INVALID_TYPE_SUPPORT : constant := 679; - ERROR_BIDI_INVALID_ORIENTATION : constant := 680; - ERROR_BIDI_INVALID_NUM_SHAPE : constant := 681; - ERROR_BIDI_INVALID_CSD : constant := 682; - ERROR_BIDI_NO_SUPPORT : constant := 683; - NO_ERROR_BIDI_RW_INCOMPLETE : constant := 684; - ERROR_IMP_INVALID_PARM : constant := 691; - ERROR_IMP_INVALID_LENGTH : constant := 692; - MSG_HPFS_DISK_ERROR_WARN : constant := 693; - ERROR_MON_BAD_BUFFER : constant := 730; - ERROR_MODULE_CORRUPTED : constant := 731; - ERROR_SM_OUTOF_SWAPFILE : constant := 1477; - ERROR_LF_TIMEOUT : constant := 2055; - ERROR_LF_SUSPEND_SUCCESS : constant := 2057; - ERROR_LF_RESUME_SUCCESS : constant := 2058; - ERROR_LF_REDIRECT_SUCCESS : constant := 2059; - ERROR_LF_REDIRECT_FAILURE : constant := 2060; - ERROR_SWAPPER_NOT_ACTIVE : constant := 32768; - ERROR_INVALID_SWAPID : constant := 32769; - ERROR_IOERR_SWAP_FILE : constant := 32770; - ERROR_SWAP_TABLE_FULL : constant := 32771; - ERROR_SWAP_FILE_FULL : constant := 32772; - ERROR_CANT_INIT_SWAPPER : constant := 32773; - ERROR_SWAPPER_ALREADY_INIT : constant := 32774; - ERROR_PMM_INSUFFICIENT_MEMORY : constant := 32775; - ERROR_PMM_INVALID_FLAGS : constant := 32776; - ERROR_PMM_INVALID_ADDRESS : constant := 32777; - ERROR_PMM_LOCK_FAILED : constant := 32778; - ERROR_PMM_UNLOCK_FAILED : constant := 32779; - ERROR_PMM_MOVE_INCOMPLETE : constant := 32780; - ERROR_UCOM_DRIVE_RENAMED : constant := 32781; - ERROR_UCOM_FILENAME_TRUNCATED : constant := 32782; - ERROR_UCOM_BUFFER_LENGTH : constant := 32783; - ERROR_MON_CHAIN_HANDLE : constant := 32784; - ERROR_MON_NOT_REGISTERED : constant := 32785; - ERROR_SMG_ALREADY_TOP : constant := 32786; - ERROR_PMM_ARENA_MODIFIED : constant := 32787; - ERROR_SMG_PRINTER_OPEN : constant := 32788; - ERROR_PMM_SET_FLAGS_FAILED : constant := 32789; - ERROR_INVALID_DOS_DD : constant := 32790; - ERROR_BLOCKED : constant := 32791; - ERROR_NOBLOCK : constant := 32792; - ERROR_INSTANCE_SHARED : constant := 32793; - ERROR_NO_OBJECT : constant := 32794; - ERROR_PARTIAL_ATTACH : constant := 32795; - ERROR_INCACHE : constant := 32796; - ERROR_SWAP_IO_PROBLEMS : constant := 32797; - ERROR_CROSSES_OBJECT_BOUNDARY : constant := 32798; - ERROR_LONGLOCK : constant := 32799; - ERROR_SHORTLOCK : constant := 32800; - ERROR_UVIRTLOCK : constant := 32801; - ERROR_ALIASLOCK : constant := 32802; - ERROR_ALIAS : constant := 32803; - ERROR_NO_MORE_HANDLES : constant := 32804; - ERROR_SCAN_TERMINATED : constant := 32805; - ERROR_TERMINATOR_NOT_FOUND : constant := 32806; - ERROR_NOT_DIRECT_CHILD : constant := 32807; - ERROR_DELAY_FREE : constant := 32808; - ERROR_GUARDPAGE : constant := 32809; - ERROR_SWAPERROR : constant := 32900; - ERROR_LDRERROR : constant := 32901; - ERROR_NOMEMORY : constant := 32902; - ERROR_NOACCESS : constant := 32903; - ERROR_NO_DLL_TERM : constant := 32904; - ERROR_CPSIO_CODE_PAGE_INVALID : constant := 65026; - ERROR_CPSIO_NO_SPOOLER : constant := 65027; - ERROR_CPSIO_FONT_ID_INVALID : constant := 65028; - ERROR_CPSIO_INTERNAL_ERROR : constant := 65033; - ERROR_CPSIO_INVALID_PTR_NAME : constant := 65034; - ERROR_CPSIO_NOT_ACTIVE : constant := 65037; - ERROR_CPSIO_PID_FULL : constant := 65039; - ERROR_CPSIO_PID_NOT_FOUND : constant := 65040; - ERROR_CPSIO_READ_CTL_SEQ : constant := 65043; - ERROR_CPSIO_READ_FNT_DEF : constant := 65045; - ERROR_CPSIO_WRITE_ERROR : constant := 65047; - ERROR_CPSIO_WRITE_FULL_ERROR : constant := 65048; - ERROR_CPSIO_WRITE_HANDLE_BAD : constant := 65049; - ERROR_CPSIO_SWIT_LOAD : constant := 65074; - ERROR_CPSIO_INV_COMMAND : constant := 65077; - ERROR_CPSIO_NO_FONT_SWIT : constant := 65078; - ERROR_ENTRY_IS_CALLGATE : constant := 65079; - -end Interfaces.OS2Lib.Errors; diff --git a/gcc/ada/i-os2lib.adb b/gcc/ada/i-os2lib.adb deleted file mode 100644 index 93a56567e0e..00000000000 --- a/gcc/ada/i-os2lib.adb +++ /dev/null @@ -1,66 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . O S 2 L I B -- --- -- --- B o d y -- --- -- --- Copyright (C) 1993-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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.OS2Lib.Errors; - -package body Interfaces.OS2Lib is - - pragma Warnings (Off, Errors); - package IOE renames Interfaces.OS2Lib.Errors; - - ------------------- - -- Must_Not_Fail -- - ------------------- - - procedure Must_Not_Fail (Return_Code : APIRET) is - begin - pragma Assert (Return_Code = IOE.NO_ERROR); - null; - end Must_Not_Fail; - - ----------------------- - -- Sem_Must_Not_Fail -- - ----------------------- - - procedure Sem_Must_Not_Fail (Return_Code : OS2Lib.APIRET) is - begin - pragma Assert - (Return_Code = IOE.NO_ERROR - or else - Return_Code = IOE.ERROR_ALREADY_POSTED - or else - Return_Code = IOE.ERROR_ALREADY_RESET); - null; - end Sem_Must_Not_Fail; - -end Interfaces.OS2Lib; diff --git a/gcc/ada/i-os2lib.ads b/gcc/ada/i-os2lib.ads deleted file mode 100644 index ac5a65433eb..00000000000 --- a/gcc/ada/i-os2lib.ads +++ /dev/null @@ -1,143 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . O S 2 L I B -- --- -- --- S p e c -- --- -- --- Copyright (C) 1993-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 (and children) provide interface definitions to the standard --- OS/2 Library. They are merely a translation of the various <bse*.h> files. - --- It is intended that higher level interfaces (with better names, and --- stronger typing!) be built on top of this one for Ada (i.e. clean) --- programming. - --- We have chosen to keep names, types, etc. as close as possible to the --- C definition to provide easier reference to the documentation. The main --- exception is when a formal and its type (in C) differed only by the case --- of letters (like in HMUX hmux). In this case, we have prepended "F_" to --- the formal (i.e. F_hmux : HMUX). - -with Interfaces.C; -with Interfaces.C.Strings; -with System; - -package Interfaces.OS2Lib is - pragma Preelaborate; - - package IC renames Interfaces.C; - package ICS renames Interfaces.C.Strings; - - ------------------- - -- General Types -- - ------------------- - - type APIRET is new IC.unsigned_long; - type APIRET16 is new IC.unsigned_short; - subtype APIRET32 is APIRET; - - subtype PSZ is ICS.chars_ptr; - subtype PCHAR is ICS.chars_ptr; - subtype PVOID is System.Address; - type PPVOID is access all PVOID; - - type BOOL32 is new IC.unsigned_long; - False32 : constant BOOL32 := 0; - True32 : constant BOOL32 := 1; - - type UCHAR is new IC.unsigned_char; - type USHORT is new IC.unsigned_short; - type ULONG is new IC.unsigned_long; - type PULONG is access all ULONG; - - -- Coprocessor stack register element - - type FPREG is record - losig : ULONG; -- Low 32-bits of the mantissa - hisig : ULONG; -- High 32-bits of the mantissa - signexp : USHORT; -- Sign and exponent - end record; - pragma Convention (C, FPREG); - - type AULONG is array (IC.size_t range <>) of ULONG; - type AFPREG is array (IC.size_t range <>) of FPREG; - - type LHANDLE is new IC.unsigned_long; - - NULLHANDLE : constant := 0; - - --------------------- - -- Time Management -- - --------------------- - - function DosSleep (How_long : ULONG) return APIRET; - pragma Import (C, DosSleep, "DosSleep"); - - type DATETIME is record - hours : UCHAR; - minutes : UCHAR; - seconds : UCHAR; - hundredths : UCHAR; - day : UCHAR; - month : UCHAR; - year : USHORT; - timezone : IC.short; - weekday : UCHAR; - end record; - - type PDATETIME is access all DATETIME; - - function DosGetDateTime (pdt : PDATETIME) return APIRET; - pragma Import (C, DosGetDateTime, "DosGetDateTime"); - - function DosSetDateTime (pdt : PDATETIME) return APIRET; - pragma Import (C, DosSetDateTime, "DosSetDateTime"); - - ---------------------------- - -- Miscelleneous Features -- - ---------------------------- - - -- Features which do not fit any child - - function DosBeep (Freq : ULONG; Dur : ULONG) return APIRET; - pragma Import (C, DosBeep, "DosBeep"); - - procedure Must_Not_Fail (Return_Code : OS2Lib.APIRET); - pragma Inline (Must_Not_Fail); - -- Many OS/2 functions return APIRET and are not supposed to fail. In C - -- style, these would be called as procedures, disregarding the returned - -- value. This procedure can be used to achieve the same effect with a - -- call of the form: Must_Not_Fail (Some_OS2_Function (...)); - - procedure Sem_Must_Not_Fail (Return_Code : OS2Lib.APIRET); - pragma Inline (Sem_Must_Not_Fail); - -- Similar to Must_Not_Fail, but used in the case of DosPostEventSem, - -- where the "error" code ERROR_ALREADY_POSTED is not really an error. - -end Interfaces.OS2Lib; diff --git a/gcc/ada/i-os2syn.ads b/gcc/ada/i-os2syn.ads deleted file mode 100644 index 9dfa2c6dfe0..00000000000 --- a/gcc/ada/i-os2syn.ads +++ /dev/null @@ -1,267 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . O S 2 L I B . S Y N C H R O N I Z A T I O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 1993-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.OS2Lib.Threads; - -package Interfaces.OS2Lib.Synchronization is - pragma Preelaborate; - - package IC renames Interfaces.C; - package IOT renames Interfaces.OS2Lib.Threads; - package S renames System; - - -- Semaphore Attributes - - DC_SEM_SHARED : constant := 16#01#; - -- DosCreateMutex, DosCreateEvent, and DosCreateMuxWait use it to indicate - -- whether the semaphore is shared or private when the PSZ is null - - SEM_INDEFINITE_WAIT : constant ULONG := -1; - SEM_IMMEDIATE_RETURN : constant ULONG := 0; - - type HSEM is new LHANDLE; - type PHSEM is access all HSEM; - - type SEMRECORD is record - hsemCur : HSEM; - ulUser : ULONG; - end record; - - type PSEMRECORD is access all SEMRECORD; - - -- Quad word structure - - -- Originally QWORD is defined as a record containing two ULONGS, - -- the first containing low word and the second for the high word, - -- but it is cleaner to define it as follows: - - type QWORD is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0; - type PQWORD is access all QWORD; - - type HEV is new HSEM; - type PHEV is access all HEV; - - type HMTX is new HSEM; - type PHMTX is access all HMTX; - - type HMUX is new HSEM; - type PHMUX is access all HMUX; - - type HTIMER is new LHANDLE; - type PHTIMER is access all HTIMER; - - ----------------------- - -- Critical sections -- - ----------------------- - - function DosEnterCritSec return APIRET; - pragma Import (C, DosEnterCritSec, "DosEnterCritSec"); - - function DosExitCritSec return APIRET; - pragma Import (C, DosExitCritSec, "DosExitCritSec"); - - -------------- - -- EventSem -- - -------------- - - function DosCreateEventSem - (pszName : PSZ; - f_phev : PHEV; - flAttr : ULONG; - fState : BOOL32) - return APIRET; - pragma Import (C, DosCreateEventSem, "DosCreateEventSem"); - - function DosOpenEventSem - (pszName : PSZ; - F_phev : PHEV) - return APIRET; - pragma Import (C, DosOpenEventSem, "DosOpenEventSem"); - - function DosCloseEventSem - (F_hev : HEV) - return APIRET; - pragma Import (C, DosCloseEventSem, "DosCloseEventSem"); - - function DosResetEventSem - (F_hev : HEV; - pulPostCt : PULONG) - return APIRET; - pragma Import (C, DosResetEventSem, "DosResetEventSem"); - - function DosPostEventSem - (F_hev : HEV) - return APIRET; - pragma Import (C, DosPostEventSem, "DosPostEventSem"); - - function DosWaitEventSem - (F_hev : HEV; - ulTimeout : ULONG) - return APIRET; - pragma Import (C, DosWaitEventSem, "DosWaitEventSem"); - - function DosQueryEventSem - (F_hev : HEV; - pulPostCt : PULONG) - return APIRET; - pragma Import (C, DosQueryEventSem, "DosQueryEventSem"); - - -------------- - -- MutexSem -- - -------------- - - function DosCreateMutexSem - (pszName : PSZ; - F_phmtx : PHMTX; - flAttr : ULONG; - fState : BOOL32) - return APIRET; - pragma Import (C, DosCreateMutexSem, "DosCreateMutexSem"); - - function DosOpenMutexSem - (pszName : PSZ; - F_phmtx : PHMTX) - return APIRET; - pragma Import (C, DosOpenMutexSem, "DosOpenMutexSem"); - - function DosCloseMutexSem - (F_hmtx : HMTX) - return APIRET; - pragma Import (C, DosCloseMutexSem, "DosCloseMutexSem"); - - function DosRequestMutexSem - (F_hmtx : HMTX; - ulTimeout : ULONG) - return APIRET; - pragma Import (C, DosRequestMutexSem, "DosRequestMutexSem"); - - function DosReleaseMutexSem - (F_hmtx : HMTX) - return APIRET; - pragma Import (C, DosReleaseMutexSem, "DosReleaseMutexSem"); - - function DosQueryMutexSem - (F_hmtx : HMTX; - F_ppid : IOT.PPID; - F_ptid : IOT.PTID; - pulCount : PULONG) - return APIRET; - pragma Import (C, DosQueryMutexSem, "DosQueryMutexSem"); - - ---------------- - -- MuxWaitSem -- - ---------------- - - function DosCreateMuxWaitSem - (pszName : PSZ; - F_phmux : PHMUX; - cSemRec : ULONG; - pSemRec : PSEMRECORD; - flAttr : ULONG) - return APIRET; - pragma Import (C, DosCreateMuxWaitSem, "DosCreateMuxWaitSem"); - - DCMW_WAIT_ANY : constant := 16#02#; -- wait on any event/mutex to occur - DCMW_WAIT_ALL : constant := 16#04#; -- wait on all events/mutexes to occur - -- Values for "flAttr" parameter in DosCreateMuxWaitSem call - - function DosOpenMuxWaitSem - (pszName : PSZ; - F_phmux : PHMUX) - return APIRET; - pragma Import (C, DosOpenMuxWaitSem, "DosOpenMuxWaitSem"); - - function DosCloseMuxWaitSem - (F_hmux : HMUX) - return APIRET; - pragma Import (C, DosCloseMuxWaitSem, "DosCloseMuxWaitSem"); - - function DosWaitMuxWaitSem - (F_hmux : HMUX; - ulTimeout : ULONG; - pulUser : PULONG) - return APIRET; - pragma Import (C, DosWaitMuxWaitSem, "DosWaitMuxWaitSem"); - - function DosAddMuxWaitSem - (F_hmux : HMUX; - pSemRec : PSEMRECORD) - return APIRET; - pragma Import (C, DosAddMuxWaitSem, "DosAddMuxWaitSem"); - - function DosDeleteMuxWaitSem - (F_hmux : HMUX; - F_hsem : HSEM) - return APIRET; - pragma Import (C, DosDeleteMuxWaitSem, "DosDeleteMuxWaitSem"); - - function DosQueryMuxWaitSem - (F_hmux : HMUX; - pcSemRec : PULONG; - pSemRec : PSEMRECORD; - pflAttr : PULONG) - return APIRET; - pragma Import (C, DosQueryMuxWaitSem, "DosQueryMuxWaitSem"); - - ----------- - -- Timer -- - ----------- - - function DosAsyncTimer - (msec : ULONG; - F_hsem : HSEM; - F_phtimer : PHTIMER) - return APIRET; - pragma Import (C, DosAsyncTimer, "DosAsyncTimer"); - - function DosStartTimer - (msec : ULONG; - F_hsem : HSEM; - F_phtimer : PHTIMER) - return APIRET; - pragma Import (C, DosStartTimer, "DosStartTimer"); - - function DosStopTimer - (F_htimer : HTIMER) - return APIRET; - pragma Import (C, DosStopTimer, "DosStopTimer"); - - -- DosTmrQueryTime provides a snapshot of the time - -- from the IRQ0 high resolution timer (Intel 8254) - - function DosTmrQueryTime - (pqwTmrTime : access QWORD) -- Time in 8254 ticks (1_192_755.2 Hz) - return APIRET; - pragma Import (C, DosTmrQueryTime, "DosTmrQueryTime"); - -end Interfaces.OS2Lib.Synchronization; diff --git a/gcc/ada/i-os2thr.ads b/gcc/ada/i-os2thr.ads deleted file mode 100644 index 97ac453d9fb..00000000000 --- a/gcc/ada/i-os2thr.ads +++ /dev/null @@ -1,193 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . O S 2 L I B . T H R E A D S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1993-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C; - -package Interfaces.OS2Lib.Threads is - pragma Preelaborate; - - package IC renames Interfaces.C; - - type PID is new IC.unsigned_long; - type PPID is access all PID; - -- Process ID, and pointer to process ID - - type TID is new IC.unsigned_long; - type PTID is access all TID; - -- Thread ID, and pointer to thread ID - - ------------------------------------------------------------- - -- Thread Creation, Activation, Suspension And Termination -- - ------------------------------------------------------------- - - -- Note: <bsedos.h> defines the "Informations" and "param" parameter below - -- as a ULONG, but everyone knows that in general an address will be passed - -- to it. We declared it here with type PVOID (which it should have had) - -- because Ada is a bit more sensitive to mixing integers and addresses. - - type PFNTHREAD is access procedure (Informations : System.Address); - -- TBSL should use PVOID instead of Address as per above node ??? - - function DosCreateThread - (F_ptid : PTID; - pfn : PFNTHREAD; - param : PVOID; - flag : ULONG; - cbStack : ULONG) return APIRET; - pragma Import (C, DosCreateThread, "DosCreateThread"); - - Block_Child : constant := 1; - No_Block_Child : constant := 0; - Commit_Stack : constant := 2; - No_Commit_Stack : constant := 0; - -- Values for "flag" parameter in DosCreateThread call - - procedure DosExit (Action : ULONG; Result : ULONG); - pragma Import (C, DosExit, "DosExit"); - - EXIT_THREAD : constant := 0; - EXIT_PROCESS : constant := 1; - -- Values for "Action" parameter in Dos_Exit call - - function DosResumeThread (Id : TID) return APIRET; - pragma Import (C, DosResumeThread, "DosResumeThread"); - - function DosSuspendThread (Id : TID) return APIRET; - pragma Import (C, DosSuspendThread, "DosSuspendThread"); - - procedure DosWaitThread (Thread_Ptr : PTID; Option : ULONG); - pragma Import (C, DosWaitThread, "DosWaitThread"); - - function DosKillThread (Id : TID) return APIRET; - pragma Import (C, DosKillThread, "DosKillThread"); - - DCWW_WAIT : constant := 0; - DCWW_NOWAIT : constant := 1; - -- Values for "Option" parameter in DosWaitThread call - - --------------------------------------------------- - -- Accessing properties of Threads and Processes -- - --------------------------------------------------- - - -- Structures translated from BSETIB.H - - -- Thread Information Block (TIB) - -- Need documentation clarifying distinction between TIB, TIB2 ??? - - -- GB970409: Changed TIB2 structure, because the tib2_ulprio field - -- is not the actual priority but contains two byte fields - -- that hold the priority class and rank respectively. - -- A proper Ada style record with explicit representation - -- avoids this kind of errors. - - type TIB2 is record - Thread_ID : TID; - Prio_Rank : UCHAR; - Prio_Class : UCHAR; - Version : ULONG; -- Version number for this structure - Must_Complete_Count : USHORT; -- Must Complete count - Must_Complete_Force : USHORT; -- Must Complete force flag - end record; - - type PTIB2 is access all TIB2; - - -- Thread Information Block (TIB) - - type TIB is record - tib_pexchain : PVOID; -- Head of exception handler chain - tib_pstack : PVOID; -- Pointer to base of stack - tib_pstacklimit : PVOID; -- Pointer to end of stack - System : PTIB2; -- Pointer to system specific TIB - tib_version : ULONG; -- Version number for this TIB structure - tib_ordinal : ULONG; -- Thread ordinal number - end record; - - type PTIB is access all TIB; - - -- Process Information Block (PIB) - - type PIB is record - pib_ulpid : ULONG; -- Process I.D. - pib_ulppid : ULONG; -- Parent process I.D. - pib_hmte : ULONG; -- Program (.EXE) module handle - pib_pchcmd : PCHAR; -- Command line pointer - pib_pchenv : PCHAR; -- Environment pointer - pib_flstatus : ULONG; -- Process' status bits - pib_ultype : ULONG; -- Process' type code - end record; - - type PPIB is access all PIB; - - function DosGetInfoBlocks - (Pptib : access PTIB; - Pppib : access PPIB) return APIRET; - pragma Import (C, DosGetInfoBlocks, "DosGetInfoBlocks"); - - -- Thread local memory - - -- This function allocates a block of memory that is unique, or local, to - -- a thread. - - function DosAllocThreadLocalMemory - (cb : ULONG; -- Number of 4-byte DWORDs to allocate - p : access PVOID) -- Address of the memory block - return APIRET; -- Return Code (rc) - pragma Import - (Convention => C, - Entity => DosAllocThreadLocalMemory, - Link_Name => "_DosAllocThreadLocalMemory"); - - ---------------- - -- Priorities -- - ---------------- - - function DosSetPriority - (Scope : ULONG; - Class : ULONG; - Delta_P : IC.long; - PorTid : TID) return APIRET; - pragma Import (C, DosSetPriority, "DosSetPriority"); - - PRTYS_PROCESS : constant := 0; - PRTYS_PROCESSTREE : constant := 1; - PRTYS_THREAD : constant := 2; - -- Values for "Scope" parameter in DosSetPriority call - - PRTYC_NOCHANGE : constant := 0; - PRTYC_IDLETIME : constant := 1; - PRTYC_REGULAR : constant := 2; - PRTYC_TIMECRITICAL : constant := 3; - PRTYC_FOREGROUNDSERVER : constant := 4; - -- Values for "class" parameter in DosSetPriority call - -end Interfaces.OS2Lib.Threads; diff --git a/gcc/ada/s-intman-irix-athread.adb b/gcc/ada/s-intman-irix-athread.adb deleted file mode 100644 index 71b20fc6dbd..00000000000 --- a/gcc/ada/s-intman-irix-athread.adb +++ /dev/null @@ -1,163 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT 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) 1991-1994, Florida State University -- --- Copyright (C) 1995-2005, AdaCore -- --- -- --- 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 an Irix (old pthread library) version of this package. - --- 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 - -with Interfaces.C; --- used for "int" - -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! - -- - - Unreserve_All_Interrupts : Interfaces.C.int; - pragma Import - (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); - - function State (Int : Interrupt_ID) return Character; - pragma Import (C, State, "__gnat_get_interrupt_state"); - -- Get interrupt state. Defined in a-init.c - -- The input argument is the interrupt number, - -- and the result is one of the following: - - User : constant Character := 'u'; - Runtime : constant Character := 'r'; - Default : constant Character := 's'; - -- 'n' this interrupt not set by any Interrupt_State pragma - -- 'u' Interrupt_State pragma set state to User - -- 'r' Interrupt_State pragma set state to Runtime - -- 's' Interrupt_State pragma set state to System (use "default" - -- system handler) - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - use Interfaces.C; - begin - Abort_Task_Interrupt := Abort_Signal; - - pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False)); - pragma Assert (Reserve = (Interrupt_ID'Range => False)); - - -- Process state of exception signals - - for J in Exception_Interrupts'Range loop - if State (Exception_Interrupts (J)) /= User then - Keep_Unmasked (Exception_Interrupts (J)) := True; - Reserve (Exception_Interrupts (J)) := True; - end if; - end loop; - - if State (Abort_Task_Interrupt) /= User then - Keep_Unmasked (Abort_Task_Interrupt) := True; - Reserve (Abort_Task_Interrupt) := True; - end if; - - -- Set SIGINT to unmasked state as long as it's - -- not in "User" state. Check for Unreserve_All_Interrupts last - - if State (SIGINT) /= User then - Keep_Unmasked (SIGINT) := True; - end if; - - -- Check all signals for state that requires keeping them - -- unmasked and reserved - - for J in Interrupt_ID'Range loop - if State (J) = Default or else State (J) = Runtime then - Keep_Unmasked (J) := True; - Reserve (J) := True; - end if; - end loop; - - -- Add target-specific reserved signals - - for J in Reserved_Interrupts'Range loop - Reserve (Interrupt_ID (Reserved_Interrupts (J))) := True; - end loop; - - -- Process pragma Unreserve_All_Interrupts. This overrides any - -- settings due to pragma Interrupt_State: - - if Unreserve_All_Interrupts /= 0 then - Keep_Unmasked (SIGINT) := False; - Reserve (SIGINT) := False; - end if; - - -- 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 Initialize; - -end System.Interrupt_Management; diff --git a/gcc/ada/s-osinte-aix-fsu.ads b/gcc/ada/s-osinte-aix-fsu.ads deleted file mode 100644 index 72e251a56f5..00000000000 --- a/gcc/ada/s-osinte-aix-fsu.ads +++ /dev/null @@ -1,589 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ I N T E R F A C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 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 --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -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; - - SA_SIGINFO : constant := 16#0100#; - - 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; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 1; - - ----------- - -- 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/s-osinte-fsu.adb b/gcc/ada/s-osinte-fsu.adb deleted file mode 100644 index f5ebf934326..00000000000 --- a/gcc/ada/s-osinte-fsu.adb +++ /dev/null @@ -1,366 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ I N T E R F A C E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2005, AdaCore -- --- -- --- 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 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 cannot 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/s-osinte-irix-athread.ads b/gcc/ada/s-osinte-irix-athread.ads deleted file mode 100644 index b8d65a81f80..00000000000 --- a/gcc/ada/s-osinte-irix-athread.ads +++ /dev/null @@ -1,699 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ I N T E R F A C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 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 --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces; -with Interfaces.C; -with Interfaces.C.Strings; -with Unchecked_Conversion; - -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; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - 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/s-osinte-linux-fsu.ads b/gcc/ada/s-osinte-linux-fsu.ads deleted file mode 100644 index 5d54315b280..00000000000 --- a/gcc/ada/s-osinte-linux-fsu.ads +++ /dev/null @@ -1,599 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ I N T E R F A C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 GNU/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 --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -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 (GNU/Linux) - SIGSTKFLT : constant := 16; -- coprocessor stack fault (GNU/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; - - SA_SIGINFO : constant := 16#04#; - - 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; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 1; - - ----------- - -- 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/s-osinte-os2.adb b/gcc/ada/s-osinte-os2.adb deleted file mode 100644 index 63c48dee386..00000000000 --- a/gcc/ada/s-osinte-os2.adb +++ /dev/null @@ -1,120 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ I N T E R F A C E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2005, AdaCore -- --- -- --- 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 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.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; - - ----------- - -- 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; - -end System.OS_Interface; diff --git a/gcc/ada/s-osinte-os2.ads b/gcc/ada/s-osinte-os2.ads deleted file mode 100644 index 6b32b5d610b..00000000000 --- a/gcc/ada/s-osinte-os2.ads +++ /dev/null @@ -1,125 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ I N T E R F A C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 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. This package 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/s-osinte-solaris-fsu.ads b/gcc/ada/s-osinte-solaris-fsu.ads deleted file mode 100644 index 86f3ac989cd..00000000000 --- a/gcc/ada/s-osinte-solaris-fsu.ads +++ /dev/null @@ -1,667 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ I N T E R F A C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 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 --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -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) - SIGRTMIN : constant := 38; -- first (highest-priority) realtime signal - SIGRTMAX : constant := 45; -- last (lowest-priority) realtime signal - - 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, SIGRTMAX); - - 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; - - SA_SIGINFO : constant := 16#08#; - - 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; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 1; - - ----------- - -- 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/s-osinte-unixware.adb b/gcc/ada/s-osinte-unixware.adb deleted file mode 100644 index d3f228efde6..00000000000 --- a/gcc/ada/s-osinte-unixware.adb +++ /dev/null @@ -1,182 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ I N T E R F A C E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2005 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 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 - pragma Warnings (Off, clock_id); - - 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 - pragma Warnings (Off, thread); - - 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/s-osinte-unixware.ads b/gcc/ada/s-osinte-unixware.ads deleted file mode 100644 index fda940f7dc4..00000000000 --- a/gcc/ada/s-osinte-unixware.ads +++ /dev/null @@ -1,600 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ I N T E R F A C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 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 --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -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; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 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/s-osprim-os2.adb b/gcc/ada/s-osprim-os2.adb deleted file mode 100644 index b8863f65dad..00000000000 --- a/gcc/ada/s-osprim-os2.adb +++ /dev/null @@ -1,184 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT 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 -- --- -- --- Copyright (C) 1998-2005 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 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; - - ---------------- - -- Initialize -- - ---------------- - - Initialized : Boolean := False; - - procedure Initialize is - begin - if not Initialized then - Initialized := True; - Set_Epoch_Offset; - end if; - end Initialize; - -end System.OS_Primitives; diff --git a/gcc/ada/s-parame-os2.adb b/gcc/ada/s-parame-os2.adb deleted file mode 100644 index 8925897e4e5..00000000000 --- a/gcc/ada/s-parame-os2.adb +++ /dev/null @@ -1,83 +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) 1997-2002 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 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/s-taprop-irix-athread.adb b/gcc/ada/s-taprop-irix-athread.adb deleted file mode 100644 index 43c0fa6380f..00000000000 --- a/gcc/ada/s-taprop-irix-athread.adb +++ /dev/null @@ -1,1110 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 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.Interrupt_Management; --- used for Keep_Unmasked --- Abort_Task_Interrupt --- Interrupt_ID - -with System.OS_Primitives; --- used for Delay_Modes - -with System.Task_Info; - -with System.Parameters; --- used for Size_Type - -with System.Program_Info; --- used for Default_Task_Stack --- Default_Time_Slice --- Stack_Guard_Pages --- Pthread_Sched_Signal --- Pthread_Arena_Size - -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; - - ----------------- - -- 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"); - - 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 - pragma Unreferenced (T); - pragma Unreferenced (On); - begin - null; - end Stack_Guard; - - -------------------- - -- Get_Thread_Id -- - -------------------- - - function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is - begin - return T.Common.LL.Thread; - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_Id 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 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); - - 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 - pragma Unreferenced (Level); - - 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; 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 : ST.Task_Id; - Reason : System.Tasking.Task_States) - is - pragma Unreferenced (Reason); - - Result : Interfaces.C.int; - - begin - if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; - - -- EINTR is not considered a failure. - - pragma Assert (Result = 0 or else Result = EINTR); - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - procedure Timed_Sleep - (Self_ID : Task_Id; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : System.Tasking.Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - pragma Unreferenced (Reason); - - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Request : aliased 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; - - 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 - or else (Result = -1 and then errno = EAGAIN)); - end loop; - end if; - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Self_ID : Task_Id; - Time : Duration; - Mode : ST.Delay_Modes) - is - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Request : aliased struct_timeval; - Result : Interfaces.C.int; - - begin - if Single_Lock then - Lock_RTS; - end if; - - 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; - - 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 = -1 and then errno = EAGAIN) or else - Result = EINTR); - end loop; - - Self_ID.Common.State := Runnable; - end if; - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - pthread_yield; - 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 - pragma Unreferenced (Reason); - Result : Interfaces.C.int; - begin - Result := pthread_cond_signal (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Wakeup; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - 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 - pragma Unreferenced (Loss_Of_Inheritance); - - 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_RTS; - - for J in Known_Tasks'Range loop - if Known_Tasks (J) = null then - Known_Tasks (J) := Self_ID; - Self_ID.Known_Tasks_Index := J; - exit; - end if; - end loop; - - Unlock_RTS; - end Enter_Task; - - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean is - begin - return False; - end Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_Id is - begin - return null; - end Register_Foreign_Thread; - - -------------------- - -- Initialize_TCB -- - -------------------- - - procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is - Result : Interfaces.C.int; - Cond_Attr : aliased pthread_condattr_t; - - begin - if not Single_Lock then - Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); - 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, 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 - 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 - Result : Interfaces.C.int; - begin - Result := pthread_set_ada_tcb (pthread_self, System.Null_Address); - pragma Assert (Result = 0); - 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; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (S : in out Suspension_Object) is - Mutex_Attr : aliased pthread_mutexattr_t; - Cond_Attr : aliased pthread_condattr_t; - Result : Interfaces.C.int; - begin - -- Initialize internal state. It is always initialized to False (ARM - -- D.10 par. 6). - - S.State := False; - S.Waiting := False; - - -- Initialize internal mutex - - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - - -- Initialize internal condition variable - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - if Result = ENOMEM then - raise Storage_Error; - end if; - end if; - - Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - if Result = ENOMEM then - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - - raise Storage_Error; - end if; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (S : in out Suspension_Object) is - Result : Interfaces.C.int; - begin - -- Destroy internal mutex - - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - -- Destroy internal condition variable - - Result := pthread_cond_destroy (S.CV'Access); - pragma Assert (Result = 0); - end Finalize; - - ------------------- - -- Current_State -- - ------------------- - - function Current_State (S : Suspension_Object) return Boolean is - begin - -- We do not want to use lock on this read operation. State is marked - -- as Atomic so that we ensure that the value retrieved is correct. - - return S.State; - end Current_State; - - --------------- - -- Set_False -- - --------------- - - procedure Set_False (S : in out Suspension_Object) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - S.State := False; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - end Set_False; - - -------------- - -- Set_True -- - -------------- - - procedure Set_True (S : in out Suspension_Object) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - -- If there is already a task waiting on this suspension object then - -- we resume it, leaving the state of the suspension object to False, - -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves - -- the state to True. - - if S.Waiting then - S.Waiting := False; - S.State := False; - - Result := pthread_cond_signal (S.CV'Access); - pragma Assert (Result = 0); - else - S.State := True; - end if; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - end Set_True; - - ------------------------ - -- Suspend_Until_True -- - ------------------------ - - procedure Suspend_Until_True (S : in out Suspension_Object) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - if S.Waiting then - -- Program_Error must be raised upon calling Suspend_Until_True - -- if another task is already waiting on that suspension object - -- (ARM D.10 par. 10). - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - raise Program_Error; - else - -- Suspend the task if the state is False. Otherwise, the task - -- continues its execution, and the state of the suspension object - -- is set to False (ARM D.10 par. 9). - - if S.State then - S.State := False; - else - S.Waiting := True; - Result := pthread_cond_wait (S.CV'Access, S.L'Access); - end if; - end if; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - end Suspend_Until_True; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy version - - function Check_Exit (Self_ID : ST.Task_Id) return Boolean is - pragma Unreferenced (Self_ID); - begin - return True; - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is - pragma Unreferenced (Self_ID); - begin - return True; - end Check_No_Locks; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_Id is - begin - return Environment_Task_Id; - end Environment_Task; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_Id; - Thread_Self : Thread_Id) return Boolean - is - 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 - Initialize_Athread_Library; - Environment_Task_Id := Environment_Task; - Interrupt_Management.Initialize; - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_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; - - -------------------------------- - -- Initialize_Athread_Library -- - -------------------------------- - - 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; - -end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-os2.adb b/gcc/ada/s-taprop-os2.adb deleted file mode 100644 index 0455b404c86..00000000000 --- a/gcc/ada/s-taprop-os2.adb +++ /dev/null @@ -1,1274 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 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 System.OS_Primitives; --- used for Delay_Modes --- Clock - -with Interfaces.OS2Lib.Errors; -with Interfaces.OS2Lib.Threads; -with Interfaces.OS2Lib.Synchronization; - -with Interfaces.C; --- used for size_t - -with Interfaces.C.Strings; --- used for Null_Ptr - -with System.Parameters; --- used for Size_Type - -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; - - use Interfaces.OS2Lib; - use Interfaces.OS2Lib.Errors; - use Interfaces.OS2Lib.Threads; - use Interfaces.OS2Lib.Synchronization; - use System.Parameters; - 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 -- - ----------------- - - 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; - - 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 - - ----------------------- - -- 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 - pragma Unreferenced (T); - pragma Unreferenced (On); - 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 - pragma Unreferenced (Level); - - 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; - Global_Lock : Boolean := False) - is - Self_ID : Task_Id; - Old_Priority : Any_Priority; - - begin - if not Single_Lock or else Global_Lock then - Self_ID := Thread_Local_Data_Ptr.Self_ID; - Old_Priority := Self_ID.Common.LL.Current_Priority; - - -- 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 if; - end Write_Lock; - - procedure Write_Lock (T : Task_Id) is - begin - if not Single_Lock then - - -- 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 if; - 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; Global_Lock : Boolean := False) is - Self_ID : Task_Id; - Old_Priority : Any_Priority; - - begin - if not Single_Lock or else Global_Lock then - Self_ID := Thread_Local_Data_Ptr.Self_ID; - Old_Priority := L.Owner_Priority; - -- 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 if; - end Unlock; - - procedure Unlock (T : Task_Id) is - begin - if not Single_Lock then - - -- 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 if; - end Unlock; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep - (Self_ID : Task_Id; - Reason : System.Tasking.Task_States) - is - pragma Unreferenced (Reason); - - 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)); - - if Single_Lock then - Unlock_RTS; - else - Unlock (Self_ID); - end if; - - -- 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 - - if Single_Lock then - Lock_RTS; - else - Write_Lock (Self_ID); - 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. - - -- 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 - pragma Unreferenced (Reason); - - 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)); - - if Single_Lock then - Unlock_RTS; - else - Unlock (Self_ID); - end if; - - 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 - - if Single_Lock then - Lock_RTS; - else - Write_Lock (Self_ID); - end if; - - 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 - if Single_Lock then - Lock_RTS; - else - Write_Lock (Self_ID); - end if; - - -- Must reset Cond BEFORE Self_ID is unlocked - - Sem_Must_Not_Fail - (DosResetEventSem (Self_ID.Common.LL.CV, - Count'Unchecked_Access)); - - if Single_Lock then - Unlock_RTS; - else - Unlock (Self_ID); - end if; - - 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; - - if Single_Lock then - Lock_RTS; - else - Write_Lock (Self_ID); - end if; - - if Timedout then - Sem_Must_Not_Fail (DosPostEventSem (Self_ID.Common.LL.CV)); - end if; - - if Single_Lock then - Unlock_RTS; - else - Unlock (Self_ID); - end if; - - System.OS_Interface.Yield; - end Timed_Delay; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is - pragma Unreferenced (Reason); - 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 - pragma Unreferenced (Loss_Of_Inheritance); - 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_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; - - -- 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 ??? - end Enter_Task; - - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean is - begin - return False; - end Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_Id is - begin - return null; - end Register_Foreign_Thread; - - -------------------- - -- 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 not Single_Lock - and then 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; - - -- 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 an 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)); - - if not Single_Lock then - Finalize_Lock (T.Common.LL.L'Unchecked_Access); - end if; - - 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 - Thread_Local_Data_Ptr := null; - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_Id) is - pragma Unreferenced (T); - - begin - null; - - -- Task abort not implemented yet. - -- Should perform other action ??? - - end Abort_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (S : in out Suspension_Object) is - Result : Interfaces.C.int; - begin - -- Initialize internal state. It is always initialized to False (ARM - -- D.10 par. 6). - - S.State := False; - S.Waiting := False; - - -- Initialize internal mutex - if DosCreateMutexSem - (ICS.Null_Ptr, S.L'Unchecked_Access, 0, False32) /= NO_ERROR - then - raise Storage_Error; - end if; - - pragma Assert (S.L /= 0, "Error creating Mutex"); - - -- Initialize internal condition variable - - if DosCreateEventSem - (ICS.Null_Ptr, S.CV'Unchecked_Access, 0, True32) /= NO_ERROR - then - Must_Not_Fail (DosCloseMutexSem (S.L)); - - raise Storage_Error; - end if; - - pragma Assert (S.CV /= 0, "Error creating Condition Variable"); - end Initialize; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (S : in out Suspension_Object) is - begin - -- Destroy internal mutex - - Must_Not_Fail (DosCloseMutexSem (S.L'Access)); - - -- Destroy internal condition variable - - Must_Not_Fail (DosCloseEventSem (S.CV'Access)); - end Finalize; - - ------------------- - -- Current_State -- - ------------------- - - function Current_State (S : Suspension_Object) return Boolean is - begin - -- We do not want to use lock on this read operation. State is marked - -- as Atomic so that we ensure that the value retrieved is correct. - - return S.State; - end Current_State; - - --------------- - -- Set_False -- - --------------- - - procedure Set_False (S : in out Suspension_Object) is - begin - Must_Not_Fail (DosRequestMutexSem (S.L, SEM_INDEFINITE_WAIT)); - - S.State := False; - - Must_Not_Fail (DosReleaseMutexSem (S.L)); - end Set_False; - - -------------- - -- Set_True -- - -------------- - - procedure Set_True (S : in out Suspension_Object) is - begin - Must_Not_Fail (DosRequestMutexSem (S.L, SEM_INDEFINITE_WAIT)); - - -- If there is already a task waiting on this suspension object then - -- we resume it, leaving the state of the suspension object to False, - -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves - -- the state to True. - - if S.Waiting then - S.Waiting := False; - S.State := False; - - Sem_Must_Not_Fail (DosPostEventSem (S.CV)); - else - S.State := True; - end if; - - Must_Not_Fail (DosReleaseMutexSem (S.L)); - end Set_True; - - ------------------------ - -- Suspend_Until_True -- - ------------------------ - - procedure Suspend_Until_True (S : in out Suspension_Object) is - Count : aliased ULONG; -- Used to store dummy result - begin - Must_Not_Fail (DosRequestMutexSem (S.L, SEM_INDEFINITE_WAIT)); - - if S.Waiting then - -- Program_Error must be raised upon calling Suspend_Until_True - -- if another task is already waiting on that suspension object - -- (ARM D.10 par. 10). - - Must_Not_Fail (DosReleaseMutexSem (S.L)); - - raise Program_Error; - else - -- Suspend the task if the state is False. Otherwise, the task - -- continues its execution, and the state of the suspension object - -- is set to False (ARM D.10 par. 9). - - if S.State then - S.State := False; - - Must_Not_Fail (DosReleaseMutexSem (S.L)); - else - S.Waiting := True; - - -- Must reset Cond BEFORE L is unlocked - - Sem_Must_Not_Fail - (DosResetEventSem (S.CV, Count'Unchecked_Access)); - - Must_Not_Fail (DosReleaseMutexSem (S.L)); - - Sem_Must_Not_Fail - (DosWaitEventSem (S.CV, SEM_INDEFINITE_WAIT)); - end if; - end if; - end Suspend_Until_True; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy version - - 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_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 - 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; - - OS_Primitives.Initialize; - - -- 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; - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_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; - -end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-tasinf-irix-athread.adb b/gcc/ada/s-tasinf-irix-athread.adb deleted file mode 100644 index 8f4fbc8df8b..00000000000 --- a/gcc/ada/s-tasinf-irix-athread.adb +++ /dev/null @@ -1,312 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T A S K _ I N F O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2004 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 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); - - ------------------------------- - -- Resource_Vector_Functions -- - ------------------------------- - - 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; - - --------------- - -- New_Sproc -- - --------------- - - 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 - --- ??? why is this commented out, should it be removed ? --- 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; - - --------------- - -- 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 : constant Sproc_Attributes := - (Sproc_Resources, CPU, Resident, NDPRI); - begin - return New_Sproc (Attr); - end New_Sproc; - - ------------------------------- - -- Unbound_Thread_Attributes -- - ------------------------------- - - 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; - - ----------------------------- - -- Bound_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; - - ----------------------------- - -- 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 : constant sproc_t := New_Sproc - (Sproc_Resources, CPU, Resident, NDPRI); - begin - return (True, Thread_Resources, Thread_Timeslice, Sproc); - end Bound_Thread_Attributes; - - ----------------------------------- - -- New_Unbound_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; - - --------------------------------- - -- New_Bound_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; - - --------------------------------- - -- 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 : constant 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/s-tasinf-irix-athread.ads b/gcc/ada/s-tasinf-irix-athread.ads deleted file mode 100644 index 96a709d8190..00000000000 --- a/gcc/ada/s-tasinf-irix-athread.ads +++ /dev/null @@ -1,274 +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-2005 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 and use 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. - --- This unit may be used directly from an application program by providing --- an appropriate WITH, and the interface can be expected to remain stable. - --- This is the SGI (libathread) specific version of this module - -with System.OS_Interface; - -package System.Task_Info is - pragma Preelaborate; - 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 : Resource_T; - 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 : Resource_Vector_T; - 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; - - type Non_Degrading_Priority is range 0 .. 255; - -- 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. - - NDPHIMAX : constant Non_Degrading_Priority := 30; - NDPHIMIN : constant Non_Degrading_Priority := 39; - -- These priorities are higher than ALL normal user process priorities - - subtype NDP_High is Non_Degrading_Priority range NDPHIMAX .. NDPHIMIN; - - NDPNORMMAX : constant Non_Degrading_Priority := 40; - NDPNORMMIN : constant Non_Degrading_Priority := 127; - -- These priorities overlap normal user process priorities - - subtype NDP_Norm is Non_Degrading_Priority range NDPNORMMAX .. NDPNORMMIN; - - NDPLOMAX : constant Non_Degrading_Priority := 128; - NDPLOMIN : constant Non_Degrading_Priority := 254; - -- These priorities are below ALL normal user process priorities - - 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; --- ??? why is that commented out, should it be removed ? --- 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 control structure and creates 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; - - Unspecified_Task_Info : constant Task_Info_Type := null; - -end System.Task_Info; diff --git a/gcc/ada/s-taspri-os2.ads b/gcc/ada/s-taspri-os2.ads deleted file mode 100644 index 502260e96d2..00000000000 --- a/gcc/ada/s-taspri-os2.ads +++ /dev/null @@ -1,122 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2005, AdaCore -- --- -- --- 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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 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 Suspension_Object is record - State : Boolean; - pragma Atomic (State); - -- Boolean that indicates whether the object is open. This field is - -- marked Atomic to ensure that we can read its value without locking - -- the access to the Suspension_Object. - - Waiting : Boolean; - -- Flag showing if there is a task already suspended on this object - - L : aliased Interfaces.OS2Lib.Synchronization.HMTX; - -- Protection for ensuring mutual exclusion on the Suspension_Object - - CV : aliased Interfaces.OS2Lib.Synchronization.HEV; - -- Condition variable used to queue threads until condition is signaled - end record; - - 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 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/system-os2.ads b/gcc/ada/system-os2.ads deleted file mode 100644 index 65c9461c050..00000000000 --- a/gcc/ada/system-os2.ads +++ /dev/null @@ -1,153 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (OS/2 Version) -- --- -- --- Copyright (C) 1992-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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. -- --- -- ------------------------------------------------------------------------------- - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; - - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := 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 := 0.01; - - -- 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; - Compiler_System_Version : constant Boolean := False; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - Functions_Return_By_DSP : constant Boolean := False; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - OpenVMS : constant Boolean := False; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := False; - Support_64_Bit_Divides : constant Boolean := True; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Suppress_Standard_Library : 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; - - -- Obsolete entries, to be removed eventually (bootstrap issues!) - - High_Integrity_Mode : constant Boolean := False; - Long_Shifts_Inlined : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-unixware.ads b/gcc/ada/system-unixware.ads deleted file mode 100644 index 801968d5141..00000000000 --- a/gcc/ada/system-unixware.ads +++ /dev/null @@ -1,153 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (SCO UnixWare Version) -- --- -- --- Copyright (C) 1992-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU 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. -- --- -- ------------------------------------------------------------------------------- - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; - - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := 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 := 0.01; - - -- 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; - Compiler_System_Version : constant Boolean := False; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - Functions_Return_By_DSP : constant Boolean := False; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - OpenVMS : constant Boolean := False; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := False; - Support_64_Bit_Divides : constant Boolean := True; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Suppress_Standard_Library : 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; - - -- Obsolete entries, to be removed eventually (bootstrap issues!) - - High_Integrity_Mode : constant Boolean := False; - Long_Shifts_Inlined : constant Boolean := True; - -end System; |