Skip to content

R
riscv-gcc-1
Commit ed50c9d2 by Arnaud Charlet
Options

a-intnam-os2.ads, [...]: Removed, no longer used. 

	* 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.

From-SVN: r111021
parent 5b4fdb20
Showing with 0 additions and 9510 deletions
gcc/ada/a-intnam-os2.ads deleted 100644 → 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;
gcc/ada/a-intnam-unixware.ads deleted 100644 → 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;
gcc/ada/g-soccon-unixware.ads deleted 100644 → 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;
gcc/ada/g-soliop-unixware.ads deleted 100644 → 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;
gcc/ada/i-os2err.ads deleted 100644 → 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;
gcc/ada/i-os2lib.adb deleted 100644 → 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;
gcc/ada/i-os2lib.ads deleted 100644 → 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;
gcc/ada/i-os2syn.ads deleted 100644 → 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;
gcc/ada/i-os2thr.ads deleted 100644 → 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;
gcc/ada/s-intman-irix-athread.adb deleted 100644 → 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;
gcc/ada/s-osinte-aix-fsu.ads deleted 100644 → 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;
gcc/ada/s-osinte-fsu.adb deleted 100644 → 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;
gcc/ada/s-osinte-irix-athread.ads deleted 100644 → 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;
gcc/ada/s-osinte-linux-fsu.ads deleted 100644 → 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;
gcc/ada/s-osinte-os2.adb deleted 100644 → 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;
gcc/ada/s-osinte-os2.ads deleted 100644 → 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;
gcc/ada/s-osinte-solaris-fsu.ads deleted 100644 → 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;
gcc/ada/s-osinte-unixware.adb deleted 100644 → 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;
gcc/ada/s-osinte-unixware.ads deleted 100644 → 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;
gcc/ada/s-osprim-os2.adb deleted 100644 → 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;
gcc/ada/s-parame-os2.adb deleted 100644 → 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;
gcc/ada/s-taprop-irix-athread.adb deleted 100644 → 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;
gcc/ada/s-taprop-os2.adb deleted 100644 → 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;
gcc/ada/s-tasinf-irix-athread.adb deleted 100644 → 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;
gcc/ada/s-tasinf-irix-athread.ads deleted 100644 → 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;
gcc/ada/s-taspri-os2.ads deleted 100644 → 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;
gcc/ada/system-os2.ads deleted 100644 → 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;
gcc/ada/system-unixware.ads deleted 100644 → 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;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment