+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . P A R A M E T E R S --
--- --
--- B o d y --
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
projects / gcc.git / commitdiff