--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- A D A . E X C E P T I O N S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package body Ada.Exceptions is
+
+ procedure Last_Chance_Handler (Msg : System.Address; Line : Integer);
+ pragma Import (C, Last_Chance_Handler, "__gnat_last_chance_handler");
+ pragma No_Return (Last_Chance_Handler);
+
+ ---------------------
+ -- Raise_Exception --
+ ---------------------
+
+ procedure Raise_Exception (E : Exception_Id; Message : String := "") is
+ begin
+ Last_Chance_Handler (Message'Address, 0);
+ end Raise_Exception;
+
+end Ada.Exceptions;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . E X C E P T I O N S --
+-- (Version for No Exception Handlers) --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for use when the restriction No_Exception_Handlers
+-- is enabled.
+
+with System;
+
+package Ada.Exceptions is
+
+ type Exception_Id is private;
+
+ Null_Id : constant Exception_Id;
+
+ procedure Raise_Exception (E : Exception_Id; Message : String := "");
+ -- Unconditionally call __gnat_last_chance_handler.
+ -- Message should be a null terminated string.
+ pragma No_Return (Raise_Exception);
+
+private
+
+ ------------------
+ -- Exception_Id --
+ ------------------
+
+ type Exception_Id is new System.Address;
+ Null_Id : constant Exception_Id := Exception_Id (System.Null_Address);
+
+ pragma Inline_Always (Raise_Exception);
+
+end Ada.Exceptions;
--- /dev/null
+-----------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- I N T E R F A C E S . C --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT Hi Integrity Edition. In accordance with the copyright of that --
+-- document, you can freely copy and modify this specification, provided --
+-- that if you redistribute a modified version, any changes that you have --
+-- made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version contains only the type definitions for standard interfacing
+-- with C. All functions have been removed from the original spec.
+
+package Interfaces.C is
+pragma Pure (C);
+
+ -- Declaration's based on C's <limits.h>
+
+ CHAR_BIT : constant := 8;
+ SCHAR_MIN : constant := -128;
+ SCHAR_MAX : constant := 127;
+ UCHAR_MAX : constant := 255;
+
+ -- Signed and Unsigned Integers. Note that in GNAT, we have ensured that
+ -- the standard predefined Ada types correspond to the standard C types
+
+ type int is new Integer;
+ type short is new Short_Integer;
+ type long is new Long_Integer;
+
+ type signed_char is range SCHAR_MIN .. SCHAR_MAX;
+ for signed_char'Size use CHAR_BIT;
+
+ type unsigned is mod 2 ** int'Size;
+ type unsigned_short is mod 2 ** short'Size;
+ type unsigned_long is mod 2 ** long'Size;
+
+ type unsigned_char is mod (UCHAR_MAX + 1);
+ for unsigned_char'Size use CHAR_BIT;
+
+ subtype plain_char is unsigned_char;
+
+ type ptrdiff_t is
+ range -(2 ** (Standard'Address_Size - 1)) ..
+ +(2 ** (Standard'Address_Size - 1) - 1);
+
+ type size_t is mod 2 ** Standard'Address_Size;
+
+ -- Floating-Point
+
+ type C_float is new Float;
+ type double is new Standard.Long_Float;
+ type long_double is new Standard.Long_Long_Float;
+
+ ----------------------------
+ -- Characters and Strings --
+ ----------------------------
+
+ type char is new Character;
+
+ nul : constant char := char'First;
+
+ type char_array is array (size_t range <>) of aliased char;
+ for char_array'Component_Size use CHAR_BIT;
+
+ ------------------------------------
+ -- Wide Character and Wide String --
+ ------------------------------------
+
+ type wchar_t is new Wide_Character;
+ for wchar_t'Size use Standard'Wchar_T_Size;
+
+ wide_nul : constant wchar_t := wchar_t'First;
+
+ type wchar_array is array (size_t range <>) of aliased wchar_t;
+
+end Interfaces.C;
--- /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 --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the version for UnixWare
+
+package GNAT.Sockets.Constants is
+
+ -- Families
+
+ AF_INET : constant := 2;
+ AF_INET6 : constant := 27;
+
+ -- Modes
+
+ SOCK_STREAM : constant := 2;
+ SOCK_DGRAM : constant := 1;
+
+ -- Socket Errors
+
+ EBADF : constant := 9;
+ ENOTSOCK : constant := 95;
+ ENOTCONN : constant := 134;
+ ENOBUFS : constant := 132;
+ EOPNOTSUPP : constant := 122;
+ EFAULT : constant := 14;
+ EWOULDBLOCK : constant := 11;
+ EADDRNOTAVAIL : constant := 126;
+ EMSGSIZE : constant := 97;
+ EADDRINUSE : constant := 125;
+ EINVAL : constant := 22;
+ EACCES : constant := 13;
+ EAFNOSUPPORT : constant := 124;
+ EISCONN : constant := 133;
+ ETIMEDOUT : constant := 145;
+ ECONNREFUSED : constant := 146;
+ ENETUNREACH : constant := 128;
+ EALREADY : constant := 149;
+ EINPROGRESS : constant := 150;
+ ENOPROTOOPT : constant := 99;
+ EPROTONOSUPPORT : constant := 120;
+ EINTR : constant := 4;
+ EIO : constant := 5;
+ ESOCKTNOSUPPORT : constant := 121;
+
+ -- Host Errors
+
+ HOST_NOT_FOUND : constant := 1;
+ TRY_AGAIN : constant := 2;
+ NO_ADDRESS : constant := 4;
+ NO_RECOVERY : constant := 3;
+
+ -- Control Flags
+
+ FIONBIO : constant := -2147195266;
+ FIONREAD : constant := 1074030207;
+
+ -- Shutdown Modes
+
+ SHUT_RD : constant := 0;
+ SHUT_WR : constant := 1;
+ SHUT_RDWR : constant := 2;
+
+ -- Protocol Levels
+
+ SOL_SOCKET : constant := 65535;
+ IPPROTO_IP : constant := 0;
+ IPPROTO_UDP : constant := 17;
+ IPPROTO_TCP : constant := 6;
+
+ -- Socket Options
+
+ TCP_NODELAY : constant := 1;
+ SO_SNDBUF : constant := 4097;
+ SO_RCVBUF : constant := 4098;
+ SO_REUSEADDR : constant := 4;
+ SO_KEEPALIVE : constant := 8;
+ SO_LINGER : constant := 128;
+ SO_ERROR : constant := 4103;
+ SO_BROADCAST : constant := 32;
+ IP_ADD_MEMBERSHIP : constant := 11;
+ IP_DROP_MEMBERSHIP : constant := 12;
+ IP_MULTICAST_TTL : constant := 16;
+ IP_MULTICAST_LOOP : constant := 10;
+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 --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package GNAT.Sockets.Linker_Options is
+
+ -- This is the UnixWare version of this package.
+
+private
+
+ pragma Linker_Options ("-lnsl");
+ pragma Linker_Options ("-lsocket");
+
+end GNAT.Sockets.Linker_Options;
--- /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 --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the version for OSF
+
+package GNAT.Sockets.Constants is
+
+ -- Families
+
+ AF_INET : constant := 2;
+ AF_INET6 : constant := 26;
+
+ -- Modes
+
+ SOCK_STREAM : constant := 1;
+ SOCK_DGRAM : constant := 2;
+
+ -- Socket Errors
+
+ EBADF : constant := 9;
+ ENOTSOCK : constant := 38;
+ ENOTCONN : constant := 57;
+ ENOBUFS : constant := 55;
+ EOPNOTSUPP : constant := 45;
+ EFAULT : constant := 14;
+ EWOULDBLOCK : constant := 35;
+ EADDRNOTAVAIL : constant := 49;
+ EMSGSIZE : constant := 40;
+ EADDRINUSE : constant := 48;
+ EINVAL : constant := 22;
+ EACCES : constant := 13;
+ EAFNOSUPPORT : constant := 47;
+ EISCONN : constant := 56;
+ ETIMEDOUT : constant := 60;
+ ECONNREFUSED : constant := 61;
+ ENETUNREACH : constant := 51;
+ EALREADY : constant := 37;
+ EINPROGRESS : constant := 36;
+ ENOPROTOOPT : constant := 42;
+ EPROTONOSUPPORT : constant := 43;
+ EINTR : constant := 4;
+ EIO : constant := 5;
+ ESOCKTNOSUPPORT : constant := 44;
+
+ -- Host Errors
+
+ HOST_NOT_FOUND : constant := 1;
+ TRY_AGAIN : constant := 2;
+ NO_ADDRESS : constant := 4;
+ NO_RECOVERY : constant := 3;
+
+ -- Control Flags
+
+ FIONBIO : constant := -2147195266;
+ FIONREAD : constant := 1074030207;
+
+ -- Shutdown Modes
+
+ SHUT_RD : constant := 0;
+ SHUT_WR : constant := 1;
+ SHUT_RDWR : constant := 2;
+
+ -- Protocol Levels
+
+ SOL_SOCKET : constant := 65535;
+ IPPROTO_IP : constant := 0;
+ IPPROTO_UDP : constant := 17;
+ IPPROTO_TCP : constant := 6;
+
+ -- Socket Options
+
+ TCP_NODELAY : constant := 1;
+ SO_SNDBUF : constant := 4097;
+ SO_RCVBUF : constant := 4098;
+ SO_REUSEADDR : constant := 4;
+ SO_KEEPALIVE : constant := 8;
+ SO_LINGER : constant := 128;
+ SO_ERROR : constant := 4103;
+ SO_BROADCAST : constant := 32;
+ IP_ADD_MEMBERSHIP : constant := 12;
+ IP_DROP_MEMBERSHIP : constant := 13;
+ IP_MULTICAST_TTL : constant := 10;
+ IP_MULTICAST_LOOP : constant := 11;
+end GNAT.Sockets.Constants;
--- /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 --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the version for AIX
+
+package GNAT.Sockets.Constants is
+
+ -- Families
+
+ AF_INET : constant := 2;
+ AF_INET6 : constant := 24;
+
+ -- Modes
+
+ SOCK_STREAM : constant := 1;
+ SOCK_DGRAM : constant := 2;
+
+ -- Socket Errors
+
+ EBADF : constant := 9;
+ ENOTSOCK : constant := 57;
+ ENOTCONN : constant := 76;
+ ENOBUFS : constant := 74;
+ EOPNOTSUPP : constant := 64;
+ EFAULT : constant := 14;
+ EWOULDBLOCK : constant := 11;
+ EADDRNOTAVAIL : constant := 68;
+ EMSGSIZE : constant := 59;
+ EADDRINUSE : constant := 67;
+ EINVAL : constant := 22;
+ EACCES : constant := 13;
+ EAFNOSUPPORT : constant := 66;
+ EISCONN : constant := 75;
+ ETIMEDOUT : constant := 78;
+ ECONNREFUSED : constant := 79;
+ ENETUNREACH : constant := 70;
+ EALREADY : constant := 56;
+ EINPROGRESS : constant := 55;
+ ENOPROTOOPT : constant := 61;
+ EPROTONOSUPPORT : constant := 62;
+ EINTR : constant := 4;
+ EIO : constant := 5;
+ ESOCKTNOSUPPORT : constant := 63;
+
+ -- Host Errors
+
+ HOST_NOT_FOUND : constant := 1;
+ TRY_AGAIN : constant := 2;
+ NO_ADDRESS : constant := 4;
+ NO_RECOVERY : constant := 3;
+
+ -- Control Flags
+
+ FIONBIO : constant := -2147195266;
+ FIONREAD : constant := 1074030207;
+
+ -- Shutdown Modes
+
+ SHUT_RD : constant := 0;
+ SHUT_WR : constant := 1;
+ SHUT_RDWR : constant := 2;
+
+ -- Protocol Levels
+
+ SOL_SOCKET : constant := 65535;
+ IPPROTO_IP : constant := 0;
+ IPPROTO_UDP : constant := 17;
+ IPPROTO_TCP : constant := 6;
+
+ -- Socket Options
+
+ TCP_NODELAY : constant := 1;
+ SO_SNDBUF : constant := 4097;
+ SO_RCVBUF : constant := 4098;
+ SO_REUSEADDR : constant := 4;
+ SO_KEEPALIVE : constant := 8;
+ SO_LINGER : constant := 128;
+ SO_ERROR : constant := 4103;
+ SO_BROADCAST : constant := 32;
+ IP_ADD_MEMBERSHIP : constant := 12;
+ IP_DROP_MEMBERSHIP : constant := 13;
+ IP_MULTICAST_TTL : constant := 10;
+ IP_MULTICAST_LOOP : constant := 11;
+end GNAT.Sockets.Constants;
--- /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 --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the version for SGI
+
+package GNAT.Sockets.Constants is
+
+ -- Families
+
+ AF_INET : constant := 2;
+ AF_INET6 : constant := 24;
+
+ -- Modes
+
+ SOCK_STREAM : constant := 2;
+ SOCK_DGRAM : constant := 1;
+
+ -- Socket Errors
+
+ EBADF : constant := 9;
+ ENOTSOCK : constant := 95;
+ ENOTCONN : constant := 134;
+ ENOBUFS : constant := 132;
+ EOPNOTSUPP : constant := 122;
+ EFAULT : constant := 14;
+ EWOULDBLOCK : constant := 11;
+ EADDRNOTAVAIL : constant := 126;
+ EMSGSIZE : constant := 97;
+ EADDRINUSE : constant := 125;
+ EINVAL : constant := 22;
+ EACCES : constant := 13;
+ EAFNOSUPPORT : constant := 124;
+ EISCONN : constant := 133;
+ ETIMEDOUT : constant := 145;
+ ECONNREFUSED : constant := 146;
+ ENETUNREACH : constant := 128;
+ EALREADY : constant := 149;
+ EINPROGRESS : constant := 150;
+ ENOPROTOOPT : constant := 99;
+ EPROTONOSUPPORT : constant := 120;
+ EINTR : constant := 4;
+ EIO : constant := 5;
+ ESOCKTNOSUPPORT : constant := 121;
+
+ -- Host Errors
+
+ HOST_NOT_FOUND : constant := 1;
+ TRY_AGAIN : constant := 2;
+ NO_ADDRESS : constant := 4;
+ NO_RECOVERY : constant := 3;
+
+ -- Control Flags
+
+ FIONBIO : constant := -2147195266;
+ FIONREAD : constant := 1074030207;
+
+ -- Shutdown Modes
+
+ SHUT_RD : constant := 0;
+ SHUT_WR : constant := 1;
+ SHUT_RDWR : constant := 2;
+
+ -- Protocol Levels
+
+ SOL_SOCKET : constant := 65535;
+ IPPROTO_IP : constant := 0;
+ IPPROTO_UDP : constant := 17;
+ IPPROTO_TCP : constant := 6;
+
+ -- Socket Options
+
+ TCP_NODELAY : constant := 1;
+ SO_SNDBUF : constant := 4097;
+ SO_RCVBUF : constant := 4098;
+ SO_REUSEADDR : constant := 4;
+ SO_KEEPALIVE : constant := 8;
+ SO_LINGER : constant := 128;
+ SO_ERROR : constant := 4103;
+ SO_BROADCAST : constant := 32;
+ IP_ADD_MEMBERSHIP : constant := 23;
+ IP_DROP_MEMBERSHIP : constant := 24;
+ IP_MULTICAST_TTL : constant := 21;
+ IP_MULTICAST_LOOP : constant := 22;
+end GNAT.Sockets.Constants;
--- /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 --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the version for HP/UX
+
+package GNAT.Sockets.Constants is
+
+ -- Families
+
+ AF_INET : constant := 2;
+ AF_INET6 : constant := -1;
+
+ -- Modes
+
+ SOCK_STREAM : constant := 1;
+ SOCK_DGRAM : constant := 2;
+
+ -- Socket Errors
+
+ EBADF : constant := 9;
+ ENOTSOCK : constant := 216;
+ ENOTCONN : constant := 235;
+ ENOBUFS : constant := 233;
+ EOPNOTSUPP : constant := 223;
+ EFAULT : constant := 14;
+ EWOULDBLOCK : constant := 246;
+ EADDRNOTAVAIL : constant := 227;
+ EMSGSIZE : constant := 218;
+ EADDRINUSE : constant := 226;
+ EINVAL : constant := 22;
+ EACCES : constant := 13;
+ EAFNOSUPPORT : constant := 225;
+ EISCONN : constant := 234;
+ ETIMEDOUT : constant := 238;
+ ECONNREFUSED : constant := 239;
+ ENETUNREACH : constant := 229;
+ EALREADY : constant := 244;
+ EINPROGRESS : constant := 245;
+ ENOPROTOOPT : constant := 220;
+ EPROTONOSUPPORT : constant := 221;
+ EINTR : constant := 4;
+ EIO : constant := 5;
+ ESOCKTNOSUPPORT : constant := 222;
+
+ -- Host Errors
+
+ HOST_NOT_FOUND : constant := 1;
+ TRY_AGAIN : constant := 2;
+ NO_ADDRESS : constant := 4;
+ NO_RECOVERY : constant := 3;
+
+ -- Control Flags
+
+ FIONBIO : constant := -2147195266;
+ FIONREAD : constant := 1074030207;
+
+ -- Shutdown Modes
+
+ SHUT_RD : constant := 0;
+ SHUT_WR : constant := 1;
+ SHUT_RDWR : constant := 2;
+
+ -- Protocol Levels
+
+ SOL_SOCKET : constant := 65535;
+ IPPROTO_IP : constant := 0;
+ IPPROTO_UDP : constant := 17;
+ IPPROTO_TCP : constant := 6;
+
+ -- Socket Options
+
+ TCP_NODELAY : constant := 1;
+ SO_SNDBUF : constant := 4097;
+ SO_RCVBUF : constant := 4098;
+ SO_REUSEADDR : constant := 4;
+ SO_KEEPALIVE : constant := 8;
+ SO_LINGER : constant := 128;
+ SO_ERROR : constant := 4103;
+ SO_BROADCAST : constant := 32;
+ IP_ADD_MEMBERSHIP : constant := 5;
+ IP_DROP_MEMBERSHIP : constant := 6;
+ IP_MULTICAST_TTL : constant := 3;
+ IP_MULTICAST_LOOP : constant := 4;
+end GNAT.Sockets.Constants;
--- /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 --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the version for Solaris
+
+package GNAT.Sockets.Constants is
+
+ -- Families
+
+ AF_INET : constant := 2;
+ AF_INET6 : constant := 26;
+
+ -- Modes
+
+ SOCK_STREAM : constant := 2;
+ SOCK_DGRAM : constant := 1;
+
+ -- Socket Errors
+
+ EBADF : constant := 9;
+ ENOTSOCK : constant := 95;
+ ENOTCONN : constant := 134;
+ ENOBUFS : constant := 132;
+ EOPNOTSUPP : constant := 122;
+ EFAULT : constant := 14;
+ EWOULDBLOCK : constant := 11;
+ EADDRNOTAVAIL : constant := 126;
+ EMSGSIZE : constant := 97;
+ EADDRINUSE : constant := 125;
+ EINVAL : constant := 22;
+ EACCES : constant := 13;
+ EAFNOSUPPORT : constant := 124;
+ EISCONN : constant := 133;
+ ETIMEDOUT : constant := 145;
+ ECONNREFUSED : constant := 146;
+ ENETUNREACH : constant := 128;
+ EALREADY : constant := 149;
+ EINPROGRESS : constant := 150;
+ ENOPROTOOPT : constant := 99;
+ EPROTONOSUPPORT : constant := 120;
+ EINTR : constant := 4;
+ EIO : constant := 5;
+ ESOCKTNOSUPPORT : constant := 121;
+
+ -- Host Errors
+
+ HOST_NOT_FOUND : constant := 1;
+ TRY_AGAIN : constant := 2;
+ NO_ADDRESS : constant := 4;
+ NO_RECOVERY : constant := 3;
+
+ -- Control Flags
+
+ FIONBIO : constant := -2147195266;
+ FIONREAD : constant := 1074030207;
+
+ -- Shutdown Modes
+
+ SHUT_RD : constant := 0;
+ SHUT_WR : constant := 1;
+ SHUT_RDWR : constant := 2;
+
+ -- Protocol Levels
+
+ SOL_SOCKET : constant := 65535;
+ IPPROTO_IP : constant := 0;
+ IPPROTO_UDP : constant := 17;
+ IPPROTO_TCP : constant := 6;
+
+ -- Socket Options
+
+ TCP_NODELAY : constant := 1;
+ SO_SNDBUF : constant := 4097;
+ SO_RCVBUF : constant := 4098;
+ SO_REUSEADDR : constant := 4;
+ SO_KEEPALIVE : constant := 8;
+ SO_LINGER : constant := 128;
+ SO_ERROR : constant := 4103;
+ SO_BROADCAST : constant := 32;
+ IP_ADD_MEMBERSHIP : constant := 19;
+ IP_DROP_MEMBERSHIP : constant := 20;
+ IP_MULTICAST_TTL : constant := 17;
+ IP_MULTICAST_LOOP : constant := 18;
+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 --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package GNAT.Sockets.Linker_Options is
+
+ -- This is the Solaris version of this package.
+
+private
+
+ pragma Linker_Options ("-lnsl");
+ pragma Linker_Options ("-lsocket");
+
+end GNAT.Sockets.Linker_Options;
--- /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 --
+-- --
+-- $Revision: 1.11 $
+-- --
+-- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the version for MINGW32 NT
+
+package GNAT.Sockets.Constants is
+
+ -- Families
+
+ AF_INET : constant := 2;
+ AF_INET6 : constant := 3;
+
+ -- Modes
+
+ SOCK_STREAM : constant := 1;
+ SOCK_DGRAM : constant := 2;
+
+ -- Socket Errors
+
+ EINTR : constant := 10004;
+ EBADF : constant := 10009;
+ EACCES : constant := 10013;
+ EFAULT : constant := 10014;
+ EINVAL : constant := 10022;
+ EMFILE : constant := 10024;
+ EWOULDBLOCK : constant := 10035;
+ EINPROGRESS : constant := 10036;
+ EALREADY : constant := 10037;
+ ENOTSOCK : constant := 10038;
+ EDESTADDRREQ : constant := 10039;
+ EMSGSIZE : constant := 10040;
+ EPROTOTYPE : constant := 10041;
+ ENOPROTOOPT : constant := 10042;
+ EPROTONOSUPPORT : constant := 10043;
+ ESOCKTNOSUPPORT : constant := 10044;
+ EOPNOTSUPP : constant := 10045;
+ EPFNOSUPPORT : constant := 10046;
+ EAFNOSUPPORT : constant := 10047;
+ EADDRINUSE : constant := 10048;
+ EADDRNOTAVAIL : constant := 10049;
+ ENETDOWN : constant := 10050;
+ ENETUNREACH : constant := 10051;
+ ENETRESET : constant := 10052;
+ ECONNABORTED : constant := 10053;
+ ECONNRESET : constant := 10054;
+ ENOBUFS : constant := 10055;
+ EISCONN : constant := 10056;
+ ENOTCONN : constant := 10057;
+ ESHUTDOWN : constant := 10058;
+ ETOOMANYREFS : constant := 10059;
+ ETIMEDOUT : constant := 10060;
+ ECONNREFUSED : constant := 10061;
+ ELOOP : constant := 10062;
+ ENAMETOOLONG : constant := 10063;
+ EHOSTDOWN : constant := 10064;
+ EHOSTUNREACH : constant := 10065;
+ SYSNOTREADY : constant := 10091;
+ VERNOTSUPPORTED : constant := 10092;
+ NOTINITIALISED : constant := 10093;
+ EDISCON : constant := 10101;
+
+ -- Host Errors
+
+ HOST_NOT_FOUND : constant := 11001;
+ TRY_AGAIN : constant := 11002;
+ NO_RECOVERY : constant := 11003;
+ NO_ADDRESS : constant := 11004;
+ NO_DATA : constant := 11004;
+
+ EIO : constant := 10101;
+
+ -- Control Flags
+
+ FIONBIO : constant := -2147195266;
+ FIONREAD : constant := 1074030207;
+
+ -- Shutdown Modes
+
+ SHUT_RD : constant := 0;
+ SHUT_WR : constant := 1;
+ SHUT_RDWR : constant := 2;
+
+ -- Protocol Levels
+
+ SOL_SOCKET : constant := 65535;
+ IPPROTO_IP : constant := 0;
+ IPPROTO_UDP : constant := 17;
+ IPPROTO_TCP : constant := 6;
+
+ -- Socket Options
+
+ TCP_NODELAY : constant := 1;
+ SO_SNDBUF : constant := 4097;
+ SO_RCVBUF : constant := 4098;
+ SO_REUSEADDR : constant := 4;
+ SO_KEEPALIVE : constant := 8;
+ SO_LINGER : constant := 128;
+ SO_ERROR : constant := 4103;
+ SO_BROADCAST : constant := 32;
+ IP_ADD_MEMBERSHIP : constant := 5;
+ IP_DROP_MEMBERSHIP : constant := 6;
+ IP_MULTICAST_TTL : constant := 3;
+ IP_MULTICAST_LOOP : constant := 4;
+
+end GNAT.Sockets.Constants;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . T H I N --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for NT.
+
+package body GNAT.Sockets.Thin is
+
+ use type C.unsigned;
+
+ WSAData_Dummy : array (1 .. 512) of C.int;
+
+ WS_Version : constant := 16#0101#;
+ Initialized : Boolean := False;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear
+ (Item : in out Fd_Set;
+ Socket : C.int)
+ is
+ begin
+ for J in 1 .. Item.fd_count loop
+ if Item.fd_array (J) = Socket then
+ Item.fd_array (J .. Item.fd_count - 1) :=
+ Item.fd_array (J + 1 .. Item.fd_count);
+ Item.fd_count := Item.fd_count - 1;
+ exit;
+ end if;
+ end loop;
+ end Clear;
+
+ -----------
+ -- Empty --
+ -----------
+
+ procedure Empty (Item : in out Fd_Set) is
+ begin
+ Item := Null_Fd_Set;
+ end Empty;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize is
+ begin
+ if Initialized then
+ WSACleanup;
+ Initialized := False;
+ end if;
+ end Finalize;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Item : Fd_Set) return Boolean is
+ begin
+ return Item.fd_count = 0;
+ end Is_Empty;
+
+ ------------
+ -- Is_Set --
+ ------------
+
+ function Is_Set (Item : Fd_Set; Socket : C.int) return Boolean is
+ begin
+ for J in 1 .. Item.fd_count loop
+ if Item.fd_array (J) = Socket then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+ end Is_Set;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Process_Blocking_IO : Boolean := False) is
+ Return_Value : Interfaces.C.int;
+
+ begin
+ if not Initialized then
+ Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address);
+ pragma Assert (Interfaces.C."=" (Return_Value, 0));
+ Initialized := True;
+ end if;
+ end Initialize;
+
+ ---------
+ -- Max --
+ ---------
+
+ function Max (Item : Fd_Set) return C.int is
+ L : C.int := 0;
+
+ begin
+ for J in 1 .. Item.fd_count loop
+ if Item.fd_array (J) > L then
+ L := Item.fd_array (J);
+ end if;
+ end loop;
+
+ return L;
+ end Max;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Item : in out Fd_Set; Socket : in C.int) is
+ begin
+ Item.fd_count := Item.fd_count + 1;
+ Item.fd_array (Item.fd_count) := Socket;
+ end Set;
+
+ --------------------------
+ -- Socket_Error_Message --
+ --------------------------
+
+ function Socket_Error_Message (Errno : Integer) return String is
+ use GNAT.Sockets.Constants;
+
+ begin
+ case Errno is
+ when EINTR =>
+ return "Interrupted system call";
+
+ when EBADF =>
+ return "Bad file number";
+
+ when EACCES =>
+ return "Permission denied";
+
+ when EFAULT =>
+ return "Bad address";
+
+ when EINVAL =>
+ return "Invalid argument";
+
+ when EMFILE =>
+ return "Too many open files";
+
+ when EWOULDBLOCK =>
+ return "Operation would block";
+
+ when EINPROGRESS =>
+ return "Operation now in progress. This error is "
+ & "returned if any Windows Sockets API "
+ & "function is called while a blocking "
+ & "function is in progress";
+
+ when EALREADY =>
+ return "Operation already in progress";
+
+ when ENOTSOCK =>
+ return "Socket operation on nonsocket";
+
+ when EDESTADDRREQ =>
+ return "Destination address required";
+
+ when EMSGSIZE =>
+ return "Message too long";
+
+ when EPROTOTYPE =>
+ return "Protocol wrong type for socket";
+
+ when ENOPROTOOPT =>
+ return "Protocol not available";
+
+ when EPROTONOSUPPORT =>
+ return "Protocol not supported";
+
+ when ESOCKTNOSUPPORT =>
+ return "Socket type not supported";
+
+ when EOPNOTSUPP =>
+ return "Operation not supported on socket";
+
+ when EPFNOSUPPORT =>
+ return "Protocol family not supported";
+
+ when EAFNOSUPPORT =>
+ return "Address family not supported by protocol family";
+
+ when EADDRINUSE =>
+ return "Address already in use";
+
+ when EADDRNOTAVAIL =>
+ return "Cannot assign requested address";
+
+ when ENETDOWN =>
+ return "Network is down. This error may be "
+ & "reported at any time if the Windows "
+ & "Sockets implementation detects an "
+ & "underlying failure";
+
+ when ENETUNREACH =>
+ return "Network is unreachable";
+
+ when ENETRESET =>
+ return "Network dropped connection on reset";
+
+ when ECONNABORTED =>
+ return "Software caused connection abort";
+
+ when ECONNRESET =>
+ return "Connection reset by peer";
+
+ when ENOBUFS =>
+ return "No buffer space available";
+
+ when EISCONN =>
+ return "Socket is already connected";
+
+ when ENOTCONN =>
+ return "Socket is not connected";
+
+ when ESHUTDOWN =>
+ return "Cannot send after socket shutdown";
+
+ when ETOOMANYREFS =>
+ return "Too many references: cannot splice";
+
+ when ETIMEDOUT =>
+ return "Connection timed out";
+
+ when ECONNREFUSED =>
+ return "Connection refused";
+
+ when ELOOP =>
+ return "Too many levels of symbolic links";
+
+ when ENAMETOOLONG =>
+ return "File name too long";
+
+ when EHOSTDOWN =>
+ return "Host is down";
+
+ when EHOSTUNREACH =>
+ return "No route to host";
+
+ when SYSNOTREADY =>
+ return "Returned by WSAStartup(), indicating that "
+ & "the network subsystem is unusable";
+
+ when VERNOTSUPPORTED =>
+ return "Returned by WSAStartup(), indicating that "
+ & "the Windows Sockets DLL cannot support this application";
+
+ when NOTINITIALISED =>
+ return "Winsock not initialized. This message is "
+ & "returned by any function except WSAStartup(), "
+ & "indicating that a successful WSAStartup() has "
+ & "not yet been performed";
+
+ when EDISCON =>
+ return "Disconnect";
+
+ when HOST_NOT_FOUND =>
+ return "Host not found. This message indicates "
+ & "that the key (name, address, and so on) was not found";
+
+ when TRY_AGAIN =>
+ return "Nonauthoritative host not found. This error may "
+ & "suggest that the name service itself is not functioning";
+
+ when NO_RECOVERY =>
+ return "Nonrecoverable error. This error may suggest that the "
+ & "name service itself is not functioning";
+
+ when NO_DATA =>
+ return "Valid name, no data record of requested type. "
+ & "This error indicates that the key (name, address, "
+ & "and so on) was not found.";
+
+ when others =>
+ return "Unknown system error";
+
+ end case;
+ end Socket_Error_Message;
+
+end GNAT.Sockets.Thin;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . T H I N --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.16 $
+-- --
+-- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for NT.
+
+with Interfaces.C.Pointers;
+with Interfaces.C.Strings;
+
+with GNAT.Sockets.Constants;
+
+with System;
+
+package GNAT.Sockets.Thin is
+
+ -- ??? far more comments required ???
+
+ package C renames Interfaces.C;
+
+ use type C.int;
+ -- So that we can declare the Failure constant below.
+
+ Success : constant C.int := 0;
+ Failure : constant C.int := -1;
+
+ function Socket_Errno return Integer;
+ -- Returns last socket error number.
+
+ function Socket_Error_Message (Errno : Integer) return String;
+ -- Returns the error message string for the error number Errno. If
+ -- Errno is not known it returns "Unknown system error".
+
+ type Socket_Fd_Array is array (C.unsigned range 1 .. 64) of C.int;
+ pragma Convention (C, Socket_Fd_Array);
+
+ type Fd_Set is record
+ fd_count : C.unsigned;
+ fd_array : Socket_Fd_Array;
+ end record;
+ pragma Convention (C, Fd_Set);
+
+ Null_Fd_Set : constant Fd_Set := (0, (others => 0));
+
+ type Fd_Set_Access is access all Fd_Set;
+ pragma Convention (C, Fd_Set_Access);
+
+ type Timeval_Unit is new C.long;
+ pragma Convention (C, Timeval_Unit);
+
+ type Timeval is record
+ Tv_Sec : Timeval_Unit;
+ Tv_Usec : Timeval_Unit;
+ end record;
+ pragma Convention (C, Timeval);
+
+ type Timeval_Access is access all Timeval;
+ pragma Convention (C, Timeval_Access);
+
+ Immediat : constant Timeval := (0, 0);
+
+ type Int_Access is access all C.int;
+ pragma Convention (C, Int_Access);
+ -- Access to C integers
+
+ type Chars_Ptr_Array is array (C.size_t range <>) of
+ aliased C.Strings.chars_ptr;
+
+ package Chars_Ptr_Pointers is
+ new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array,
+ C.Strings.Null_Ptr);
+ -- Arrays of C (char *)
+
+ type In_Addr is record
+ S_B1, S_B2, S_B3, S_B4 : C.unsigned_char;
+ end record;
+ pragma Convention (C, In_Addr);
+ -- Internet address
+
+ type In_Addr_Access is access all In_Addr;
+ pragma Convention (C, In_Addr_Access);
+ -- Access to internet address
+
+ Inaddr_Any : aliased constant In_Addr := (others => 0);
+ -- Any internet address (all the interfaces)
+
+ type In_Addr_Access_Array is array (C.size_t range <>)
+ of aliased In_Addr_Access;
+ pragma Convention (C, In_Addr_Access_Array);
+ package In_Addr_Access_Pointers is
+ new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null);
+ -- Array of internet addresses
+
+ type Sockaddr is record
+ Sa_Family : C.unsigned_short;
+ Sa_Data : C.char_array (1 .. 14);
+ end record;
+ pragma Convention (C, Sockaddr);
+ -- Socket address
+
+ type Sockaddr_Access is access all Sockaddr;
+ pragma Convention (C, Sockaddr_Access);
+ -- Access to socket address
+
+ type Sockaddr_In is record
+ Sin_Family : C.unsigned_short := Constants.AF_INET;
+ Sin_Port : C.unsigned_short := 0;
+ Sin_Addr : In_Addr := Inaddr_Any;
+ Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0));
+ end record;
+ pragma Convention (C, Sockaddr_In);
+ -- Internet socket address
+
+ type Sockaddr_In_Access is access all Sockaddr_In;
+ pragma Convention (C, Sockaddr_In_Access);
+ -- Access to internet socket address
+
+ type Hostent is record
+ H_Name : C.Strings.chars_ptr;
+ H_Aliases : Chars_Ptr_Pointers.Pointer;
+ H_Addrtype : C.short;
+ H_Length : C.short;
+ H_Addr_List : In_Addr_Access_Pointers.Pointer;
+ end record;
+ pragma Convention (C, Hostent);
+ -- Host entry
+
+ type Hostent_Access is access all Hostent;
+ pragma Convention (C, Hostent_Access);
+ -- Access to host entry
+
+ type Two_Int is array (0 .. 1) of C.int;
+ pragma Convention (C, Two_Int);
+ -- Used with pipe()
+
+ function C_Accept
+ (S : C.int;
+ Addr : System.Address;
+ Addrlen : access C.int)
+ return C.int;
+
+ function C_Bind
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int)
+ return C.int;
+
+ function C_Close
+ (Fd : C.int)
+ return C.int;
+
+ function C_Connect
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int)
+ return C.int;
+
+ function C_Gethostbyaddr
+ (Addr : System.Address;
+ Length : C.int;
+ Typ : C.int)
+ return Hostent_Access;
+
+ function C_Gethostbyname
+ (Name : C.char_array)
+ return Hostent_Access;
+
+ function C_Gethostname
+ (Name : System.Address;
+ Namelen : C.int)
+ return C.int;
+
+ function C_Getpeername
+ (S : C.int;
+ Name : System.Address;
+ Namelen : access C.int)
+ return C.int;
+
+ function C_Getsockname
+ (S : C.int;
+ Name : System.Address;
+ Namelen : access C.int)
+ return C.int;
+
+ function C_Getsockopt
+ (S : C.int;
+ Level : C.int;
+ Optname : C.int;
+ Optval : System.Address;
+ Optlen : access C.int)
+ return C.int;
+
+ function C_Inet_Addr
+ (Cp : C.Strings.chars_ptr)
+ return C.int;
+
+ function C_Ioctl
+ (S : C.int;
+ Req : C.int;
+ Arg : Int_Access)
+ return C.int;
+
+ function C_Listen
+ (S, Backlog : C.int)
+ return C.int;
+
+ function C_Read
+ (Fildes : C.int;
+ Buf : System.Address;
+ Nbyte : C.int)
+ return C.int;
+
+ function C_Recv
+ (S : C.int;
+ Buf : System.Address;
+ Len : C.int;
+ Flags : C.int)
+ return C.int;
+
+ function C_Recvfrom
+ (S : C.int;
+ Buf : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ From : Sockaddr_In_Access;
+ Fromlen : access C.int)
+ return C.int;
+
+ function C_Select
+ (Nfds : C.int;
+ Readfds : Fd_Set_Access;
+ Writefds : Fd_Set_Access;
+ Exceptfds : Fd_Set_Access;
+ Timeout : Timeval_Access)
+ return C.int;
+
+ function C_Send
+ (S : C.int;
+ Buf : System.Address;
+ Len : C.int;
+ Flags : C.int)
+ return C.int;
+
+ function C_Sendto
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ To : Sockaddr_In_Access;
+ Tolen : C.int)
+ return C.int;
+
+ function C_Setsockopt
+ (S : C.int;
+ Level : C.int;
+ Optname : C.int;
+ Optval : System.Address;
+ Optlen : C.int)
+ return C.int;
+
+ function C_Shutdown
+ (S : C.int;
+ How : C.int)
+ return C.int;
+
+ function C_Socket
+ (Domain : C.int;
+ Typ : C.int;
+ Protocol : C.int)
+ return C.int;
+
+ function C_Strerror
+ (Errnum : C.int)
+ return C.Strings.chars_ptr;
+
+ function C_System
+ (Command : System.Address)
+ return C.int;
+
+ function C_Write
+ (Fildes : C.int;
+ Buf : System.Address;
+ Nbyte : C.int)
+ return C.int;
+
+ function WSAStartup
+ (WS_Version : Interfaces.C.int;
+ WSADataAddress : System.Address)
+ return Interfaces.C.int;
+
+ procedure WSACleanup;
+
+ procedure Clear (Item : in out Fd_Set; Socket : in C.int);
+ procedure Empty (Item : in out Fd_Set);
+ function Is_Empty (Item : Fd_Set) return Boolean;
+ function Is_Set (Item : Fd_Set; Socket : C.int) return Boolean;
+ function Max (Item : Fd_Set) return C.int;
+ procedure Set (Item : in out Fd_Set; Socket : in C.int);
+
+ procedure Finalize;
+ procedure Initialize (Process_Blocking_IO : Boolean := False);
+
+private
+
+ pragma Import (Stdcall, C_Accept, "accept");
+ pragma Import (Stdcall, C_Bind, "bind");
+ pragma Import (Stdcall, C_Close, "closesocket");
+ pragma Import (Stdcall, C_Connect, "connect");
+ pragma Import (Stdcall, C_Gethostbyaddr, "gethostbyaddr");
+ pragma Import (Stdcall, C_Gethostbyname, "gethostbyname");
+ pragma Import (Stdcall, C_Gethostname, "gethostname");
+ pragma Import (Stdcall, C_Getpeername, "getpeername");
+ pragma Import (Stdcall, C_Getsockname, "getsockname");
+ pragma Import (Stdcall, C_Getsockopt, "getsockopt");
+ pragma Import (Stdcall, C_Inet_Addr, "inet_addr");
+ pragma Import (Stdcall, C_Ioctl, "ioctlsocket");
+ pragma Import (Stdcall, C_Listen, "listen");
+ pragma Import (C, C_Read, "_read");
+ pragma Import (Stdcall, C_Recv, "recv");
+ pragma Import (Stdcall, C_Recvfrom, "recvfrom");
+ pragma Import (Stdcall, C_Select, "select");
+ pragma Import (Stdcall, C_Send, "send");
+ pragma Import (Stdcall, C_Sendto, "sendto");
+ pragma Import (Stdcall, C_Setsockopt, "setsockopt");
+ pragma Import (Stdcall, C_Shutdown, "shutdown");
+ pragma Import (Stdcall, C_Socket, "socket");
+ pragma Import (C, C_Strerror, "strerror");
+ pragma Import (C, C_System, "_system");
+ pragma Import (C, C_Write, "_write");
+ pragma Import (Stdcall, Socket_Errno, "WSAGetLastError");
+ pragma Import (Stdcall, WSAStartup, "WSAStartup");
+ pragma Import (Stdcall, WSACleanup, "WSACleanup");
+
+end GNAT.Sockets.Thin;
--- /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 --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package GNAT.Sockets.Linker_Options is
+
+ -- Windows NT version of this package
+
+private
+
+ pragma Linker_Options ("-lwsock32");
+
+end GNAT.Sockets.Linker_Options;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a 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
+-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
+
+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
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a LynxOS 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
+-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
+
+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)
+
+ SIGBRK : constant Interrupt_ID :=
+ System.OS_Interface.SIGBRK; -- break
+
+ 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
+
+ SIGCORE : constant Interrupt_ID :=
+ System.OS_Interface.SIGCORE; -- kill with core dump
+
+ 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
+
+ SIGURG : constant Interrupt_ID :=
+ System.OS_Interface.SIGURG; -- urgent condition on IO channel
+
+ 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
+
+ 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
+
+ SIGTTIN : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTIN; -- background tty read attempted
+
+ SIGTTOU : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTOU; -- background tty write attempted
+
+ 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)
+
+ SIGXCPU : constant Interrupt_ID :=
+ System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
+
+ SIGXFSZ : constant Interrupt_ID :=
+ System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
+
+ SIGVTALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGVTALRM; -- virtual timer expired
+
+ SIGPROF : constant Interrupt_ID :=
+ System.OS_Interface.SIGPROF; -- profiling timer expired
+
+ SIGWINCH : constant Interrupt_ID :=
+ System.OS_Interface.SIGWINCH; -- window size change
+
+ SIGLOST : constant Interrupt_ID :=
+ System.OS_Interface.SIGLOST; -- SUN 4.1 compatibility
+
+ SIGUSR1 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR1; -- user defined signal 1
+
+ SIGUSR2 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR2; -- user defined signal 2
+
+ SIGPRIO : constant Interrupt_ID :=
+ System.OS_Interface.SIGPRIO;
+ -- sent to a process with its priority
+ -- or group is changed
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the DEC Unix 4.0 version of this package.
+--
+-- The following signals are reserved by the run time:
+--
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGALRM,
+-- SIGSTOP, SIGKILL
+--
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+--
+-- SIGINT: made available for Ada handler
+-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
+
+with System.OS_Interface;
+-- used for names of interrupts
+
+package Ada.Interrupts.Names is
+
+ -- Beware that the mapping of names to signals may be
+ -- many-to-one. There may be aliases. Also, for all
+ -- signal names that are not supported on the current system
+ -- the value of the corresponding constant will be zero.
+
+ SIGHUP : constant Interrupt_ID :=
+ System.OS_Interface.SIGHUP; -- hangup
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGQUIT : constant Interrupt_ID :=
+ System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGTRAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTRAP; -- trace trap (not reset)
+
+ SIGIOT : constant Interrupt_ID :=
+ System.OS_Interface.SIGIOT; -- IOT instruction
+
+ SIGABRT : constant Interrupt_ID := -- 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
+
+ SIGCHLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
+
+ SIGWINCH : constant Interrupt_ID :=
+ System.OS_Interface.SIGWINCH; -- window size change
+
+ SIGURG : constant Interrupt_ID :=
+ System.OS_Interface.SIGURG; -- urgent condition on IO channel
+
+ SIGPOLL : constant Interrupt_ID :=
+ System.OS_Interface.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
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a AIX version of this package.
+--
+-- The following signals are reserved by the run time (native threads):
+--
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGTERM,
+-- SIGSTOP, SIGKILL
+--
+-- The following signals are reserved by the run time (FSU threads):
+--
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGALRM,
+-- SIGWAITING, SIGSTOP, SIGKILL
+--
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+--
+-- SIGINT: made available for Ada handler
+-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
+
+-- This target-dependent package spec contains names of interrupts
+-- supported by the local system.
+
+with System.OS_Interface;
+-- used for names of interrupts
+
+package Ada.Interrupts.Names is
+
+ -- Beware that the mapping of names to signals may be
+ -- many-to-one. There may be aliases. Also, for all
+ -- signal names that are not supported on the current system
+ -- the value of the corresponding constant will be zero.
+
+ SIGHUP : constant Interrupt_ID :=
+ System.OS_Interface.SIGHUP; -- hangup
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGQUIT : constant Interrupt_ID :=
+ System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGTRAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTRAP; -- trace trap (not reset)
+
+ SIGIOT : constant Interrupt_ID :=
+ System.OS_Interface.SIGIOT; -- IOT instruction
+
+ SIGABRT : constant Interrupt_ID := -- 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
+
+ SIGMSG : constant Interrupt_ID :=
+ System.OS_Interface.SIGMSG; -- input data is in the ring buffer
+
+ SIGDANGER : constant Interrupt_ID :=
+ System.OS_Interface.SIGDANGER; -- system crash imminent;
+
+ SIGMIGRATE : constant Interrupt_ID :=
+ System.OS_Interface.SIGMIGRATE; -- migrate process
+
+ SIGPRE : constant Interrupt_ID :=
+ System.OS_Interface.SIGPRE; -- programming exception
+
+ SIGVIRT : constant Interrupt_ID :=
+ System.OS_Interface.SIGVIRT; -- AIX virtual time alarm
+
+ SIGALRM1 : constant Interrupt_ID :=
+ System.OS_Interface.SIGALRM1; -- m:n condition variables
+
+ SIGWAITING : constant Interrupt_ID :=
+ System.OS_Interface.SIGWAITING; -- m:n scheduling
+
+ SIGKAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGKAP; -- keep alive poll from native keyboard
+
+ SIGGRANT : constant Interrupt_ID :=
+ System.OS_Interface.SIGGRANT; -- monitor mode granted
+
+ SIGRETRACT : constant Interrupt_ID :=
+ System.OS_Interface.SIGRETRACT; -- monitor mode should be relinguished
+
+ SIGSOUND : constant Interrupt_ID :=
+ System.OS_Interface.SIGSOUND; -- sound control has completed
+
+ SIGSAK : constant Interrupt_ID :=
+ System.OS_Interface.SIGSAK; -- secure attention key
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a DOS/DJGPPv2 (FSU THREAD) version of this package.
+--
+-- The following signals are reserved by the run time:
+--
+-- SIGFPE, SIGILL, SIGSEGV, SIGABRT, SIGTRAP, SIGINT, SIGALRM
+-- SIGSTOP, SIGKILL
+--
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+--
+-- SIGINT: Made available for Ada handler
+-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
+
+-- This target-dependent package spec contains names of interrupts
+-- supported by the local system.
+
+with System.OS_Interface;
+-- used for names of interrupts
+
+package Ada.Interrupts.Names is
+
+ -- Beware that the mapping of names to signals may be
+ -- many-to-one. There may be aliases. Also, for all
+ -- signal names that are not supported on the current system
+ -- the value of the corresponding constant will be zero.
+
+ SIGHUP : constant Interrupt_ID :=
+ System.OS_Interface.SIGHUP; -- hangup
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGQUIT : constant Interrupt_ID :=
+ System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGABRT : constant Interrupt_ID := -- used by abort,
+ System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
+
+ 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)
+
+ SIGSEGV : constant Interrupt_ID :=
+ System.OS_Interface.SIGSEGV; -- segmentation violation
+
+ 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
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1997-2001, Florida State University --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU Library General Public License as published by the --
+-- Free Software Foundation; either version 2, or (at your option) any --
+-- later version. GNARL is distributed in the hope that it will be use- --
+-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of --
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Gen- --
+-- eral Library Public License for more details. You should have received --
+-- a copy of the GNU Library General Public License along with GNARL; see --
+-- file COPYING.LIB. If not, write to the Free Software Foundation, 675 --
+-- Mass Ave, Cambridge, MA 02139, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Irix version of this package
+--
+-- The following signals are reserved by the run time (Athread library):
+--
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGSTOP, SIGKILL
+--
+-- The following signals are reserved by the run time (Pthread library):
+--
+-- SIGTSTP, SIGILL, SIGTRAP, SIGEMT, SIGFPE, SIGBUS, SIGSTOP, SIGKILL,
+-- SIGSEGV, SIGSYS, SIGXCPU, SIGXFSZ, SIGPROF, SIGPTINTR, SIGPTRESCHED,
+-- SIGABRT, SIGINT
+--
+-- The pragma Unreserve_All_Interrupts affects the following signal
+-- (Pthread library):
+--
+-- SIGINT: made available for Ada handler
+-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
+
+-- This target-dependent package spec contains names of interrupts
+-- supported by the local system.
+
+with System.OS_Interface;
+-- used for names of interrupts
+
+package Ada.Interrupts.Names is
+
+ -- Beware that the mapping of names to signals may be
+ -- many-to-one. There may be aliases. Also, for all
+ -- signal names that are not supported on the current system
+ -- the value of the corresponding constant will be zero.
+
+ SIGHUP : constant Interrupt_ID :=
+ System.OS_Interface.SIGHUP; -- hangup
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGQUIT : constant Interrupt_ID :=
+ System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGTRAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTRAP; -- trace trap (not reset)
+
+ SIGIOT : constant Interrupt_ID :=
+ System.OS_Interface.SIGIOT; -- IOT instruction
+
+ SIGABRT : constant Interrupt_ID :=
+ System.OS_Interface.SIGABRT; -- used by abort, replace SIGIOT in the
+ -- future
+
+ SIGEMT : constant Interrupt_ID :=
+ System.OS_Interface.SIGEMT; -- EMT instruction
+
+ SIGFPE : constant Interrupt_ID :=
+ System.OS_Interface.SIGFPE; -- floating point exception
+
+ SIGKILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
+
+ SIGBUS : constant Interrupt_ID :=
+ System.OS_Interface.SIGBUS; -- bus error
+
+ SIGSEGV : constant Interrupt_ID :=
+ System.OS_Interface.SIGSEGV; -- segmentation violation
+
+ SIGSYS : constant Interrupt_ID :=
+ System.OS_Interface.SIGSYS; -- bad argument to system call
+
+ SIGPIPE : constant Interrupt_ID :=
+ System.OS_Interface.SIGPIPE; -- write on pipe with no one to read it
+
+ SIGALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGALRM; -- alarm clock
+
+ SIGTERM : constant Interrupt_ID :=
+ System.OS_Interface.SIGTERM; -- software termination signal from kill
+
+ SIGUSR1 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR1; -- user defined signal 1
+
+ SIGUSR2 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR2; -- user defined signal 2
+
+ SIGCLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCLD; -- alias for SIGCHLD
+
+ SIGCHLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCHLD; -- child status change
+
+ 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 :=
+ System.OS_Interface.SIGIO; -- I/O possible (Solaris SIGPOLL alias)
+
+ 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
+
+ SIGK32 : constant Interrupt_ID :=
+ System.OS_Interface.SIGK32; -- reserved for kernel (IRIX)
+
+ SIGCKPT : constant Interrupt_ID :=
+ System.OS_Interface.SIGCKPT; -- Checkpoint warning
+
+ SIGRESTART : constant Interrupt_ID :=
+ System.OS_Interface.SIGRESTART; -- Restart warning
+
+ SIGUME : constant Interrupt_ID :=
+ System.OS_Interface.SIGUME; -- Uncorrectable memory error
+
+ -- Signals defined for Posix 1003.1c.
+
+ SIGPTINTR : constant Interrupt_ID :=
+ System.OS_Interface.SIGPTINTR; -- Pthread Interrupt Signal
+
+ SIGPTRESCHED : constant Interrupt_ID :=
+ System.OS_Interface.SIGPTRESCHED; -- Pthread Rescheduling Signal
+
+ -- Posix 1003.1b signals
+
+ SIGRTMIN : constant Interrupt_ID :=
+ System.OS_Interface.SIGRTMIN; -- Posix 1003.1b signals
+
+ SIGRTMAX : constant Interrupt_ID :=
+ System.OS_Interface.SIGRTMAX; -- Posix 1003.1b signals
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . E X C E P T I O N S . P O L L --
+-- (version supporting asynchronous abort test and time slicing) --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-2000, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for targets that do not support per-thread asynchronous
+-- signals or that do not handle async timers properly. On such targets, we
+-- require compilation with the -gnatP switch that activates periodic polling.
+-- Then in the body of the polling routine we test for asynchronous abort and
+-- yield periodically.
+
+-- HP-UX and SCO currently use this file
+
+with System.Soft_Links;
+-- used for Check_Abort_Status
+
+separate (Ada.Exceptions)
+
+----------
+-- Poll --
+----------
+
+procedure Poll is
+begin
+ if Counter = 10000 then
+ Counter := 0;
+ delay 0.0;
+ else
+ Counter := Counter + 1;
+ end if;
+
+ -- Test for asynchronous abort on each poll
+
+ if System.Soft_Links.Check_Abort_Status.all /= 0 then
+ raise Standard'Abort_Signal;
+ end if;
+end Poll;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1991-2001, Florida State University --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a HP-UX version of this package.
+--
+-- The following signals are reserved by the run time:
+--
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT,
+-- SIGALRM, SIGSTOP, SIGKILL
+--
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+--
+-- SIGINT: made available for Ada handler
+-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
+
+-- This target-dependent package spec contains names of interrupts
+-- supported by the local system.
+
+with System.OS_Interface;
+-- used for names of interrupts
+
+package Ada.Interrupts.Names is
+
+ -- Beware that the mapping of names to signals may be
+ -- many-to-one. There may be aliases. Also, for all
+ -- signal names that are not supported on the current system
+ -- the value of the corresponding constant will be zero.
+
+ SIGHUP : constant Interrupt_ID :=
+ System.OS_Interface.SIGHUP; -- hangup
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGQUIT : constant Interrupt_ID :=
+ System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGTRAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTRAP; -- trace trap (not reset)
+
+ SIGIOT : constant Interrupt_ID :=
+ System.OS_Interface.SIGIOT; -- IOT instruction
+
+ SIGABRT : constant Interrupt_ID := -- 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
+
+ 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
+
+ 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
+
+ SIGPWR : constant Interrupt_ID :=
+ System.OS_Interface.SIGPWR; -- power-fail restart
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Linux version of this package.
+--
+-- The following signals are reserved by the run time (FSU threads):
+--
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
+-- SIGALRM, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL
+--
+-- The following signals are reserved by the run time (LinuxThreads):
+--
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
+-- SIGUSR1, SIGUSR2, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL
+--
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+--
+-- SIGINT: made available for Ada handler
+-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
+
+-- This target-dependent package spec contains names of interrupts
+-- supported by the local system.
+
+with System.OS_Interface;
+-- used for names of interrupts
+
+package Ada.Interrupts.Names is
+
+ -- Beware that the mapping of names to signals may be
+ -- many-to-one. There may be aliases. Also, for all
+ -- signal names that are not supported on the current system
+ -- the value of the corresponding constant will be zero.
+
+ SIGHUP : constant Interrupt_ID :=
+ System.OS_Interface.SIGHUP; -- hangup
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGQUIT : constant Interrupt_ID :=
+ System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGTRAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTRAP; -- trace trap (not reset)
+
+ SIGIOT : constant Interrupt_ID :=
+ System.OS_Interface.SIGIOT; -- IOT instruction
+
+ SIGABRT : constant Interrupt_ID := -- used by abort,
+ System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
+
+ 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
+
+ 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
+
+ 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
+
+ SIGUNUSED : constant Interrupt_ID :=
+ System.OS_Interface.SIGUNUSED; -- unused signal
+
+ SIGSTKFLT : constant Interrupt_ID :=
+ System.OS_Interface.SIGSTKFLT; -- stack fault on coprocessor
+
+ SIGLOST : constant Interrupt_ID :=
+ System.OS_Interface.SIGLOST; -- Linux alias for SIGIO
+
+ SIGPWR : constant Interrupt_ID :=
+ System.OS_Interface.SIGPWR; -- Power failure
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1996-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Machten version of this package.
+--
+-- The following signals are reserved by the run time:
+--
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
+-- SIGALRM, SIGEMT, SIGCHLD, SIGSTOP, SIGKILL
+--
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+--
+-- SIGINT: made available for Ada handlers
+-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
+
+-- This target-dependent package spec contains names of interrupts
+-- supported by the local system.
+
+with System.OS_Interface;
+-- used for names of interrupts
+
+package Ada.Interrupts.Names is
+
+ -- Beware that the mapping of names to signals may be
+ -- many-to-one. There may be aliases. Also, for all
+ -- signal names that are not supported on the current system
+ -- the value of the corresponding constant will be zero.
+
+ SIGHUP : constant Interrupt_ID :=
+ System.OS_Interface.SIGHUP; -- hangup
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGQUIT : constant Interrupt_ID :=
+ System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGTRAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTRAP; -- trace trap (not reset)
+
+ SIGABRT : constant Interrupt_ID := -- used by abort,
+ System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
+
+ SIGIOT : constant Interrupt_ID :=
+ System.OS_Interface.SIGIOT; -- IOT instruction
+
+ SIGBUS : constant Interrupt_ID :=
+ System.OS_Interface.SIGBUS; -- bus error
+
+ 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)
+
+ SIGUSR1 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR1; -- user defined signal 1
+
+ SIGSEGV : constant Interrupt_ID :=
+ System.OS_Interface.SIGSEGV; -- segmentation violation
+
+ SIGUSR2 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR2; -- user defined signal 2
+
+ 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
+
+ SIGCHLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
+
+ SIGCONT : constant Interrupt_ID :=
+ System.OS_Interface.SIGCONT; -- stopped process has been continued
+
+ 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
+
+ SIGTTIN : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTIN; -- background tty read attempted
+
+ SIGTTOU : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTOU; -- background tty write attempted
+
+ SIGURG : constant Interrupt_ID :=
+ System.OS_Interface.SIGURG; -- urgent condition on IO channel
+
+ SIGXCPU : constant Interrupt_ID :=
+ System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
+
+ SIGXFSZ : constant Interrupt_ID :=
+ System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
+
+ SIGVTALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGVTALRM; -- virtual timer expired
+
+ SIGPROF : constant Interrupt_ID :=
+ System.OS_Interface.SIGPROF; -- profiling timer expired
+
+ SIGWINCH : constant Interrupt_ID :=
+ System.OS_Interface.SIGWINCH; -- window size change
+
+ SIGIO : constant Interrupt_ID := -- input/output possible,
+ System.OS_Interface.SIGIO;
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME 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 --
+-- (No Tasking Version) --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1991,92,93,94,95,1996 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- The standard implementation of this spec contains only dummy interrupt
+-- names. These dummy entries permit checking out code for correctness of
+-- semantics, even if interrupts are not supported.
+
+-- For specific implementations that fully support interrupts, this package
+-- spec is replaced by an implementation dependent version that defines the
+-- interrupts available on the system.
+
+package Ada.Interrupts.Names is
+
+ DUMMY_INTERRUPT_1 : constant Interrupt_ID := 1;
+ DUMMY_INTERRUPT_2 : constant Interrupt_ID := 2;
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1991-1997 Florida State University --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is an OS/2 version of this package.
+
+-- This 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 RUNTIME COMPONENTS --
+-- --
+-- A D A . N U M E R I C S . A U X --
+-- --
+-- S p e c --
+-- (C Library Version for x86) --
+-- --
+-- $Revision: 1.11 $ --
+-- --
+-- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides the basic computational interface for the generic
+-- elementary functions. The C library version interfaces with the routines
+-- in the C mathematical library, and is thus quite portable, although it may
+-- not necessarily meet the requirements for accuracy in the numerics annex.
+-- One advantage of using this package is that it will interface directly to
+-- hardware instructions, such as the those provided on the Intel x86.
+
+-- Note: there are two versions of this package. One using the 80-bit x86
+-- long double format (which is this version), and one using 64-bit IEEE
+-- double (see file a-numaux.ads).
+
+package Ada.Numerics.Aux is
+pragma Pure (Aux);
+
+ pragma Linker_Options ("-lm");
+
+ type Double is digits 18;
+
+ function Sin (X : Double) return Double;
+ pragma Import (C, Sin, "sinl");
+
+ function Cos (X : Double) return Double;
+ pragma Import (C, Cos, "cosl");
+
+ function Tan (X : Double) return Double;
+ pragma Import (C, Tan, "tanl");
+
+ function Exp (X : Double) return Double;
+ pragma Import (C, Exp, "expl");
+
+ function Sqrt (X : Double) return Double;
+ pragma Import (C, Sqrt, "sqrtl");
+
+ function Log (X : Double) return Double;
+ pragma Import (C, Log, "logl");
+
+ function Acos (X : Double) return Double;
+ pragma Import (C, Acos, "acosl");
+
+ function Asin (X : Double) return Double;
+ pragma Import (C, Asin, "asinl");
+
+ function Atan (X : Double) return Double;
+ pragma Import (C, Atan, "atanl");
+
+ function Sinh (X : Double) return Double;
+ pragma Import (C, Sinh, "sinhl");
+
+ function Cosh (X : Double) return Double;
+ pragma Import (C, Cosh, "coshl");
+
+ function Tanh (X : Double) return Double;
+ pragma Import (C, Tanh, "tanhl");
+
+ function Pow (X, Y : Double) return Double;
+ pragma Import (C, Pow, "powl");
+
+end Ada.Numerics.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a OpenNT (FSU THREAD) version of this package.
+--
+-- The following signals are reserved by the run time:
+--
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
+-- SIGALRM, SIGVTALRM, SIGSTOP, SIGKILL
+--
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+--
+-- SIGINT: made available for Ada handlers
+-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
+
+-- This target-dependent package spec contains names of interrupts
+-- supported by the local system.
+
+with System.OS_Interface;
+-- used for names of interrupts
+
+package Ada.Interrupts.Names is
+
+ -- Beware that the mapping of names to signals may be
+ -- many-to-one. There may be aliases. Also, for all
+ -- signal names that are not supported on the current system
+ -- the value of the corresponding constant will be zero.
+
+ SIGHUP : constant Interrupt_ID :=
+ System.OS_Interface.SIGHUP; -- hangup
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGQUIT : constant Interrupt_ID :=
+ System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGTRAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTRAP; -- trace trap (not reset)
+
+ SIGIOT : constant Interrupt_ID :=
+ System.OS_Interface.SIGIOT; -- IOT instruction
+
+ SIGABRT : constant Interrupt_ID := -- used by abort,
+ System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
+
+ 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
+
+ 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
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+-- The GNARL files that were developed for RTEMS are maintained by On-Line --
+-- Applications Research Corporation (http://www.oarcorp.com) in coopera- --
+-- tion with Ada Core Technologies Inc. and Florida State University. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a RTEMS version of this package
+--
+-- The following signals are reserved by the run time:
+--
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
+-- SIGALRM, SIGEMT, SIGKILL
+--
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+--
+-- SIGINT: made available for Ada handlers
+-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
+
+-- This target-dependent package spec contains names of interrupts
+-- supported by the local system.
+
+with System.OS_Interface;
+-- used for names of interrupts
+
+package Ada.Interrupts.Names is
+
+ -- Beware that the mapping of names to signals may be
+ -- many-to-one. There may be aliases. Also, for all
+ -- signal names that are not supported on the current system
+ -- the value of the corresponding constant will be zero.
+
+ SIGHUP : constant Interrupt_ID :=
+ System.OS_Interface.SIGHUP; -- hangup
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGQUIT : constant Interrupt_ID :=
+ System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGTRAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTRAP; -- trace trap (not reset)
+
+ SIGIOT : constant Interrupt_ID :=
+ System.OS_Interface.SIGIOT; -- IOT instruction
+
+ SIGABRT : constant Interrupt_ID := -- 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
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.7 $ --
+-- --
+-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Solaris version of this package.
+--
+-- The following signals are reserved by the run time (native threads):
+--
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
+-- SIGLWP, SIGWAITING, SIGCANCEL, SIGSTOP, SIGKILL
+--
+-- The following signals are reserved by the run time (FSU threads):
+--
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT,
+-- SIGLWP, SIGALRM, SIGVTALRM, SIGAITING, SIGSTOP, SIGKILL
+--
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+--
+-- SIGINT: made available for Ada handlers
+-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
+
+with System.OS_Interface;
+-- used for names of interrupts
+
+package Ada.Interrupts.Names is
+
+ -- Beware that the mapping of names to signals may be
+ -- many-to-one. There may be aliases. Also, for all
+ -- signal names that are not supported on the current system
+ -- the value of the corresponding constant will be zero.
+
+ SIGHUP : constant Interrupt_ID :=
+ System.OS_Interface.SIGHUP; -- hangup
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGQUIT : constant Interrupt_ID :=
+ System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGTRAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTRAP; -- trace trap (not reset)
+
+ SIGIOT : constant Interrupt_ID :=
+ System.OS_Interface.SIGIOT; -- IOT instruction
+
+ SIGABRT : constant Interrupt_ID := -- 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
+
+ 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
+
+ SIGPWR : constant Interrupt_ID :=
+ System.OS_Interface.SIGPWR; -- power-fail restart
+
+ 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)
+
+ SIGFREEZE : constant Interrupt_ID :=
+ System.OS_Interface.SIGFREEZE; -- used by CPR (Solaris)
+
+-- what is CPR????
+
+ SIGTHAW : constant Interrupt_ID :=
+ System.OS_Interface.SIGTHAW; -- used by CPR (Solaris)
+
+ SIGCANCEL : constant Interrupt_ID :=
+ System.OS_Interface.SIGCANCEL; -- used for thread cancel (Solaris)
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.7 $ --
+-- --
+-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Sun OS (FSU THREADS) version of this package.
+--
+-- The following signals are reserved by the run time:
+--
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
+-- SIGALRM, SIGEMT, SIGCHLD, SIGSTOP, SIGKILL
+--
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+--
+-- SIGINT: made available for Ada handlers
+-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
+
+with System.OS_Interface;
+-- used for names of interrupts
+
+package Ada.Interrupts.Names is
+
+ -- Beware that the mapping of names to signals may be
+ -- many-to-one. There may be aliases. Also, for all
+ -- signal names that are not supported on the current system
+ -- the value of the corresponding constant will be zero.
+
+ SIGHUP : constant Interrupt_ID :=
+ System.OS_Interface.SIGHUP; -- hangup
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGQUIT : constant Interrupt_ID :=
+ System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGTRAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTRAP; -- trace trap (not reset)
+
+ SIGIOT : constant Interrupt_ID :=
+ System.OS_Interface.SIGIOT; -- IOT instruction
+
+ SIGABRT : constant Interrupt_ID := -- 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
+
+ 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
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . C A L E N D A R . D E L A Y S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.18 $
+-- --
+-- Copyright (C) 1991-2000 Florida State University --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Alpha/VMS version.
+
+with System.OS_Primitives;
+-- Used for Max_Sensible_Delay
+
+with System.Soft_Links;
+-- Used for Timed_Delay
+
+package body Ada.Calendar.Delays is
+
+ package OSP renames System.OS_Primitives;
+ package TSL renames System.Soft_Links;
+
+ use type TSL.Timed_Delay_Call;
+
+ ---------------
+ -- Delay_For --
+ ---------------
+
+ procedure Delay_For (D : Duration) is
+ begin
+ TSL.Timed_Delay.all
+ (Duration'Min (D, OSP.Max_Sensible_Delay), OSP.Relative);
+ end Delay_For;
+
+ -----------------
+ -- Delay_Until --
+ -----------------
+
+ procedure Delay_Until (T : Time) is
+ begin
+ TSL.Timed_Delay.all (To_Duration (T), OSP.Absolute_Calendar);
+ end Delay_Until;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (T : Time) return Duration is
+ begin
+ return OSP.To_Duration (OSP.OS_Time (T), OSP.Absolute_Calendar);
+ end To_Duration;
+
+ --------------------
+ -- Timed_Delay_NT --
+ --------------------
+
+ procedure Timed_Delay_NT (Time : Duration; Mode : Integer);
+
+ procedure Timed_Delay_NT (Time : Duration; Mode : Integer) is
+ begin
+ OSP.Timed_Delay (Time, Mode);
+ end Timed_Delay_NT;
+
+begin
+ -- Set up the Timed_Delay soft link to the non tasking version if it has
+ -- not been already set.
+ -- If tasking is present, Timed_Delay has already set this soft link, or
+ -- this will be overriden during the elaboration of
+ -- System.Tasking.Initialization
+
+ if TSL.Timed_Delay = null then
+ TSL.Timed_Delay := Timed_Delay_NT'Access;
+ end if;
+end Ada.Calendar.Delays;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . C A L E N D A R --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.19 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Alpha/VMS version.
+
+with System.Aux_DEC; use System.Aux_DEC;
+
+package body Ada.Calendar is
+
+ ------------------------------
+ -- Use of Pragma Unsuppress --
+ ------------------------------
+
+ -- This implementation of Calendar takes advantage of the permission in
+ -- Ada 95 of using arithmetic overflow checks to check for out of bounds
+ -- time values. This means that we must catch the constraint error that
+ -- results from arithmetic overflow, so we use pragma Unsuppress to make
+ -- sure that overflow is enabled, using software overflow checking if
+ -- necessary. That way, compiling Calendar with options to suppress this
+ -- checking will not affect its correctness.
+
+ ------------------------
+ -- Local Declarations --
+ ------------------------
+
+ Ada_Year_Min : constant := 1901;
+ Ada_Year_Max : constant := 2099;
+
+ -- Some basic constants used throughout
+
+ Days_In_Month : constant array (Month_Number) of Day_Number :=
+ (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
+
+ function To_Relative_Time (D : Duration) return Time;
+
+ function To_Relative_Time (D : Duration) return Time is
+ begin
+ return Time (Long_Integer'Integer_Value (D) / 100);
+ end To_Relative_Time;
+
+ ---------
+ -- "+" --
+ ---------
+
+ function "+" (Left : Time; Right : Duration) return Time is
+ pragma Unsuppress (Overflow_Check);
+ begin
+ return (Left + To_Relative_Time (Right));
+
+ exception
+ when Constraint_Error =>
+ raise Time_Error;
+ end "+";
+
+ function "+" (Left : Duration; Right : Time) return Time is
+ pragma Unsuppress (Overflow_Check);
+ begin
+ return (To_Relative_Time (Left) + Right);
+
+ exception
+ when Constraint_Error =>
+ raise Time_Error;
+ end "+";
+
+ ---------
+ -- "-" --
+ ---------
+
+ function "-" (Left : Time; Right : Duration) return Time is
+ pragma Unsuppress (Overflow_Check);
+ begin
+ return Left - To_Relative_Time (Right);
+
+ exception
+ when Constraint_Error =>
+ raise Time_Error;
+ end "-";
+
+ function "-" (Left : Time; Right : Time) return Duration is
+ pragma Unsuppress (Overflow_Check);
+ begin
+ return Duration'Fixed_Value
+ ((Long_Integer (Left) - Long_Integer (Right)) * 100);
+
+ exception
+ when Constraint_Error =>
+ raise Time_Error;
+ end "-";
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<" (Left, Right : Time) return Boolean is
+ begin
+ return Long_Integer (Left) < Long_Integer (Right);
+ end "<";
+
+ ----------
+ -- "<=" --
+ ----------
+
+ function "<=" (Left, Right : Time) return Boolean is
+ begin
+ return Long_Integer (Left) <= Long_Integer (Right);
+ end "<=";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">" (Left, Right : Time) return Boolean is
+ begin
+ return Long_Integer (Left) > Long_Integer (Right);
+ end ">";
+
+ ----------
+ -- ">=" --
+ ----------
+
+ function ">=" (Left, Right : Time) return Boolean is
+ begin
+ return Long_Integer (Left) >= Long_Integer (Right);
+ end ">=";
+
+ -----------
+ -- Clock --
+ -----------
+
+ -- The Ada.Calendar.Clock function gets the time.
+ -- Note that on other targets a soft-link is used to get a different clock
+ -- depending whether tasking is used or not. On VMS this isn't needed
+ -- since all clock calls end up using SYS$GETTIM, so call the
+ -- OS_Primitives version for efficiency.
+
+ function Clock return Time is
+ begin
+ return Time (OSP.OS_Clock);
+ end Clock;
+
+ ---------
+ -- Day --
+ ---------
+
+ function Day (Date : Time) return Day_Number is
+ DY : Year_Number;
+ DM : Month_Number;
+ DD : Day_Number;
+ DS : Day_Duration;
+
+ begin
+ Split (Date, DY, DM, DD, DS);
+ return DD;
+ end Day;
+
+ -----------
+ -- Month --
+ -----------
+
+ function Month (Date : Time) return Month_Number is
+ DY : Year_Number;
+ DM : Month_Number;
+ DD : Day_Number;
+ DS : Day_Duration;
+
+ begin
+ Split (Date, DY, DM, DD, DS);
+ return DM;
+ end Month;
+
+ -------------
+ -- Seconds --
+ -------------
+
+ function Seconds (Date : Time) return Day_Duration is
+ DY : Year_Number;
+ DM : Month_Number;
+ DD : Day_Number;
+ DS : Day_Duration;
+
+ begin
+ Split (Date, DY, DM, DD, DS);
+ return DS;
+ end Seconds;
+
+ -----------
+ -- Split --
+ -----------
+
+ procedure Split
+ (Date : Time;
+ Year : out Year_Number;
+ Month : out Month_Number;
+ Day : out Day_Number;
+ Seconds : out Day_Duration)
+ is
+ procedure Numtim (
+ Status : out Unsigned_Longword;
+ Timbuf : out Unsigned_Word_Array;
+ Timadr : in Time);
+
+ pragma Interface (External, Numtim);
+
+ pragma Import_Valued_Procedure (Numtim, "SYS$NUMTIM",
+ (Unsigned_Longword, Unsigned_Word_Array, Time),
+ (Value, Reference, Reference));
+
+ Status : Unsigned_Longword;
+ Timbuf : Unsigned_Word_Array (1 .. 7);
+
+ begin
+ Numtim (Status, Timbuf, Date);
+
+ if Status mod 2 /= 1
+ or else Timbuf (1) not in Ada_Year_Min .. Ada_Year_Max
+ then
+ raise Time_Error;
+ end if;
+
+ Seconds
+ := Day_Duration (Timbuf (6) + 60 * (Timbuf (5) + 60 * Timbuf (4)))
+ + Day_Duration (Timbuf (7)) / 100.0;
+ Day := Integer (Timbuf (3));
+ Month := Integer (Timbuf (2));
+ Year := Integer (Timbuf (1));
+ end Split;
+
+ -------------
+ -- Time_Of --
+ -------------
+
+ function Time_Of
+ (Year : Year_Number;
+ Month : Month_Number;
+ Day : Day_Number;
+ Seconds : Day_Duration := 0.0)
+ return Time
+ is
+
+ procedure Cvt_Vectim (
+ Status : out Unsigned_Longword;
+ Input_Time : in Unsigned_Word_Array;
+ Resultant_Time : out Time);
+
+ pragma Interface (External, Cvt_Vectim);
+
+ pragma Import_Valued_Procedure (Cvt_Vectim, "LIB$CVT_VECTIM",
+ (Unsigned_Longword, Unsigned_Word_Array, Time),
+ (Value, Reference, Reference));
+
+ Status : Unsigned_Longword;
+ Timbuf : Unsigned_Word_Array (1 .. 7);
+ Date : Time;
+ Int_Secs : Integer;
+ Day_Hack : Boolean := False;
+ begin
+ -- The following checks are redundant with respect to the constraint
+ -- error checks that should normally be made on parameters, but we
+ -- decide to raise Constraint_Error in any case if bad values come
+ -- in (as a result of checks being off in the caller, or for other
+ -- erroneous or bounded error cases).
+
+ if not Year 'Valid
+ or else not Month 'Valid
+ or else not Day 'Valid
+ or else not Seconds'Valid
+ then
+ raise Constraint_Error;
+ end if;
+
+ -- Truncate seconds value by subtracting 0.5 and rounding,
+ -- but be careful with 0.0 since that will give -1.0 unless
+ -- it is treated specially.
+
+ if Seconds > 0.0 then
+ Int_Secs := Integer (Seconds - 0.5);
+ else
+ Int_Secs := Integer (Seconds);
+ end if;
+
+ -- Cvt_Vectim barfs on the largest Day_Duration, so trick it by
+ -- setting it to zero and then adding the difference after conversion.
+
+ if Int_Secs = 86_400 then
+ Int_Secs := 0;
+ Day_Hack := True;
+ Timbuf (7) := 0;
+ else
+ Timbuf (7) := Unsigned_Word
+ (100.0 * Duration (Seconds - Day_Duration (Int_Secs)));
+ -- Cvt_Vectim accurate only to within .01 seconds
+ end if;
+
+ -- Similar hack needed for 86399 and 100/100ths, since that gets
+ -- treated as 86400 (largest Day_Duration). This can happen because
+ -- Duration has more accuracy than VMS system time conversion calls
+ -- can handle.
+
+ if Int_Secs = 86_399 and then Timbuf (7) = 100 then
+ Int_Secs := 0;
+ Day_Hack := True;
+ Timbuf (7) := 0;
+ end if;
+
+ Timbuf (6) := Unsigned_Word (Int_Secs mod 60);
+ Timbuf (5) := Unsigned_Word ((Int_Secs / 60) mod 60);
+ Timbuf (4) := Unsigned_Word (Int_Secs / 3600);
+ Timbuf (3) := Unsigned_Word (Day);
+ Timbuf (2) := Unsigned_Word (Month);
+ Timbuf (1) := Unsigned_Word (Year);
+
+ Cvt_Vectim (Status, Timbuf, Date);
+
+ if Status mod 2 /= 1 then
+ raise Time_Error;
+ end if;
+
+ if Day_Hack then
+ Date := Date + 10_000_000 * 86_400;
+ end if;
+
+ return Date;
+
+ end Time_Of;
+
+ ----------
+ -- Year --
+ ----------
+
+ function Year (Date : Time) return Year_Number is
+ DY : Year_Number;
+ DM : Month_Number;
+ DD : Day_Number;
+ DS : Day_Duration;
+
+ begin
+ Split (Date, DY, DM, DD, DS);
+ return DY;
+ end Year;
+
+end Ada.Calendar;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . C A L E N D A R --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Alpha/VMS version.
+
+with System.OS_Primitives;
+package Ada.Calendar is
+
+ package OSP renames System.OS_Primitives;
+
+ type Time is private;
+
+ -- Declarations representing limits of allowed local time values. Note that
+ -- these do NOT constrain the possible stored values of time which may well
+ -- permit a larger range of times (this is explicitly allowed in Ada 95).
+
+ subtype Year_Number is Integer range 1901 .. 2099;
+ subtype Month_Number is Integer range 1 .. 12;
+ subtype Day_Number is Integer range 1 .. 31;
+
+ subtype Day_Duration is Duration range 0.0 .. 86_400.0;
+
+ function Clock return Time;
+
+ function Year (Date : Time) return Year_Number;
+ function Month (Date : Time) return Month_Number;
+ function Day (Date : Time) return Day_Number;
+ function Seconds (Date : Time) return Day_Duration;
+
+ procedure Split
+ (Date : Time;
+ Year : out Year_Number;
+ Month : out Month_Number;
+ Day : out Day_Number;
+ Seconds : out Day_Duration);
+
+ function Time_Of
+ (Year : Year_Number;
+ Month : Month_Number;
+ Day : Day_Number;
+ Seconds : Day_Duration := 0.0)
+ return Time;
+
+ function "+" (Left : Time; Right : Duration) return Time;
+ function "+" (Left : Duration; Right : Time) return Time;
+ function "-" (Left : Time; Right : Duration) return Time;
+ function "-" (Left : Time; Right : Time) return Duration;
+
+ function "<" (Left, Right : Time) return Boolean;
+ function "<=" (Left, Right : Time) return Boolean;
+ function ">" (Left, Right : Time) return Boolean;
+ function ">=" (Left, Right : Time) return Boolean;
+
+ Time_Error : exception;
+
+private
+
+ pragma Inline (Clock);
+
+ pragma Inline (Year);
+ pragma Inline (Month);
+ pragma Inline (Day);
+
+ pragma Inline ("+");
+ pragma Inline ("-");
+
+ pragma Inline ("<");
+ pragma Inline ("<=");
+ pragma Inline (">");
+ pragma Inline (">=");
+
+ -- Time is represented as the number of 100-nanosecond (ns) units offset
+ -- from the system base date and time, which is 00:00 o'clock,
+ -- November 17, 1858 (the Smithsonian base date and time for the
+ -- astronomic calendar).
+
+ -- The time value stored is typically a GMT value, as provided in standard
+ -- Unix environments. If this is the case then Split and Time_Of perform
+ -- required conversions to and from local times.
+
+ type Time is new OSP.OS_Time;
+
+ -- Notwithstanding this definition, Time is not quite the same as OS_Time.
+ -- Relative Time is positive, whereas relative OS_Time is negative,
+ -- but this declaration makes for easier conversion.
+
+end Ada.Calendar;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1991-2000 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a OpenVMS/Alpha version of this package.
+--
+-- This target-dependent package spec contains names of interrupts
+-- supported by the local system.
+
+with System.OS_Interface;
+package Ada.Interrupts.Names is
+
+ package OS renames System.OS_Interface;
+
+ Interrupt_ID_0 : constant Interrupt_ID := OS.Interrupt_ID_0;
+ Interrupt_ID_1 : constant Interrupt_ID := OS.Interrupt_ID_1;
+ Interrupt_ID_2 : constant Interrupt_ID := OS.Interrupt_ID_2;
+ Interrupt_ID_3 : constant Interrupt_ID := OS.Interrupt_ID_3;
+ Interrupt_ID_4 : constant Interrupt_ID := OS.Interrupt_ID_4;
+ Interrupt_ID_5 : constant Interrupt_ID := OS.Interrupt_ID_5;
+ Interrupt_ID_6 : constant Interrupt_ID := OS.Interrupt_ID_6;
+ Interrupt_ID_7 : constant Interrupt_ID := OS.Interrupt_ID_7;
+ Interrupt_ID_8 : constant Interrupt_ID := OS.Interrupt_ID_8;
+ Interrupt_ID_9 : constant Interrupt_ID := OS.Interrupt_ID_9;
+ Interrupt_ID_10 : constant Interrupt_ID := OS.Interrupt_ID_10;
+ Interrupt_ID_11 : constant Interrupt_ID := OS.Interrupt_ID_11;
+ Interrupt_ID_12 : constant Interrupt_ID := OS.Interrupt_ID_12;
+ Interrupt_ID_13 : constant Interrupt_ID := OS.Interrupt_ID_13;
+ Interrupt_ID_14 : constant Interrupt_ID := OS.Interrupt_ID_14;
+ Interrupt_ID_15 : constant Interrupt_ID := OS.Interrupt_ID_15;
+ Interrupt_ID_16 : constant Interrupt_ID := OS.Interrupt_ID_16;
+ Interrupt_ID_17 : constant Interrupt_ID := OS.Interrupt_ID_17;
+ Interrupt_ID_18 : constant Interrupt_ID := OS.Interrupt_ID_18;
+ Interrupt_ID_19 : constant Interrupt_ID := OS.Interrupt_ID_19;
+ Interrupt_ID_20 : constant Interrupt_ID := OS.Interrupt_ID_20;
+ Interrupt_ID_21 : constant Interrupt_ID := OS.Interrupt_ID_21;
+ Interrupt_ID_22 : constant Interrupt_ID := OS.Interrupt_ID_22;
+ Interrupt_ID_23 : constant Interrupt_ID := OS.Interrupt_ID_23;
+ Interrupt_ID_24 : constant Interrupt_ID := OS.Interrupt_ID_24;
+ Interrupt_ID_25 : constant Interrupt_ID := OS.Interrupt_ID_25;
+ Interrupt_ID_26 : constant Interrupt_ID := OS.Interrupt_ID_26;
+ Interrupt_ID_27 : constant Interrupt_ID := OS.Interrupt_ID_27;
+ Interrupt_ID_28 : constant Interrupt_ID := OS.Interrupt_ID_28;
+ Interrupt_ID_29 : constant Interrupt_ID := OS.Interrupt_ID_29;
+ Interrupt_ID_30 : constant Interrupt_ID := OS.Interrupt_ID_30;
+ Interrupt_ID_31 : constant Interrupt_ID := OS.Interrupt_ID_31;
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . C A L E N D A R --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.14 $
+-- --
+-- Copyright (C) 1997-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Windows NT/95 version.
+
+with System.OS_Primitives;
+-- used for Clock
+
+with System.OS_Interface;
+
+package body Ada.Calendar is
+
+ use System.OS_Interface;
+
+ ------------------------------
+ -- Use of Pragma Unsuppress --
+ ------------------------------
+
+ -- This implementation of Calendar takes advantage of the permission in
+ -- Ada 95 of using arithmetic overflow checks to check for out of bounds
+ -- time values. This means that we must catch the constraint error that
+ -- results from arithmetic overflow, so we use pragma Unsuppress to make
+ -- sure that overflow is enabled, using software overflow checking if
+ -- necessary. That way, compiling Calendar with options to suppress this
+ -- checking will not affect its correctness.
+
+ ------------------------
+ -- Local Declarations --
+ ------------------------
+
+ Ada_Year_Min : constant := 1901;
+ Ada_Year_Max : constant := 2099;
+
+ -- Win32 time constants
+
+ epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch
+ system_time_ns : constant := 100; -- 100 ns per tick
+ Sec_Unit : constant := 10#1#E9;
+
+ ---------
+ -- "+" --
+ ---------
+
+ function "+" (Left : Time; Right : Duration) return Time is
+ pragma Unsuppress (Overflow_Check);
+ begin
+ return (Left + Time (Right));
+
+ exception
+ when Constraint_Error =>
+ raise Time_Error;
+ end "+";
+
+ function "+" (Left : Duration; Right : Time) return Time is
+ pragma Unsuppress (Overflow_Check);
+ begin
+ return (Time (Left) + Right);
+
+ exception
+ when Constraint_Error =>
+ raise Time_Error;
+ end "+";
+
+ ---------
+ -- "-" --
+ ---------
+
+ function "-" (Left : Time; Right : Duration) return Time is
+ pragma Unsuppress (Overflow_Check);
+ begin
+ return Left - Time (Right);
+
+ exception
+ when Constraint_Error =>
+ raise Time_Error;
+ end "-";
+
+ function "-" (Left : Time; Right : Time) return Duration is
+ pragma Unsuppress (Overflow_Check);
+ begin
+ return Duration (Left) - Duration (Right);
+
+ exception
+ when Constraint_Error =>
+ raise Time_Error;
+ end "-";
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<" (Left, Right : Time) return Boolean is
+ begin
+ return Duration (Left) < Duration (Right);
+ end "<";
+
+ ----------
+ -- "<=" --
+ ----------
+
+ function "<=" (Left, Right : Time) return Boolean is
+ begin
+ return Duration (Left) <= Duration (Right);
+ end "<=";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">" (Left, Right : Time) return Boolean is
+ begin
+ return Duration (Left) > Duration (Right);
+ end ">";
+
+ ----------
+ -- ">=" --
+ ----------
+
+ function ">=" (Left, Right : Time) return Boolean is
+ begin
+ return Duration (Left) >= Duration (Right);
+ end ">=";
+
+ -----------
+ -- Clock --
+ -----------
+
+ -- The Ada.Calendar.Clock function gets the time from the soft links
+ -- interface which will call the appropriate function depending wether
+ -- tasking is involved or not.
+
+ function Clock return Time is
+ begin
+ return Time (System.OS_Primitives.Clock);
+ end Clock;
+
+ ---------
+ -- Day --
+ ---------
+
+ function Day (Date : Time) return Day_Number is
+ DY : Year_Number;
+ DM : Month_Number;
+ DD : Day_Number;
+ DS : Day_Duration;
+
+ begin
+ Split (Date, DY, DM, DD, DS);
+ return DD;
+ end Day;
+
+ -----------
+ -- Month --
+ -----------
+
+ function Month (Date : Time) return Month_Number is
+ DY : Year_Number;
+ DM : Month_Number;
+ DD : Day_Number;
+ DS : Day_Duration;
+
+ begin
+ Split (Date, DY, DM, DD, DS);
+ return DM;
+ end Month;
+
+ -------------
+ -- Seconds --
+ -------------
+
+ function Seconds (Date : Time) return Day_Duration is
+ DY : Year_Number;
+ DM : Month_Number;
+ DD : Day_Number;
+ DS : Day_Duration;
+
+ begin
+ Split (Date, DY, DM, DD, DS);
+ return DS;
+ end Seconds;
+
+ -----------
+ -- Split --
+ -----------
+
+ procedure Split
+ (Date : Time;
+ Year : out Year_Number;
+ Month : out Month_Number;
+ Day : out Day_Number;
+ Seconds : out Day_Duration)
+ is
+
+ Date_Int : aliased Long_Long_Integer;
+ Date_Loc : aliased Long_Long_Integer;
+ Timbuf : aliased SYSTEMTIME;
+ Int_Date : Long_Long_Integer;
+ Sub_Seconds : Duration;
+
+ begin
+ -- We take the sub-seconds (decimal part) of Date and this is added
+ -- to compute the Seconds. This way we keep the precision of the
+ -- high-precision clock that was lost with the Win32 API calls
+ -- below.
+
+ if Date < 0.0 then
+
+ -- this is a Date before Epoch (January 1st, 1970)
+
+ Sub_Seconds := Duration (Date) -
+ Duration (Long_Long_Integer (Date + Duration'(0.5)));
+
+ Int_Date := Long_Long_Integer (Date - Sub_Seconds);
+
+ -- For Date = -86400.1 we are 2 days before Epoch at 0.1 seconds
+ -- from day 1 before Epoch. It means that it is 23h 59m 59.9s.
+ -- here we adjust for that.
+
+ if Sub_Seconds < 0.0 then
+ Int_Date := Int_Date - 1;
+ Sub_Seconds := 1.0 + Sub_Seconds;
+ end if;
+
+ else
+
+ -- this is a Date after Epoch (January 1st, 1970)
+
+ Sub_Seconds := Duration (Date) -
+ Duration (Long_Long_Integer (Date - Duration'(0.5)));
+
+ Int_Date := Long_Long_Integer (Date - Sub_Seconds);
+
+ end if;
+
+ -- Date_Int is the number of seconds from Epoch.
+
+ Date_Int := Long_Long_Integer
+ (Int_Date * Sec_Unit / system_time_ns) + epoch_1970;
+
+ if not FileTimeToLocalFileTime (Date_Int'Access, Date_Loc'Access) then
+ raise Time_Error;
+ end if;
+
+ if not FileTimeToSystemTime (Date_Loc'Access, Timbuf'Access) then
+ raise Time_Error;
+ end if;
+
+ if Timbuf.wYear not in Ada_Year_Min .. Ada_Year_Max then
+ raise Time_Error;
+ end if;
+
+ Seconds :=
+ Duration (Timbuf.wHour) * 3_600.0 +
+ Duration (Timbuf.wMinute) * 60.0 +
+ Duration (Timbuf.wSecond) +
+ Sub_Seconds;
+
+ Day := Integer (Timbuf.wDay);
+ Month := Integer (Timbuf.wMonth);
+ Year := Integer (Timbuf.wYear);
+ end Split;
+
+ -------------
+ -- Time_Of --
+ -------------
+
+ function Time_Of
+ (Year : Year_Number;
+ Month : Month_Number;
+ Day : Day_Number;
+ Seconds : Day_Duration := 0.0)
+ return Time
+ is
+
+ Timbuf : aliased SYSTEMTIME;
+ Now : aliased Long_Long_Integer;
+ Loc : aliased Long_Long_Integer;
+ Int_Secs : Integer;
+ Secs : Integer;
+ Add_One_Day : Boolean := False;
+ Date : Time;
+
+ begin
+ -- The following checks are redundant with respect to the constraint
+ -- error checks that should normally be made on parameters, but we
+ -- decide to raise Constraint_Error in any case if bad values come
+ -- in (as a result of checks being off in the caller, or for other
+ -- erroneous or bounded error cases).
+
+ if not Year 'Valid
+ or else not Month 'Valid
+ or else not Day 'Valid
+ or else not Seconds'Valid
+ then
+ raise Constraint_Error;
+ end if;
+
+ if Seconds = 0.0 then
+ Int_Secs := 0;
+ else
+ Int_Secs := Integer (Seconds - 0.5);
+ end if;
+
+ -- Timbuf.wMillisec is to keep the msec. We can't use that because the
+ -- high-resolution clock has a precision of 1 Microsecond.
+ -- Anyway the sub-seconds part is not needed to compute the number
+ -- of seconds in UTC.
+
+ if Int_Secs = 86_400 then
+ Secs := 0;
+ Add_One_Day := True;
+ else
+ Secs := Int_Secs;
+ end if;
+
+ Timbuf.wMilliseconds := 0;
+ Timbuf.wSecond := WORD (Secs mod 60);
+ Timbuf.wMinute := WORD ((Secs / 60) mod 60);
+ Timbuf.wHour := WORD (Secs / 3600);
+ Timbuf.wDay := WORD (Day);
+ Timbuf.wMonth := WORD (Month);
+ Timbuf.wYear := WORD (Year);
+
+ if not SystemTimeToFileTime (Timbuf'Access, Loc'Access) then
+ raise Time_Error;
+ end if;
+
+ if not LocalFileTimeToFileTime (Loc'Access, Now'Access) then
+ raise Time_Error;
+ end if;
+
+ -- Here we have the UTC now translate UTC to Epoch time (UNIX style
+ -- time based on 1 january 1970) and add there the sub-seconds part.
+
+ declare
+ Sub_Sec : Duration := Seconds - Duration (Int_Secs);
+ begin
+ Date := Time ((Now - epoch_1970) * system_time_ns / Sec_Unit) +
+ Sub_Sec;
+ end;
+
+ if Add_One_Day then
+ Date := Date + Duration (86400.0);
+ end if;
+
+ return Date;
+ end Time_Of;
+
+ ----------
+ -- Year --
+ ----------
+
+ function Year (Date : Time) return Year_Number is
+ DY : Year_Number;
+ DM : Month_Number;
+ DD : Day_Number;
+ DS : Day_Duration;
+
+ begin
+ Split (Date, DY, DM, DD, DS);
+ return DY;
+ end Year;
+
+end Ada.Calendar;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . E X C E P T I O N S . P O L L --
+-- (version supporting asynchronous abort test) --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.9 $
+-- --
+-- Copyright (C) 1992-2000, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for targets that do not support per-thread asynchronous
+-- signals. On such targets, we require compilation with the -gnatP switch
+-- that activates periodic polling. Then in the body of the polling routine
+-- we test for asynchronous abort.
+
+-- NT, OS/2, HPUX/DCE and SCO currently use this file
+
+with System.Soft_Links;
+-- used for Check_Abort_Status
+
+separate (Ada.Exceptions)
+
+----------
+-- Poll --
+----------
+
+procedure Poll is
+begin
+ -- Test for asynchronous abort on each poll
+
+ if System.Soft_Links.Check_Abort_Status.all /= 0 then
+ raise Standard'Abort_Signal;
+ end if;
+end Poll;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1997-1998 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a NT (native) version of this package.
+
+-- This target-dependent package spec contains names of interrupts
+-- supported by the local system.
+
+with System.OS_Interface;
+-- used for names of interrupts
+
+package Ada.Interrupts.Names is
+
+ -- Beware that the mapping of names to signals may be
+ -- many-to-one. There may be aliases. Also, for all
+ -- signal names that are not supported on the current system
+ -- the value of the corresponding constant will be zero.
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGABRT : constant Interrupt_ID := -- used by abort,
+ System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
+
+ SIGFPE : constant Interrupt_ID :=
+ System.OS_Interface.SIGFPE; -- floating point exception
+
+ SIGSEGV : constant Interrupt_ID :=
+ System.OS_Interface.SIGSEGV; -- segmentation violation
+
+ SIGTERM : constant Interrupt_ID :=
+ System.OS_Interface.SIGTERM; -- software termination signal from kill
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks version of this package.
+--
+-- The following signals are reserved by the run time:
+--
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT
+--
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+--
+-- none
+
+-- This target-dependent package spec contains names of interrupts
+-- supported by the local system.
+
+with System.OS_Interface;
+with System.VxWorks;
+
+package Ada.Interrupts.Names is
+
+ subtype Hardware_Interrupts is Interrupt_ID
+ range Interrupt_ID'First .. System.OS_Interface.Max_HW_Interrupt;
+ -- Range of values that can be used for hardware interrupts.
+
+ -- The following constants can be used for software interrupts mapped to
+ -- user-level signals:
+
+ SIGHUP : constant Interrupt_ID;
+ -- hangup
+
+ SIGINT : constant Interrupt_ID;
+ -- interrupt
+
+ SIGQUIT : constant Interrupt_ID;
+ -- quit
+
+ SIGILL : constant Interrupt_ID;
+ -- illegal instruction (not reset)
+
+ SIGTRAP : constant Interrupt_ID;
+ -- trace trap (not reset)
+
+ SIGIOT : constant Interrupt_ID;
+ -- IOT instruction
+
+ SIGABRT : constant Interrupt_ID;
+ -- used by abort, replace SIGIOT
+
+ SIGEMT : constant Interrupt_ID;
+ -- EMT instruction
+
+ SIGFPE : constant Interrupt_ID;
+ -- floating point exception
+
+ SIGKILL : constant Interrupt_ID;
+ -- kill (cannot be caught or ignored)
+
+ SIGBUS : constant Interrupt_ID;
+ -- bus error
+
+ SIGSEGV : constant Interrupt_ID;
+ -- segmentation violation
+
+ SIGSYS : constant Interrupt_ID;
+ -- bad argument to system call
+
+ SIGPIPE : constant Interrupt_ID;
+ -- no one to read it
+
+ SIGALRM : constant Interrupt_ID;
+ -- alarm clock
+
+ SIGTERM : constant Interrupt_ID;
+ -- software termination signal from kill
+
+ SIGURG : constant Interrupt_ID;
+ -- urgent condition on IO channel
+
+ SIGSTOP : constant Interrupt_ID;
+ -- stop (cannot be caught or ignored)
+
+ SIGTSTP : constant Interrupt_ID;
+ -- user stop requested from tty
+
+ SIGCONT : constant Interrupt_ID;
+ -- stopped process has been continued
+
+ SIGCHLD : constant Interrupt_ID;
+ -- child status change
+
+ SIGTTIN : constant Interrupt_ID;
+ -- background tty read attempted
+
+ SIGTTOU : constant Interrupt_ID;
+ -- background tty write attempted
+
+ SIGIO : constant Interrupt_ID;
+ -- input/output possible,
+
+ SIGXCPU : constant Interrupt_ID;
+ -- CPU time limit exceeded
+
+ SIGXFSZ : constant Interrupt_ID;
+ -- filesize limit exceeded
+
+ SIGVTALRM : constant Interrupt_ID;
+ -- virtual timer expired
+
+ SIGPROF : constant Interrupt_ID;
+ -- profiling timer expired
+
+ SIGWINCH : constant Interrupt_ID;
+ -- window size change
+
+ SIGUSR1 : constant Interrupt_ID;
+ -- user defined signal 1
+
+ SIGUSR2 : constant Interrupt_ID;
+ -- user defined signal 2
+
+private
+
+ Signal_Base : constant := System.VxWorks.Num_HW_Interrupts;
+
+ SIGHUP : constant Interrupt_ID := 1 + Signal_Base;
+ SIGINT : constant Interrupt_ID := 2 + Signal_Base;
+ SIGQUIT : constant Interrupt_ID := 3 + Signal_Base;
+ SIGILL : constant Interrupt_ID := 4 + Signal_Base;
+ SIGTRAP : constant Interrupt_ID := 5 + Signal_Base;
+ SIGIOT : constant Interrupt_ID := 6 + Signal_Base;
+ SIGABRT : constant Interrupt_ID := 6 + Signal_Base;
+ SIGEMT : constant Interrupt_ID := 7 + Signal_Base;
+ SIGFPE : constant Interrupt_ID := 8 + Signal_Base;
+ SIGKILL : constant Interrupt_ID := 9 + Signal_Base;
+ SIGBUS : constant Interrupt_ID := 10 + Signal_Base;
+ SIGSEGV : constant Interrupt_ID := 11 + Signal_Base;
+ SIGSYS : constant Interrupt_ID := 12 + Signal_Base;
+ SIGPIPE : constant Interrupt_ID := 13 + Signal_Base;
+ SIGALRM : constant Interrupt_ID := 14 + Signal_Base;
+ SIGTERM : constant Interrupt_ID := 15 + Signal_Base;
+ SIGURG : constant Interrupt_ID := 16 + Signal_Base;
+ SIGSTOP : constant Interrupt_ID := 17 + Signal_Base;
+ SIGTSTP : constant Interrupt_ID := 18 + Signal_Base;
+ SIGCONT : constant Interrupt_ID := 19 + Signal_Base;
+ SIGCHLD : constant Interrupt_ID := 20 + Signal_Base;
+ SIGTTIN : constant Interrupt_ID := 21 + Signal_Base;
+ SIGTTOU : constant Interrupt_ID := 22 + Signal_Base;
+ SIGIO : constant Interrupt_ID := 23 + Signal_Base;
+ SIGXCPU : constant Interrupt_ID := 24 + Signal_Base;
+ SIGXFSZ : constant Interrupt_ID := 25 + Signal_Base;
+ SIGVTALRM : constant Interrupt_ID := 26 + Signal_Base;
+ SIGPROF : constant Interrupt_ID := 27 + Signal_Base;
+ SIGWINCH : constant Interrupt_ID := 28 + Signal_Base;
+ SIGUSR1 : constant Interrupt_ID := 30 + Signal_Base;
+ SIGUSR2 : constant Interrupt_ID := 31 + Signal_Base;
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . N U M E R I C S . A U X --
+-- --
+-- S p e c --
+-- (C Library Version, VxWorks) --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides the basic computational interface for the generic
+-- elementary functions. The C library version interfaces with the routines
+-- in the C mathematical library, and is thus quite portable, although it may
+-- not necessarily meet the requirements for accuracy in the numerics annex.
+-- One advantage of using this package is that it will interface directly to
+-- hardware instructions, such as the those provided on the Intel x86.
+
+-- Note: there are two versions of this package. One using the normal IEEE
+-- 64-bit double format (which is this version), and one using 80-bit x86
+-- long double (see file 4onumaux.ads).
+
+package Ada.Numerics.Aux is
+pragma Pure (Aux);
+
+ -- This version omits the pragma linker_options ("-lm") since there is
+ -- no libm.a library for VxWorks.
+
+ type Double is digits 15;
+ pragma Float_Representation (IEEE_Float, Double);
+ -- Type Double is the type used to call the C routines. Note that this
+ -- is IEEE format even when running on VMS with Vax_Float representation
+ -- since we use the IEEE version of the C library with VMS.
+
+ function Sin (X : Double) return Double;
+ pragma Import (C, Sin, "sin");
+
+ function Cos (X : Double) return Double;
+ pragma Import (C, Cos, "cos");
+
+ function Tan (X : Double) return Double;
+ pragma Import (C, Tan, "tan");
+
+ function Exp (X : Double) return Double;
+ pragma Import (C, Exp, "exp");
+
+ function Sqrt (X : Double) return Double;
+ pragma Import (C, Sqrt, "sqrt");
+
+ function Log (X : Double) return Double;
+ pragma Import (C, Log, "log");
+
+ function Acos (X : Double) return Double;
+ pragma Import (C, Acos, "acos");
+
+ function Asin (X : Double) return Double;
+ pragma Import (C, Asin, "asin");
+
+ function Atan (X : Double) return Double;
+ pragma Import (C, Atan, "atan");
+
+ function Sinh (X : Double) return Double;
+ pragma Import (C, Sinh, "sinh");
+
+ function Cosh (X : Double) return Double;
+ pragma Import (C, Cosh, "cosh");
+
+ function Tanh (X : Double) return Double;
+ pragma Import (C, Tanh, "tanh");
+
+ function Pow (X, Y : Double) return Double;
+ pragma Import (C, Pow, "pow");
+
+end Ada.Numerics.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S Y N C H R O N O U S _ T A S K _ C O N T R O L --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Interfaces.C;
+package body Ada.Synchronous_Task_Control is
+ use System.OS_Interface;
+ use type Interfaces.C.int;
+
+ -------------------
+ -- Current_State --
+ -------------------
+
+ function Current_State (S : Suspension_Object) return Boolean is
+ St : STATUS;
+ Result : Boolean := False;
+
+ begin
+ -- Determine state by attempting to take the semaphore with
+ -- a 0 timeout value. Status = OK indicates the semaphore was
+ -- full, so reset it to the full state.
+
+ St := semTake (S.Sema, NO_WAIT);
+
+ if St = OK then
+ -- Took the semaphore. Reset semaphore state to FULL
+ Result := True;
+ St := semGive (S.Sema);
+ end if;
+
+ return Result;
+ end Current_State;
+
+ ---------------
+ -- Set_False --
+ ---------------
+
+ procedure Set_False (S : in out Suspension_Object) is
+ St : STATUS;
+ begin
+ -- Need to get the semaphore into the "empty" state.
+ -- On return, this task will have made the semaphore
+ -- empty (St = OK) or have left it empty.
+ St := semTake (S.Sema, NO_WAIT);
+ end Set_False;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True (S : in out Suspension_Object) is
+ St : STATUS;
+ begin
+ St := semGive (S.Sema);
+ end Set_True;
+
+ ------------------------
+ -- Suspend_Until_True --
+ ------------------------
+
+ procedure Suspend_Until_True (S : in out Suspension_Object) is
+ St : STATUS;
+
+ -- Declare local exception so the mutex can still be reset
+ -- to full if Program_Error is raised
+
+ Task_Already_Pending : exception;
+ begin
+ -- Determine whether another task is pending on the suspension
+ -- object. Should never be called from an ISR. Therefore semTake can
+ -- be called on the mutex
+ St := semTake (S.Mutex, NO_WAIT);
+
+ if St = OK then
+ -- Wait for suspension object
+
+ St := semTake (S.Sema, WAIT_FOREVER);
+ St := semGive (S.Mutex);
+
+ else
+ -- Another task is pending on the suspension object
+
+ raise Task_Already_Pending;
+ end if;
+ exception
+ when Task_Already_Pending =>
+ raise Program_Error;
+ when others =>
+ St := semGive (S.Mutex);
+ raise;
+ end Suspend_Until_True;
+
+ procedure Initialize (S : in out Suspension_Object) is
+ begin
+ S.Sema := semBCreate (SEM_Q_FIFO, SEM_EMPTY);
+
+ -- Use simpler binary semaphore instead of VxWorks
+ -- mutual exclusion semaphore, because we don't need
+ -- the fancier semantics and their overhead.
+
+ S.Mutex := semBCreate (SEM_Q_FIFO, SEM_FULL);
+ end Initialize;
+
+ procedure Finalize (S : in out Suspension_Object) is
+ St : STATUS;
+ begin
+ St := semDelete (S.Sema);
+ St := semDelete (S.Mutex);
+ end Finalize;
+
+end Ada.Synchronous_Task_Control;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S Y N C H R O N O U S _ T A S K _ C O N T R O L --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.OS_Interface;
+with Ada.Finalization;
+package Ada.Synchronous_Task_Control is
+
+ type Suspension_Object is limited private;
+
+ procedure Set_True (S : in out Suspension_Object);
+
+ procedure Set_False (S : in out Suspension_Object);
+
+ function Current_State (S : Suspension_Object) return Boolean;
+
+ procedure Suspend_Until_True (S : in out Suspension_Object);
+
+private
+
+ procedure Initialize (S : in out Suspension_Object);
+
+ procedure Finalize (S : in out Suspension_Object);
+
+ -- Implement with a VxWorks binary semaphore. A second semaphore
+ -- is used to avoid a race condition related to the implementation of
+ -- the STC requirement to raise Program_Error when Suspend_Until_True is
+ -- called with a task already pending on the suspension object
+
+ type Suspension_Object is new Ada.Finalization.Controlled with record
+ Sema : System.OS_Interface.SEM_ID;
+ Mutex : System.OS_Interface.SEM_ID;
+ end record;
+
+end Ada.Synchronous_Task_Control;
OSDN Git Service
