diff -Nrc3pad gcc-3.3.3/gcc/ada/1aexcept.adb gcc-3.4.0/gcc/ada/1aexcept.adb *** gcc-3.3.3/gcc/ada/1aexcept.adb 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/1aexcept.adb 2003-04-24 17:53:50.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/1aexcept.ads gcc-3.4.0/gcc/ada/1aexcept.ads *** gcc-3.3.3/gcc/ada/1aexcept.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/1aexcept.ads 2003-04-24 17:53:50.000000000 +0000 *************** *** 7,14 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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 -- --- 7,13 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2003 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 -- diff -Nrc3pad gcc-3.3.3/gcc/ada/1ic.ads gcc-3.4.0/gcc/ada/1ic.ads *** gcc-3.3.3/gcc/ada/1ic.ads 2002-03-14 10:58:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/1ic.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 1,4 **** ! ----------------------------------------------------------------------------- -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- 1,4 ---- ! ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/1ssecsta.adb gcc-3.4.0/gcc/ada/1ssecsta.adb *** gcc-3.3.3/gcc/ada/1ssecsta.adb 2002-10-23 08:04:16.000000000 +0000 --- gcc-3.4.0/gcc/ada/1ssecsta.adb 2004-01-12 11:45:23.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- *************** package body System.Secondary_Stack is *** 95,101 **** end if; Address := Sec_Stack.Mem (Sec_Stack.Top)'Address; ! Sec_Stack.Top := Sec_Stack.Top + Mark_Id (Max_Size); end SS_Allocate; ------------- --- 94,100 ---- end if; Address := Sec_Stack.Mem (Sec_Stack.Top)'Address; ! Sec_Stack.Top := Sec_Stack.Top + Max_Size; end SS_Allocate; ------------- diff -Nrc3pad gcc-3.3.3/gcc/ada/1ssecsta.ads gcc-3.4.0/gcc/ada/1ssecsta.ads *** gcc-3.3.3/gcc/ada/1ssecsta.ads 2002-10-23 08:04:16.000000000 +0000 --- gcc-3.4.0/gcc/ada/1ssecsta.ads 2004-01-05 15:20:42.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2003 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- -- *************** *** 32,45 **** -- -- ------------------------------------------------------------------------------ with System.Storage_Elements; package System.Secondary_Stack is package SSE renames System.Storage_Elements; ! Default_Secondary_Stack_Size : constant := 10 * 1024; ! -- Default size of a secondary stack procedure SS_Init (Stk : System.Address; --- 31,46 ---- -- -- ------------------------------------------------------------------------------ + -- Version for use in HI-E mode + with System.Storage_Elements; package System.Secondary_Stack is package SSE renames System.Storage_Elements; ! Default_Secondary_Stack_Size : Natural := 10 * 1024; ! -- Default size of a secondary stack. May be modified by binder -D switch procedure SS_Init (Stk : System.Address; diff -Nrc3pad gcc-3.3.3/gcc/ada/31soccon.ads gcc-3.4.0/gcc/ada/31soccon.ads *** gcc-3.3.3/gcc/ada/31soccon.ads 2002-03-14 10:58:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/31soccon.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2003 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- -- *************** *** 27,114 **** -- 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; --- 26,158 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNAT was originally developed by the GNAT team at New York University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ + -- This package provides target dependent definitions of constant for use + -- by the GNAT.Sockets package (g-socket.ads). This package should not be + -- directly with'ed by an applications program. + -- This is the version for UnixWare package GNAT.Sockets.Constants is ! -------------- ! -- Families -- ! -------------- ! AF_INET : constant := 2; -- IPv4 address family ! AF_INET6 : constant := 27; -- IPv6 address family ! ----------- ! -- Modes -- ! ----------- ! SOCK_STREAM : constant := 2; -- Stream socket ! SOCK_DGRAM : constant := 1; -- Datagram socket ! ------------------- ! -- Socket errors -- ! ------------------- ! EACCES : constant := 13; -- Permission denied ! EADDRINUSE : constant := 125; -- Address already in use ! EADDRNOTAVAIL : constant := 126; -- Cannot assign address ! EAFNOSUPPORT : constant := 124; -- Addr family not supported ! EALREADY : constant := 149; -- Operation in progress ! EBADF : constant := 9; -- Bad file descriptor ! ECONNABORTED : constant := 130; -- Connection aborted ! ECONNREFUSED : constant := 146; -- Connection refused ! ECONNRESET : constant := 131; -- Connection reset by peer ! EDESTADDRREQ : constant := 96; -- Destination addr required ! EFAULT : constant := 14; -- Bad address ! EHOSTDOWN : constant := 147; -- Host is down ! EHOSTUNREACH : constant := 148; -- No route to host ! EINPROGRESS : constant := 150; -- Operation now in progress ! EINTR : constant := 4; -- Interrupted system call ! EINVAL : constant := 22; -- Invalid argument ! EIO : constant := 5; -- Input output error ! EISCONN : constant := 133; -- Socket already connected ! ELOOP : constant := 90; -- Too many symbolic lynks ! EMFILE : constant := 24; -- Too many open files ! EMSGSIZE : constant := 97; -- Message too long ! ENAMETOOLONG : constant := 78; -- Name too long ! ENETDOWN : constant := 127; -- Network is down ! ENETRESET : constant := 129; -- Disconn. on network reset ! ENETUNREACH : constant := 128; -- Network is unreachable ! ENOBUFS : constant := 132; -- No buffer space available ! ENOPROTOOPT : constant := 99; -- Protocol not available ! ENOTCONN : constant := 134; -- Socket not connected ! ENOTSOCK : constant := 95; -- Operation on non socket ! EOPNOTSUPP : constant := 122; -- Operation not supported ! EPFNOSUPPORT : constant := 123; -- Unknown protocol family ! EPROTONOSUPPORT : constant := 120; -- Unknown protocol ! EPROTOTYPE : constant := 98; -- Unknown protocol type ! ESHUTDOWN : constant := 143; -- Cannot send once shutdown ! ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported ! ETIMEDOUT : constant := 145; -- Connection timed out ! ETOOMANYREFS : constant := 144; -- Too many references ! EWOULDBLOCK : constant := 11; -- Operation would block ! ----------------- ! -- Host errors -- ! ----------------- ! HOST_NOT_FOUND : constant := 1; -- Unknown host ! TRY_AGAIN : constant := 2; -- Host name lookup failure ! NO_DATA : constant := 4; -- No data record for name ! NO_RECOVERY : constant := 3; -- Non recoverable errors ! ------------------- ! -- Control flags -- ! ------------------- ! FIONBIO : constant := -2147195266; -- Set/clear non-blocking io ! FIONREAD : constant := 1074030207; -- How many bytes to read ! -------------------- ! -- Shutdown modes -- ! -------------------- ! SHUT_RD : constant := 0; -- No more recv ! SHUT_WR : constant := 1; -- No more send ! SHUT_RDWR : constant := 2; -- No more recv/send ! --------------------- ! -- Protocol levels -- ! --------------------- ! SOL_SOCKET : constant := 65535; -- Options for socket level ! IPPROTO_IP : constant := 0; -- Dummy protocol for IP ! IPPROTO_UDP : constant := 17; -- UDP ! IPPROTO_TCP : constant := 6; -- TCP ! ------------------- ! -- Request flags -- ! ------------------- ! ! MSG_OOB : constant := 1; -- Process out-of-band data ! MSG_PEEK : constant := 2; -- Peek at incoming data ! MSG_EOR : constant := 8; -- Send end of record ! MSG_WAITALL : constant := 64; -- Wait for full reception ! ! -------------------- ! -- Socket options -- ! -------------------- ! ! TCP_NODELAY : constant := 1; -- Do not coalesce packets ! SO_SNDBUF : constant := 4097; -- Set/get send buffer size ! SO_RCVBUF : constant := 4098; -- Set/get recv buffer size ! SO_REUSEADDR : constant := 4; -- Bind reuse local address ! SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs ! SO_LINGER : constant := 128; -- Defer close to flush data ! SO_ERROR : constant := 4103; -- Get/clear error status ! SO_BROADCAST : constant := 32; -- Can send broadcast msgs ! IP_ADD_MEMBERSHIP : constant := 11; -- Join a multicast group ! IP_DROP_MEMBERSHIP : constant := 12; -- Leave a multicast group ! IP_MULTICAST_TTL : constant := 16; -- Set/get multicast TTL ! IP_MULTICAST_LOOP : constant := 10; -- Set/get mcast loopback end GNAT.Sockets.Constants; diff -Nrc3pad gcc-3.3.3/gcc/ada/31soliop.ads gcc-3.4.0/gcc/ada/31soliop.ads *** gcc-3.3.3/gcc/ada/31soliop.ads 2002-03-14 10:58:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/31soliop.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2002-2003 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- -- *************** *** 27,43 **** -- 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; --- 26,43 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNAT was originally developed by the GNAT team at New York University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This package is used to provide target specific linker_options for the ! -- support of scokets as required by the package GNAT.Sockets. ! -- This is the UnixWare version of this package + package GNAT.Sockets.Linker_Options is private pragma Linker_Options ("-lnsl"); pragma Linker_Options ("-lsocket"); end GNAT.Sockets.Linker_Options; diff -Nrc3pad gcc-3.3.3/gcc/ada/35soccon.ads gcc-3.4.0/gcc/ada/35soccon.ads *** gcc-3.3.3/gcc/ada/35soccon.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/35soccon.ads 2003-11-20 17:51:26.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S O C K E T S . C O N S T A N T S -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2000-2003 Free Software Foundation, Inc. -- + -- -- + -- GNAT is free software; you can redistribute it and/or modify it under -- + -- terms of the GNU General Public License as published by the Free Soft- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- + -- MA 02111-1307, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package provides target dependent definitions of constant for use + -- by the GNAT.Sockets package (g-socket.ads). This package should not be + -- directly with'ed by an applications program. + + -- This is the version for i386 FreeBSD + + package GNAT.Sockets.Constants is + + -------------- + -- Families -- + -------------- + + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 28; -- IPv6 address family + + ----------- + -- Modes -- + ----------- + + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket + + ------------------- + -- Socket errors -- + ------------------- + + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 48; -- Address already in use + EADDRNOTAVAIL : constant := 49; -- Cannot assign address + EAFNOSUPPORT : constant := 47; -- Addr family not supported + EALREADY : constant := 37; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 53; -- Connection aborted + ECONNREFUSED : constant := 61; -- Connection refused + ECONNRESET : constant := 54; -- Connection reset by peer + EDESTADDRREQ : constant := 39; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 64; -- Host is down + EHOSTUNREACH : constant := 65; -- No route to host + EINPROGRESS : constant := 36; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 56; -- Socket already connected + ELOOP : constant := 62; -- Too many symbolic lynks + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 40; -- Message too long + ENAMETOOLONG : constant := 63; -- Name too long + ENETDOWN : constant := 50; -- Network is down + ENETRESET : constant := 52; -- Disconn. on network reset + ENETUNREACH : constant := 51; -- Network is unreachable + ENOBUFS : constant := 55; -- No buffer space available + ENOPROTOOPT : constant := 42; -- Protocol not available + ENOTCONN : constant := 57; -- Socket not connected + ENOTSOCK : constant := 38; -- Operation on non socket + EOPNOTSUPP : constant := 45; -- Operation not supported + EPFNOSUPPORT : constant := 46; -- Unknown protocol family + EPROTONOSUPPORT : constant := 43; -- Unknown protocol + EPROTOTYPE : constant := 41; -- Unknown protocol type + ESHUTDOWN : constant := 58; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported + ETIMEDOUT : constant := 60; -- Connection timed out + ETOOMANYREFS : constant := 59; -- Too many references + EWOULDBLOCK : constant := 35; -- Operation would block + + ----------------- + -- Host errors -- + ----------------- + + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors + + ------------------- + -- Control flags -- + ------------------- + + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read + + -------------------- + -- Shutdown modes -- + -------------------- + + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send + + --------------------- + -- Protocol levels -- + --------------------- + + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP + + ------------------- + -- Request flags -- + ------------------- + + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + + -------------------- + -- Socket options -- + -------------------- + + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_ERROR : constant := 4103; -- Get/clear error status + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group + IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback + + end GNAT.Sockets.Constants; diff -Nrc3pad gcc-3.3.3/gcc/ada/3asoccon.ads gcc-3.4.0/gcc/ada/3asoccon.ads *** gcc-3.3.3/gcc/ada/3asoccon.ads 2002-03-14 10:58:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/3asoccon.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2003 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- -- *************** *** 27,114 **** -- 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; --- 26,158 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNAT was originally developed by the GNAT team at New York University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ + -- This package provides target dependent definitions of constant for use + -- by the GNAT.Sockets package (g-socket.ads). This package should not be + -- directly with'ed by an applications program. + -- This is the version for OSF package GNAT.Sockets.Constants is ! -------------- ! -- Families -- ! -------------- ! AF_INET : constant := 2; -- IPv4 address family ! AF_INET6 : constant := 26; -- IPv6 address family ! ----------- ! -- Modes -- ! ----------- ! SOCK_STREAM : constant := 1; -- Stream socket ! SOCK_DGRAM : constant := 2; -- Datagram socket ! ------------------- ! -- Socket errors -- ! ------------------- ! EACCES : constant := 13; -- Permission denied ! EADDRINUSE : constant := 48; -- Address already in use ! EADDRNOTAVAIL : constant := 49; -- Cannot assign address ! EAFNOSUPPORT : constant := 47; -- Addr family not supported ! EALREADY : constant := 37; -- Operation in progress ! EBADF : constant := 9; -- Bad file descriptor ! ECONNABORTED : constant := 53; -- Connection aborted ! ECONNREFUSED : constant := 61; -- Connection refused ! ECONNRESET : constant := 54; -- Connection reset by peer ! EDESTADDRREQ : constant := 39; -- Destination addr required ! EFAULT : constant := 14; -- Bad address ! EHOSTDOWN : constant := 64; -- Host is down ! EHOSTUNREACH : constant := 65; -- No route to host ! EINPROGRESS : constant := 36; -- Operation now in progress ! EINTR : constant := 4; -- Interrupted system call ! EINVAL : constant := 22; -- Invalid argument ! EIO : constant := 5; -- Input output error ! EISCONN : constant := 56; -- Socket already connected ! ELOOP : constant := 62; -- Too many symbolic lynks ! EMFILE : constant := 24; -- Too many open files ! EMSGSIZE : constant := 40; -- Message too long ! ENAMETOOLONG : constant := 63; -- Name too long ! ENETDOWN : constant := 50; -- Network is down ! ENETRESET : constant := 52; -- Disconn. on network reset ! ENETUNREACH : constant := 51; -- Network is unreachable ! ENOBUFS : constant := 55; -- No buffer space available ! ENOPROTOOPT : constant := 42; -- Protocol not available ! ENOTCONN : constant := 57; -- Socket not connected ! ENOTSOCK : constant := 38; -- Operation on non socket ! EOPNOTSUPP : constant := 45; -- Operation not supported ! EPFNOSUPPORT : constant := 46; -- Unknown protocol family ! EPROTONOSUPPORT : constant := 43; -- Unknown protocol ! EPROTOTYPE : constant := 41; -- Unknown protocol type ! ESHUTDOWN : constant := 58; -- Cannot send once shutdown ! ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported ! ETIMEDOUT : constant := 60; -- Connection timed out ! ETOOMANYREFS : constant := 59; -- Too many references ! EWOULDBLOCK : constant := 35; -- Operation would block ! ----------------- ! -- Host errors -- ! ----------------- ! HOST_NOT_FOUND : constant := 1; -- Unknown host ! TRY_AGAIN : constant := 2; -- Host name lookup failure ! NO_DATA : constant := 4; -- No data record for name ! NO_RECOVERY : constant := 3; -- Non recoverable errors ! ------------------- ! -- Control flags -- ! ------------------- ! FIONBIO : constant := -2147195266; -- Set/clear non-blocking io ! FIONREAD : constant := 1074030207; -- How many bytes to read ! -------------------- ! -- Shutdown modes -- ! -------------------- ! SHUT_RD : constant := 0; -- No more recv ! SHUT_WR : constant := 1; -- No more send ! SHUT_RDWR : constant := 2; -- No more recv/send ! --------------------- ! -- Protocol levels -- ! --------------------- ! SOL_SOCKET : constant := 65535; -- Options for socket level ! IPPROTO_IP : constant := 0; -- Dummy protocol for IP ! IPPROTO_UDP : constant := 17; -- UDP ! IPPROTO_TCP : constant := 6; -- TCP ! ------------------- ! -- Request flags -- ! ------------------- ! ! MSG_OOB : constant := 1; -- Process out-of-band data ! MSG_PEEK : constant := 2; -- Peek at incoming data ! MSG_EOR : constant := 8; -- Send end of record ! MSG_WAITALL : constant := 64; -- Wait for full reception ! ! -------------------- ! -- Socket options -- ! -------------------- ! ! TCP_NODELAY : constant := 1; -- Do not coalesce packets ! SO_SNDBUF : constant := 4097; -- Set/get send buffer size ! SO_RCVBUF : constant := 4098; -- Set/get recv buffer size ! SO_REUSEADDR : constant := 4; -- Bind reuse local address ! SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs ! SO_LINGER : constant := 128; -- Defer close to flush data ! SO_ERROR : constant := 4103; -- Get/clear error status ! SO_BROADCAST : constant := 32; -- Can send broadcast msgs ! IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group ! IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group ! IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL ! IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback end GNAT.Sockets.Constants; diff -Nrc3pad gcc-3.3.3/gcc/ada/3bsoccon.ads gcc-3.4.0/gcc/ada/3bsoccon.ads *** gcc-3.3.3/gcc/ada/3bsoccon.ads 2002-03-14 10:58:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/3bsoccon.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2003 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- -- *************** *** 27,114 **** -- 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; --- 26,158 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNAT was originally developed by the GNAT team at New York University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ + -- This package provides target dependent definitions of constant for use + -- by the GNAT.Sockets package (g-socket.ads). This package should not be + -- directly with'ed by an applications program. + -- This is the version for AIX package GNAT.Sockets.Constants is ! -------------- ! -- Families -- ! -------------- ! AF_INET : constant := 2; -- IPv4 address family ! AF_INET6 : constant := 24; -- IPv6 address family ! ----------- ! -- Modes -- ! ----------- ! SOCK_STREAM : constant := 1; -- Stream socket ! SOCK_DGRAM : constant := 2; -- Datagram socket ! ------------------- ! -- Socket errors -- ! ------------------- ! EACCES : constant := 13; -- Permission denied ! EADDRINUSE : constant := 67; -- Address already in use ! EADDRNOTAVAIL : constant := 68; -- Cannot assign address ! EAFNOSUPPORT : constant := 66; -- Addr family not supported ! EALREADY : constant := 56; -- Operation in progress ! EBADF : constant := 9; -- Bad file descriptor ! ECONNABORTED : constant := 72; -- Connection aborted ! ECONNREFUSED : constant := 79; -- Connection refused ! ECONNRESET : constant := 73; -- Connection reset by peer ! EDESTADDRREQ : constant := 58; -- Destination addr required ! EFAULT : constant := 14; -- Bad address ! EHOSTDOWN : constant := 80; -- Host is down ! EHOSTUNREACH : constant := 81; -- No route to host ! EINPROGRESS : constant := 55; -- Operation now in progress ! EINTR : constant := 4; -- Interrupted system call ! EINVAL : constant := 22; -- Invalid argument ! EIO : constant := 5; -- Input output error ! EISCONN : constant := 75; -- Socket already connected ! ELOOP : constant := 85; -- Too many symbolic lynks ! EMFILE : constant := 24; -- Too many open files ! EMSGSIZE : constant := 59; -- Message too long ! ENAMETOOLONG : constant := 86; -- Name too long ! ENETDOWN : constant := 69; -- Network is down ! ENETRESET : constant := 71; -- Disconn. on network reset ! ENETUNREACH : constant := 70; -- Network is unreachable ! ENOBUFS : constant := 74; -- No buffer space available ! ENOPROTOOPT : constant := 61; -- Protocol not available ! ENOTCONN : constant := 76; -- Socket not connected ! ENOTSOCK : constant := 57; -- Operation on non socket ! EOPNOTSUPP : constant := 64; -- Operation not supported ! EPFNOSUPPORT : constant := 65; -- Unknown protocol family ! EPROTONOSUPPORT : constant := 62; -- Unknown protocol ! EPROTOTYPE : constant := 60; -- Unknown protocol type ! ESHUTDOWN : constant := 77; -- Cannot send once shutdown ! ESOCKTNOSUPPORT : constant := 63; -- Socket type not supported ! ETIMEDOUT : constant := 78; -- Connection timed out ! ETOOMANYREFS : constant := 115; -- Too many references ! EWOULDBLOCK : constant := 11; -- Operation would block ! ----------------- ! -- Host errors -- ! ----------------- ! HOST_NOT_FOUND : constant := 1; -- Unknown host ! TRY_AGAIN : constant := 2; -- Host name lookup failure ! NO_DATA : constant := 4; -- No data record for name ! NO_RECOVERY : constant := 3; -- Non recoverable errors ! ------------------- ! -- Control flags -- ! ------------------- ! FIONBIO : constant := -2147195266; -- Set/clear non-blocking io ! FIONREAD : constant := 1074030207; -- How many bytes to read ! -------------------- ! -- Shutdown modes -- ! -------------------- ! SHUT_RD : constant := 0; -- No more recv ! SHUT_WR : constant := 1; -- No more send ! SHUT_RDWR : constant := 2; -- No more recv/send ! --------------------- ! -- Protocol levels -- ! --------------------- ! SOL_SOCKET : constant := 65535; -- Options for socket level ! IPPROTO_IP : constant := 0; -- Dummy protocol for IP ! IPPROTO_UDP : constant := 17; -- UDP ! IPPROTO_TCP : constant := 6; -- TCP ! ------------------- ! -- Request flags -- ! ------------------- ! ! MSG_OOB : constant := 1; -- Process out-of-band data ! MSG_PEEK : constant := 2; -- Peek at incoming data ! MSG_EOR : constant := 8; -- Send end of record ! MSG_WAITALL : constant := 64; -- Wait for full reception ! ! -------------------- ! -- Socket options -- ! -------------------- ! ! TCP_NODELAY : constant := 1; -- Do not coalesce packets ! SO_SNDBUF : constant := 4097; -- Set/get send buffer size ! SO_RCVBUF : constant := 4098; -- Set/get recv buffer size ! SO_REUSEADDR : constant := 4; -- Bind reuse local address ! SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs ! SO_LINGER : constant := 128; -- Defer close to flush data ! SO_ERROR : constant := 4103; -- Get/clear error status ! SO_BROADCAST : constant := 32; -- Can send broadcast msgs ! IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group ! IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group ! IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL ! IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback end GNAT.Sockets.Constants; diff -Nrc3pad gcc-3.3.3/gcc/ada/3gsoccon.ads gcc-3.4.0/gcc/ada/3gsoccon.ads *** gcc-3.3.3/gcc/ada/3gsoccon.ads 2002-03-14 10:58:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/3gsoccon.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2003 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- -- *************** *** 27,114 **** -- 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; --- 26,158 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNAT was originally developed by the GNAT team at New York University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ + -- This package provides target dependent definitions of constant for use + -- by the GNAT.Sockets package (g-socket.ads). This package should not be + -- directly with'ed by an applications program. + -- This is the version for SGI package GNAT.Sockets.Constants is ! -------------- ! -- Families -- ! -------------- ! AF_INET : constant := 2; -- IPv4 address family ! AF_INET6 : constant := 24; -- IPv6 address family ! ----------- ! -- Modes -- ! ----------- ! SOCK_STREAM : constant := 2; -- Stream socket ! SOCK_DGRAM : constant := 1; -- Datagram socket ! ------------------- ! -- Socket errors -- ! ------------------- ! EACCES : constant := 13; -- Permission denied ! EADDRINUSE : constant := 125; -- Address already in use ! EADDRNOTAVAIL : constant := 126; -- Cannot assign address ! EAFNOSUPPORT : constant := 124; -- Addr family not supported ! EALREADY : constant := 149; -- Operation in progress ! EBADF : constant := 9; -- Bad file descriptor ! ECONNABORTED : constant := 130; -- Connection aborted ! ECONNREFUSED : constant := 146; -- Connection refused ! ECONNRESET : constant := 131; -- Connection reset by peer ! EDESTADDRREQ : constant := 96; -- Destination addr required ! EFAULT : constant := 14; -- Bad address ! EHOSTDOWN : constant := 147; -- Host is down ! EHOSTUNREACH : constant := 148; -- No route to host ! EINPROGRESS : constant := 150; -- Operation now in progress ! EINTR : constant := 4; -- Interrupted system call ! EINVAL : constant := 22; -- Invalid argument ! EIO : constant := 5; -- Input output error ! EISCONN : constant := 133; -- Socket already connected ! ELOOP : constant := 90; -- Too many symbolic lynks ! EMFILE : constant := 24; -- Too many open files ! EMSGSIZE : constant := 97; -- Message too long ! ENAMETOOLONG : constant := 78; -- Name too long ! ENETDOWN : constant := 127; -- Network is down ! ENETRESET : constant := 129; -- Disconn. on network reset ! ENETUNREACH : constant := 128; -- Network is unreachable ! ENOBUFS : constant := 132; -- No buffer space available ! ENOPROTOOPT : constant := 99; -- Protocol not available ! ENOTCONN : constant := 134; -- Socket not connected ! ENOTSOCK : constant := 95; -- Operation on non socket ! EOPNOTSUPP : constant := 122; -- Operation not supported ! EPFNOSUPPORT : constant := 123; -- Unknown protocol family ! EPROTONOSUPPORT : constant := 120; -- Unknown protocol ! EPROTOTYPE : constant := 98; -- Unknown protocol type ! ESHUTDOWN : constant := 143; -- Cannot send once shutdown ! ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported ! ETIMEDOUT : constant := 145; -- Connection timed out ! ETOOMANYREFS : constant := 144; -- Too many references ! EWOULDBLOCK : constant := 11; -- Operation would block ! ----------------- ! -- Host errors -- ! ----------------- ! HOST_NOT_FOUND : constant := 1; -- Unknown host ! TRY_AGAIN : constant := 2; -- Host name lookup failure ! NO_DATA : constant := 4; -- No data record for name ! NO_RECOVERY : constant := 3; -- Non recoverable errors ! ------------------- ! -- Control flags -- ! ------------------- ! FIONBIO : constant := -2147195266; -- Set/clear non-blocking io ! FIONREAD : constant := 1074030207; -- How many bytes to read ! -------------------- ! -- Shutdown modes -- ! -------------------- ! SHUT_RD : constant := 0; -- No more recv ! SHUT_WR : constant := 1; -- No more send ! SHUT_RDWR : constant := 2; -- No more recv/send ! --------------------- ! -- Protocol levels -- ! --------------------- ! SOL_SOCKET : constant := 65535; -- Options for socket level ! IPPROTO_IP : constant := 0; -- Dummy protocol for IP ! IPPROTO_UDP : constant := 17; -- UDP ! IPPROTO_TCP : constant := 6; -- TCP ! ------------------- ! -- Request flags -- ! ------------------- ! ! MSG_OOB : constant := 1; -- Process out-of-band data ! MSG_PEEK : constant := 2; -- Peek at incoming data ! MSG_EOR : constant := 8; -- Send end of record ! MSG_WAITALL : constant := 64; -- Wait for full reception ! ! -------------------- ! -- Socket options -- ! -------------------- ! ! TCP_NODELAY : constant := 1; -- Do not coalesce packets ! SO_SNDBUF : constant := 4097; -- Set/get send buffer size ! SO_RCVBUF : constant := 4098; -- Set/get recv buffer size ! SO_REUSEADDR : constant := 4; -- Bind reuse local address ! SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs ! SO_LINGER : constant := 128; -- Defer close to flush data ! SO_ERROR : constant := 4103; -- Get/clear error status ! SO_BROADCAST : constant := 32; -- Can send broadcast msgs ! IP_ADD_MEMBERSHIP : constant := 23; -- Join a multicast group ! IP_DROP_MEMBERSHIP : constant := 24; -- Leave a multicast group ! IP_MULTICAST_TTL : constant := 21; -- Set/get multicast TTL ! IP_MULTICAST_LOOP : constant := 22; -- Set/get mcast loopback end GNAT.Sockets.Constants; diff -Nrc3pad gcc-3.3.3/gcc/ada/3hsoccon.ads gcc-3.4.0/gcc/ada/3hsoccon.ads *** gcc-3.3.3/gcc/ada/3hsoccon.ads 2002-03-14 10:58:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/3hsoccon.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2003 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- -- *************** *** 27,114 **** -- 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; --- 26,158 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNAT was originally developed by the GNAT team at New York University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ + -- This package provides target dependent definitions of constant for use + -- by the GNAT.Sockets package (g-socket.ads). This package should not be + -- directly with'ed by an applications program. + -- This is the version for HP/UX package GNAT.Sockets.Constants is ! -------------- ! -- Families -- ! -------------- ! AF_INET : constant := 2; -- IPv4 address family ! AF_INET6 : constant := 26; -- IPv6 address family ! ----------- ! -- Modes -- ! ----------- ! SOCK_STREAM : constant := 1; -- Stream socket ! SOCK_DGRAM : constant := 2; -- Datagram socket ! ------------------- ! -- Socket errors -- ! ------------------- ! EACCES : constant := 13; -- Permission denied ! EADDRINUSE : constant := 226; -- Address already in use ! EADDRNOTAVAIL : constant := 227; -- Cannot assign address ! EAFNOSUPPORT : constant := 225; -- Addr family not supported ! EALREADY : constant := 244; -- Operation in progress ! EBADF : constant := 9; -- Bad file descriptor ! ECONNABORTED : constant := 231; -- Connection aborted ! ECONNREFUSED : constant := 239; -- Connection refused ! ECONNRESET : constant := 232; -- Connection reset by peer ! EDESTADDRREQ : constant := 217; -- Destination addr required ! EFAULT : constant := 14; -- Bad address ! EHOSTDOWN : constant := 241; -- Host is down ! EHOSTUNREACH : constant := 242; -- No route to host ! EINPROGRESS : constant := 245; -- Operation now in progress ! EINTR : constant := 4; -- Interrupted system call ! EINVAL : constant := 22; -- Invalid argument ! EIO : constant := 5; -- Input output error ! EISCONN : constant := 234; -- Socket already connected ! ELOOP : constant := 249; -- Too many symbolic lynks ! EMFILE : constant := 24; -- Too many open files ! EMSGSIZE : constant := 218; -- Message too long ! ENAMETOOLONG : constant := 248; -- Name too long ! ENETDOWN : constant := 228; -- Network is down ! ENETRESET : constant := 230; -- Disconn. on network reset ! ENETUNREACH : constant := 229; -- Network is unreachable ! ENOBUFS : constant := 233; -- No buffer space available ! ENOPROTOOPT : constant := 220; -- Protocol not available ! ENOTCONN : constant := 235; -- Socket not connected ! ENOTSOCK : constant := 216; -- Operation on non socket ! EOPNOTSUPP : constant := 223; -- Operation not supported ! EPFNOSUPPORT : constant := 224; -- Unknown protocol family ! EPROTONOSUPPORT : constant := 221; -- Unknown protocol ! EPROTOTYPE : constant := 219; -- Unknown protocol type ! ESHUTDOWN : constant := 236; -- Cannot send once shutdown ! ESOCKTNOSUPPORT : constant := 222; -- Socket type not supported ! ETIMEDOUT : constant := 238; -- Connection timed out ! ETOOMANYREFS : constant := 237; -- Too many references ! EWOULDBLOCK : constant := 246; -- Operation would block ! ----------------- ! -- Host errors -- ! ----------------- ! HOST_NOT_FOUND : constant := 1; -- Unknown host ! TRY_AGAIN : constant := 2; -- Host name lookup failure ! NO_DATA : constant := 4; -- No data record for name ! NO_RECOVERY : constant := 3; -- Non recoverable errors ! ------------------- ! -- Control flags -- ! ------------------- ! FIONBIO : constant := -2147195266; -- Set/clear non-blocking io ! FIONREAD : constant := 1074030207; -- How many bytes to read ! -------------------- ! -- Shutdown modes -- ! -------------------- ! SHUT_RD : constant := 0; -- No more recv ! SHUT_WR : constant := 1; -- No more send ! SHUT_RDWR : constant := 2; -- No more recv/send ! --------------------- ! -- Protocol levels -- ! --------------------- ! SOL_SOCKET : constant := 65535; -- Options for socket level ! IPPROTO_IP : constant := 0; -- Dummy protocol for IP ! IPPROTO_UDP : constant := 17; -- UDP ! IPPROTO_TCP : constant := 6; -- TCP ! ------------------- ! -- Request flags -- ! ------------------- ! ! MSG_OOB : constant := 1; -- Process out-of-band data ! MSG_PEEK : constant := 2; -- Peek at incoming data ! MSG_EOR : constant := 8; -- Send end of record ! MSG_WAITALL : constant := 64; -- Wait for full reception ! ! -------------------- ! -- Socket options -- ! -------------------- ! ! TCP_NODELAY : constant := 1; -- Do not coalesce packets ! SO_SNDBUF : constant := 4097; -- Set/get send buffer size ! SO_RCVBUF : constant := 4098; -- Set/get recv buffer size ! SO_REUSEADDR : constant := 4; -- Bind reuse local address ! SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs ! SO_LINGER : constant := 128; -- Defer close to flush data ! SO_ERROR : constant := 4103; -- Get/clear error status ! SO_BROADCAST : constant := 32; -- Can send broadcast msgs ! IP_ADD_MEMBERSHIP : constant := 5; -- Join a multicast group ! IP_DROP_MEMBERSHIP : constant := 6; -- Leave a multicast group ! IP_MULTICAST_TTL : constant := 3; -- Set/get multicast TTL ! IP_MULTICAST_LOOP : constant := 4; -- Set/get mcast loopback end GNAT.Sockets.Constants; diff -Nrc3pad gcc-3.3.3/gcc/ada/3psoccon.ads gcc-3.4.0/gcc/ada/3psoccon.ads *** gcc-3.3.3/gcc/ada/3psoccon.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/3psoccon.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S O C K E T S . C O N S T A N T S -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2000-2003 Free Software Foundation, Inc. -- + -- -- + -- GNAT is free software; you can redistribute it and/or modify it under -- + -- terms of the GNU General Public License as published by the Free Soft- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- + -- MA 02111-1307, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package provides target dependent definitions of constant for use + -- by the GNAT.Sockets package (g-socket.ads). This package should not be + -- directly with'ed by an applications program. + + -- This is the version for Interix + + package GNAT.Sockets.Constants is + + -------------- + -- Families -- + -------------- + + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := -1; -- IPv6 address family + + ----------- + -- Modes -- + ----------- + + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket + + ------------------- + -- Socket errors -- + ------------------- + + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 48; -- Address already in use + EADDRNOTAVAIL : constant := 49; -- Cannot assign address + EAFNOSUPPORT : constant := 47; -- Addr family not supported + EALREADY : constant := 37; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 53; -- Connection aborted + ECONNREFUSED : constant := 61; -- Connection refused + ECONNRESET : constant := 54; -- Connection reset by peer + EDESTADDRREQ : constant := 82; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 64; -- Host is down + EHOSTUNREACH : constant := 65; -- No route to host + EINPROGRESS : constant := 80; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 56; -- Socket already connected + ELOOP : constant := 62; -- Too many symbolic lynks + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 83; -- Message too long + ENAMETOOLONG : constant := 38; -- Name too long + ENETDOWN : constant := 50; -- Network is down + ENETRESET : constant := 52; -- Disconn. on network reset + ENETUNREACH : constant := 51; -- Network is unreachable + ENOBUFS : constant := 55; -- No buffer space available + ENOPROTOOPT : constant := 85; -- Protocol not available + ENOTCONN : constant := 57; -- Socket not connected + ENOTSOCK : constant := 81; -- Operation on non socket + EOPNOTSUPP : constant := 45; -- Operation not supported + EPFNOSUPPORT : constant := 46; -- Unknown protocol family + EPROTONOSUPPORT : constant := 43; -- Unknown protocol + EPROTOTYPE : constant := 84; -- Unknown protocol type + ESHUTDOWN : constant := 58; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported + ETIMEDOUT : constant := 60; -- Connection timed out + ETOOMANYREFS : constant := 59; -- Too many references + EWOULDBLOCK : constant := 11; -- Operation would block + + ----------------- + -- Host errors -- + ----------------- + + HOST_NOT_FOUND : constant := 90; -- Unknown host + TRY_AGAIN : constant := 91; -- Host name lookup failure + NO_DATA : constant := 93; -- No data record for name + NO_RECOVERY : constant := 92; -- Non recoverable errors + + ------------------- + -- Control flags -- + ------------------- + + FIONBIO : constant := -2147195390; -- Set/clear non-blocking io + FIONREAD : constant := 1074030081; -- How many bytes to read + + -------------------- + -- Shutdown modes -- + -------------------- + + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send + + --------------------- + -- Protocol levels -- + --------------------- + + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP + + ------------------- + -- Request flags -- + ------------------- + + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + + -------------------- + -- Socket options -- + -------------------- + + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_ERROR : constant := 4103; -- Get/clear error status + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + IP_ADD_MEMBERSHIP : constant := 5; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 6; -- Leave a multicast group + IP_MULTICAST_TTL : constant := 3; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 4; -- Set/get mcast loopback + + end GNAT.Sockets.Constants; diff -Nrc3pad gcc-3.3.3/gcc/ada/3ssoccon.ads gcc-3.4.0/gcc/ada/3ssoccon.ads *** gcc-3.3.3/gcc/ada/3ssoccon.ads 2002-03-14 10:58:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/3ssoccon.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2003 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- -- *************** *** 27,114 **** -- 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; --- 26,158 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNAT was originally developed by the GNAT team at New York University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ + -- This package provides target dependent definitions of constant for use + -- by the GNAT.Sockets package (g-socket.ads). This package should not be + -- directly with'ed by an applications program. + -- This is the version for Solaris package GNAT.Sockets.Constants is ! -------------- ! -- Families -- ! -------------- ! AF_INET : constant := 2; -- IPv4 address family ! AF_INET6 : constant := 26; -- IPv6 address family ! ----------- ! -- Modes -- ! ----------- ! SOCK_STREAM : constant := 2; -- Stream socket ! SOCK_DGRAM : constant := 1; -- Datagram socket ! ------------------- ! -- Socket errors -- ! ------------------- ! EACCES : constant := 13; -- Permission denied ! EADDRINUSE : constant := 125; -- Address already in use ! EADDRNOTAVAIL : constant := 126; -- Cannot assign address ! EAFNOSUPPORT : constant := 124; -- Addr family not supported ! EALREADY : constant := 149; -- Operation in progress ! EBADF : constant := 9; -- Bad file descriptor ! ECONNABORTED : constant := 130; -- Connection aborted ! ECONNREFUSED : constant := 146; -- Connection refused ! ECONNRESET : constant := 131; -- Connection reset by peer ! EDESTADDRREQ : constant := 96; -- Destination addr required ! EFAULT : constant := 14; -- Bad address ! EHOSTDOWN : constant := 147; -- Host is down ! EHOSTUNREACH : constant := 148; -- No route to host ! EINPROGRESS : constant := 150; -- Operation now in progress ! EINTR : constant := 4; -- Interrupted system call ! EINVAL : constant := 22; -- Invalid argument ! EIO : constant := 5; -- Input output error ! EISCONN : constant := 133; -- Socket already connected ! ELOOP : constant := 90; -- Too many symbolic lynks ! EMFILE : constant := 24; -- Too many open files ! EMSGSIZE : constant := 97; -- Message too long ! ENAMETOOLONG : constant := 78; -- Name too long ! ENETDOWN : constant := 127; -- Network is down ! ENETRESET : constant := 129; -- Disconn. on network reset ! ENETUNREACH : constant := 128; -- Network is unreachable ! ENOBUFS : constant := 132; -- No buffer space available ! ENOPROTOOPT : constant := 99; -- Protocol not available ! ENOTCONN : constant := 134; -- Socket not connected ! ENOTSOCK : constant := 95; -- Operation on non socket ! EOPNOTSUPP : constant := 122; -- Operation not supported ! EPFNOSUPPORT : constant := 123; -- Unknown protocol family ! EPROTONOSUPPORT : constant := 120; -- Unknown protocol ! EPROTOTYPE : constant := 98; -- Unknown protocol type ! ESHUTDOWN : constant := 143; -- Cannot send once shutdown ! ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported ! ETIMEDOUT : constant := 145; -- Connection timed out ! ETOOMANYREFS : constant := 144; -- Too many references ! EWOULDBLOCK : constant := 11; -- Operation would block ! ----------------- ! -- Host errors -- ! ----------------- ! HOST_NOT_FOUND : constant := 1; -- Unknown host ! TRY_AGAIN : constant := 2; -- Host name lookup failure ! NO_DATA : constant := 4; -- No data record for name ! NO_RECOVERY : constant := 3; -- Non recoverable errors ! ------------------- ! -- Control flags -- ! ------------------- ! FIONBIO : constant := -2147195266; -- Set/clear non-blocking io ! FIONREAD : constant := 1074030207; -- How many bytes to read ! -------------------- ! -- Shutdown modes -- ! -------------------- ! SHUT_RD : constant := 0; -- No more recv ! SHUT_WR : constant := 1; -- No more send ! SHUT_RDWR : constant := 2; -- No more recv/send ! --------------------- ! -- Protocol levels -- ! --------------------- ! SOL_SOCKET : constant := 65535; -- Options for socket level ! IPPROTO_IP : constant := 0; -- Dummy protocol for IP ! IPPROTO_UDP : constant := 17; -- UDP ! IPPROTO_TCP : constant := 6; -- TCP ! ------------------- ! -- Request flags -- ! ------------------- ! ! MSG_OOB : constant := 1; -- Process out-of-band data ! MSG_PEEK : constant := 2; -- Peek at incoming data ! MSG_EOR : constant := 8; -- Send end of record ! MSG_WAITALL : constant := 64; -- Wait for full reception ! ! -------------------- ! -- Socket options -- ! -------------------- ! ! TCP_NODELAY : constant := 1; -- Do not coalesce packets ! SO_SNDBUF : constant := 4097; -- Set/get send buffer size ! SO_RCVBUF : constant := 4098; -- Set/get recv buffer size ! SO_REUSEADDR : constant := 4; -- Bind reuse local address ! SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs ! SO_LINGER : constant := 128; -- Defer close to flush data ! SO_ERROR : constant := 4103; -- Get/clear error status ! SO_BROADCAST : constant := 32; -- Can send broadcast msgs ! IP_ADD_MEMBERSHIP : constant := 19; -- Join a multicast group ! IP_DROP_MEMBERSHIP : constant := 20; -- Leave a multicast group ! IP_MULTICAST_TTL : constant := 17; -- Set/get multicast TTL ! IP_MULTICAST_LOOP : constant := 18; -- Set/get mcast loopback end GNAT.Sockets.Constants; diff -Nrc3pad gcc-3.3.3/gcc/ada/3ssoliop.ads gcc-3.4.0/gcc/ada/3ssoliop.ads *** gcc-3.3.3/gcc/ada/3ssoliop.ads 2002-03-14 10:58:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/3ssoliop.ads 2003-12-05 10:24:04.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2003 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- -- *************** *** 27,43 **** -- 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; --- 26,43 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNAT was originally developed by the GNAT team at New York University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This package is used to provide target specific linker_options for the ! -- support of scokets as required by the package GNAT.Sockets. ! -- This is the Solaris version of this package + package GNAT.Sockets.Linker_Options is private pragma Linker_Options ("-lnsl"); pragma Linker_Options ("-lsocket"); end GNAT.Sockets.Linker_Options; diff -Nrc3pad gcc-3.3.3/gcc/ada/3veacodu.adb gcc-3.4.0/gcc/ada/3veacodu.adb *** gcc-3.3.3/gcc/ada/3veacodu.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/3veacodu.adb 2003-10-21 13:41:51.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . E X C E P T I O N _ A C T I O N S . C O R E _ D U M P -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2003 Free Software Foundation, Inc. -- + -- -- + -- GNAT is free software; you can redistribute it and/or modify it under -- + -- terms of the GNU General Public License as published by the Free Soft- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- + -- MA 02111-1307, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the VMS version. + + with System; + with System.Aux_DEC; + separate (GNAT.Exception_Actions) + procedure Core_Dump (Occurrence : Exception_Occurrence) is + + use System; + use System.Aux_DEC; + + pragma Unreferenced (Occurrence); + + SS_IMGDMP : constant := 1276; + + subtype Cond_Value_Type is Unsigned_Longword; + subtype Access_Mode_Type is + Unsigned_Word range 0 .. 3; + Access_Mode_Zero : constant Access_Mode_Type := 0; + + Status : Cond_Value_Type; + + procedure Setexv ( + Status : out Cond_Value_Type; + Vector : in Unsigned_Longword := 0; + Addres : in Address := Address_Zero; + Acmode : in Access_Mode_Type := Access_Mode_Zero; + Prvhnd : in Unsigned_Longword := 0); + pragma Interface (External, Setexv); + pragma Import_Valued_Procedure (Setexv, "SYS$SETEXV", + (Cond_Value_Type, Unsigned_Longword, Address, Access_Mode_Type, + Unsigned_Longword), + (Value, Value, Value, Value, Value)); + + procedure Lib_Signal (I : in Integer); + pragma Interface (C, Lib_Signal); + pragma Import_Procedure (Lib_Signal, "LIB$SIGNAL", Mechanism => (Value)); + begin + Setexv (Status, 1, Address_Zero, 3); + Lib_Signal (SS_IMGDMP); + end Core_Dump; diff -Nrc3pad gcc-3.3.3/gcc/ada/3vexpect.adb gcc-3.4.0/gcc/ada/3vexpect.adb *** gcc-3.3.3/gcc/ada/3vexpect.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/3vexpect.adb 2004-01-05 15:20:42.000000000 +0000 *************** *** 0 **** --- 1,1184 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT LIBRARY COMPONENTS -- + -- -- + -- G N A T . E X P E C T -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2002-2003 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 was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the VMS version. + + with System; use System; + with Ada.Calendar; use Ada.Calendar; + + with GNAT.IO; + with GNAT.OS_Lib; use GNAT.OS_Lib; + with GNAT.Regpat; use GNAT.Regpat; + + with Unchecked_Deallocation; + + package body GNAT.Expect is + + type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access; + + Save_Input : File_Descriptor; + Save_Output : File_Descriptor; + Save_Error : File_Descriptor; + + procedure Expect_Internal + (Descriptors : in out Array_Of_Pd; + Result : out Expect_Match; + Timeout : Integer; + Full_Buffer : Boolean); + -- Internal function used to read from the process Descriptor. + -- + -- Three outputs are possible: + -- Result=Expect_Timeout, if no output was available before the timeout + -- expired. + -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters + -- had to be discarded from the internal buffer of Descriptor. + -- Result=, indicates how many characters were added to the + -- internal buffer. These characters are from indexes + -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index + -- Process_Died is raised if the process is no longer valid. + + procedure Reinitialize_Buffer + (Descriptor : in out Process_Descriptor'Class); + -- Reinitialize the internal buffer. + -- The buffer is deleted up to the end of the last match. + + procedure Free is new Unchecked_Deallocation + (Pattern_Matcher, Pattern_Matcher_Access); + + procedure Call_Filters + (Pid : Process_Descriptor'Class; + Str : String; + Filter_On : Filter_Type); + -- Call all the filters that have the appropriate type. + -- This function does nothing if the filters are locked + + ------------------------------ + -- Target dependent section -- + ------------------------------ + + function Dup (Fd : File_Descriptor) return File_Descriptor; + pragma Import (C, Dup); + + procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); + pragma Import (C, Dup2); + + procedure Kill (Pid : Process_Id; Sig_Num : Integer); + pragma Import (C, Kill); + + function Create_Pipe (Pipe : access Pipe_Type) return Integer; + pragma Import (C, Create_Pipe, "__gnat_pipe"); + + function Poll + (Fds : System.Address; + Num_Fds : Integer; + Timeout : Integer; + Is_Set : System.Address) return Integer; + pragma Import (C, Poll, "__gnat_expect_poll"); + -- Check whether there is any data waiting on the file descriptor + -- Out_fd, and wait if there is none, at most Timeout milliseconds + -- Returns -1 in case of error, 0 if the timeout expired before + -- data became available. + -- + -- Out_Is_Set is set to 1 if data was available, 0 otherwise. + + function Waitpid (Pid : Process_Id) return Integer; + pragma Import (C, Waitpid, "__gnat_waitpid"); + -- Wait for a specific process id, and return its exit code. + + --------- + -- "+" -- + --------- + + function "+" (S : String) return GNAT.OS_Lib.String_Access is + begin + return new String'(S); + end "+"; + + --------- + -- "+" -- + --------- + + function "+" + (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access + is + begin + return new GNAT.Regpat.Pattern_Matcher'(P); + end "+"; + + ---------------- + -- Add_Filter -- + ---------------- + + procedure Add_Filter + (Descriptor : in out Process_Descriptor; + Filter : Filter_Function; + Filter_On : Filter_Type := Output; + User_Data : System.Address := System.Null_Address; + After : Boolean := False) + is + Current : Filter_List := Descriptor.Filters; + + begin + if After then + while Current /= null and then Current.Next /= null loop + Current := Current.Next; + end loop; + + if Current = null then + Descriptor.Filters := + new Filter_List_Elem' + (Filter => Filter, Filter_On => Filter_On, + User_Data => User_Data, Next => null); + else + Current.Next := + new Filter_List_Elem' + (Filter => Filter, Filter_On => Filter_On, + User_Data => User_Data, Next => null); + end if; + + else + Descriptor.Filters := + new Filter_List_Elem' + (Filter => Filter, Filter_On => Filter_On, + User_Data => User_Data, Next => Descriptor.Filters); + end if; + end Add_Filter; + + ------------------ + -- Call_Filters -- + ------------------ + + procedure Call_Filters + (Pid : Process_Descriptor'Class; + Str : String; + Filter_On : Filter_Type) + is + Current_Filter : Filter_List; + + begin + if Pid.Filters_Lock = 0 then + Current_Filter := Pid.Filters; + + while Current_Filter /= null loop + if Current_Filter.Filter_On = Filter_On then + Current_Filter.Filter + (Pid, Str, Current_Filter.User_Data); + end if; + + Current_Filter := Current_Filter.Next; + end loop; + end if; + end Call_Filters; + + ----------- + -- Close -- + ----------- + + procedure Close + (Descriptor : in out Process_Descriptor; + Status : out Integer) + is + begin + Close (Descriptor.Input_Fd); + + if Descriptor.Error_Fd /= Descriptor.Output_Fd then + Close (Descriptor.Error_Fd); + end if; + + Close (Descriptor.Output_Fd); + + -- ??? Should have timeouts for different signals + Kill (Descriptor.Pid, 9); + + GNAT.OS_Lib.Free (Descriptor.Buffer); + Descriptor.Buffer_Size := 0; + + Status := Waitpid (Descriptor.Pid); + end Close; + + procedure Close (Descriptor : in out Process_Descriptor) is + Status : Integer; + begin + Close (Descriptor, Status); + end Close; + + ------------ + -- Expect -- + ------------ + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : String; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + begin + if Regexp = "" then + Expect (Descriptor, Result, Never_Match, Timeout, Full_Buffer); + else + Expect (Descriptor, Result, Compile (Regexp), Timeout, Full_Buffer); + end if; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : String; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + begin + pragma Assert (Matched'First = 0); + if Regexp = "" then + Expect + (Descriptor, Result, Never_Match, Matched, Timeout, Full_Buffer); + else + Expect + (Descriptor, Result, Compile (Regexp), Matched, Timeout, + Full_Buffer); + end if; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : GNAT.Regpat.Pattern_Matcher; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + Matched : GNAT.Regpat.Match_Array (0 .. 0); + + begin + Expect (Descriptor, Result, Regexp, Matched, Timeout, Full_Buffer); + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : GNAT.Regpat.Pattern_Matcher; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + N : Expect_Match; + Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); + Try_Until : constant Time := Clock + Duration (Timeout) / 1000.0; + Timeout_Tmp : Integer := Timeout; + + begin + pragma Assert (Matched'First = 0); + Reinitialize_Buffer (Descriptor); + + loop + -- First, test if what is already in the buffer matches (This is + -- required if this package is used in multi-task mode, since one of + -- the tasks might have added something in the buffer, and we don't + -- want other tasks to wait for new input to be available before + -- checking the regexps). + + Match + (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); + + if Descriptor.Buffer_Index >= 1 and then Matched (0).First /= 0 then + Result := 1; + Descriptor.Last_Match_Start := Matched (0).First; + Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; + + -- Else try to read new input + + Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer); + + if N = Expect_Timeout or else N = Expect_Full_Buffer then + Result := N; + return; + end if; + + -- Calculate the timeout for the next turn. + -- Note that Timeout is, from the caller's perspective, the maximum + -- time until a match, not the maximum time until some output is + -- read, and thus can not be reused as is for Expect_Internal. + + if Timeout /= -1 then + Timeout_Tmp := Integer (Try_Until - Clock) * 1000; + + if Timeout_Tmp < 0 then + Result := Expect_Timeout; + exit; + end if; + end if; + end loop; + + -- Even if we had the general timeout above, we have to test that the + -- last test we read from the external process didn't match. + + Match + (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); + + if Matched (0).First /= 0 then + Result := 1; + Descriptor.Last_Match_Start := Matched (0).First; + Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Regexp_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + Patterns : Compiled_Regexp_Array (Regexps'Range); + Matched : GNAT.Regpat.Match_Array (0 .. 0); + + begin + for J in Regexps'Range loop + Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all)); + end loop; + + Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer); + + for J in Regexps'Range loop + Free (Patterns (J)); + end loop; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Compiled_Regexp_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + Matched : GNAT.Regpat.Match_Array (0 .. 0); + + begin + Expect (Descriptor, Result, Regexps, Matched, Timeout, Full_Buffer); + end Expect; + + procedure Expect + (Result : out Expect_Match; + Regexps : Multiprocess_Regexp_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + Matched : GNAT.Regpat.Match_Array (0 .. 0); + + begin + Expect (Result, Regexps, Matched, Timeout, Full_Buffer); + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Regexp_Array; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + Patterns : Compiled_Regexp_Array (Regexps'Range); + + begin + pragma Assert (Matched'First = 0); + + for J in Regexps'Range loop + Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all)); + end loop; + + Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer); + + for J in Regexps'Range loop + Free (Patterns (J)); + end loop; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Compiled_Regexp_Array; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + N : Expect_Match; + Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); + + begin + pragma Assert (Matched'First = 0); + + Reinitialize_Buffer (Descriptor); + + loop + -- First, test if what is already in the buffer matches (This is + -- required if this package is used in multi-task mode, since one of + -- the tasks might have added something in the buffer, and we don't + -- want other tasks to wait for new input to be available before + -- checking the regexps). + + if Descriptor.Buffer /= null then + for J in Regexps'Range loop + Match + (Regexps (J).all, + Descriptor.Buffer (1 .. Descriptor.Buffer_Index), + Matched); + + if Matched (0) /= No_Match then + Result := Expect_Match (J); + Descriptor.Last_Match_Start := Matched (0).First; + Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; + end loop; + end if; + + Expect_Internal (Descriptors, N, Timeout, Full_Buffer); + + if N = Expect_Timeout or else N = Expect_Full_Buffer then + Result := N; + return; + end if; + end loop; + end Expect; + + procedure Expect + (Result : out Expect_Match; + Regexps : Multiprocess_Regexp_Array; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + N : Expect_Match; + Descriptors : Array_Of_Pd (Regexps'Range); + + begin + pragma Assert (Matched'First = 0); + + for J in Descriptors'Range loop + Descriptors (J) := Regexps (J).Descriptor; + Reinitialize_Buffer (Regexps (J).Descriptor.all); + end loop; + + loop + -- First, test if what is already in the buffer matches (This is + -- required if this package is used in multi-task mode, since one of + -- the tasks might have added something in the buffer, and we don't + -- want other tasks to wait for new input to be available before + -- checking the regexps). + + for J in Regexps'Range loop + Match (Regexps (J).Regexp.all, + Regexps (J).Descriptor.Buffer + (1 .. Regexps (J).Descriptor.Buffer_Index), + Matched); + + if Matched (0) /= No_Match then + Result := Expect_Match (J); + Regexps (J).Descriptor.Last_Match_Start := Matched (0).First; + Regexps (J).Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; + end loop; + + Expect_Internal (Descriptors, N, Timeout, Full_Buffer); + + if N = Expect_Timeout or else N = Expect_Full_Buffer then + Result := N; + return; + end if; + end loop; + end Expect; + + --------------------- + -- Expect_Internal -- + --------------------- + + procedure Expect_Internal + (Descriptors : in out Array_Of_Pd; + Result : out Expect_Match; + Timeout : Integer; + Full_Buffer : Boolean) + is + Num_Descriptors : Integer; + Buffer_Size : Integer := 0; + + N : Integer; + + type File_Descriptor_Array is + array (Descriptors'Range) of File_Descriptor; + Fds : aliased File_Descriptor_Array; + + type Integer_Array is array (Descriptors'Range) of Integer; + Is_Set : aliased Integer_Array; + + begin + for J in Descriptors'Range loop + Fds (J) := Descriptors (J).Output_Fd; + + if Descriptors (J).Buffer_Size = 0 then + Buffer_Size := Integer'Max (Buffer_Size, 4096); + else + Buffer_Size := + Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size); + end if; + end loop; + + declare + Buffer : aliased String (1 .. Buffer_Size); + -- Buffer used for input. This is allocated only once, not for + -- every iteration of the loop + + begin + -- Loop until we match or we have a timeout + + loop + Num_Descriptors := + Poll (Fds'Address, Fds'Length, Timeout, Is_Set'Address); + + case Num_Descriptors is + + -- Error? + + when -1 => + raise Process_Died; + + -- Timeout? + + when 0 => + Result := Expect_Timeout; + return; + + -- Some input + + when others => + for J in Descriptors'Range loop + if Is_Set (J) = 1 then + Buffer_Size := Descriptors (J).Buffer_Size; + + if Buffer_Size = 0 then + Buffer_Size := 4096; + end if; + + N := Read (Descriptors (J).Output_Fd, Buffer'Address, + Buffer_Size); + + -- Error or End of file + + if N <= 0 then + -- ??? Note that ddd tries again up to three times + -- in that case. See LiterateA.C:174 + raise Process_Died; + + else + -- If there is no limit to the buffer size + + if Descriptors (J).Buffer_Size = 0 then + + declare + Tmp : String_Access := Descriptors (J).Buffer; + + begin + if Tmp /= null then + Descriptors (J).Buffer := + new String (1 .. Tmp'Length + N); + Descriptors (J).Buffer (1 .. Tmp'Length) := + Tmp.all; + Descriptors (J).Buffer + (Tmp'Length + 1 .. Tmp'Length + N) := + Buffer (1 .. N); + Free (Tmp); + Descriptors (J).Buffer_Index := + Descriptors (J).Buffer'Last; + + else + Descriptors (J).Buffer := + new String (1 .. N); + Descriptors (J).Buffer.all := + Buffer (1 .. N); + Descriptors (J).Buffer_Index := N; + end if; + end; + + else + -- Add what we read to the buffer + + if Descriptors (J).Buffer_Index + N - 1 > + Descriptors (J).Buffer_Size + then + -- If the user wants to know when we have + -- read more than the buffer can contain. + + if Full_Buffer then + Result := Expect_Full_Buffer; + return; + end if; + + -- Keep as much as possible from the buffer, + -- and forget old characters. + + Descriptors (J).Buffer + (1 .. Descriptors (J).Buffer_Size - N) := + Descriptors (J).Buffer + (N - Descriptors (J).Buffer_Size + + Descriptors (J).Buffer_Index + 1 .. + Descriptors (J).Buffer_Index); + Descriptors (J).Buffer_Index := + Descriptors (J).Buffer_Size - N; + end if; + + -- Keep what we read in the buffer. + + Descriptors (J).Buffer + (Descriptors (J).Buffer_Index + 1 .. + Descriptors (J).Buffer_Index + N) := + Buffer (1 .. N); + Descriptors (J).Buffer_Index := + Descriptors (J).Buffer_Index + N; + end if; + + -- Call each of the output filter with what we + -- read. + + Call_Filters + (Descriptors (J).all, Buffer (1 .. N), Output); + + Result := Expect_Match (N); + return; + end if; + end if; + end loop; + end case; + end loop; + end; + end Expect_Internal; + + ---------------- + -- Expect_Out -- + ---------------- + + function Expect_Out (Descriptor : Process_Descriptor) return String is + begin + return Descriptor.Buffer (1 .. Descriptor.Last_Match_End); + end Expect_Out; + + ---------------------- + -- Expect_Out_Match -- + ---------------------- + + function Expect_Out_Match (Descriptor : Process_Descriptor) return String is + begin + return Descriptor.Buffer + (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End); + end Expect_Out_Match; + + ----------- + -- Flush -- + ----------- + + procedure Flush + (Descriptor : in out Process_Descriptor; + Timeout : Integer := 0) + is + Buffer_Size : constant Integer := 8192; + Num_Descriptors : Integer; + N : Integer; + Is_Set : aliased Integer; + Buffer : aliased String (1 .. Buffer_Size); + + begin + -- Empty the current buffer + + Descriptor.Last_Match_End := Descriptor.Buffer_Index; + Reinitialize_Buffer (Descriptor); + + -- Read everything from the process to flush its output + + loop + Num_Descriptors := + Poll (Descriptor.Output_Fd'Address, 1, Timeout, Is_Set'Address); + + case Num_Descriptors is + + -- Error ? + + when -1 => + raise Process_Died; + + -- Timeout => End of flush + + when 0 => + return; + + -- Some input + + when others => + if Is_Set = 1 then + N := Read (Descriptor.Output_Fd, Buffer'Address, + Buffer_Size); + + if N = -1 then + raise Process_Died; + elsif N = 0 then + return; + end if; + end if; + end case; + end loop; + + end Flush; + + ------------------ + -- Get_Error_Fd -- + ------------------ + + function Get_Error_Fd + (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor + is + begin + return Descriptor.Error_Fd; + end Get_Error_Fd; + + ------------------ + -- Get_Input_Fd -- + ------------------ + + function Get_Input_Fd + (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor + is + begin + return Descriptor.Input_Fd; + end Get_Input_Fd; + + ------------------- + -- Get_Output_Fd -- + ------------------- + + function Get_Output_Fd + (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor + is + begin + return Descriptor.Output_Fd; + end Get_Output_Fd; + + ------------- + -- Get_Pid -- + ------------- + + function Get_Pid + (Descriptor : Process_Descriptor) return Process_Id + is + begin + return Descriptor.Pid; + end Get_Pid; + + --------------- + -- Interrupt -- + --------------- + + procedure Interrupt (Descriptor : in out Process_Descriptor) is + SIGINT : constant := 2; + + begin + Send_Signal (Descriptor, SIGINT); + end Interrupt; + + ------------------ + -- Lock_Filters -- + ------------------ + + procedure Lock_Filters (Descriptor : in out Process_Descriptor) is + begin + Descriptor.Filters_Lock := Descriptor.Filters_Lock + 1; + end Lock_Filters; + + ------------------------ + -- Non_Blocking_Spawn -- + ------------------------ + + procedure Non_Blocking_Spawn + (Descriptor : out Process_Descriptor'Class; + Command : String; + Args : GNAT.OS_Lib.Argument_List; + Buffer_Size : Natural := 4096; + Err_To_Out : Boolean := False) + is + function Alloc_Vfork_Blocks return Integer; + pragma Import (C, Alloc_Vfork_Blocks, "decc$$alloc_vfork_blocks"); + + function Get_Vfork_Jmpbuf return System.Address; + pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf"); + + function Get_Current_Invo_Context + (Addr : System.Address) return Process_Id; + pragma Import (C, Get_Current_Invo_Context, + "LIB$GET_CURRENT_INVO_CONTEXT"); + + Pipe1, Pipe2, Pipe3 : aliased Pipe_Type; + + Arg : String_Access; + Arg_List : aliased array (1 .. Args'Length + 2) of System.Address; + + Command_With_Path : String_Access; + + begin + -- Create the rest of the pipes + + Set_Up_Communications + (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); + + Command_With_Path := Locate_Exec_On_Path (Command); + + if Command_With_Path = null then + raise Invalid_Process; + end if; + + -- Fork a new process. It's not possible to do this in a subprogram. + + if Alloc_Vfork_Blocks >= 0 then + Descriptor.Pid := Get_Current_Invo_Context (Get_Vfork_Jmpbuf); + else + Descriptor.Pid := -1; + end if; + + -- Are we now in the child (or, for Windows, still in the common + -- process). + + if Descriptor.Pid = Null_Pid then + -- Prepare an array of arguments to pass to C + + Arg := new String (1 .. Command_With_Path'Length + 1); + Arg (1 .. Command_With_Path'Length) := Command_With_Path.all; + Arg (Arg'Last) := ASCII.Nul; + Arg_List (1) := Arg.all'Address; + + for J in Args'Range loop + Arg := new String (1 .. Args (J)'Length + 1); + Arg (1 .. Args (J)'Length) := Args (J).all; + Arg (Arg'Last) := ASCII.Nul; + Arg_List (J + 2 - Args'First) := Arg.all'Address; + end loop; + + Arg_List (Arg_List'Last) := System.Null_Address; + + -- This does not return on Unix systems + + Set_Up_Child_Communications + (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all, + Arg_List'Address); + end if; + + Free (Command_With_Path); + + -- Did we have an error when spawning the child ? + + if Descriptor.Pid < Null_Pid then + raise Invalid_Process; + else + -- We are now in the parent process + + Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3); + end if; + + -- Create the buffer + + Descriptor.Buffer_Size := Buffer_Size; + + if Buffer_Size /= 0 then + Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); + end if; + end Non_Blocking_Spawn; + + ------------------------- + -- Reinitialize_Buffer -- + ------------------------- + + procedure Reinitialize_Buffer + (Descriptor : in out Process_Descriptor'Class) + is + begin + if Descriptor.Buffer_Size = 0 then + declare + Tmp : String_Access := Descriptor.Buffer; + + begin + Descriptor.Buffer := + new String + (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End); + + if Tmp /= null then + Descriptor.Buffer.all := Tmp + (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index); + Free (Tmp); + end if; + end; + + Descriptor.Buffer_Index := Descriptor.Buffer'Last; + + else + Descriptor.Buffer + (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End) := + Descriptor.Buffer + (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index); + + if Descriptor.Buffer_Index > Descriptor.Last_Match_End then + Descriptor.Buffer_Index := + Descriptor.Buffer_Index - Descriptor.Last_Match_End; + else + Descriptor.Buffer_Index := 0; + end if; + end if; + + Descriptor.Last_Match_Start := 0; + Descriptor.Last_Match_End := 0; + end Reinitialize_Buffer; + + ------------------- + -- Remove_Filter -- + ------------------- + + procedure Remove_Filter + (Descriptor : in out Process_Descriptor; + Filter : Filter_Function) + is + Previous : Filter_List := null; + Current : Filter_List := Descriptor.Filters; + + begin + while Current /= null loop + if Current.Filter = Filter then + if Previous = null then + Descriptor.Filters := Current.Next; + else + Previous.Next := Current.Next; + end if; + end if; + + Previous := Current; + Current := Current.Next; + end loop; + end Remove_Filter; + + ---------- + -- Send -- + ---------- + + procedure Send + (Descriptor : in out Process_Descriptor; + Str : String; + Add_LF : Boolean := True; + Empty_Buffer : Boolean := False) + is + Full_Str : constant String := Str & ASCII.LF; + Last : Natural; + Result : Expect_Match; + Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); + + Discard : Natural; + pragma Unreferenced (Discard); + + begin + if Empty_Buffer then + + -- Force a read on the process if there is anything waiting + + Expect_Internal (Descriptors, Result, + Timeout => 0, Full_Buffer => False); + Descriptor.Last_Match_End := Descriptor.Buffer_Index; + + -- Empty the buffer + + Reinitialize_Buffer (Descriptor); + end if; + + if Add_LF then + Last := Full_Str'Last; + else + Last := Full_Str'Last - 1; + end if; + + Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input); + + Discard := Write (Descriptor.Input_Fd, + Full_Str'Address, + Last - Full_Str'First + 1); + -- Shouldn't we at least have a pragma Assert on the result ??? + end Send; + + ----------------- + -- Send_Signal -- + ----------------- + + procedure Send_Signal + (Descriptor : Process_Descriptor; + Signal : Integer) + is + begin + Kill (Descriptor.Pid, Signal); + -- ??? Need to check process status here. + end Send_Signal; + + --------------------------------- + -- Set_Up_Child_Communications -- + --------------------------------- + + procedure Set_Up_Child_Communications + (Pid : in out Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type; + Cmd : in String; + Args : in System.Address) + is + pragma Warnings (Off, Pid); + + begin + -- Since the code between fork and exec on VMS executes + -- in the context of the parent process, we need to + -- perform the following actions: + -- - save stdin, stdout, stderr + -- - replace them by our pipes + -- - create the child with process handle inheritance + -- - revert to the previous stdin, stdout and stderr. + + Save_Input := Dup (GNAT.OS_Lib.Standin); + Save_Output := Dup (GNAT.OS_Lib.Standout); + Save_Error := Dup (GNAT.OS_Lib.Standerr); + + -- Since we are still called from the parent process, there is no way + -- currently we can cleanly close the unneeded ends of the pipes, but + -- this doesn't really matter. + -- We could close Pipe1.Output, Pipe2.Input, Pipe3.Input. + + Dup2 (Pipe1.Input, GNAT.OS_Lib.Standin); + Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout); + Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr); + + Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.Nul, Args); + + end Set_Up_Child_Communications; + + --------------------------- + -- Set_Up_Communications -- + --------------------------- + + procedure Set_Up_Communications + (Pid : in out Process_Descriptor; + Err_To_Out : Boolean; + Pipe1 : access Pipe_Type; + Pipe2 : access Pipe_Type; + Pipe3 : access Pipe_Type) + is + begin + -- Create the pipes + + if Create_Pipe (Pipe1) /= 0 then + return; + end if; + + if Create_Pipe (Pipe2) /= 0 then + return; + end if; + + Pid.Input_Fd := Pipe1.Output; + Pid.Output_Fd := Pipe2.Input; + + if Err_To_Out then + Pipe3.all := Pipe2.all; + else + if Create_Pipe (Pipe3) /= 0 then + return; + end if; + end if; + + Pid.Error_Fd := Pipe3.Input; + end Set_Up_Communications; + + ---------------------------------- + -- Set_Up_Parent_Communications -- + ---------------------------------- + + procedure Set_Up_Parent_Communications + (Pid : in out Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type) + is + pragma Warnings (Off, Pid); + + begin + + Dup2 (Save_Input, GNAT.OS_Lib.Standin); + Dup2 (Save_Output, GNAT.OS_Lib.Standout); + Dup2 (Save_Error, GNAT.OS_Lib.Standerr); + + Close (Save_Input); + Close (Save_Output); + Close (Save_Error); + + Close (Pipe1.Input); + Close (Pipe2.Output); + Close (Pipe3.Output); + end Set_Up_Parent_Communications; + + ------------------ + -- Trace_Filter -- + ------------------ + + procedure Trace_Filter + (Descriptor : Process_Descriptor'Class; + Str : String; + User_Data : System.Address := System.Null_Address) + is + pragma Warnings (Off, Descriptor); + pragma Warnings (Off, User_Data); + + begin + GNAT.IO.Put (Str); + end Trace_Filter; + + -------------------- + -- Unlock_Filters -- + -------------------- + + procedure Unlock_Filters (Descriptor : in out Process_Descriptor) is + begin + if Descriptor.Filters_Lock > 0 then + Descriptor.Filters_Lock := Descriptor.Filters_Lock - 1; + end if; + end Unlock_Filters; + + end GNAT.Expect; diff -Nrc3pad gcc-3.3.3/gcc/ada/3vsoccon.ads gcc-3.4.0/gcc/ada/3vsoccon.ads *** gcc-3.3.3/gcc/ada/3vsoccon.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/3vsoccon.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S O C K E T S . C O N S T A N T S -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2000-2003 Free Software Foundation, Inc. -- + -- -- + -- GNAT is free software; you can redistribute it and/or modify it under -- + -- terms of the GNU General Public License as published by the Free Soft- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- + -- MA 02111-1307, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package provides target dependent definitions of constant for use + -- by the GNAT.Sockets package (g-socket.ads). This package should not be + -- directly with'ed by an applications program. + + -- This is the version for Alpha/VMS + + package GNAT.Sockets.Constants is + + -------------- + -- Families -- + -------------- + + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 26; -- IPv6 address family + + ----------- + -- Modes -- + ----------- + + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket + + ------------------- + -- Socket errors -- + ------------------- + + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 48; -- Address already in use + EADDRNOTAVAIL : constant := 49; -- Cannot assign address + EAFNOSUPPORT : constant := 47; -- Addr family not supported + EALREADY : constant := 37; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 53; -- Connection aborted + ECONNREFUSED : constant := 61; -- Connection refused + ECONNRESET : constant := 54; -- Connection reset by peer + EDESTADDRREQ : constant := 39; -- Destination addr required + EFAULT : constant := 45; -- Bad address + EHOSTDOWN : constant := 64; -- Host is down + EHOSTUNREACH : constant := 65; -- No route to host + EINPROGRESS : constant := 36; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 56; -- Socket already connected + ELOOP : constant := 62; -- Too many symbolic lynks + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 40; -- Message too long + ENAMETOOLONG : constant := 63; -- Name too long + ENETDOWN : constant := 50; -- Network is down + ENETRESET : constant := 52; -- Disconn. on network reset + ENETUNREACH : constant := 51; -- Network is unreachable + ENOBUFS : constant := 55; -- No buffer space available + ENOPROTOOPT : constant := 42; -- Protocol not available + ENOTCONN : constant := 57; -- Socket not connected + ENOTSOCK : constant := 38; -- Operation on non socket + EOPNOTSUPP : constant := 95; -- Operation not supported + EPFNOSUPPORT : constant := 46; -- Unknown protocol family + EPROTONOSUPPORT : constant := 43; -- Unknown protocol + EPROTOTYPE : constant := 41; -- Unknown protocol type + ESHUTDOWN : constant := 58; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported + ETIMEDOUT : constant := 60; -- Connection timed out + ETOOMANYREFS : constant := 59; -- Too many references + EWOULDBLOCK : constant := 35; -- Operation would block + + ----------------- + -- Host errors -- + ----------------- + + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors + + ------------------- + -- Control flags -- + ------------------- + + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read + + -------------------- + -- Shutdown modes -- + -------------------- + + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send + + --------------------- + -- Protocol levels -- + --------------------- + + SOL_SOCKET : constant := 16#FFFF#; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP + + ------------------- + -- Request flags -- + ------------------- + + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + + -------------------- + -- Socket options -- + -------------------- + + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_SNDBUF : constant := 16#1001#; -- Set/get send buffer size + SO_RCVBUF : constant := 16#1002#; -- Set/get recv buffer size + SO_REUSEADDR : constant := 16#0004#; -- Bind reuse local address + SO_KEEPALIVE : constant := 16#0008#; -- Enable keep-alive msgs + SO_LINGER : constant := 16#0080#; -- Defer close to flush data + SO_ERROR : constant := 16#1007#; -- Get/clear error status + SO_BROADCAST : constant := 16#0020#; -- Can send broadcast msgs + IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group + IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback + + end GNAT.Sockets.Constants; diff -Nrc3pad gcc-3.3.3/gcc/ada/3vsocthi.adb gcc-3.4.0/gcc/ada/3vsocthi.adb *** gcc-3.3.3/gcc/ada/3vsocthi.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/3vsocthi.adb 2004-01-12 11:45:23.000000000 +0000 *************** *** 0 **** --- 1,551 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S O C K E T S . T H I N -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2001-2004 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 was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- Temporary version for Alpha/VMS. + + with GNAT.OS_Lib; use GNAT.OS_Lib; + with GNAT.Task_Lock; + + with Interfaces.C; use Interfaces.C; + + package body GNAT.Sockets.Thin is + + Non_Blocking_Sockets : constant Fd_Set_Access + := New_Socket_Set (No_Socket_Set); + -- When this package is initialized with Process_Blocking_IO set + -- to True, sockets are set in non-blocking mode to avoid blocking + -- the whole process when a thread wants to perform a blocking IO + -- operation. But the user can also set a socket in non-blocking + -- mode by purpose. In order to make a difference between these + -- two situations, we track the origin of non-blocking mode in + -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has + -- been set in non-blocking mode by the user. + + Quantum : constant Duration := 0.2; + -- When Thread_Blocking_IO is False, we set sockets in + -- non-blocking mode and we spend a period of time Quantum between + -- two attempts on a blocking operation. + + Thread_Blocking_IO : Boolean := True; + + Unknown_System_Error : constant C.Strings.chars_ptr := + C.Strings.New_String ("Unknown system error"); + + function Syscall_Accept + (S : C.int; + Addr : System.Address; + Addrlen : access C.int) return C.int; + pragma Import (C, Syscall_Accept, "accept"); + + function Syscall_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int; + pragma Import (C, Syscall_Connect, "connect"); + + function Syscall_Ioctl + (S : C.int; + Req : C.int; + Arg : Int_Access) return C.int; + pragma Import (C, Syscall_Ioctl, "ioctl"); + + function Syscall_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int; + pragma Import (C, Syscall_Recv, "recv"); + + function Syscall_Recvfrom + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + From : Sockaddr_In_Access; + Fromlen : access C.int) return C.int; + pragma Import (C, Syscall_Recvfrom, "recvfrom"); + + function Syscall_Send + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) + return C.int; + pragma Import (C, Syscall_Send, "send"); + + function Syscall_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : Sockaddr_In_Access; + Tolen : C.int) + return C.int; + pragma Import (C, Syscall_Sendto, "sendto"); + + function Syscall_Socket + (Domain, Typ, Protocol : C.int) return C.int; + pragma Import (C, Syscall_Socket, "socket"); + + function Non_Blocking_Socket (S : C.int) return Boolean; + procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean); + + -------------- + -- C_Accept -- + -------------- + + function C_Accept + (S : C.int; + Addr : System.Address; + Addrlen : access C.int) return C.int + is + R : C.int; + Val : aliased C.int := 1; + + Discard : C.int; + pragma Warnings (Off, Discard); + + begin + loop + R := Syscall_Accept (S, Addr, Addrlen); + exit when Thread_Blocking_IO + or else R /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + if not Thread_Blocking_IO + and then R /= Failure + then + -- A socket inherits the properties ot its server especially + -- the FIONBIO flag. Do not use C_Ioctl as this subprogram + -- tracks sockets set in non-blocking mode by user. + + Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); + Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); + end if; + + return R; + end C_Accept; + + --------------- + -- C_Connect -- + --------------- + + function C_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int + is + Res : C.int; + + begin + Res := Syscall_Connect (S, Name, Namelen); + + if Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EINPROGRESS + then + return Res; + end if; + + declare + WSet : Fd_Set_Access; + Now : aliased Timeval; + + begin + WSet := New_Socket_Set (No_Socket_Set); + loop + Insert_Socket_In_Set (WSet, S); + Now := Immediat; + Res := C_Select + (S + 1, + No_Fd_Set, + WSet, + No_Fd_Set, + Now'Unchecked_Access); + + exit when Res > 0; + + if Res = Failure then + Free_Socket_Set (WSet); + return Res; + end if; + + delay Quantum; + end loop; + + Free_Socket_Set (WSet); + end; + + Res := Syscall_Connect (S, Name, Namelen); + + if Res = Failure + and then Errno = Constants.EISCONN + then + return Thin.Success; + else + return Res; + end if; + end C_Connect; + + ------------- + -- C_Ioctl -- + ------------- + + function C_Ioctl + (S : C.int; + Req : C.int; + Arg : Int_Access) return C.int + is + begin + if not Thread_Blocking_IO + and then Req = Constants.FIONBIO + then + if Arg.all /= 0 then + Set_Non_Blocking_Socket (S, True); + end if; + end if; + + return Syscall_Ioctl (S, Req, Arg); + end C_Ioctl; + + ------------ + -- C_Recv -- + ------------ + + function C_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Recv (S, Msg, Len, Flags); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Recv; + + ---------------- + -- C_Recvfrom -- + ---------------- + + function C_Recvfrom + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + From : Sockaddr_In_Access; + Fromlen : access C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Recvfrom; + + ------------ + -- C_Send -- + ------------ + + function C_Send + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Send (S, Msg, Len, Flags); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Send; + + -------------- + -- C_Sendto -- + -------------- + + 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 + is + Res : C.int; + + begin + loop + Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Sendto; + + -------------- + -- C_Socket -- + -------------- + + function C_Socket + (Domain : C.int; + Typ : C.int; + Protocol : C.int) return C.int + is + R : C.int; + Val : aliased C.int := 1; + + Discard : C.int; + pragma Unreferenced (Discard); + + begin + R := Syscall_Socket (Domain, Typ, Protocol); + + if not Thread_Blocking_IO + and then R /= Failure + then + -- Do not use C_Ioctl as this subprogram tracks sockets set + -- in non-blocking mode by user. + + Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); + Set_Non_Blocking_Socket (R, False); + end if; + + return R; + end C_Socket; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + null; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Process_Blocking_IO : Boolean) is + begin + Thread_Blocking_IO := not Process_Blocking_IO; + end Initialize; + + ------------------------- + -- Non_Blocking_Socket -- + ------------------------- + + function Non_Blocking_Socket (S : C.int) return Boolean is + R : Boolean; + begin + Task_Lock.Lock; + R := Is_Socket_In_Set (Non_Blocking_Sockets, S); + Task_Lock.Unlock; + return R; + end Non_Blocking_Socket; + + ----------------- + -- Set_Address -- + ----------------- + + procedure Set_Address (Sin : Sockaddr_In_Access; Address : In_Addr) is + begin + Sin.Sin_Addr := Address; + end Set_Address; + + ---------------- + -- Set_Family -- + ---------------- + + procedure Set_Family (Sin : Sockaddr_In_Access; Family : C.int) is + begin + Sin.Sin_Family := C.unsigned_short (Family); + end Set_Family; + + ---------------- + -- Set_Length -- + ---------------- + + procedure Set_Length (Sin : Sockaddr_In_Access; Len : C.int) is + pragma Unreferenced (Sin); + pragma Unreferenced (Len); + begin + null; + end Set_Length; + + ----------------------------- + -- Set_Non_Blocking_Socket -- + ----------------------------- + + procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is + begin + Task_Lock.Lock; + + if V then + Insert_Socket_In_Set (Non_Blocking_Sockets, S); + else + Remove_Socket_From_Set (Non_Blocking_Sockets, S); + end if; + + Task_Lock.Unlock; + end Set_Non_Blocking_Socket; + + -------------- + -- Set_Port -- + -------------- + + procedure Set_Port (Sin : Sockaddr_In_Access; Port : C.unsigned_short) is + begin + Sin.Sin_Port := Port; + end Set_Port; + + -------------------------- + -- Socket_Error_Message -- + -------------------------- + + function Socket_Error_Message + (Errno : Integer) return C.Strings.chars_ptr + is + use type Interfaces.C.Strings.chars_ptr; + + C_Msg : C.Strings.chars_ptr; + + begin + C_Msg := C_Strerror (C.int (Errno)); + + if C_Msg = C.Strings.Null_Ptr then + return Unknown_System_Error; + else + return C_Msg; + end if; + end Socket_Error_Message; + + ------------- + -- C_Readv -- + ------------- + + function C_Readv + (Fd : C.int; + Iov : System.Address; + Iovcnt : C.int) return C.int + is + Res : C.int; + Count : C.int := 0; + + Iovec : array (0 .. Iovcnt - 1) of Vector_Element; + for Iovec'Address use Iov; + pragma Import (Ada, Iovec); + + begin + for J in Iovec'Range loop + Res := C_Read + (Fd, + Iovec (J).Base.all'Address, + Interfaces.C.int (Iovec (J).Length)); + + if Res < 0 then + return Res; + else + Count := Count + Res; + end if; + end loop; + return Count; + end C_Readv; + + -------------- + -- C_Writev -- + -------------- + + function C_Writev + (Fd : C.int; + Iov : System.Address; + Iovcnt : C.int) return C.int + is + Res : C.int; + Count : C.int := 0; + + Iovec : array (0 .. Iovcnt - 1) of Vector_Element; + for Iovec'Address use Iov; + pragma Import (Ada, Iovec); + + begin + for J in Iovec'Range loop + Res := C_Write + (Fd, + Iovec (J).Base.all'Address, + Interfaces.C.int (Iovec (J).Length)); + + if Res < 0 then + return Res; + else + Count := Count + Res; + end if; + end loop; + return Count; + end C_Writev; + + end GNAT.Sockets.Thin; diff -Nrc3pad gcc-3.3.3/gcc/ada/3vsocthi.ads gcc-3.4.0/gcc/ada/3vsocthi.ads *** gcc-3.3.3/gcc/ada/3vsocthi.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/3vsocthi.ads 2004-01-12 11:45:23.000000000 +0000 *************** *** 0 **** --- 1,445 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S O C K E T S . T H I N -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2002-2004 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 was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package provides a target dependent thin interface to the sockets + -- layer for use by the GNAT.Sockets package (g-socket.ads). This package + -- should not be directly with'ed by an applications program. + + -- This is the Alpha/VMS version. + + with Interfaces.C.Pointers; + + with Interfaces.C.Strings; + with GNAT.Sockets.Constants; + with GNAT.OS_Lib; + + with System; + + package GNAT.Sockets.Thin is + + -- ??? more comments needed ??? + + package C renames Interfaces.C; + + use type C.int; + -- This is so we can declare the Failure constant below + + Success : constant C.int := 0; + Failure : constant C.int := -1; + + function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; + -- Returns last socket error number. + + function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr; + -- Returns the error message string for the error number Errno. If + -- Errno is not known it returns "Unknown system error". + + subtype Fd_Set_Access is System.Address; + No_Fd_Set : constant Fd_Set_Access := System.Null_Address; + + type Timeval_Unit is new C.int; + 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 + + procedure Set_Length + (Sin : Sockaddr_In_Access; + Len : C.int); + pragma Inline (Set_Length); + -- Set Sin.Sin_Length to Len. + -- On this platform, nothing is done as there is no such field. + + procedure Set_Family + (Sin : Sockaddr_In_Access; + Family : C.int); + pragma Inline (Set_Family); + -- Set Sin.Sin_Family to Family + + procedure Set_Port + (Sin : Sockaddr_In_Access; + Port : C.unsigned_short); + pragma Inline (Set_Port); + -- Set Sin.Sin_Port to Port + + procedure Set_Address + (Sin : Sockaddr_In_Access; + Address : In_Addr); + pragma Inline (Set_Address); + -- Set Sin.Sin_Addr to Address + + type Hostent is record + H_Name : C.Strings.chars_ptr; + H_Aliases : Chars_Ptr_Pointers.Pointer; + H_Addrtype : C.int; + H_Length : C.int; + 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 Servent is record + S_Name : C.Strings.chars_ptr; + S_Aliases : Chars_Ptr_Pointers.Pointer; + S_Port : C.int; + S_Proto : C.Strings.chars_ptr; + end record; + pragma Convention (C, Servent); + -- Service entry + + type Servent_Access is access all Servent; + pragma Convention (C, Servent_Access); + -- Access to service 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; + Len : 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_Getservbyname + (Name : C.char_array; + Proto : C.char_array) + return Servent_Access; + + function C_Getservbyport + (Port : C.int; + Proto : C.char_array) + return Servent_Access; + + 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 + (Fd : C.int; + Buf : System.Address; + Count : C.int) + return C.int; + + function C_Readv + (Fd : C.int; + Iov : System.Address; + Iovcnt : C.int) + return C.int; + + function C_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) + return C.int; + + function C_Recvfrom + (S : C.int; + Msg : 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; + Msg : 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 + (Fd : C.int; + Buf : System.Address; + Count : C.int) + return C.int; + + function C_Writev + (Fd : C.int; + Iov : System.Address; + Iovcnt : C.int) + return C.int; + + procedure Free_Socket_Set + (Set : Fd_Set_Access); + -- Free system-dependent socket set. + + procedure Get_Socket_From_Set + (Set : Fd_Set_Access; + Socket : Int_Access; + Last : Int_Access); + -- Get last socket in Socket and remove it from the socket + -- set. The parameter Last is a maximum value of the largest + -- socket. This hint is used to avoid scanning very large socket + -- sets. After a call to Get_Socket_From_Set, Last is set back to + -- the real largest socket in the socket set. + + procedure Insert_Socket_In_Set + (Set : Fd_Set_Access; + Socket : C.int); + -- Insert socket in the socket set. + + function Is_Socket_In_Set + (Set : Fd_Set_Access; + Socket : C.int) + return Boolean; + -- Check whether Socket is in the socket set. + + procedure Last_Socket_In_Set + (Set : Fd_Set_Access; + Last : Int_Access); + -- Find the largest socket in the socket set. This is needed for + -- select(). When Last_Socket_In_Set is called, parameter Last is + -- a maximum value of the largest socket. This hint is used to + -- avoid scanning very large socket sets. After the call, Last is + -- set back to the real largest socket in the socket set. + + function New_Socket_Set + (Set : Fd_Set_Access) + return Fd_Set_Access; + -- Allocate a new socket set which is a system-dependent structure + -- and initialize by copying Set if it is non-null, by making it + -- empty otherwise. + + procedure Remove_Socket_From_Set + (Set : Fd_Set_Access; + Socket : C.int); + -- Remove socket from the socket set. + + procedure Finalize; + procedure Initialize (Process_Blocking_IO : Boolean); + + private + + pragma Import (C, C_Bind, "DECC$BIND"); + pragma Import (C, C_Close, "DECC$CLOSE"); + pragma Import (C, C_Gethostbyaddr, "DECC$GETHOSTBYADDR"); + pragma Import (C, C_Gethostbyname, "DECC$GETHOSTBYNAME"); + pragma Import (C, C_Gethostname, "DECC$GETHOSTNAME"); + pragma Import (C, C_Getpeername, "DECC$GETPEERNAME"); + pragma Import (C, C_Getservbyname, "DECC$GETSERVBYNAME"); + pragma Import (C, C_Getservbyport, "DECC$GETSERVBYPORT"); + pragma Import (C, C_Getsockname, "DECC$GETSOCKNAME"); + pragma Import (C, C_Getsockopt, "DECC$GETSOCKOPT"); + pragma Import (C, C_Inet_Addr, "DECC$INET_ADDR"); + pragma Import (C, C_Listen, "DECC$LISTEN"); + pragma Import (C, C_Read, "DECC$READ"); + pragma Import (C, C_Select, "DECC$SELECT"); + pragma Import (C, C_Setsockopt, "DECC$SETSOCKOPT"); + pragma Import (C, C_Shutdown, "DECC$SHUTDOWN"); + pragma Import (C, C_Strerror, "DECC$STRERROR"); + pragma Import (C, C_System, "DECC$SYSTEM"); + pragma Import (C, C_Write, "DECC$WRITE"); + + pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); + pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); + pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); + pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); + pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); + pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); + pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); + end GNAT.Sockets.Thin; diff -Nrc3pad gcc-3.3.3/gcc/ada/3vtrasym.adb gcc-3.4.0/gcc/ada/3vtrasym.adb *** gcc-3.3.3/gcc/ada/3vtrasym.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/3vtrasym.adb 2003-11-04 12:51:45.000000000 +0000 *************** *** 0 **** --- 1,282 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- G N A T . T R A C E B A C K . S Y M B O L I C -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 1999-2003 Free Software Foundation, Inc. -- + -- -- + -- GNAT is free software; you can redistribute it and/or modify it under -- + -- terms of the GNU General Public License as published by the Free Soft- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- + -- MA 02111-1307, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- Run-time symbolic traceback support for VMS + + with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; + with Interfaces.C; + with System; + with System.Aux_DEC; + with System.Soft_Links; + with System.Traceback_Entries; + + package body GNAT.Traceback.Symbolic is + + pragma Warnings (Off); + pragma Linker_Options ("--for-linker=sys$library:trace.exe"); + + use Interfaces.C; + use System; + use System.Aux_DEC; + use System.Traceback_Entries; + + subtype User_Arg_Type is Unsigned_Longword; + subtype Cond_Value_Type is Unsigned_Longword; + + type ASCIC is record + Count : unsigned_char; + Data : char_array (1 .. 255); + end record; + pragma Convention (C, ASCIC); + + for ASCIC use record + Count at 0 range 0 .. 7; + Data at 1 range 0 .. 8 * 255 - 1; + end record; + for ASCIC'Size use 8 * 256; + + function Fetch_ASCIC is new Fetch_From_Address (ASCIC); + + procedure Symbolize + (Status : out Cond_Value_Type; + Current_PC : in Address; + Adjusted_PC : in Address; + Current_FP : in Address; + Current_R26 : in Address; + Image_Name : out Address; + Module_Name : out Address; + Routine_Name : out Address; + Line_Number : out Integer; + Relative_PC : out Address; + Absolute_PC : out Address; + PC_Is_Valid : out Long_Integer; + User_Act_Proc : Address := Address'Null_Parameter; + User_Arg_Value : User_Arg_Type := User_Arg_Type'Null_Parameter); + + pragma Interface (External, Symbolize); + + pragma Import_Valued_Procedure + (Symbolize, "TBK$SYMBOLIZE", + (Cond_Value_Type, Address, Address, Address, Address, + Address, Address, Address, Integer, + Address, Address, Long_Integer, + Address, User_Arg_Type), + (Value, Value, Value, Value, Value, + Reference, Reference, Reference, Reference, + Reference, Reference, Reference, + Value, Value), + User_Act_Proc); + + function Decode_Ada_Name (Encoded_Name : String) return String; + -- Decodes an Ada identifier name. Removes leading "_ada_" and trailing + -- __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.' + + --------------------- + -- Decode_Ada_Name -- + --------------------- + + function Decode_Ada_Name (Encoded_Name : String) return String is + Decoded_Name : String (1 .. Encoded_Name'Length); + Pos : Integer := Encoded_Name'First; + Last : Integer := Encoded_Name'Last; + DPos : Integer := 1; + + begin + if Pos > Last then + return ""; + end if; + + -- Skip leading _ada_ + + if Encoded_Name'Length > 4 + and then Encoded_Name (Pos .. Pos + 4) = "_ada_" + then + Pos := Pos + 5; + end if; + + -- Skip trailing __{DIGIT}+ or ${DIGIT}+ + + if Encoded_Name (Last) in '0' .. '9' then + for J in reverse Pos + 2 .. Last - 1 loop + case Encoded_Name (J) is + when '0' .. '9' => + null; + when '$' => + Last := J - 1; + exit; + when '_' => + if Encoded_Name (J - 1) = '_' then + Last := J - 2; + end if; + exit; + when others => + exit; + end case; + end loop; + end if; + + -- Now just copy encoded name to decoded name, converting "__" to '.' + + while Pos <= Last loop + if Encoded_Name (Pos) = '_' and then Encoded_Name (Pos + 1) = '_' + and then Pos /= Encoded_Name'First + then + Decoded_Name (DPos) := '.'; + Pos := Pos + 2; + + else + Decoded_Name (DPos) := Encoded_Name (Pos); + Pos := Pos + 1; + end if; + + DPos := DPos + 1; + end loop; + + return Decoded_Name (1 .. DPos - 1); + end Decode_Ada_Name; + + ------------------------ + -- Symbolic_Traceback -- + ------------------------ + + function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is + Status : Cond_Value_Type; + Image_Name : ASCIC; + Image_Name_Addr : Address; + Module_Name : ASCIC; + Module_Name_Addr : Address; + Routine_Name : ASCIC; + Routine_Name_Addr : Address; + Line_Number : Integer; + Relative_PC : Address; + Absolute_PC : Address; + PC_Is_Valid : Long_Integer; + Return_Address : Address; + Res : String (1 .. 256 * Traceback'Length); + Len : Integer; + + begin + if Traceback'Length > 0 then + Len := 0; + + -- Since image computation is not thread-safe we need task lockout + + System.Soft_Links.Lock_Task.all; + + for J in Traceback'Range loop + if J = Traceback'Last then + Return_Address := Address_Zero; + else + Return_Address := PC_For (Traceback (J + 1)); + end if; + + Symbolize + (Status, + PC_For (Traceback (J)), + PC_For (Traceback (J)), + PV_For (Traceback (J)), + Return_Address, + Image_Name_Addr, + Module_Name_Addr, + Routine_Name_Addr, + Line_Number, + Relative_PC, + Absolute_PC, + PC_Is_Valid); + + Image_Name := Fetch_ASCIC (Image_Name_Addr); + Module_Name := Fetch_ASCIC (Module_Name_Addr); + Routine_Name := Fetch_ASCIC (Routine_Name_Addr); + + declare + First : Integer := Len + 1; + Last : Integer := First + 80 - 1; + Pos : Integer; + Routine_Name_D : String := Decode_Ada_Name + (To_Ada + (Routine_Name.Data (1 .. size_t (Routine_Name.Count)), + False)); + + begin + Res (First .. Last) := (others => ' '); + + Res (First .. First + Integer (Image_Name.Count) - 1) := + To_Ada + (Image_Name.Data (1 .. size_t (Image_Name.Count)), + False); + + Res (First + 10 .. + First + 10 + Integer (Module_Name.Count) - 1) := + To_Ada + (Module_Name.Data (1 .. size_t (Module_Name.Count)), + False); + + Res (First + 30 .. + First + 30 + Routine_Name_D'Length - 1) := + Routine_Name_D; + + -- If routine name doesn't fit 20 characters, output + -- the line number on next line at 50th position + + if Routine_Name_D'Length > 20 then + Pos := First + 30 + Routine_Name_D'Length; + Res (Pos) := ASCII.LF; + Last := Pos + 80; + Res (Pos + 1 .. Last) := (others => ' '); + Pos := Pos + 51; + else + Pos := First + 50; + end if; + + Res (Pos .. Pos + Integer'Image (Line_Number)'Length - 1) := + Integer'Image (Line_Number); + + Res (Last) := ASCII.LF; + Len := Last; + end; + end loop; + + System.Soft_Links.Unlock_Task.all; + return Res (1 .. Len); + + else + return ""; + end if; + end Symbolic_Traceback; + + function Symbolic_Traceback (E : Exception_Occurrence) return String is + begin + return Symbolic_Traceback (Tracebacks (E)); + end Symbolic_Traceback; + + end GNAT.Traceback.Symbolic; diff -Nrc3pad gcc-3.3.3/gcc/ada/3wsoccon.ads gcc-3.4.0/gcc/ada/3wsoccon.ads *** gcc-3.3.3/gcc/ada/3wsoccon.ads 2002-03-14 10:58:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/3wsoccon.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2003 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- -- *************** *** 27,135 **** -- 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; --- 26,158 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNAT was originally developed by the GNAT team at New York University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ + -- This package provides target dependent definitions of constant for use + -- by the GNAT.Sockets package (g-socket.ads). This package should not be + -- directly with'ed by an applications program. + -- This is the version for MINGW32 NT package GNAT.Sockets.Constants is ! -------------- ! -- Families -- ! -------------- ! AF_INET : constant := 2; -- IPv4 address family ! AF_INET6 : constant := 3; -- IPv6 address family ! ----------- ! -- Modes -- ! ----------- ! SOCK_STREAM : constant := 1; -- Stream socket ! SOCK_DGRAM : constant := 2; -- Datagram socket ! ------------------- ! -- Socket errors -- ! ------------------- ! EACCES : constant := 10013; -- Permission denied ! EADDRINUSE : constant := 10048; -- Address already in use ! EADDRNOTAVAIL : constant := 10049; -- Cannot assign address ! EAFNOSUPPORT : constant := 10047; -- Addr family not supported ! EALREADY : constant := 10037; -- Operation in progress ! EBADF : constant := 10009; -- Bad file descriptor ! ECONNABORTED : constant := 10053; -- Connection aborted ! ECONNREFUSED : constant := 10061; -- Connection refused ! ECONNRESET : constant := 10054; -- Connection reset by peer ! EDESTADDRREQ : constant := 10039; -- Destination addr required ! EFAULT : constant := 10014; -- Bad address ! EHOSTDOWN : constant := 10064; -- Host is down ! EHOSTUNREACH : constant := 10065; -- No route to host ! EINPROGRESS : constant := 10036; -- Operation now in progress ! EINTR : constant := 10004; -- Interrupted system call ! EINVAL : constant := 10022; -- Invalid argument ! EIO : constant := 10101; -- Input output error ! EISCONN : constant := 10056; -- Socket already connected ! ELOOP : constant := 10062; -- Too many symbolic lynks ! EMFILE : constant := 10024; -- Too many open files ! EMSGSIZE : constant := 10040; -- Message too long ! ENAMETOOLONG : constant := 10063; -- Name too long ! ENETDOWN : constant := 10050; -- Network is down ! ENETRESET : constant := 10052; -- Disconn. on network reset ! ENETUNREACH : constant := 10051; -- Network is unreachable ! ENOBUFS : constant := 10055; -- No buffer space available ! ENOPROTOOPT : constant := 10042; -- Protocol not available ! ENOTCONN : constant := 10057; -- Socket not connected ! ENOTSOCK : constant := 10038; -- Operation on non socket ! EOPNOTSUPP : constant := 10045; -- Operation not supported ! EPFNOSUPPORT : constant := 10046; -- Unknown protocol family ! EPROTONOSUPPORT : constant := 10043; -- Unknown protocol ! EPROTOTYPE : constant := 10041; -- Unknown protocol type ! ESHUTDOWN : constant := 10058; -- Cannot send once shutdown ! ESOCKTNOSUPPORT : constant := 10044; -- Socket type not supported ! ETIMEDOUT : constant := 10060; -- Connection timed out ! ETOOMANYREFS : constant := 10059; -- Too many references ! EWOULDBLOCK : constant := 10035; -- Operation would block ! ----------------- ! -- Host errors -- ! ----------------- ! HOST_NOT_FOUND : constant := 11001; -- Unknown host ! TRY_AGAIN : constant := 11002; -- Host name lookup failure ! NO_DATA : constant := 11004; -- No data record for name ! NO_RECOVERY : constant := 11003; -- Non recoverable errors ! ------------------- ! -- Control flags -- ! ------------------- ! FIONBIO : constant := -2147195266; -- Set/clear non-blocking io ! FIONREAD : constant := 1074030207; -- How many bytes to read ! -------------------- ! -- Shutdown modes -- ! -------------------- ! SHUT_RD : constant := 0; -- No more recv ! SHUT_WR : constant := 1; -- No more send ! SHUT_RDWR : constant := 2; -- No more recv/send ! --------------------- ! -- Protocol levels -- ! --------------------- ! SOL_SOCKET : constant := 65535; -- Options for socket level ! IPPROTO_IP : constant := 0; -- Dummy protocol for IP ! IPPROTO_UDP : constant := 17; -- UDP ! IPPROTO_TCP : constant := 6; -- TCP ! ------------------- ! -- Request flags -- ! ------------------- ! MSG_OOB : constant := 1; -- Process out-of-band data ! MSG_PEEK : constant := 2; -- Peek at incoming data ! MSG_EOR : constant := -1; -- Send end of record ! MSG_WAITALL : constant := -1; -- Wait for full reception ! -------------------- ! -- Socket options -- ! -------------------- ! ! TCP_NODELAY : constant := 1; -- Do not coalesce packets ! SO_SNDBUF : constant := 4097; -- Set/get send buffer size ! SO_RCVBUF : constant := 4098; -- Set/get recv buffer size ! SO_REUSEADDR : constant := 4; -- Bind reuse local address ! SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs ! SO_LINGER : constant := 128; -- Defer close to flush data ! SO_ERROR : constant := 4103; -- Get/clear error status ! SO_BROADCAST : constant := 32; -- Can send broadcast msgs ! IP_ADD_MEMBERSHIP : constant := 5; -- Join a multicast group ! IP_DROP_MEMBERSHIP : constant := 6; -- Leave a multicast group ! IP_MULTICAST_TTL : constant := 3; -- Set/get multicast TTL ! IP_MULTICAST_LOOP : constant := 4; -- Set/get mcast loopback end GNAT.Sockets.Constants; diff -Nrc3pad gcc-3.3.3/gcc/ada/3wsocthi.adb gcc-3.4.0/gcc/ada/3wsocthi.adb *** gcc-3.3.3/gcc/ada/3wsocthi.adb 2002-03-14 10:58:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/3wsocthi.adb 2004-01-12 11:45:23.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2004 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- -- *************** *** 27,38 **** -- 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; --- 26,47 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNAT was originally developed by the GNAT team at New York University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ + -- This package provides a target dependent thin interface to the sockets + -- layer for use by the GNAT.Sockets package (g-socket.ads). This package + -- should not be directly with'ed by an applications program. + -- This version is for NT. + with GNAT.Sockets.Constants; use GNAT.Sockets.Constants; + with Interfaces.C.Strings; use Interfaces.C.Strings; + + with System; use System; + package body GNAT.Sockets.Thin is use type C.unsigned; *************** package body GNAT.Sockets.Thin is *** 42,316 **** 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; --- 51,586 ---- WS_Version : constant := 16#0101#; Initialized : Boolean := False; ! SYSNOTREADY : constant := 10091; ! VERNOTSUPPORTED : constant := 10092; ! NOTINITIALISED : constant := 10093; ! EDISCON : constant := 10101; ! function Standard_Connect ! (S : C.int; ! Name : System.Address; ! Namelen : C.int) ! return C.int; ! pragma Import (Stdcall, Standard_Connect, "connect"); ! function Standard_Select ! (Nfds : C.int; ! Readfds : Fd_Set_Access; ! Writefds : Fd_Set_Access; ! Exceptfds : Fd_Set_Access; ! Timeout : Timeval_Access) ! return C.int; ! pragma Import (Stdcall, Standard_Select, "select"); ! type Error_Type is ! (N_EINTR, ! N_EBADF, ! N_EACCES, ! N_EFAULT, ! N_EINVAL, ! N_EMFILE, ! N_EWOULDBLOCK, ! N_EINPROGRESS, ! N_EALREADY, ! N_ENOTSOCK, ! N_EDESTADDRREQ, ! N_EMSGSIZE, ! N_EPROTOTYPE, ! N_ENOPROTOOPT, ! N_EPROTONOSUPPORT, ! N_ESOCKTNOSUPPORT, ! N_EOPNOTSUPP, ! N_EPFNOSUPPORT, ! N_EAFNOSUPPORT, ! N_EADDRINUSE, ! N_EADDRNOTAVAIL, ! N_ENETDOWN, ! N_ENETUNREACH, ! N_ENETRESET, ! N_ECONNABORTED, ! N_ECONNRESET, ! N_ENOBUFS, ! N_EISCONN, ! N_ENOTCONN, ! N_ESHUTDOWN, ! N_ETOOMANYREFS, ! N_ETIMEDOUT, ! N_ECONNREFUSED, ! N_ELOOP, ! N_ENAMETOOLONG, ! N_EHOSTDOWN, ! N_EHOSTUNREACH, ! N_SYSNOTREADY, ! N_VERNOTSUPPORTED, ! N_NOTINITIALISED, ! N_EDISCON, ! N_HOST_NOT_FOUND, ! N_TRY_AGAIN, ! N_NO_RECOVERY, ! N_NO_DATA, ! N_OTHERS); ! Error_Messages : constant array (Error_Type) of chars_ptr := ! (N_EINTR => ! New_String ("Interrupted system call"), ! N_EBADF => ! New_String ("Bad file number"), ! N_EACCES => ! New_String ("Permission denied"), ! N_EFAULT => ! New_String ("Bad address"), ! N_EINVAL => ! New_String ("Invalid argument"), ! N_EMFILE => ! New_String ("Too many open files"), ! N_EWOULDBLOCK => ! New_String ("Operation would block"), ! N_EINPROGRESS => ! New_String ("Operation now in progress. This error is " ! & "returned if any Windows Sockets API " ! & "function is called while a blocking " ! & "function is in progress"), ! N_EALREADY => ! New_String ("Operation already in progress"), ! N_ENOTSOCK => ! New_String ("Socket operation on nonsocket"), ! N_EDESTADDRREQ => ! New_String ("Destination address required"), ! N_EMSGSIZE => ! New_String ("Message too long"), ! N_EPROTOTYPE => ! New_String ("Protocol wrong type for socket"), ! N_ENOPROTOOPT => ! New_String ("Protocol not available"), ! N_EPROTONOSUPPORT => ! New_String ("Protocol not supported"), ! N_ESOCKTNOSUPPORT => ! New_String ("Socket type not supported"), ! N_EOPNOTSUPP => ! New_String ("Operation not supported on socket"), ! N_EPFNOSUPPORT => ! New_String ("Protocol family not supported"), ! N_EAFNOSUPPORT => ! New_String ("Address family not supported by protocol family"), ! N_EADDRINUSE => ! New_String ("Address already in use"), ! N_EADDRNOTAVAIL => ! New_String ("Cannot assign requested address"), ! N_ENETDOWN => ! New_String ("Network is down. This error may be " ! & "reported at any time if the Windows " ! & "Sockets implementation detects an " ! & "underlying failure"), ! N_ENETUNREACH => ! New_String ("Network is unreachable"), ! N_ENETRESET => ! New_String ("Network dropped connection on reset"), ! N_ECONNABORTED => ! New_String ("Software caused connection abort"), ! N_ECONNRESET => ! New_String ("Connection reset by peer"), ! N_ENOBUFS => ! New_String ("No buffer space available"), ! N_EISCONN => ! New_String ("Socket is already connected"), ! N_ENOTCONN => ! New_String ("Socket is not connected"), ! N_ESHUTDOWN => ! New_String ("Cannot send after socket shutdown"), ! N_ETOOMANYREFS => ! New_String ("Too many references: cannot splice"), ! N_ETIMEDOUT => ! New_String ("Connection timed out"), ! N_ECONNREFUSED => ! New_String ("Connection refused"), ! N_ELOOP => ! New_String ("Too many levels of symbolic links"), ! N_ENAMETOOLONG => ! New_String ("File name too long"), ! N_EHOSTDOWN => ! New_String ("Host is down"), ! N_EHOSTUNREACH => ! New_String ("No route to host"), ! N_SYSNOTREADY => ! New_String ("Returned by WSAStartup(), indicating that " ! & "the network subsystem is unusable"), ! N_VERNOTSUPPORTED => ! New_String ("Returned by WSAStartup(), indicating that " ! & "the Windows Sockets DLL cannot support " ! & "this application"), ! N_NOTINITIALISED => ! New_String ("Winsock not initialized. This message is " ! & "returned by any function except WSAStartup(), " ! & "indicating that a successful WSAStartup() has " ! & "not yet been performed"), ! N_EDISCON => ! New_String ("Disconnect"), ! N_HOST_NOT_FOUND => ! New_String ("Host not found. This message indicates " ! & "that the key (name, address, and so on) was not found"), ! N_TRY_AGAIN => ! New_String ("Nonauthoritative host not found. This error may " ! & "suggest that the name service itself is not " ! & "functioning"), ! N_NO_RECOVERY => ! New_String ("Nonrecoverable error. This error may suggest that the " ! & "name service itself is not functioning"), ! N_NO_DATA => ! New_String ("Valid name, no data record of requested type. " ! & "This error indicates that the key (name, address, " ! & "and so on) was not found."), ! N_OTHERS => ! New_String ("Unknown system error")); ! --------------- ! -- C_Connect -- ! --------------- ! function C_Connect ! (S : C.int; ! Name : System.Address; ! Namelen : C.int) ! return C.int ! is ! Res : C.int; begin ! Res := Standard_Connect (S, Name, Namelen); ! if Res = -1 then ! if Socket_Errno = EWOULDBLOCK then ! Set_Socket_Errno (EINPROGRESS); end if; ! end if; ! return Res; ! end C_Connect; ! ------------- ! -- C_Readv -- ! ------------- ! function C_Readv ! (Socket : C.int; ! Iov : System.Address; ! Iovcnt : C.int) ! return C.int ! is ! Res : C.int; ! Count : C.int := 0; ! Iovec : array (0 .. Iovcnt - 1) of Vector_Element; ! for Iovec'Address use Iov; ! pragma Import (Ada, Iovec); begin ! for J in Iovec'Range loop ! Res := C_Recv ! (Socket, ! Iovec (J).Base.all'Address, ! C.int (Iovec (J).Length), ! 0); ! ! if Res < 0 then ! return Res; ! else ! Count := Count + Res; end if; end loop; + return Count; + end C_Readv; ! -------------- ! -- C_Select -- ! -------------- ! function C_Select ! (Nfds : C.int; ! Readfds : Fd_Set_Access; ! Writefds : Fd_Set_Access; ! Exceptfds : Fd_Set_Access; ! Timeout : Timeval_Access) ! return C.int ! is ! pragma Warnings (Off, Exceptfds); ! RFS : constant Fd_Set_Access := Readfds; ! WFS : constant Fd_Set_Access := Writefds; ! WFSC : Fd_Set_Access := No_Fd_Set; ! EFS : Fd_Set_Access := Exceptfds; ! Res : C.int; ! S : aliased C.int; ! Last : aliased C.int; begin ! -- Asynchronous connection failures are notified in the ! -- exception fd set instead of the write fd set. To ensure ! -- POSIX compatitibility, copy write fd set into exception fd ! -- set. Once select() returns, check any socket present in the ! -- exception fd set and peek at incoming out-of-band data. If ! -- the test is not successfull and if the socket is present in ! -- the initial write fd set, then move the socket from the ! -- exception fd set to the write fd set. ! if WFS /= No_Fd_Set then ! -- Add any socket present in write fd set into exception fd set ! if EFS = No_Fd_Set then ! EFS := New_Socket_Set (WFS); ! else ! WFSC := New_Socket_Set (WFS); ! Last := Nfds - 1; ! loop ! Get_Socket_From_Set ! (WFSC, S'Unchecked_Access, Last'Unchecked_Access); ! exit when S = -1; ! Insert_Socket_In_Set (EFS, S); ! end loop; ! Free_Socket_Set (WFSC); ! end if; ! -- Keep a copy of write fd set ! WFSC := New_Socket_Set (WFS); ! end if; ! Res := Standard_Select (Nfds, RFS, WFS, EFS, Timeout); ! if EFS /= No_Fd_Set then ! declare ! EFSC : constant Fd_Set_Access := New_Socket_Set (EFS); ! Flag : constant C.int := MSG_PEEK + MSG_OOB; ! Buffer : Character; ! Length : C.int; ! Fromlen : aliased C.int; ! begin ! Last := Nfds - 1; ! loop ! Get_Socket_From_Set ! (EFSC, S'Unchecked_Access, Last'Unchecked_Access); ! -- No more sockets in EFSC ! exit when S = -1; ! -- Check out-of-band data ! Length := C_Recvfrom ! (S, Buffer'Address, 1, Flag, ! null, Fromlen'Unchecked_Access); ! -- If the signal is not an out-of-band data, then it ! -- is a connection failure notification. ! if Length = -1 then ! Remove_Socket_From_Set (EFS, S); ! -- If S is present in the initial write fd set, ! -- move it from exception fd set back to write fd ! -- set. Otherwise, ignore this event since the user ! -- is not watching for it. ! if WFSC /= No_Fd_Set ! and then Is_Socket_In_Set (WFSC, S) ! then ! Insert_Socket_In_Set (WFS, S); ! end if; ! end if; ! end loop; ! Free_Socket_Set (EFSC); ! end; ! if Exceptfds = No_Fd_Set then ! Free_Socket_Set (EFS); ! end if; ! end if; ! -- Free any copy of write fd set ! if WFSC /= No_Fd_Set then ! Free_Socket_Set (WFSC); ! end if; ! return Res; ! end C_Select; ! -------------- ! -- C_Writev -- ! -------------- ! function C_Writev ! (Socket : C.int; ! Iov : System.Address; ! Iovcnt : C.int) ! return C.int ! is ! Res : C.int; ! Count : C.int := 0; ! Iovec : array (0 .. Iovcnt - 1) of Vector_Element; ! for Iovec'Address use Iov; ! pragma Import (Ada, Iovec); ! begin ! for J in Iovec'Range loop ! Res := C_Send ! (Socket, ! Iovec (J).Base.all'Address, ! C.int (Iovec (J).Length), ! 0); ! if Res < 0 then ! return Res; ! else ! Count := Count + Res; ! end if; ! end loop; ! return Count; ! end C_Writev; ! -------------- ! -- Finalize -- ! -------------- ! procedure Finalize is ! begin ! if Initialized then ! WSACleanup; ! Initialized := False; ! end if; ! end Finalize; ! ---------------- ! -- Initialize -- ! ---------------- ! procedure Initialize (Process_Blocking_IO : Boolean := False) is ! pragma Unreferenced (Process_Blocking_IO); ! 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; ! ----------------- ! -- Set_Address -- ! ----------------- ! procedure Set_Address ! (Sin : Sockaddr_In_Access; ! Address : In_Addr) ! is ! begin ! Sin.Sin_Addr := Address; ! end Set_Address; ! ---------------- ! -- Set_Family -- ! ---------------- ! procedure Set_Family ! (Sin : Sockaddr_In_Access; ! Family : C.int) ! is ! begin ! Sin.Sin_Family := C.unsigned_short (Family); ! end Set_Family; ! ---------------- ! -- Set_Length -- ! ---------------- ! procedure Set_Length ! (Sin : Sockaddr_In_Access; ! Len : C.int) ! is ! pragma Unreferenced (Sin); ! pragma Unreferenced (Len); ! begin ! null; ! end Set_Length; ! -------------- ! -- Set_Port -- ! -------------- ! procedure Set_Port ! (Sin : Sockaddr_In_Access; ! Port : C.unsigned_short) ! is ! begin ! Sin.Sin_Port := Port; ! end Set_Port; ! -------------------------- ! -- Socket_Error_Message -- ! -------------------------- ! function Socket_Error_Message ! (Errno : Integer) ! return C.Strings.chars_ptr ! is ! use GNAT.Sockets.Constants; + begin + case Errno is + when EINTR => return Error_Messages (N_EINTR); + when EBADF => return Error_Messages (N_EBADF); + when EACCES => return Error_Messages (N_EACCES); + when EFAULT => return Error_Messages (N_EFAULT); + when EINVAL => return Error_Messages (N_EINVAL); + when EMFILE => return Error_Messages (N_EMFILE); + when EWOULDBLOCK => return Error_Messages (N_EWOULDBLOCK); + when EINPROGRESS => return Error_Messages (N_EINPROGRESS); + when EALREADY => return Error_Messages (N_EALREADY); + when ENOTSOCK => return Error_Messages (N_ENOTSOCK); + when EDESTADDRREQ => return Error_Messages (N_EDESTADDRREQ); + when EMSGSIZE => return Error_Messages (N_EMSGSIZE); + when EPROTOTYPE => return Error_Messages (N_EPROTOTYPE); + when ENOPROTOOPT => return Error_Messages (N_ENOPROTOOPT); + when EPROTONOSUPPORT => return Error_Messages (N_EPROTONOSUPPORT); + when ESOCKTNOSUPPORT => return Error_Messages (N_ESOCKTNOSUPPORT); + when EOPNOTSUPP => return Error_Messages (N_EOPNOTSUPP); + when EPFNOSUPPORT => return Error_Messages (N_EPFNOSUPPORT); + when EAFNOSUPPORT => return Error_Messages (N_EAFNOSUPPORT); + when EADDRINUSE => return Error_Messages (N_EADDRINUSE); + when EADDRNOTAVAIL => return Error_Messages (N_EADDRNOTAVAIL); + when ENETDOWN => return Error_Messages (N_ENETDOWN); + when ENETUNREACH => return Error_Messages (N_ENETUNREACH); + when ENETRESET => return Error_Messages (N_ENETRESET); + when ECONNABORTED => return Error_Messages (N_ECONNABORTED); + when ECONNRESET => return Error_Messages (N_ECONNRESET); + when ENOBUFS => return Error_Messages (N_ENOBUFS); + when EISCONN => return Error_Messages (N_EISCONN); + when ENOTCONN => return Error_Messages (N_ENOTCONN); + when ESHUTDOWN => return Error_Messages (N_ESHUTDOWN); + when ETOOMANYREFS => return Error_Messages (N_ETOOMANYREFS); + when ETIMEDOUT => return Error_Messages (N_ETIMEDOUT); + when ECONNREFUSED => return Error_Messages (N_ECONNREFUSED); + when ELOOP => return Error_Messages (N_ELOOP); + when ENAMETOOLONG => return Error_Messages (N_ENAMETOOLONG); + when EHOSTDOWN => return Error_Messages (N_EHOSTDOWN); + when EHOSTUNREACH => return Error_Messages (N_EHOSTUNREACH); + when SYSNOTREADY => return Error_Messages (N_SYSNOTREADY); + when VERNOTSUPPORTED => return Error_Messages (N_VERNOTSUPPORTED); + when NOTINITIALISED => return Error_Messages (N_NOTINITIALISED); + when EDISCON => return Error_Messages (N_EDISCON); + when HOST_NOT_FOUND => return Error_Messages (N_HOST_NOT_FOUND); + when TRY_AGAIN => return Error_Messages (N_TRY_AGAIN); + when NO_RECOVERY => return Error_Messages (N_NO_RECOVERY); + when NO_DATA => return Error_Messages (N_NO_DATA); + when others => return Error_Messages (N_OTHERS); end case; end Socket_Error_Message; diff -Nrc3pad gcc-3.3.3/gcc/ada/3wsocthi.ads gcc-3.4.0/gcc/ada/3wsocthi.ads *** gcc-3.3.3/gcc/ada/3wsocthi.ads 2002-03-14 10:58:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/3wsocthi.ads 2004-01-12 11:45:23.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2004 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- -- *************** *** 27,37 **** -- 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; --- 26,41 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNAT was originally developed by the GNAT team at New York University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This package provides a target dependent thin interface to the sockets ! -- layer for use by the GNAT.Sockets package (g-socket.ads). This package ! -- should not be directly with'ed by an applications program. ! ! -- This version is for NT with Interfaces.C.Pointers; with Interfaces.C.Strings; *************** with System; *** 42,49 **** package GNAT.Sockets.Thin is - -- ??? far more comments required ??? - package C renames Interfaces.C; use type C.int; --- 46,51 ---- *************** package GNAT.Sockets.Thin is *** 55,77 **** 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); --- 57,73 ---- function Socket_Errno return Integer; -- Returns last socket error number. ! procedure Set_Socket_Errno (Errno : Integer); ! -- Set last socket error number. ! ! function Socket_Error_Message ! (Errno : Integer) ! return C.Strings.chars_ptr; -- Returns the error message string for the error number Errno. If -- Errno is not known it returns "Unknown system error". ! subtype Fd_Set_Access is System.Address; ! No_Fd_Set : constant Fd_Set_Access := System.Null_Address; type Timeval_Unit is new C.long; pragma Convention (C, Timeval_Unit); *************** package GNAT.Sockets.Thin is *** 143,148 **** --- 139,169 ---- pragma Convention (C, Sockaddr_In_Access); -- Access to internet socket address + procedure Set_Length + (Sin : Sockaddr_In_Access; + Len : C.int); + pragma Inline (Set_Length); + -- Set Sin.Sin_Length to Len. + -- On this platform, nothing is done as there is no such field. + + procedure Set_Family + (Sin : Sockaddr_In_Access; + Family : C.int); + pragma Inline (Set_Family); + -- Set Sin.Sin_Family to Family + + procedure Set_Port + (Sin : Sockaddr_In_Access; + Port : C.unsigned_short); + pragma Inline (Set_Port); + -- Set Sin.Sin_Port to Port + + procedure Set_Address + (Sin : Sockaddr_In_Access; + Address : In_Addr); + pragma Inline (Set_Address); + -- Set Sin.Sin_Addr to Address + type Hostent is record H_Name : C.Strings.chars_ptr; H_Aliases : Chars_Ptr_Pointers.Pointer; *************** package GNAT.Sockets.Thin is *** 157,162 **** --- 178,196 ---- pragma Convention (C, Hostent_Access); -- Access to host entry + type Servent is record + S_Name : C.Strings.chars_ptr; + S_Aliases : Chars_Ptr_Pointers.Pointer; + S_Port : C.int; + S_Proto : C.Strings.chars_ptr; + end record; + pragma Convention (C, Servent); + -- Service entry + + type Servent_Access is access all Servent; + pragma Convention (C, Servent_Access); + -- Access to service entry + type Two_Int is array (0 .. 1) of C.int; pragma Convention (C, Two_Int); -- Used with pipe() *************** package GNAT.Sockets.Thin is *** 164,249 **** 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; --- 198,282 ---- 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_Getservbyname ! (Name : C.char_array; ! Proto : C.char_array) return Servent_Access; ! ! function C_Getservbyport ! (Port : C.int; ! Proto : C.char_array) return Servent_Access; 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 : C.int; ! Backlog : C.int) return C.int; function C_Read (Fildes : C.int; Buf : System.Address; ! Nbyte : C.int) return C.int; ! ! function C_Readv ! (Socket : C.int; ! Iov : System.Address; ! Iovcnt : 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; *************** package GNAT.Sockets.Thin is *** 251,273 **** 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; --- 284,303 ---- 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; *************** package GNAT.Sockets.Thin is *** 275,343 **** 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"); --- 305,407 ---- 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 C_Writev ! (Socket : C.int; ! Iov : System.Address; ! Iovcnt : C.int) return C.int; function WSAStartup (WS_Version : Interfaces.C.int; ! WSADataAddress : System.Address) return Interfaces.C.int; ! procedure Free_Socket_Set ! (Set : Fd_Set_Access); ! -- Free system-dependent socket set. ! procedure Get_Socket_From_Set ! (Set : Fd_Set_Access; ! Socket : Int_Access; ! Last : Int_Access); ! -- Get last socket in Socket and remove it from the socket ! -- set. The parameter Last is a maximum value of the largest ! -- socket. This hint is used to avoid scanning very large socket ! -- sets. After a call to Get_Socket_From_Set, Last is set back to ! -- the real largest socket in the socket set. ! ! procedure Insert_Socket_In_Set ! (Set : Fd_Set_Access; ! Socket : C.int); ! -- Insert socket in the socket set ! ! function Is_Socket_In_Set ! (Set : Fd_Set_Access; ! Socket : C.int) return Boolean; ! -- Check whether Socket is in the socket set ! ! procedure Last_Socket_In_Set ! (Set : Fd_Set_Access; ! Last : Int_Access); ! -- Find the largest socket in the socket set. This is needed for ! -- select(). When Last_Socket_In_Set is called, parameter Last is ! -- a maximum value of the largest socket. This hint is used to ! -- avoid scanning very large socket sets. After the call, Last is ! -- set back to the real largest socket in the socket set. ! ! function New_Socket_Set ! (Set : Fd_Set_Access) return Fd_Set_Access; ! -- Allocate a new socket set which is a system-dependent structure ! -- and initialize by copying Set if it is non-null, by making it ! -- empty otherwise. ! ! procedure Remove_Socket_From_Set ! (Set : Fd_Set_Access; ! Socket : C.int); ! -- Remove socket from the socket set ! ! procedure WSACleanup; 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_Gethostbyaddr, "gethostbyaddr"); pragma Import (Stdcall, C_Gethostbyname, "gethostbyname"); pragma Import (Stdcall, C_Gethostname, "gethostname"); pragma Import (Stdcall, C_Getpeername, "getpeername"); + pragma Import (Stdcall, C_Getservbyname, "getservbyname"); + pragma Import (Stdcall, C_Getservbyport, "getservbyport"); pragma Import (Stdcall, C_Getsockname, "getsockname"); pragma Import (Stdcall, C_Getsockopt, "getsockopt"); pragma Import (Stdcall, C_Inet_Addr, "inet_addr"); *************** private *** 346,352 **** 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"); --- 410,415 ---- *************** private *** 356,362 **** --- 419,433 ---- pragma Import (C, C_System, "_system"); pragma Import (C, C_Write, "_write"); pragma Import (Stdcall, Socket_Errno, "WSAGetLastError"); + pragma Import (Stdcall, Set_Socket_Errno, "WSASetLastError"); pragma Import (Stdcall, WSAStartup, "WSAStartup"); pragma Import (Stdcall, WSACleanup, "WSACleanup"); + pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); + pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); + pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); + pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); + pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); + pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); + pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); end GNAT.Sockets.Thin; diff -Nrc3pad gcc-3.3.3/gcc/ada/3wsoliop.ads gcc-3.4.0/gcc/ada/3wsoliop.ads *** gcc-3.3.3/gcc/ada/3wsoliop.ads 2002-03-14 10:58:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/3wsoliop.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2003 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- -- *************** *** 27,42 **** -- 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; --- 26,43 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNAT was originally developed by the GNAT team at New York University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This package is used to provide target specific linker_options for the ! -- support of scokets as required by the package GNAT.Sockets. ! -- This is the Windows/NT version of this package + package GNAT.Sockets.Linker_Options is + private pragma Linker_Options ("-lwsock32"); end GNAT.Sockets.Linker_Options; diff -Nrc3pad gcc-3.3.3/gcc/ada/3zsoccon.ads gcc-3.4.0/gcc/ada/3zsoccon.ads *** gcc-3.3.3/gcc/ada/3zsoccon.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/3zsoccon.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S O C K E T S . C O N S T A N T S -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2000-2003 Free Software Foundation, Inc. -- + -- -- + -- GNAT is free software; you can redistribute it and/or modify it under -- + -- terms of the GNU General Public License as published by the Free Soft- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- + -- MA 02111-1307, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package provides target dependent definitions of constant for use + -- by the GNAT.Sockets package (g-socket.ads). This package should not be + -- directly with'ed by an applications program. + + -- This is the version for VxWorks + + package GNAT.Sockets.Constants is + + -------------- + -- Families -- + -------------- + + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := -1; -- IPv6 address family + + ----------- + -- Modes -- + ----------- + + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket + + ------------------- + -- Socket errors -- + ------------------- + + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 48; -- Address already in use + EADDRNOTAVAIL : constant := 49; -- Cannot assign address + EAFNOSUPPORT : constant := 47; -- Addr family not supported + EALREADY : constant := 69; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 53; -- Connection aborted + ECONNREFUSED : constant := 61; -- Connection refused + ECONNRESET : constant := 54; -- Connection reset by peer + EDESTADDRREQ : constant := 40; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 67; -- Host is down + EHOSTUNREACH : constant := 65; -- No route to host + EINPROGRESS : constant := 68; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 56; -- Socket already connected + ELOOP : constant := 64; -- Too many symbolic lynks + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 36; -- Message too long + ENAMETOOLONG : constant := 26; -- Name too long + ENETDOWN : constant := 62; -- Network is down + ENETRESET : constant := 52; -- Disconn. on network reset + ENETUNREACH : constant := 51; -- Network is unreachable + ENOBUFS : constant := 55; -- No buffer space available + ENOPROTOOPT : constant := 42; -- Protocol not available + ENOTCONN : constant := 57; -- Socket not connected + ENOTSOCK : constant := 50; -- Operation on non socket + EOPNOTSUPP : constant := 45; -- Operation not supported + EPFNOSUPPORT : constant := 46; -- Unknown protocol family + EPROTONOSUPPORT : constant := 43; -- Unknown protocol + EPROTOTYPE : constant := 41; -- Unknown protocol type + ESHUTDOWN : constant := 58; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported + ETIMEDOUT : constant := 60; -- Connection timed out + ETOOMANYREFS : constant := 59; -- Too many references + EWOULDBLOCK : constant := 70; -- Operation would block + + ----------------- + -- Host errors -- + ----------------- + + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors + + ------------------- + -- Control flags -- + ------------------- + + FIONBIO : constant := 16; -- Set/clear non-blocking io + FIONREAD : constant := 1; -- How many bytes to read + + -------------------- + -- Shutdown modes -- + -------------------- + + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send + + --------------------- + -- Protocol levels -- + --------------------- + + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP + + ------------------- + -- Request flags -- + ------------------- + + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + + -------------------- + -- Socket options -- + -------------------- + + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_ERROR : constant := 4103; -- Get/clear error status + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + IP_ADD_MEMBERSHIP : constant := 35; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 36; -- Leave a multicast group + IP_MULTICAST_TTL : constant := 33; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 34; -- Set/get mcast loopback + + end GNAT.Sockets.Constants; diff -Nrc3pad gcc-3.3.3/gcc/ada/3zsocthi.adb gcc-3.4.0/gcc/ada/3zsocthi.adb *** gcc-3.3.3/gcc/ada/3zsocthi.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/3zsocthi.adb 2004-01-13 11:51:31.000000000 +0000 *************** *** 0 **** --- 1,624 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S O C K E T S . T H I N -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2002-2004 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 was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package provides a target dependent thin interface to the sockets + -- layer for use by the GNAT.Sockets package (g-socket.ads). This package + -- should not be directly with'ed by an applications program. + + -- This version is for VxWorks + + with GNAT.OS_Lib; use GNAT.OS_Lib; + with GNAT.Task_Lock; + + with Interfaces.C; use Interfaces.C; + with Unchecked_Conversion; + + package body GNAT.Sockets.Thin is + + Non_Blocking_Sockets : constant Fd_Set_Access := + New_Socket_Set (No_Socket_Set); + -- When this package is initialized with Process_Blocking_IO set + -- to True, sockets are set in non-blocking mode to avoid blocking + -- the whole process when a thread wants to perform a blocking IO + -- operation. But the user can also set a socket in non-blocking + -- mode by purpose. In order to make a difference between these + -- two situations, we track the origin of non-blocking mode in + -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has + -- been set in non-blocking mode by the user. + + Quantum : constant Duration := 0.2; + -- When Thread_Blocking_IO is False, we set sockets in + -- non-blocking mode and we spend a period of time Quantum between + -- two attempts on a blocking operation. + + Thread_Blocking_IO : Boolean := True; + + Unknown_System_Error : constant C.Strings.chars_ptr := + C.Strings.New_String ("Unknown system error"); + + -- The following types and variables are required to create a Hostent + -- record "by hand". + + type In_Addr_Access_Array_Access is access In_Addr_Access_Array; + + Alias_Access : constant Chars_Ptr_Pointers.Pointer := + new C.Strings.chars_ptr'(C.Strings.Null_Ptr); + + In_Addr_Access_Array_A : constant In_Addr_Access_Array_Access := + new In_Addr_Access_Array'(new In_Addr, null); + + In_Addr_Access_Ptr : constant In_Addr_Access_Pointers.Pointer := + In_Addr_Access_Array_A + (In_Addr_Access_Array_A'First)'Access; + + Local_Hostent : constant Hostent_Access := new Hostent; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- All these require comments ??? + + function Syscall_Accept + (S : C.int; + Addr : System.Address; + Addrlen : access C.int) return C.int; + pragma Import (C, Syscall_Accept, "accept"); + + function Syscall_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int; + pragma Import (C, Syscall_Connect, "connect"); + + function Syscall_Ioctl + (S : C.int; + Req : C.int; + Arg : Int_Access) return C.int; + pragma Import (C, Syscall_Ioctl, "ioctl"); + + function Syscall_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int; + pragma Import (C, Syscall_Recv, "recv"); + + function Syscall_Recvfrom + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + From : Sockaddr_In_Access; + Fromlen : access C.int) return C.int; + pragma Import (C, Syscall_Recvfrom, "recvfrom"); + + function Syscall_Send + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int; + pragma Import (C, Syscall_Send, "send"); + + function Syscall_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : Sockaddr_In_Access; + Tolen : C.int) return C.int; + pragma Import (C, Syscall_Sendto, "sendto"); + + function Syscall_Socket + (Domain : C.int; + Typ : C.int; + Protocol : C.int) return C.int; + pragma Import (C, Syscall_Socket, "socket"); + + function Non_Blocking_Socket (S : C.int) return Boolean; + procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean); + + -------------- + -- C_Accept -- + -------------- + + function C_Accept + (S : C.int; + Addr : System.Address; + Addrlen : access C.int) return C.int + is + R : C.int; + Val : aliased C.int := 1; + + Res : C.int; + pragma Unreferenced (Res); + + begin + loop + R := Syscall_Accept (S, Addr, Addrlen); + exit when Thread_Blocking_IO + or else R /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + if not Thread_Blocking_IO + and then R /= Failure + then + -- A socket inherits the properties ot its server especially + -- the FIONBIO flag. Do not use C_Ioctl as this subprogram + -- tracks sockets set in non-blocking mode by user. + + Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); + Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); + -- Is it OK to ignore result ??? + end if; + + return R; + end C_Accept; + + --------------- + -- C_Connect -- + --------------- + + function C_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int + is + Res : C.int; + + begin + Res := Syscall_Connect (S, Name, Namelen); + + if Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EINPROGRESS + then + return Res; + end if; + + declare + WSet : Fd_Set_Access; + Now : aliased Timeval; + + begin + WSet := New_Socket_Set (No_Socket_Set); + + loop + Insert_Socket_In_Set (WSet, S); + Now := Immediat; + Res := C_Select + (S + 1, + No_Fd_Set, + WSet, + No_Fd_Set, + Now'Unchecked_Access); + + exit when Res > 0; + + if Res = Failure then + Free_Socket_Set (WSet); + return Res; + end if; + + delay Quantum; + end loop; + + Free_Socket_Set (WSet); + end; + + Res := Syscall_Connect (S, Name, Namelen); + + if Res = Failure + and then Errno = Constants.EISCONN + then + return Thin.Success; + else + return Res; + end if; + end C_Connect; + + --------------------- + -- C_Gethostbyaddr -- + --------------------- + + function C_Gethostbyaddr + (Addr : System.Address; + Len : C.int; + Typ : C.int) return Hostent_Access + is + pragma Warnings (Off, Len); + pragma Warnings (Off, Typ); + + type int_Access is access int; + function To_Pointer is + new Unchecked_Conversion (System.Address, int_Access); + + procedure VxWorks_Gethostbyaddr + (Addr : C.int; Buf : out C.char_array); + pragma Import (C, VxWorks_Gethostbyaddr, "hostGetByAddr"); + + Host_Name : C.char_array (1 .. Max_Name_Length); + + begin + VxWorks_Gethostbyaddr (To_Pointer (Addr).all, Host_Name); + + In_Addr_Access_Ptr.all.all := To_In_Addr (To_Pointer (Addr).all); + Local_Hostent.all.H_Name := C.Strings.New_Char_Array (Host_Name); + + return Local_Hostent; + end C_Gethostbyaddr; + + --------------------- + -- C_Gethostbyname -- + --------------------- + + function C_Gethostbyname + (Name : C.char_array) return Hostent_Access + is + function VxWorks_Gethostbyname + (Name : C.char_array) return C.int; + pragma Import (C, VxWorks_Gethostbyname, "hostGetByName"); + + Addr : C.int; + + begin + Addr := VxWorks_Gethostbyname (Name); + + In_Addr_Access_Ptr.all.all := To_In_Addr (Addr); + Local_Hostent.all.H_Name := C.Strings.New_Char_Array (To_C (Host_Name)); + + return Local_Hostent; + end C_Gethostbyname; + + --------------------- + -- C_Getservbyname -- + --------------------- + + function C_Getservbyname + (Name : C.char_array; + Proto : C.char_array) return Servent_Access + is + pragma Warnings (Off, Name); + pragma Warnings (Off, Proto); + + begin + return null; + end C_Getservbyname; + + --------------------- + -- C_Getservbyport -- + --------------------- + + function C_Getservbyport + (Port : C.int; + Proto : C.char_array) return Servent_Access + is + pragma Warnings (Off, Port); + pragma Warnings (Off, Proto); + + begin + return null; + end C_Getservbyport; + + ------------- + -- C_Ioctl -- + ------------- + + function C_Ioctl + (S : C.int; + Req : C.int; + Arg : Int_Access) return C.int + is + begin + if not Thread_Blocking_IO + and then Req = Constants.FIONBIO + then + if Arg.all /= 0 then + Set_Non_Blocking_Socket (S, True); + end if; + end if; + + return Syscall_Ioctl (S, Req, Arg); + end C_Ioctl; + + ------------ + -- C_Recv -- + ------------ + + function C_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Recv (S, Msg, Len, Flags); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Recv; + + ---------------- + -- C_Recvfrom -- + ---------------- + + function C_Recvfrom + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + From : Sockaddr_In_Access; + Fromlen : access C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Recvfrom; + + ------------ + -- C_Send -- + ------------ + + function C_Send + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Send (S, Msg, Len, Flags); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Send; + + -------------- + -- C_Sendto -- + -------------- + + 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 + is + Res : C.int; + + begin + loop + Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Sendto; + + -------------- + -- C_Socket -- + -------------- + + function C_Socket + (Domain : C.int; + Typ : C.int; + Protocol : C.int) return C.int + is + R : C.int; + Val : aliased C.int := 1; + + Res : C.int; + pragma Unreferenced (Res); + + begin + R := Syscall_Socket (Domain, Typ, Protocol); + + if not Thread_Blocking_IO + and then R /= Failure + then + -- Do not use C_Ioctl as this subprogram tracks sockets set + -- in non-blocking mode by user. + + Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); + -- Is it OK to ignore result ??? + Set_Non_Blocking_Socket (R, False); + end if; + + return R; + end C_Socket; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + null; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Process_Blocking_IO : Boolean) is + begin + Thread_Blocking_IO := not Process_Blocking_IO; + end Initialize; + + ------------------------- + -- Non_Blocking_Socket -- + ------------------------- + + function Non_Blocking_Socket (S : C.int) return Boolean is + R : Boolean; + + begin + Task_Lock.Lock; + R := Is_Socket_In_Set (Non_Blocking_Sockets, S); + Task_Lock.Unlock; + return R; + end Non_Blocking_Socket; + + ----------------- + -- Set_Address -- + ----------------- + + procedure Set_Address + (Sin : Sockaddr_In_Access; + Address : In_Addr) + is + begin + Sin.Sin_Addr := Address; + end Set_Address; + + ---------------- + -- Set_Family -- + ---------------- + + procedure Set_Family + (Sin : Sockaddr_In_Access; + Family : C.int) + is + begin + Sin.Sin_Family := C.unsigned_char (Family); + end Set_Family; + + ---------------- + -- Set_Length -- + ---------------- + + procedure Set_Length + (Sin : Sockaddr_In_Access; + Len : C.int) + is + begin + Sin.Sin_Length := C.unsigned_char (Len); + end Set_Length; + + ----------------------------- + -- Set_Non_Blocking_Socket -- + ----------------------------- + + procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is + begin + Task_Lock.Lock; + if V then + Insert_Socket_In_Set (Non_Blocking_Sockets, S); + else + Remove_Socket_From_Set (Non_Blocking_Sockets, S); + end if; + + Task_Lock.Unlock; + end Set_Non_Blocking_Socket; + + -------------- + -- Set_Port -- + -------------- + + procedure Set_Port + (Sin : Sockaddr_In_Access; + Port : C.unsigned_short) + is + begin + Sin.Sin_Port := Port; + end Set_Port; + + -------------------------- + -- Socket_Error_Message -- + -------------------------- + + function Socket_Error_Message + (Errno : Integer) return C.Strings.chars_ptr + is + use type Interfaces.C.Strings.chars_ptr; + + C_Msg : C.Strings.chars_ptr; + + begin + C_Msg := C_Strerror (C.int (Errno)); + + if C_Msg = C.Strings.Null_Ptr then + return Unknown_System_Error; + + else + return C_Msg; + end if; + end Socket_Error_Message; + + -- Package elaboration + + begin + Local_Hostent.all.H_Aliases := Alias_Access; + + -- VxWorks currently only supports AF_INET + + Local_Hostent.all.H_Addrtype := Constants.AF_INET; + + Local_Hostent.all.H_Length := 1; + Local_Hostent.all.H_Addr_List := In_Addr_Access_Ptr; + + end GNAT.Sockets.Thin; diff -Nrc3pad gcc-3.3.3/gcc/ada/3zsocthi.ads gcc-3.4.0/gcc/ada/3zsocthi.ads *** gcc-3.3.3/gcc/ada/3zsocthi.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/3zsocthi.ads 2004-01-12 11:45:23.000000000 +0000 *************** *** 0 **** --- 1,446 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- G N A T . S O C K E T S . T H I N -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2002-2004 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 was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package provides a target dependent thin interface to the sockets + -- layer for use by the GNAT.Sockets package (g-socket.ads). This package + -- should not be directly with'ed by an applications program. + + -- This is the version for VxWorks + + with Interfaces.C.Pointers; + + with Ada.Unchecked_Conversion; + with Interfaces.C.Strings; + with GNAT.Sockets.Constants; + with GNAT.OS_Lib; + + with System; + + package GNAT.Sockets.Thin is + + package C renames Interfaces.C; + + use type C.int; + -- This is so we can declare the Failure constant below + + Success : constant C.int := 0; + Failure : constant C.int := -1; + + function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; + -- Returns last socket error number. + + function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr; + -- Returns the error message string for the error number Errno. If + -- Errno is not known it returns "Unknown system error". + + subtype Fd_Set_Access is System.Address; + No_Fd_Set : constant Fd_Set_Access := System.Null_Address; + + type Timeval_Unit is new C.int; + 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 + + function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr); + + 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_Length : C.unsigned_char; + Sa_Family : C.unsigned_char; + 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_Length : C.unsigned_char := 0; + Sin_Family : C.unsigned_char := 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 + + procedure Set_Length + (Sin : Sockaddr_In_Access; + Len : C.int); + pragma Inline (Set_Length); + -- Set Sin.Sin_Length to Len. + + procedure Set_Family + (Sin : Sockaddr_In_Access; + Family : C.int); + pragma Inline (Set_Family); + -- Set Sin.Sin_Family to Family. + + procedure Set_Port + (Sin : Sockaddr_In_Access; + Port : C.unsigned_short); + pragma Inline (Set_Port); + -- Set Sin.Sin_Port to Port. + + procedure Set_Address + (Sin : Sockaddr_In_Access; + Address : In_Addr); + pragma Inline (Set_Address); + -- Set Sin.Sin_Addr to Address. + + type Hostent is record + H_Name : C.Strings.chars_ptr; + H_Aliases : Chars_Ptr_Pointers.Pointer; + H_Addrtype : C.int; + H_Length : C.int; + 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 Servent is record + S_Name : C.Strings.chars_ptr; + S_Aliases : Chars_Ptr_Pointers.Pointer; + S_Port : C.int; + S_Proto : C.Strings.chars_ptr; + end record; + pragma Convention (C, Servent); + -- Service entry + + type Servent_Access is access all Servent; + pragma Convention (C, Servent_Access); + -- Access to service 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; + Len : 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_Getservbyname + (Name : C.char_array; + Proto : C.char_array) + return Servent_Access; + + function C_Getservbyport + (Port : C.int; + Proto : C.char_array) + return Servent_Access; + + 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 + (Fd : C.int; + Buf : System.Address; + Count : C.int) + return C.int; + + function C_Readv + (Fd : C.int; + Iov : System.Address; + Iovcnt : C.int) + return C.int; + + function C_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) + return C.int; + + function C_Recvfrom + (S : C.int; + Msg : 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; + Msg : 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 + (Fd : C.int; + Buf : System.Address; + Count : C.int) + return C.int; + + function C_Writev + (Fd : C.int; + Iov : System.Address; + Iovcnt : C.int) + return C.int; + + procedure Free_Socket_Set + (Set : Fd_Set_Access); + -- Free system-dependent socket set + + procedure Get_Socket_From_Set + (Set : Fd_Set_Access; + Socket : Int_Access; + Last : Int_Access); + -- Get last socket in Socket and remove it from the socket + -- set. The parameter Last is a maximum value of the largest + -- socket. This hint is used to avoid scanning very large socket + -- sets. After a call to Get_Socket_From_Set, Last is set back to + -- the real largest socket in the socket set. + + procedure Insert_Socket_In_Set + (Set : Fd_Set_Access; + Socket : C.int); + -- Insert socket in the socket set + + function Is_Socket_In_Set + (Set : Fd_Set_Access; + Socket : C.int) + return Boolean; + -- Check whether Socket is in the socket set + + procedure Last_Socket_In_Set + (Set : Fd_Set_Access; + Last : Int_Access); + -- Find the largest socket in the socket set. This is needed for + -- select(). When Last_Socket_In_Set is called, parameter Last is + -- a maximum value of the largest socket. This hint is used to + -- avoid scanning very large socket sets. After the call, Last is + -- set back to the real largest socket in the socket set. + + function New_Socket_Set + (Set : Fd_Set_Access) + return Fd_Set_Access; + -- Allocate a new socket set which is a system-dependent structure + -- and initialize by copying Set if it is non-null, by making it + -- empty otherwise. + + procedure Remove_Socket_From_Set + (Set : Fd_Set_Access; + Socket : C.int); + -- Remove socket from the socket set + + procedure Finalize; + procedure Initialize (Process_Blocking_IO : Boolean); + + private + + pragma Import (C, C_Bind, "bind"); + pragma Import (C, C_Close, "close"); + pragma Import (C, C_Gethostname, "gethostname"); + pragma Import (C, C_Getpeername, "getpeername"); + pragma Import (C, C_Getsockname, "getsockname"); + pragma Import (C, C_Getsockopt, "getsockopt"); + pragma Import (C, C_Inet_Addr, "inet_addr"); + pragma Import (C, C_Listen, "listen"); + pragma Import (C, C_Read, "read"); + pragma Import (C, C_Readv, "readv"); + pragma Import (C, C_Select, "select"); + pragma Import (C, C_Setsockopt, "setsockopt"); + pragma Import (C, C_Shutdown, "shutdown"); + pragma Import (C, C_Strerror, "strerror"); + pragma Import (C, C_System, "system"); + pragma Import (C, C_Write, "write"); + pragma Import (C, C_Writev, "writev"); + + pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); + pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); + pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); + pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); + pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); + pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); + pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); + + end GNAT.Sockets.Thin; diff -Nrc3pad gcc-3.3.3/gcc/ada/41intnam.ads gcc-3.4.0/gcc/ada/41intnam.ads *** gcc-3.3.3/gcc/ada/41intnam.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/41intnam.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1991-2002 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/42intnam.ads gcc-3.4.0/gcc/ada/42intnam.ads *** gcc-3.3.3/gcc/ada/42intnam.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/42intnam.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1991-2002 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/45intnam.ads gcc-3.4.0/gcc/ada/45intnam.ads *** gcc-3.3.3/gcc/ada/45intnam.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/45intnam.ads 2003-11-20 17:51:26.000000000 +0000 *************** *** 0 **** --- 1,136 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- A D A . I N T E R R U P T S . N A M E S -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 1991-2003 Free Software Foundation, Inc. -- + -- -- + -- GNARL is free software; you can redistribute it and/or modify it under -- + -- terms of the GNU General Public License as published by the Free Soft- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNARL; see file COPYING. If not, write -- + -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- + -- MA 02111-1307, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNARL was developed by the GNARL team at Florida State University. -- + -- Extensive contributions were provided by Ada Core Technologies, Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the FreeBSD THREADS version of this package + + with System.OS_Interface; + -- used for names of interrupts + + package Ada.Interrupts.Names is + + 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 + + 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 + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- child status change + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + 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 + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + -- 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. + + end Ada.Interrupts.Names; diff -Nrc3pad gcc-3.3.3/gcc/ada/4aintnam.ads gcc-3.4.0/gcc/ada/4aintnam.ads *** gcc-3.3.3/gcc/ada/4aintnam.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4aintnam.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1991-2002 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/4cintnam.ads gcc-3.4.0/gcc/ada/4cintnam.ads *** gcc-3.3.3/gcc/ada/4cintnam.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4cintnam.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1991-2002 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/4dintnam.ads gcc-3.4.0/gcc/ada/4dintnam.ads *** gcc-3.3.3/gcc/ada/4dintnam.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4dintnam.ads 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,98 **** - ------------------------------------------------------------------------------ - -- -- - -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- - -- -- - -- A D A . I N T E R R U P T S . N A M E S -- - -- -- - -- S p e c -- - -- -- - -- -- - -- Copyright (C) 1991-2002 Free Software Foundation, Inc. -- - -- -- - -- GNARL is free software; you can redistribute it and/or modify it under -- - -- terms of the GNU General Public License as published by the Free Soft- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNARL; see file COPYING. If not, write -- - -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- - -- MA 02111-1307, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNARL was developed by the GNARL team at Florida State University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is a 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 - - -- 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; --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/4gintnam.ads gcc-3.4.0/gcc/ada/4gintnam.ads *** gcc-3.3.3/gcc/ada/4gintnam.ads 2002-03-14 10:58:23.000000000 +0000 --- gcc-3.4.0/gcc/ada/4gintnam.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1997-2002, 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 -- --- 6,13 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2003, Ada Core Technologies -- -- -- -- 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 -- *************** *** 27,53 **** -- 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 -- This target-dependent package spec contains names of interrupts --- 27,52 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ -- This is the 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 -- This target-dependent package spec contains names of interrupts diff -Nrc3pad gcc-3.3.3/gcc/ada/4hexcpol.adb gcc-3.4.0/gcc/ada/4hexcpol.adb *** gcc-3.3.3/gcc/ada/4hexcpol.adb 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4hexcpol.adb 2003-10-21 13:41:51.000000000 +0000 *************** *** 7,13 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992-2000, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 7,12 ---- *************** *** 29,35 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 28,34 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/4hintnam.ads gcc-3.4.0/gcc/ada/4hintnam.ads *** gcc-3.3.3/gcc/ada/4hintnam.ads 2002-03-14 10:58:23.000000000 +0000 --- gcc-3.4.0/gcc/ada/4hintnam.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1991-2002, 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- -- --- 6,13 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2003, Ada Core Technologies -- -- -- -- 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- -- *************** *** 27,47 **** -- 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 -- This target-dependent package spec contains names of interrupts --- 27,46 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ -- This is a 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 -- This target-dependent package spec contains names of interrupts diff -Nrc3pad gcc-3.3.3/gcc/ada/4lintnam.ads gcc-3.4.0/gcc/ada/4lintnam.ads *** gcc-3.3.3/gcc/ada/4lintnam.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4lintnam.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1991-2002 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/4mintnam.ads gcc-3.4.0/gcc/ada/4mintnam.ads *** gcc-3.3.3/gcc/ada/4mintnam.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4mintnam.ads 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,146 **** - ------------------------------------------------------------------------------ - -- -- - -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- - -- -- - -- A D A . I N T E R R U P T S . N A M E S -- - -- -- - -- S p e c -- - -- -- - -- -- - -- Copyright (C) 1996-2002 Free Software Foundation, Inc. -- - -- -- - -- GNARL is free software; you can redistribute it and/or modify it under -- - -- terms of the GNU General Public License as published by the Free Soft- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNARL; see file COPYING. If not, write -- - -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- - -- MA 02111-1307, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNARL was developed by the GNARL team at Florida State University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is a 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 - - -- 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; --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/4nintnam.ads gcc-3.4.0/gcc/ada/4nintnam.ads *** gcc-3.3.3/gcc/ada/4nintnam.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4nintnam.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 7,14 **** -- S p e c -- -- (No Tasking Version) -- -- -- ! -- -- ! -- 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- -- --- 7,13 ---- -- S p e c -- -- (No Tasking Version) -- -- -- ! -- Copyright (C) 1991-2002 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- *************** *** 29,35 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 28,34 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/4ointnam.ads gcc-3.4.0/gcc/ada/4ointnam.ads *** gcc-3.3.3/gcc/ada/4ointnam.ads 2002-03-14 10:58:24.000000000 +0000 --- gcc-3.4.0/gcc/ada/4ointnam.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,13 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2003, Ada Core Technologies -- -- -- -- 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- -- *************** *** 27,35 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 27,34 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/4onumaux.ads gcc-3.4.0/gcc/ada/4onumaux.ads *** gcc-3.3.3/gcc/ada/4onumaux.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4onumaux.ads 2004-01-05 15:20:42.000000000 +0000 *************** *** 7,14 **** -- S p e c -- -- (C Library Version for x86) -- -- -- ! -- -- ! -- 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- -- --- 7,13 ---- -- S p e c -- -- (C Library Version for x86) -- -- -- ! -- Copyright (C) 1992-2003 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- -- *************** pragma Pure (Aux); *** 51,93 **** --- 50,108 ---- type Double is digits 18; + -- We import these functions directly from C. Note that we label them + -- all as pure functions, because indeed all of them are in fact pure! + function Sin (X : Double) return Double; pragma Import (C, Sin, "sinl"); + pragma Pure_Function (Sin); function Cos (X : Double) return Double; pragma Import (C, Cos, "cosl"); + pragma Pure_Function (Cos); function Tan (X : Double) return Double; pragma Import (C, Tan, "tanl"); + pragma Pure_Function (Tan); function Exp (X : Double) return Double; pragma Import (C, Exp, "expl"); + pragma Pure_Function (Exp); function Sqrt (X : Double) return Double; pragma Import (C, Sqrt, "sqrtl"); + pragma Pure_Function (Sqrt); function Log (X : Double) return Double; pragma Import (C, Log, "logl"); + pragma Pure_Function (Log); function Acos (X : Double) return Double; pragma Import (C, Acos, "acosl"); + pragma Pure_Function (Acos); function Asin (X : Double) return Double; pragma Import (C, Asin, "asinl"); + pragma Pure_Function (Asin); function Atan (X : Double) return Double; pragma Import (C, Atan, "atanl"); + pragma Pure_Function (Atan); function Sinh (X : Double) return Double; pragma Import (C, Sinh, "sinhl"); + pragma Pure_Function (Sinh); function Cosh (X : Double) return Double; pragma Import (C, Cosh, "coshl"); + pragma Pure_Function (Cosh); function Tanh (X : Double) return Double; pragma Import (C, Tanh, "tanhl"); + pragma Pure_Function (Tanh); function Pow (X, Y : Double) return Double; pragma Import (C, Pow, "powl"); + pragma Pure_Function (Pow); end Ada.Numerics.Aux; diff -Nrc3pad gcc-3.3.3/gcc/ada/4pintnam.ads gcc-3.4.0/gcc/ada/4pintnam.ads *** gcc-3.3.3/gcc/ada/4pintnam.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4pintnam.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1991-2002 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/4rintnam.ads gcc-3.4.0/gcc/ada/4rintnam.ads *** gcc-3.3.3/gcc/ada/4rintnam.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4rintnam.ads 2003-04-24 17:53:50.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1991-2002 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/4sintnam.ads gcc-3.4.0/gcc/ada/4sintnam.ads *** gcc-3.3.3/gcc/ada/4sintnam.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4sintnam.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1991-2002 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/4uintnam.ads gcc-3.4.0/gcc/ada/4uintnam.ads *** gcc-3.3.3/gcc/ada/4uintnam.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4uintnam.ads 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,155 **** - ------------------------------------------------------------------------------ - -- -- - -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- - -- -- - -- A D A . I N T E R R U P T S . N A M E S -- - -- -- - -- S p e c -- - -- -- - -- -- - -- Copyright (C) 1991-2002 Free Software Foundation, Inc. -- - -- -- - -- GNARL is free software; you can redistribute it and/or modify it under -- - -- terms of the GNU General Public License as published by the Free Soft- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNARL; see file COPYING. If not, write -- - -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- - -- MA 02111-1307, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNARL was developed by the GNARL team at Florida State University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is a 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 - - 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; --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/4vcaldel.adb gcc-3.4.0/gcc/ada/4vcaldel.adb *** gcc-3.3.3/gcc/ada/4vcaldel.adb 2002-03-14 10:58:24.000000000 +0000 --- gcc-3.4.0/gcc/ada/4vcaldel.adb 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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- -- --- 6,13 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2003, Ada Core Technologies -- -- -- -- 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- -- *************** *** 27,35 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 27,34 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/4vcalend.adb gcc-3.4.0/gcc/ada/4vcalend.adb *** gcc-3.3.3/gcc/ada/4vcalend.adb 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4vcalend.adb 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2003 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- -- *************** package body Ada.Calendar is *** 236,243 **** 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 --- 235,245 ---- Status : Unsigned_Longword; Timbuf : Unsigned_Word_Array (1 .. 7); + Subsecs : constant Time := Date mod 10_000_000; + Date_Secs : constant Time := Date - Subsecs; + begin ! Numtim (Status, Timbuf, Date_Secs); if Status mod 2 /= 1 or else Timbuf (1) not in Ada_Year_Min .. Ada_Year_Max *************** package body Ada.Calendar is *** 245,256 **** 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; ------------- --- 247,259 ---- raise Time_Error; end if; ! Seconds := Day_Duration (Timbuf (6) ! + 60 * (Timbuf (5) + 60 * Timbuf (4))) ! + Duration (Subsecs) / 10_000_000.0; ! ! Day := Integer (Timbuf (3)); ! Month := Integer (Timbuf (2)); ! Year := Integer (Timbuf (1)); end Split; ------------- *************** package body Ada.Calendar is *** 281,286 **** --- 284,291 ---- Date : Time; Int_Secs : Integer; Day_Hack : Boolean := False; + Subsecs : Day_Duration; + begin -- The following checks are redundant with respect to the constraint -- error checks that should normally be made on parameters, but we *************** package body Ada.Calendar is *** 306,335 **** 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); --- 311,327 ---- Int_Secs := Integer (Seconds); end if; + Subsecs := Seconds - Day_Duration (Int_Secs); + -- 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; end if; + Timbuf (7) := 0; Timbuf (6) := Unsigned_Word (Int_Secs mod 60); Timbuf (5) := Unsigned_Word ((Int_Secs / 60) mod 60); Timbuf (4) := Unsigned_Word (Int_Secs / 3600); *************** package body Ada.Calendar is *** 347,354 **** Date := Date + 10_000_000 * 86_400; end if; return Date; - end Time_Of; ---------- --- 339,346 ---- Date := Date + 10_000_000 * 86_400; end if; + Date := Date + Time (10_000_000.0 * Subsecs); return Date; end Time_Of; ---------- diff -Nrc3pad gcc-3.3.3/gcc/ada/4vcalend.ads gcc-3.4.0/gcc/ada/4vcalend.ads *** gcc-3.3.3/gcc/ada/4vcalend.ads 2002-03-14 10:58:24.000000000 +0000 --- gcc-3.4.0/gcc/ada/4vcalend.ads 2003-04-24 17:53:51.000000000 +0000 *************** *** 6,16 **** -- -- -- S p e c -- -- -- -- -- ! -- 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. -- -- -- ------------------------------------------------------------------------------ --- 6,37 ---- -- -- -- S p e c -- -- -- + -- Copyright (C) 1992-2002 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. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/4vintnam.ads gcc-3.4.0/gcc/ada/4vintnam.ads *** gcc-3.3.3/gcc/ada/4vintnam.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4vintnam.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2002 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/4wcalend.adb gcc-3.4.0/gcc/ada/4wcalend.adb *** gcc-3.3.3/gcc/ada/4wcalend.adb 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4wcalend.adb 2003-04-24 17:53:51.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2002 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- *************** package body Ada.Calendar is *** 364,370 **** -- 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; --- 363,369 ---- -- time based on 1 january 1970) and add there the sub-seconds part. declare ! Sub_Sec : constant Duration := Seconds - Duration (Int_Secs); begin Date := Time ((Now - epoch_1970) * system_time_ns / Sec_Unit) + Sub_Sec; diff -Nrc3pad gcc-3.3.3/gcc/ada/4wexcpol.adb gcc-3.4.0/gcc/ada/4wexcpol.adb *** gcc-3.3.3/gcc/ada/4wexcpol.adb 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4wexcpol.adb 2003-10-21 13:41:51.000000000 +0000 *************** *** 7,13 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992-2000, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 7,12 ---- *************** *** 29,35 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 28,34 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/4wintnam.ads gcc-3.4.0/gcc/ada/4wintnam.ads *** gcc-3.3.3/gcc/ada/4wintnam.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4wintnam.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2002 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/4zintnam.ads gcc-3.4.0/gcc/ada/4zintnam.ads *** gcc-3.3.3/gcc/ada/4zintnam.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4zintnam.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/4znumaux.ads gcc-3.4.0/gcc/ada/4znumaux.ads *** gcc-3.3.3/gcc/ada/4znumaux.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4znumaux.ads 2004-01-05 15:20:42.000000000 +0000 *************** *** 7,14 **** -- S p e c -- -- (C Library Version, VxWorks) -- -- -- ! -- -- ! -- 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- -- --- 7,13 ---- -- S p e c -- -- (C Library Version, VxWorks) -- -- -- ! -- Copyright (C) 1992-2003 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- -- *************** pragma Pure (Aux); *** 51,98 **** -- 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; --- 50,110 ---- -- no libm.a library for VxWorks. type Double is digits 15; ! -- Type Double is the type used to call the C routines ! ! -- We import these functions directly from C. Note that we label them ! -- all as pure functions, because indeed all of them are in fact pure! function Sin (X : Double) return Double; pragma Import (C, Sin, "sin"); + pragma Pure_Function (Sin); function Cos (X : Double) return Double; pragma Import (C, Cos, "cos"); + pragma Pure_Function (Cos); function Tan (X : Double) return Double; pragma Import (C, Tan, "tan"); + pragma Pure_Function (Tan); function Exp (X : Double) return Double; pragma Import (C, Exp, "exp"); + pragma Pure_Function (Exp); function Sqrt (X : Double) return Double; pragma Import (C, Sqrt, "sqrt"); + pragma Pure_Function (Sqrt); function Log (X : Double) return Double; pragma Import (C, Log, "log"); + pragma Pure_Function (Log); function Acos (X : Double) return Double; pragma Import (C, Acos, "acos"); + pragma Pure_Function (Acos); function Asin (X : Double) return Double; pragma Import (C, Asin, "asin"); + pragma Pure_Function (Asin); function Atan (X : Double) return Double; pragma Import (C, Atan, "atan"); + pragma Pure_Function (Atan); function Sinh (X : Double) return Double; pragma Import (C, Sinh, "sinh"); + pragma Pure_Function (Sinh); function Cosh (X : Double) return Double; pragma Import (C, Cosh, "cosh"); + pragma Pure_Function (Cosh); function Tanh (X : Double) return Double; pragma Import (C, Tanh, "tanh"); + pragma Pure_Function (Tanh); function Pow (X, Y : Double) return Double; pragma Import (C, Pow, "pow"); + pragma Pure_Function (Pow); end Ada.Numerics.Aux; diff -Nrc3pad gcc-3.3.3/gcc/ada/4zsytaco.adb gcc-3.4.0/gcc/ada/4zsytaco.adb *** gcc-3.3.3/gcc/ada/4zsytaco.adb 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4zsytaco.adb 2004-01-05 15:20:42.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- *************** *** 33,38 **** --- 32,38 ---- ------------------------------------------------------------------------------ with Interfaces.C; + package body Ada.Synchronous_Task_Control is use System.OS_Interface; use type Interfaces.C.int; *************** package body Ada.Synchronous_Task_Contro *** 52,59 **** 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; --- 52,60 ---- St := semTake (S.Sema, NO_WAIT); + -- If we took the semaphore, reset semaphore state to FULL + if St = OK then Result := True; St := semGive (S.Sema); end if; *************** package body Ada.Synchronous_Task_Contro *** 67,77 **** --- 68,81 ---- 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); + pragma Assert (St = OK); end Set_False; -------------- *************** package body Ada.Synchronous_Task_Contro *** 80,85 **** --- 84,90 ---- procedure Set_True (S : in out Suspension_Object) is St : STATUS; + pragma Unreferenced (St); begin St := semGive (S.Sema); end Set_True; *************** package body Ada.Synchronous_Task_Contro *** 91,107 **** 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); --- 96,110 ---- procedure Suspend_Until_True (S : in out Suspension_Object) is St : STATUS; 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); *************** package body Ada.Synchronous_Task_Contro *** 110,125 **** 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); --- 113,126 ---- else -- Another task is pending on the suspension object raise Program_Error; ! end if; end Suspend_Until_True; + ---------------- + -- Initialize -- + ---------------- + procedure Initialize (S : in out Suspension_Object) is begin S.Sema := semBCreate (SEM_Q_FIFO, SEM_EMPTY); *************** package body Ada.Synchronous_Task_Contro *** 131,138 **** --- 132,144 ---- S.Mutex := semBCreate (SEM_Q_FIFO, SEM_FULL); end Initialize; + -------------- + -- Finalize -- + -------------- + procedure Finalize (S : in out Suspension_Object) is St : STATUS; + pragma Unreferenced (St); begin St := semDelete (S.Sema); St := semDelete (S.Mutex); diff -Nrc3pad gcc-3.3.3/gcc/ada/4zsytaco.ads gcc-3.4.0/gcc/ada/4zsytaco.ads *** gcc-3.3.3/gcc/ada/4zsytaco.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/4zsytaco.ads 2003-04-24 17:53:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/50system.ads gcc-3.4.0/gcc/ada/50system.ads *** gcc-3.3.3/gcc/ada/50system.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/50system.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 0 **** --- 1,163 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (VxWorks/HIE Version PPC) -- + -- -- + -- Copyright (C) 1992-2003 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. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + pragma Restrictions (No_Exception_Handlers); + pragma Restrictions (No_Implicit_Dynamic_Code); + pragma Restrictions (No_Finalization); + pragma Discard_Names; + + package System is + pragma Pure (System); + -- Note that we take advantage of the implementation permission to + -- make this unit Pure instead of Preelaborable, see RM 13.7(36) + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 1.0 / 60.0; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + + -- Priority-related Declarations (RM D.1) + + -- 256 is reserved for the VxWorks kernel + -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 + -- 247 is a catchall default "interrupt" priority for signals, + -- allowing higher priority than normal tasks, but lower than + -- hardware priority levels. Protected Object ceilings can + -- override these values. + -- 246 is used by the Interrupt_Manager task + + Max_Priority : constant Positive := 245; + Max_Interrupt_Priority : constant Positive := 255; + + subtype Any_Priority is Integer range 0 .. 255; + subtype Priority is Any_Priority range 0 .. 245; + subtype Interrupt_Priority is Any_Priority range 246 .. 255; + + Default_Priority : constant Priority := 122; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + AAMP : constant Boolean := False; + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := False; + Configurable_Run_Time : constant Boolean := True; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := True; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Functions_Return_By_DSP : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + OpenVMS : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := True; + Use_Ada_Main_Program_Name : constant Boolean := True; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + Front_End_ZCX_Support : constant Boolean := False; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := True; + Long_Shifts_Inlined : constant Boolean := False; + + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/51osinte.adb gcc-3.4.0/gcc/ada/51osinte.adb *** gcc-3.3.3/gcc/ada/51osinte.adb 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/51osinte.adb 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1999-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2002 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ *************** package body System.OS_Interface is *** 78,85 **** F := F + 1.0; end if; ! return timespec' (tv_sec => S, ! tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; ---------------- --- 77,84 ---- F := F + 1.0; end if; ! return timespec'(tv_sec => S, ! tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; ---------------- *************** package body System.OS_Interface is *** 102,109 **** F := F + 1.0; end if; ! return struct_timeval' (tv_sec => S, ! tv_usec => long (Long_Long_Integer (F * 10#1#E6))); end To_Timeval; ------------------- --- 101,110 ---- F := F + 1.0; end if; ! return ! struct_timeval' ! (tv_sec => S, ! tv_usec => long (Long_Long_Integer (F * 10#1#E6))); end To_Timeval; ------------------- *************** package body System.OS_Interface is *** 112,125 **** function clock_gettime (clock_id : clockid_t; ! tp : access timespec) return int is Result : int; tv : aliased struct_timeval; function gettimeofday ! (tv : access struct_timeval; ! tz : System.Address := System.Null_Address) return int; pragma Import (C, gettimeofday, "gettimeofday"); begin --- 113,130 ---- function clock_gettime (clock_id : clockid_t; ! tp : access timespec) ! return int is + pragma Warnings (Off, clock_id); + Result : int; tv : aliased struct_timeval; function gettimeofday ! (tv : access struct_timeval; ! tz : System.Address := System.Null_Address) ! return int; pragma Import (C, gettimeofday, "gettimeofday"); begin *************** package body System.OS_Interface is *** 163,168 **** --- 168,175 ---- end pthread_kill; function Get_Stack_Base (thread : pthread_t) return Address is + pragma Warnings (Off, thread); + begin return Null_Address; end Get_Stack_Base; diff -Nrc3pad gcc-3.3.3/gcc/ada/51osinte.ads gcc-3.4.0/gcc/ada/51osinte.ads *** gcc-3.3.3/gcc/ada/51osinte.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/51osinte.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/51system.ads gcc-3.4.0/gcc/ada/51system.ads *** gcc-3.3.3/gcc/ada/51system.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/51system.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 0 **** --- 1,150 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (SCO UnixWare Version) -- + -- -- + -- Copyright (C) 1992-2003 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. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package System is + pragma Pure (System); + -- Note that we take advantage of the implementation permission to + -- make this unit Pure instead of Preelaborable, see RM 13.7(36) + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + AAMP : constant Boolean := False; + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Functions_Return_By_DSP : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + OpenVMS : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + Front_End_ZCX_Support : constant Boolean := False; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/52osinte.adb gcc-3.4.0/gcc/ada/52osinte.adb *** gcc-3.3.3/gcc/ada/52osinte.adb 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/52osinte.adb 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1999-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2003 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- -- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ *************** package body System.OS_Interface is *** 51,62 **** function clock_gettime (clock_id : clockid_t; tp : access timespec) ! return int is function clock_gettime_base (clock_id : clockid_t; tp : access timespec) ! return int; pragma Import (C, clock_gettime_base, "clock_gettime"); begin --- 50,61 ---- function clock_gettime (clock_id : clockid_t; tp : access timespec) ! return int is function clock_gettime_base (clock_id : clockid_t; tp : access timespec) ! return int; pragma Import (C, clock_gettime_base, "clock_gettime"); begin *************** package body System.OS_Interface is *** 101,107 **** F := F + 1.0; end if; ! return timespec' (tv_sec => S, tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; --- 100,106 ---- F := F + 1.0; end if; ! return timespec'(tv_sec => S, tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; *************** package body System.OS_Interface is *** 125,131 **** F := F + 1.0; end if; ! return struct_timeval' (tv_sec => S, tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); end To_Timeval; --- 124,130 ---- F := F + 1.0; end if; ! return struct_timeval'(tv_sec => S, tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); end To_Timeval; *************** package body System.OS_Interface is *** 141,147 **** function sigwait_base (set : access sigset_t; value : System.Address) ! return Signal; pragma Import (C, sigwait_base, "sigwait"); begin --- 140,146 ---- function sigwait_base (set : access sigset_t; value : System.Address) ! return Signal; pragma Import (C, sigwait_base, "sigwait"); begin *************** package body System.OS_Interface is *** 425,430 **** --- 424,430 ---- protocol : int) return int is + pragma Unreferenced (attr, protocol); begin return 0; end pthread_mutexattr_setprotocol; *************** package body System.OS_Interface is *** 434,439 **** --- 434,440 ---- prioceiling : int) return int is + pragma Unreferenced (attr, prioceiling); begin return 0; end pthread_mutexattr_setprioceiling; *************** package body System.OS_Interface is *** 443,448 **** --- 444,450 ---- contentionscope : int) return int is + pragma Unreferenced (attr, contentionscope); begin return 0; end pthread_attr_setscope; *************** package body System.OS_Interface is *** 465,470 **** --- 467,473 ---- detachstate : int) return int is + pragma Unreferenced (attr, detachstate); begin return 0; end pthread_attr_setdetachstate; *************** package body System.OS_Interface is *** 561,566 **** --- 564,571 ---- end pthread_getspecific; function Get_Stack_Base (thread : pthread_t) return Address is + pragma Warnings (Off, thread); + begin return Null_Address; end Get_Stack_Base; diff -Nrc3pad gcc-3.3.3/gcc/ada/52osinte.ads gcc-3.4.0/gcc/ada/52osinte.ads *** gcc-3.3.3/gcc/ada/52osinte.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/52osinte.ads 2003-12-05 10:24:04.000000000 +0000 *************** *** 7,13 **** -- S p e c -- -- -- -- -- ! -- Copyright (C) 1999-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- -- --- 7,13 ---- -- S p e c -- -- -- -- -- ! -- Copyright (C) 1999-2003 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- -- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 28,34 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ *************** package System.OS_Interface is *** 153,158 **** --- 153,160 ---- pragma Convention (C, struct_sigaction); type struct_sigaction_ptr is access all struct_sigaction; + SA_SIGINFO : constant := 16#80#; + SIG_BLOCK : constant := 0; SIG_UNBLOCK : constant := 1; SIG_SETMASK : constant := 2; *************** package System.OS_Interface is *** 458,463 **** --- 460,468 ---- pragma Inline (pthread_create); -- LynxOS has a non standard pthread_create + function pthread_detach (thread : pthread_t) return int; + pragma Inline (pthread_detach); + procedure pthread_exit (status : System.Address); pragma Import (C, pthread_exit, "pthread_exit"); diff -Nrc3pad gcc-3.3.3/gcc/ada/52system.ads gcc-3.4.0/gcc/ada/52system.ads *** gcc-3.3.3/gcc/ada/52system.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/52system.ads 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,139 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT RUN-TIME COMPONENTS -- - -- -- - -- S Y S T E M -- - -- -- - -- S p e c -- - -- (LynxOS PPC/x86 Version) - -- -- - -- -- - -- Copyright (C) 1992-2002 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. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - package System is - pragma Pure (System); - -- Note that we take advantage of the implementation permission to - -- make this unit Pure instead of Preelaborable, see RM 13.7(36) - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; - - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := Integer'Last; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := 63; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0; - - -- Storage-related Declarations - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - - private - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - AAMP : constant Boolean := False; - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := False; - Command_Line_Args : constant Boolean := True; - Denorm : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - Functions_Return_By_DSP : constant Boolean := False; - Long_Shifts_Inlined : constant Boolean := True; - High_Integrity_Mode : constant Boolean := False; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - OpenVMS : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - ZCX_By_Default : constant Boolean := False; - GCC_ZCX_Support : constant Boolean := False; - Front_End_ZCX_Support : constant Boolean := False; - - end System; --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/53osinte.ads gcc-3.4.0/gcc/ada/53osinte.ads *** gcc-3.3.3/gcc/ada/53osinte.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/53osinte.ads 2003-12-05 10:24:04.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1999-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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2003 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- -- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ *************** package System.OS_Interface is *** 154,159 **** --- 153,160 ---- pragma Convention (C, struct_sigaction); type struct_sigaction_ptr is access all struct_sigaction; + SA_SIGINFO : constant := 16#10#; + SIG_BLOCK : constant := 0; SIG_UNBLOCK : constant := 1; SIG_SETMASK : constant := 2; *************** package System.OS_Interface is *** 185,190 **** --- 186,196 ---- tp : access timespec) return int; pragma Import (C, clock_gettime, "clock_gettime"); + function clock_getres + (clock_id : clockid_t; + res : access timespec) return int; + pragma Import (C, clock_getres, "clock_getres"); + function To_Duration (TS : timespec) return Duration; pragma Inline (To_Duration); diff -Nrc3pad gcc-3.3.3/gcc/ada/54osinte.ads gcc-3.4.0/gcc/ada/54osinte.ads *** gcc-3.3.3/gcc/ada/54osinte.ads 2002-03-14 10:58:27.000000000 +0000 --- gcc-3.4.0/gcc/ada/54osinte.ads 2003-12-05 10:24:04.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 2000-2001 Ada Core Technologies, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-2003 Ada Core Technologies, 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- -- *************** *** 27,35 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 26,33 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ *************** package System.OS_Interface is *** 159,164 **** --- 157,164 ---- pragma Convention (C, struct_sigaction); type struct_sigaction_ptr is access all struct_sigaction; + SA_SIGINFO : constant := 16#0008#; + SIG_BLOCK : constant := 1; SIG_UNBLOCK : constant := 2; SIG_SETMASK : constant := 3; *************** package System.OS_Interface is *** 293,299 **** function sigwait (set : access sigset_t; sig : access Signal) return int; ! pragma Import (C, sigwait, "sigwait"); function pthread_kill (thread : pthread_t; --- 293,299 ---- function sigwait (set : access sigset_t; sig : access Signal) return int; ! pragma Import (C, sigwait, "__posix_sigwait"); function pthread_kill (thread : pthread_t; diff -Nrc3pad gcc-3.3.3/gcc/ada/55osinte.adb gcc-3.4.0/gcc/ada/55osinte.adb *** gcc-3.3.3/gcc/ada/55osinte.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/55osinte.adb 2003-11-20 17:51:26.000000000 +0000 *************** *** 0 **** --- 1,108 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . O S _ I N T E R F A C E -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 1991-2003 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 FreeBSD THREADS version of this package + + with Interfaces.C; use Interfaces.C; + + package body System.OS_Interface is + + function Errno return int is + type int_ptr is access all int; + + function internal_errno return int_ptr; + pragma Import (C, internal_errno, "__error"); + begin + return (internal_errno.all); + end Errno; + + function Get_Stack_Base (thread : pthread_t) return Address is + pragma Unreferenced (thread); + begin + return (0); + end Get_Stack_Base; + + procedure pthread_init is + begin + null; + end pthread_init; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; + end To_Duration; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + if F < 0.0 then S := S - 1; F := F + 1.0; end if; + return timespec'(ts_sec => S, + ts_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + + function To_Duration (TV : struct_timeval) return Duration is + begin + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end To_Duration; + + function To_Timeval (D : Duration) return struct_timeval is + S : long; + F : Duration; + begin + S := long (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + if F < 0.0 then S := S - 1; F := F + 1.0; end if; + return struct_timeval'(tv_sec => S, + tv_usec => long (Long_Long_Integer (F * 10#1#E6))); + end To_Timeval; + + end System.OS_Interface; diff -Nrc3pad gcc-3.3.3/gcc/ada/55osinte.ads gcc-3.4.0/gcc/ada/55osinte.ads *** gcc-3.3.3/gcc/ada/55osinte.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/55osinte.ads 2003-12-05 10:24:04.000000000 +0000 *************** *** 0 **** --- 1,632 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . O S _ I N T E R F A C E -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 1991-2003 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 FreeBSD PTHREADS version of this package + + with Interfaces.C; + package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-pthread"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function Errno return int; + pragma Inline (Errno); + + EAGAIN : constant := 35; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 60; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 31; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGURG : constant := 16; -- urgent condition on IO channel + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGCLD : constant := 20; -- alias for SIGCHLD + SIGCHLD : constant := 20; -- child status change + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGWINCH : constant := 28; -- window size change + SIGINFO : constant := 29; -- information request (NetBSD/FreeBSD) + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + + SIGADAABORT : constant := SIGABRT; + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + type Signal_Set is array (Natural range <>) of Signal; + + -- Interrupts that must be unmasked at all times. FreeBSD + -- pthreads will not allow an application to mask out any + -- interrupt needed by the threads library. + Unmasked : constant Signal_Set := + (SIGTRAP, SIGBUS, SIGTTIN, SIGTTOU, SIGTSTP); + + -- FreeBSD will uses SIGPROF for timing. Do not allow a + -- handler to attach to this signal. + Reserved : constant Signal_Set := (0 .. 0 => SIGPROF); + + type sigset_t is private; + + function sigaddset + (set : access sigset_t; + sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset + (set : access sigset_t; + sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember + (set : access sigset_t; + sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + -- sigcontext is architecture dependent, so define it private + type struct_sigcontext is private; + + type old_struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, old_struct_sigaction); + + type new_struct_sigaction is record + sa_handler : System.Address; + sa_flags : int; + sa_mask : sigset_t; + end record; + pragma Convention (C, new_struct_sigaction); + + subtype struct_sigaction is new_struct_sigaction; + type struct_sigaction_ptr is access all struct_sigaction; + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + SA_SIGINFO : constant := 16#0040#; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates wether time slicing is supported (i.e SCHED_RR is supported) + + type timespec is private; + + function nanosleep (rqtp, rmtp : access timespec) return int; + pragma Import (C, nanosleep, "nanosleep"); + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) + return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timezone is record + tz_minuteswest : int; + tz_dsttime : int; + end record; + pragma Convention (C, struct_timezone); + type struct_timeval is private; + -- This is needed on systems that do not have clock_gettime() + -- but do have gettimeofday(). + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + function gettimeofday + (tv : access struct_timeval; + tz : System.Address) return int; + pragma Import (C, gettimeofday, "gettimeofday"); + + procedure usleep (useconds : unsigned_long); + pragma Import (C, usleep, "usleep"); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 1; + SCHED_OTHER : constant := 2; + SCHED_RR : constant := 3; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + Self_PID : constant pid_t; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + -- lwp_self does not exist on this thread library, revert to pthread_self + -- which is the closest approximation (with getpid). This function is + -- needed to share 7staprop.adb across POSIX-like targets. + pragma Import (C, lwp_self, "pthread_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + PTHREAD_CREATE_JOINABLE : constant := 0; + + ----------- + -- Stack -- + ----------- + + Stack_Base_Available : constant Boolean := False; + -- Indicates wether the stack base is available on this target. + -- This allows us to share s-osinte.adb between all the FSU run time. + -- Note that this value can only be true if pthread_t has a complete + -- definition that corresponds exactly to the C header files. + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- returns the stack base of the specified thread. + -- Only call this function when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- returns the size of a page, or 0 if this is not relevant on this + -- target + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + + PROT_ON : constant := PROT_NONE; + PROT_OFF : constant := PROT_ALL; + + function mprotect + (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + ----------------------------------------- + -- Nonstandard Thread Initialization -- + ----------------------------------------- + -- FSU_THREADS requires pthread_init, which is nonstandard + -- and this should be invoked during the elaboration of s-taprop.adb + -- + -- FreeBSD does not require this so we provide an empty Ada body. + procedure pthread_init; + + --------------------------- + -- POSIX.1c Section 3 -- + --------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Import (C, sigwait, "sigwait"); + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + type sigset_t_ptr is access all sigset_t; + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + + ---------------------------- + -- POSIX.1c Section 11 -- + ---------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + ---------------------------- + -- POSIX.1c Section 13 -- + ---------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_PROTECT : constant := 2; + PTHREAD_PRIO_INHERIT : constant := 1; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import + (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol"); + + function pthread_mutexattr_getprotocol + (attr : access pthread_mutexattr_t; + protocol : access int) return int; + pragma Import + (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol"); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import + (C, pthread_mutexattr_setprioceiling, + "pthread_mutexattr_setprioceiling"); + + function pthread_mutexattr_getprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : access int) return int; + pragma Import + (C, pthread_mutexattr_getprioceiling, + "pthread_mutexattr_getprioceiling"); + + type struct_sched_param is record + sched_priority : int; + end record; + pragma Convention (C, struct_sched_param); + + function pthread_getschedparam + (thread : pthread_t; + policy : access int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_getschedparam, "pthread_getschedparam"); + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_getscope + (attr : access pthread_attr_t; + contentionscope : access int) return int; + pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import + (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched"); + + function pthread_attr_getinheritsched + (attr : access pthread_attr_t; + inheritsched : access int) return int; + pragma Import + (C, pthread_attr_getinheritsched, "pthread_attr_getinheritsched"); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy, + "pthread_attr_setschedpolicy"); + + function pthread_attr_getschedpolicy + (attr : access pthread_attr_t; + policy : access int) return int; + pragma Import (C, pthread_attr_getschedpolicy, + "pthread_attr_getschedpolicy"); + + function pthread_attr_setschedparam + (attr : access pthread_attr_t; + sched_param : int) return int; + pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam"); + + function pthread_attr_getschedparam + (attr : access pthread_attr_t; + sched_param : access int) return int; + pragma Import (C, pthread_attr_getschedparam, "pthread_attr_getschedparam"); + + function sched_yield return int; + pragma Import (C, sched_yield, "pthread_yield"); + + ----------------------------- + -- P1003.1c - Section 16 -- + ----------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import + (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate"); + + function pthread_attr_getdetachstate + (attr : access pthread_attr_t; + detachstate : access int) return int; + pragma Import + (C, pthread_attr_getdetachstate, "pthread_attr_getdetachstate"); + + function pthread_attr_getstacksize + (attr : access pthread_attr_t; + stacksize : access size_t) return int; + pragma Import + (C, pthread_attr_getstacksize, "pthread_attr_getstacksize"); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import + (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + function pthread_detach (thread : pthread_t) return int; + pragma Import (C, pthread_detach, "pthread_detach"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + ---------------------------- + -- POSIX.1c Section 17 -- + ---------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access + procedure (arg : System.Address); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + + -------------------------------------- + -- Non-portable pthread functions -- + -------------------------------------- + + function pthread_set_name_np + (thread : pthread_t; + name : System.Address) return int; + pragma Import (C, pthread_set_name_np, "pthread_set_name_np"); + + private + + type sigset_t is array (1 .. 4) of unsigned; + + -- In FreeBSD the component sa_handler turns out to + -- be one a union type, and the selector is a macro: + -- #define sa_handler __sigaction_u._handler + -- #define sa_sigaction __sigaction_u._sigaction + + -- Should we add a signal_context type here ? + -- How could it be done independent of the CPU architecture ? + -- sigcontext type is opaque, so it is architecturally neutral. + -- It is always passed as an access type, so define it as an empty record + -- since the contents are not used anywhere. + type struct_sigcontext is null record; + pragma Convention (C, struct_sigcontext); + + type pid_t is new int; + Self_PID : constant pid_t := 0; + + type time_t is new long; + + type timespec is record + ts_sec : time_t; + ts_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; + + type struct_timeval is record + tv_sec : long; + tv_usec : long; + end record; + pragma Convention (C, struct_timeval); + + type pthread_t is new System.Address; + type pthread_attr_t is new System.Address; + type pthread_mutex_t is new System.Address; + type pthread_mutexattr_t is new System.Address; + type pthread_cond_t is new System.Address; + type pthread_condattr_t is new System.Address; + type pthread_key_t is new int; + + end System.OS_Interface; diff -Nrc3pad gcc-3.3.3/gcc/ada/55system.ads gcc-3.4.0/gcc/ada/55system.ads *** gcc-3.3.3/gcc/ada/55system.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/55system.ads 2003-11-21 15:25:00.000000000 +0000 *************** *** 0 **** --- 1,150 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (GNU-Linux/ia64 Version) -- + -- -- + -- Copyright (C) 1992-2003 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. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package System is + pragma Pure (System); + -- Note that we take advantage of the implementation permission to + -- make this unit Pure instead of Preelaborable, see RM 13.7(36) + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 64; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + AAMP : constant Boolean := False; + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Functions_Return_By_DSP : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + OpenVMS : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + Front_End_ZCX_Support : constant Boolean := False; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/56osinte.adb gcc-3.4.0/gcc/ada/56osinte.adb *** gcc-3.3.3/gcc/ada/56osinte.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/56osinte.adb 2003-10-21 13:41:51.000000000 +0000 *************** *** 0 **** --- 1,154 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . O S _ I N T E R F A C E -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2001-2002 Ada Core Technologies, Inc. -- + -- -- + -- GNARL is free software; you can redistribute it and/or modify it under -- + -- terms of the GNU General Public License as published by the Free Soft- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNARL; see file COPYING. If not, write -- + -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- + -- MA 02111-1307, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNARL was developed by the GNARL team at Florida State University. -- + -- Extensive contributions were provided by Ada Core Technologies, Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is a LynxOS (POSIX Threads) version of this package + + pragma Polling (Off); + -- Turn off polling, we do not want ATC polling to take place during + -- tasking operations. It causes infinite loops and other problems. + + with Interfaces.C; + + package body System.OS_Interface is + + use Interfaces.C; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; + end To_Duration; + + function To_Duration (TV : struct_timeval) return Duration is + begin + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end To_Duration; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ---------------- + -- To_Timeval -- + ---------------- + + function To_Timeval (D : Duration) return struct_timeval is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return + struct_timeval' + (tv_sec => S, + tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); + end To_Timeval; + + ------------- + -- sigwait -- + ------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) + return int + is + function sigwaitinfo + (set : access sigset_t; + info : System.Address) return Signal; + pragma Import (C, sigwaitinfo, "sigwaitinfo"); + + begin + sig.all := sigwaitinfo (set, Null_Address); + + if sig.all = -1 then + return errno; + end if; + + return 0; + end sigwait; + + -------------------- + -- Get_Stack_Base -- + -------------------- + + function Get_Stack_Base (thread : pthread_t) return Address is + pragma Warnings (Off, thread); + + begin + return Null_Address; + end Get_Stack_Base; + + ------------------ + -- pthread_init -- + ------------------ + + procedure pthread_init is + begin + null; + end pthread_init; + + end System.OS_Interface; diff -Nrc3pad gcc-3.3.3/gcc/ada/56osinte.ads gcc-3.4.0/gcc/ada/56osinte.ads *** gcc-3.3.3/gcc/ada/56osinte.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/56osinte.ads 2003-12-05 10:24:04.000000000 +0000 *************** *** 0 **** --- 1,586 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . O S _ I N T E R F A C E -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2002-2003 Ada Core Technologies, Inc. -- + -- -- + -- GNARL is free software; you can redistribute it and/or modify it under -- + -- terms of the GNU General Public License as published by the Free Soft- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNARL; see file COPYING. If not, write -- + -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- + -- MA 02111-1307, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNARL was developed by the GNARL team at Florida State University. -- + -- Extensive contributions were provided by Ada Core Technologies, Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is a LynxOS (POSIX Threads) version of this package. + + -- This package encapsulates all direct interfaces to OS services + -- that are needed by children of System. + + -- PLEASE DO NOT add any with-clauses to this package + -- or remove the pragma Elaborate_Body. + -- It is designed to be a bottom-level (leaf) package. + + with Interfaces.C; + package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-mthreads"); + -- Selects the POSIX 1.c runtime, rather than the non-threading runtime + -- or the deprecated legacy threads library. The -mthreads flag is + -- defined in patch.LynxOS and matches the definition for Lynx's gcc. + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 60; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 63; + + -- Max_Interrupt is the number of OS signals, as defined in: + -- + -- /usr/include/sys/signal.h + -- + -- + -- The lowest numbered signal is 1, but 0 is a valid argument to some + -- library functions, eg. kill(2). However, 0 is not just another + -- signal: For instance 'I in Signal' and similar should be used with + -- caution. + + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGBRK : constant := 6; -- break + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in future + SIGCORE : constant := 7; -- kill with core dump + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGURG : constant := 16; -- urgent condition on IO channel + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGCLD : constant := 20; -- alias for SIGCHLD + SIGCHLD : constant := 20; -- child status change + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) + SIGPOLL : constant := 23; -- pollable event occurred + SIGTHREADKILL : constant := 24; -- Reserved by LynxOS runtime + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGWINCH : constant := 28; -- window size change + SIGLOST : constant := 29; -- SUN 4.1 compatibility + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + + SIGPRIO : constant := 32; + -- sent to a process with its priority or group is changed + + SIGADAABORT : constant := SIGABRT; + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := + (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGTHREADKILL); + Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP, SIGPRIO); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SA_SIGINFO : constant := 16#80#; + + SIG_BLOCK : constant := 0; + SIG_UNBLOCK : constant := 1; + SIG_SETMASK : constant := 2; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates whether time slicing is supported + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function clock_getres + (clock_id : clockid_t; + res : access timespec) return int; + pragma Import (C, clock_getres, "clock_getres"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timezone is record + tz_minuteswest : int; + tz_dsttime : int; + end record; + pragma Convention (C, struct_timezone); + type struct_timezone_ptr is access all struct_timezone; + + type struct_timeval is private; + -- This is needed on systems that do not have clock_gettime() + -- but do have gettimeofday(). + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 16#200000#; + SCHED_RR : constant := 16#100000#; + SCHED_OTHER : constant := 16#400000#; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + pragma Import (C, lwp_self, "pthread_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + PTHREAD_CREATE_JOINABLE : constant := 0; + + ----------- + -- Stack -- + ----------- + + Stack_Base_Available : constant Boolean := False; + -- Indicates whether the stack base is available on this target. + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- Returns the stack base of the specified thread. + -- Only call this function when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- Returns the size of a page, or 0 if this is not relevant on this + -- target + + PROT_NONE : constant := 1; + PROT_READ : constant := 2; + PROT_WRITE : constant := 4; + PROT_EXEC : constant := 8; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + + PROT_ON : constant := PROT_READ; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + ----------------------------------------- + -- Nonstandard Thread Initialization -- + ----------------------------------------- + + procedure pthread_init; + -- This is a dummy procedure to share some GNULLI files + + --------------------------- + -- POSIX.1c Section 3 -- + --------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Inline (sigwait); + -- LynxOS has non standard sigwait + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + type sigset_t_ptr is access all sigset_t; + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + -- The behavior of pthread_sigmask on LynxOS requires + -- further investigation. + + ---------------------------- + -- POSIX.1c Section 11 -- + ---------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_INHERIT : constant := 1; + PTHREAD_PRIO_PROTECT : constant := 2; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import (C, pthread_mutexattr_setprioceiling); + + type struct_sched_param is record + sched_priority : int; + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy); + + function sched_yield return int; + pragma Import (C, sched_yield, "sched_yield"); + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import (C, pthread_attr_setdetachstate); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function st_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, st_setspecific, "st_setspecific"); + + function st_getspecific + (key : pthread_key_t; + retval : System.Address) return int; + pragma Import (C, st_getspecific, "st_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + + function st_keycreate + (destructor : destructor_pointer; + key : access pthread_key_t) return int; + pragma Import (C, st_keycreate, "st_keycreate"); + + private + + type sigset_t is record + X1, X2 : long; + end record; + pragma Convention (C, sigset_t); + + type pid_t is new long; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new unsigned_char; + CLOCK_REALTIME : constant clockid_t := 0; + + type struct_timeval is record + tv_sec : time_t; + tv_usec : time_t; + end record; + pragma Convention (C, struct_timeval); + + type st_attr_t is record + stksize : int; + prio : int; + inheritsched : int; + state : int; + sched : int; + detachstate : int; + guardsize : int; + end record; + pragma Convention (C, st_attr_t); + + type pthread_attr_t is record + pthread_attr_magic : unsigned; + st : st_attr_t; + pthread_attr_scope : int; + end record; + pragma Convention (C, pthread_attr_t); + + type pthread_condattr_t is record + cv_magic : unsigned; + cv_pshared : unsigned; + end record; + pragma Convention (C, pthread_condattr_t); + + type pthread_mutexattr_t is record + m_flags : unsigned; + m_prio_c : int; + m_pshared : int; + end record; + pragma Convention (C, pthread_mutexattr_t); + + type tid_t is new short; + type pthread_t is new tid_t; + + type block_obj_t is new System.Address; + -- typedef struct _block_obj_s { + -- struct st_entry *b_head; + -- } block_obj_t; + + type pthread_mutex_t is record + m_flags : unsigned; + m_owner : tid_t; + m_wait : block_obj_t; + m_prio_c : int; + m_oldprio : int; + m_count : int; + m_referenced : int; + end record; + pragma Convention (C, pthread_mutex_t); + type pthread_mutex_t_ptr is access all pthread_mutex_t; + + type pthread_cond_t is record + cv_magic : unsigned; + cv_wait : block_obj_t; + cv_mutex : pthread_mutex_t_ptr; + cv_refcnt : int; + end record; + pragma Convention (C, pthread_cond_t); + + type pthread_key_t is new int; + + end System.OS_Interface; diff -Nrc3pad gcc-3.3.3/gcc/ada/56system.ads gcc-3.4.0/gcc/ada/56system.ads *** gcc-3.3.3/gcc/ada/56system.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/56system.ads 2003-11-20 17:51:26.000000000 +0000 *************** *** 0 **** --- 1,150 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (FreeBSD/x86 Version) -- + -- -- + -- Copyright (C) 1992-2003 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. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package System is + pragma Pure (System); + -- Note that we take advantage of the implementation permission to + -- make this unit Pure instead of Preelaborable, see RM 13.7(36) + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.000_001; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + AAMP : constant Boolean := False; + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Functions_Return_By_DSP : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + OpenVMS : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + Front_End_ZCX_Support : constant Boolean := False; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/56taprop.adb gcc-3.4.0/gcc/ada/56taprop.adb *** gcc-3.3.3/gcc/ada/56taprop.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/56taprop.adb 2004-01-05 15:20:42.000000000 +0000 *************** *** 0 **** --- 1,1188 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- + -- -- + -- GNARL is free software; you can redistribute it and/or modify it under -- + -- terms of the GNU General Public License as published by the Free Soft- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNARL; see file COPYING. If not, write -- + -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- + -- MA 02111-1307, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNARL was developed by the GNARL team at Florida State University. -- + -- Extensive contributions were provided by Ada Core Technologies, Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is a LynxOS version of this file, adapted to make + -- SCHED_FIFO and ceiling locking (Annex D compliance) work properly + + -- This package contains all the GNULL primitives that interface directly + -- with the underlying OS. + + pragma Polling (Off); + -- Turn off polling, we do not want ATC polling to take place during + -- tasking operations. It causes infinite loops and other problems. + + with System.Tasking.Debug; + -- used for Known_Tasks + + with System.Task_Info; + -- used for Task_Info_Type + + with Interfaces.C; + -- used for int + -- size_t + + with System.Interrupt_Management; + -- used for Keep_Unmasked + -- Abort_Task_Interrupt + -- Interrupt_ID + + with System.Interrupt_Management.Operations; + -- used for Set_Interrupt_Mask + -- All_Tasks_Mask + pragma Elaborate_All (System.Interrupt_Management.Operations); + + with System.Parameters; + -- used for Size_Type + + with System.Tasking; + -- used for Ada_Task_Control_Block + -- Task_ID + + with System.Soft_Links; + -- used for Defer/Undefer_Abort + + -- Note that we do not use System.Tasking.Initialization directly since + -- this is a higher level package that we shouldn't depend on. For example + -- when using the restricted run time, it is replaced by + -- System.Tasking.Restricted.Initialization + + with System.OS_Primitives; + -- used for Delay_Modes + + with Unchecked_Conversion; + with Unchecked_Deallocation; + + package body System.Task_Primitives.Operations is + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + + package SSL renames System.Soft_Links; + + ---------------- + -- Local Data -- + ---------------- + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_ID associated with a thread + + Environment_Task_ID : Task_ID; + -- A variable to hold Task_ID for the environment task. + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + -- Value of the pragma Locking_Policy: + -- 'C' for Ceiling_Locking + -- 'I' for Inherit_Locking + -- ' ' for none. + + Unblocked_Signal_Mask : aliased sigset_t; + -- The set of signals that should unblocked in all tasks + + -- The followings are internal configuration constants needed. + + Next_Serial_Number : Task_Serial_Number := 100; + -- We start at 100, to reserve some special values for + -- using in error checking. + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; + -- Indicates whether FIFO_Within_Priorities is set. + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads). + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_ID); + pragma Inline (Initialize); + -- Initialize various data needed by this package. + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does the current thread have an ATCB? + + procedure Set (Self_Id : Task_ID); + pragma Inline (Set); + -- Set the self id for the current task. + + function Self return Task_ID; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task. + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific. + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; + -- Allocate and Initialize a new ATCB for the current Thread. + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_ID is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Abort_Handler (Sig : Signal); + -- Signal handler used to implement asynchronous abort. + + procedure Set_OS_Priority (T : Task_ID; Prio : System.Any_Priority); + -- This procedure calls the scheduler of the OS to set thread's priority + + function To_Address is new Unchecked_Conversion (Task_ID, System.Address); + + ------------------- + -- Abort_Handler -- + ------------------- + + procedure Abort_Handler (Sig : Signal) is + pragma Unreferenced (Sig); + + T : Task_ID := Self; + Result : Interfaces.C.int; + Old_Set : aliased sigset_t; + + begin + -- It is not safe to raise an exception when using ZCX and the GCC + -- exception handling mechanism. + + if ZCX_By_Default and then GCC_ZCX_Support then + return; + end if; + + if T.Deferral_Level = 0 + and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then + not T.Aborting + then + T.Aborting := True; + + -- Make sure signals used for RTS internal purpose are unmasked + + Result := pthread_sigmask (SIG_UNBLOCK, + Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + ----------------- + -- Stack_Guard -- + ----------------- + + procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread); + Guard_Page_Address : Address; + + Res : Interfaces.C.int; + + begin + if Stack_Base_Available then + + -- Compute the guard page address + + Guard_Page_Address := + Stack_Base - (Stack_Base mod Get_Page_Size) + Get_Page_Size; + + if On then + Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_ON); + else + Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_OFF); + end if; + + pragma Assert (Res = 0); + end if; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_ID renames Specific.Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : access Lock) + is + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + L.Ceiling := Prio; + end if; + + Result := pthread_mutex_init (L.Mutex'Access, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Unreferenced (Level); + + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L.Mutex'Access); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : access RTS_Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + Result : Interfaces.C.int; + T : constant Task_ID := Self; + + begin + if Locking_Policy = 'C' then + if T.Common.Current_Priority > L.Ceiling then + Ceiling_Violation := True; + return; + end if; + + L.Saved_Priority := T.Common.Current_Priority; + + if T.Common.Current_Priority < L.Ceiling then + Set_OS_Priority (T, L.Ceiling); + end if; + end if; + + Result := pthread_mutex_lock (L.Mutex'Access); + + -- Assume that the cause of EINVAL is a priority ceiling violation + + Ceiling_Violation := (Result = EINVAL); + pragma Assert (Result = 0 or else Result = EINVAL); + end Write_Lock; + + -- No tricks on RTS_Locks + + procedure Write_Lock + (L : access RTS_Lock; Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_lock (L); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_ID) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_lock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : access Lock) is + Result : Interfaces.C.int; + T : constant Task_ID := Self; + + begin + Result := pthread_mutex_unlock (L.Mutex'Access); + pragma Assert (Result = 0); + + if Locking_Policy = 'C' then + if T.Common.Current_Priority > L.Saved_Priority then + Set_OS_Priority (T, L.Saved_Priority); + end if; + end if; + end Unlock; + + procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_ID) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_unlock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_ID; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + + begin + if Single_Lock then + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + else + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + end if; + + -- EINTR is not considered a failure + + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + -- This is for use within the run-time system, so abort is + -- assumed to be already deferred, and the caller should be + -- holding its own ATCB lock. + + procedure Timed_Sleep + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Check_Time : constant Duration := Monotonic_Clock; + Rel_Time : Duration; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + Timedout := True; + Yielded := False; + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time); + end if; + + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); + end if; + end if; + + if Abs_Time > Check_Time then + if Relative_Timed_Wait then + Request := To_Timespec (Rel_Time); + else + Request := To_Timespec (Abs_Time); + end if; + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + or else Self_ID.Pending_Priority_Change; + + if Single_Lock then + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, + Request'Access); + + else + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, + Request'Access); + end if; + + exit when Abs_Time <= Monotonic_Clock; + + if Result = 0 or Result = EINTR then + + -- Somebody may have called Wakeup for us + + Timedout := False; + exit; + end if; + + pragma Assert (Result = ETIMEDOUT); + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + -- This is for use in implementing delay statements, so we assume + -- the caller is abort-deferred but is holding no locks. + + procedure Timed_Delay + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes) + is + Check_Time : constant Duration := Monotonic_Clock; + Abs_Time : Duration; + Rel_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + -- Only the little window between deferring abort and + -- locking Self_ID is the reason we need to + -- check for pending abort and priority change below! + + SSL.Abort_Defer.all; + + if Single_Lock then + Lock_RTS; + end if; + + -- Comments needed in code below ??? + + Write_Lock (Self_ID); + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time); + end if; + + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); + end if; + end if; + + if Abs_Time > Check_Time then + if Relative_Timed_Wait then + Request := To_Timespec (Rel_Time); + else + Request := To_Timespec (Abs_Time); + end if; + + Self_ID.Common.State := Delay_Sleep; + + loop + if Self_ID.Pending_Priority_Change then + Self_ID.Pending_Priority_Change := False; + Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + end if; + + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + if Single_Lock then + Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access, Request'Access); + else + Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, Request'Access); + end if; + + exit when Abs_Time <= Monotonic_Clock; + + pragma Assert (Result = 0 + or else Result = ETIMEDOUT + or else Result = EINTR); + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Result := sched_yield; + SSL.Abort_Undefer.all; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; + begin + Result := clock_gettime + (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (TS); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + Res : aliased timespec; + Result : Interfaces.C.int; + begin + Result := clock_getres + (clock_id => CLOCK_REALTIME, Res => Res'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (Res); + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin + Result := pthread_cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin + if Do_Yield then + Result := sched_yield; + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_OS_Priority (T : Task_ID; Prio : System.Any_Priority) is + Result : Interfaces.C.int; + Param : aliased struct_sched_param; + + begin + Param.sched_priority := Interfaces.C.int (Prio); + + if Time_Slice_Supported and then Time_Slice_Val > 0 then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); + + elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + + else + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + end if; + + pragma Assert (Result = 0); + end Set_OS_Priority; + + type Prio_Array_Type is array (System.Any_Priority) of Integer; + pragma Atomic_Components (Prio_Array_Type); + Prio_Array : Prio_Array_Type; + -- Comments needed for these declarations ??? + + procedure Set_Priority + (T : Task_ID; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + Array_Item : Integer; + + begin + Set_OS_Priority (T, Prio); + + if Locking_Policy = 'C' then + -- Annex D requirements: loss of inheritance puts task at the + -- beginning of the queue for that prio; copied from 5ztaprop + -- (VxWorks) + + if Loss_Of_Inheritance + and then Prio < T.Common.Current_Priority then + + Array_Item := Prio_Array (T.Common.Base_Priority) + 1; + Prio_Array (T.Common.Base_Priority) := Array_Item; + + loop + Yield; + exit when Array_Item = Prio_Array (T.Common.Base_Priority) + or else Prio_Array (T.Common.Base_Priority) = 1; + end loop; + + Prio_Array (T.Common.Base_Priority) := + Prio_Array (T.Common.Base_Priority) - 1; + end if; + end if; + + T.Common.Current_Priority := Prio; + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_ID) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_ID) is + begin + Self_ID.Common.LL.Thread := pthread_self; + Self_ID.Common.LL.LWP := lwp_self; + + Specific.Set (Self_ID); + + Lock_RTS; + + for J in Known_Tasks'Range loop + if Known_Tasks (J) = null then + Known_Tasks (J) := Self_ID; + Self_ID.Known_Tasks_Index := J; + exit; + end if; + end loop; + + Unlock_RTS; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + + ---------------------- + -- Initialize_TCB -- + ---------------------- + + procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is + Mutex_Attr : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; + + begin + -- Give the task a unique serial number. + + Self_ID.Serial_Number := Next_Serial_Number; + Next_Serial_Number := Next_Serial_Number + 1; + pragma Assert (Next_Serial_Number /= 0); + + if not Single_Lock then + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, + Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, + Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Succeeded := True; + else + if not Single_Lock then + Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_ID; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Attributes : aliased pthread_attr_t; + Adjusted_Stack_Size : Interfaces.C.size_t; + Result : Interfaces.C.int; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + use System.Task_Info; + + begin + if Stack_Size = Unspecified_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size); + + elsif Stack_Size < Minimum_Stack_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); + + else + Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); + end if; + + if Stack_Base_Available then + + -- If Stack Checking is supported then allocate 2 additional pages: + -- + -- In the worst case, stack is allocated at something like + -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages + -- to be sure the effective stack size is greater than what + -- has been asked. + + Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Get_Page_Size; + end if; + + Result := pthread_attr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); + pragma Assert (Result = 0); + + Result := pthread_attr_setstacksize + (Attributes'Access, Adjusted_Stack_Size); + pragma Assert (Result = 0); + + if T.Common.Task_Info /= Default_Scope then + + -- We are assuming that Scope_Type has the same values than the + -- corresponding C macros + + Result := pthread_attr_setscope + (Attributes'Access, Task_Info_Type'Pos (T.Common.Task_Info)); + pragma Assert (Result = 0); + end if; + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + Result := pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + pragma Assert (Result = 0 or else Result = EAGAIN); + + Succeeded := Result = 0; + + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result = 0); + + Set_Priority (T, Priority); + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_ID) is + Result : Interfaces.C.int; + Tmp : Task_ID := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); + + begin + if not Single_Lock then + Result := pthread_mutex_destroy (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (Tmp); + + if Is_Self then + Result := st_setspecific (ATCB_Key, System.Null_Address); + pragma Assert (Result = 0); + end if; + + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_ID) is + Result : Interfaces.C.int; + begin + Result := pthread_kill (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + pragma Assert (Result = 0); + end Abort_Task; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy versions + + function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_ID is + begin + return Environment_Task_ID; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) + return Boolean + is + pragma Unreferenced (T); + pragma Unreferenced (Thread_Self); + begin + return False; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) return Boolean + is + pragma Unreferenced (T); + pragma Unreferenced (Thread_Self); + begin + return False; + end Resume_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_ID) is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; + + function State + (Int : System.Interrupt_Management.Interrupt_ID) + return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state. Defined in a-init.c + -- The input argument is the interrupt number, + -- and the result is one of the following: + + Default : constant Character := 's'; + -- 'n' this interrupt not set by any Interrupt_State pragma + -- 'u' Interrupt_State pragma set state to User + -- 'r' Interrupt_State pragma set state to Runtime + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + begin + Environment_Task_ID := Environment_Task; + + -- Initialize the lock used to synchronize chain of all ATCBs. + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Specific.Initialize (Environment_Task); + + Enter_Task (Environment_Task); + + -- Install the abort-signal handler + + if State (System.Interrupt_Management.Abort_Task_Interrupt) + /= Default + then + act.sa_flags := 0; + act.sa_handler := Abort_Handler'Address; + + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction + (Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); + + pragma Assert (Result = 0); + end if; + end Initialize; + + begin + declare + Result : Interfaces.C.int; + + begin + -- Mask Environment task for all signals. The original mask of the + -- Environment task will be recovered by Interrupt_Server task + -- during the elaboration of s-interr.adb. + + System.Interrupt_Management.Operations.Set_Interrupt_Mask + (System.Interrupt_Management.Operations.All_Tasks_Mask'Access); + + -- Prepare the set of signals that should unblocked in all tasks + + Result := sigemptyset (Unblocked_Signal_Mask'Access); + pragma Assert (Result = 0); + + for J in Interrupt_Management.Interrupt_ID loop + if System.Interrupt_Management.Keep_Unmasked (J) then + Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); + pragma Assert (Result = 0); + end if; + end loop; + end; + end System.Task_Primitives.Operations; diff -Nrc3pad gcc-3.3.3/gcc/ada/56taspri.ads gcc-3.4.0/gcc/ada/56taspri.ads *** gcc-3.3.3/gcc/ada/56taspri.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/56taspri.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . T A S K _ P R I M I T I V E S -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 1991-1994, Florida State University -- + -- Copyright (C) 1995-2003, Ada Core Technologies -- + -- -- + -- GNARL is free software; you can redistribute it and/or modify it under -- + -- terms of the GNU General Public License as published by the Free Soft- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNARL; see file COPYING. If not, write -- + -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- + -- MA 02111-1307, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNARL was developed by the GNARL team at Florida State University. -- + -- Extensive contributions were provided by Ada Core Technologies, Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is a LynxOS version of this package, derived from + -- 7staspri.ads + + pragma Polling (Off); + -- Turn off polling, we do not want ATC polling to take place during + -- tasking operations. It causes infinite loops and other problems. + + with System.OS_Interface; + -- used for pthread_mutex_t + -- pthread_cond_t + -- pthread_t + + package System.Task_Primitives is + + type Lock is limited private; + -- Should be used for implementation of protected objects. + + type RTS_Lock is limited private; + -- Should be used inside the runtime system. + -- The difference between Lock and the RTS_Lock is that the later + -- one serves only as a semaphore so that do not check for + -- ceiling violations. + + type Task_Body_Access is access procedure; + -- Pointer to the task body's entry point (or possibly a wrapper + -- declared local to the GNARL). + + type Private_Data is limited private; + -- Any information that the GNULLI needs maintained on a per-task + -- basis. A component of this type is guaranteed to be included + -- in the Ada_Task_Control_Block. + + private + + type Lock is record + Mutex : aliased System.OS_Interface.pthread_mutex_t; + Ceiling : System.Any_Priority; + Saved_Priority : System.Any_Priority; + end record; + + type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + + type Private_Data is record + Thread : aliased System.OS_Interface.pthread_t; + pragma Atomic (Thread); + -- Thread field may be updated by two different threads of control. + -- (See, Enter_Task and Create_Task in s-taprop.adb). + -- They put the same value (thr_self value). We do not want to + -- use lock on those operations and the only thing we have to + -- make sure is that they are updated in atomic fashion. + + LWP : aliased System.Address; + -- The purpose of this field is to provide a better tasking support on + -- gdb. The order of the two first fields (Thread and LWP) is important. + -- On targets where lwp is not relevant, this is equivalent to Thread. + + CV : aliased System.OS_Interface.pthread_cond_t; + + L : aliased RTS_Lock; + -- Protection for all components is lock L + end record; + + end System.Task_Primitives; diff -Nrc3pad gcc-3.3.3/gcc/ada/56tpopsp.adb gcc-3.4.0/gcc/ada/56tpopsp.adb *** gcc-3.3.3/gcc/ada/56tpopsp.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/56tpopsp.adb 2004-01-05 15:20:42.000000000 +0000 *************** *** 0 **** --- 1,113 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- + -- -- + -- GNARL is free software; you can redistribute it and/or modify it under -- + -- terms of the GNU General Public License as published by the Free Soft- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNARL; see file COPYING. If not, write -- + -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- + -- MA 02111-1307, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNARL was developed by the GNARL team at Florida State University. -- + -- Extensive contributions were provided by Ada Core Technologies, Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is a LynxOS version of this package. + + separate (System.Task_Primitives.Operations) + package body Specific is + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_ID) is + pragma Warnings (Off, Environment_Task); + Result : Interfaces.C.int; + + begin + Result := st_keycreate (null, ATCB_Key'Access); + pragma Assert (Result = 0); + end Initialize; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + Result : Interfaces.C.int; + Value : aliased System.Address; + begin + Result := st_getspecific (ATCB_Key, Value'Address); + pragma Assert (Result = 0); + return (Value /= System.Null_Address); + end Is_Valid_Task; + + --------- + -- Set -- + --------- + + procedure Set (Self_Id : Task_ID) is + Result : Interfaces.C.int; + + begin + Result := st_setspecific (ATCB_Key, To_Address (Self_Id)); + pragma Assert (Result = 0); + end Set; + + ---------- + -- Self -- + ---------- + + -- To make Ada tasks and C threads interoperate better, we have added some + -- functionality to Self. Suppose a C main program (with threads) calls an + -- Ada procedure and the Ada procedure calls the tasking runtime system. + -- Eventually, a call will be made to self. Since the call is not coming + -- from an Ada task, there will be no corresponding ATCB. + + -- What we do in Self is to catch references that do not come from + -- recognized Ada tasks, and create an ATCB for the calling thread. + + -- The new ATCB will be "detached" from the normal Ada task master + -- hierarchy, much like the existing implicitly created signal-server + -- tasks. + + function Self return Task_ID is + Value : aliased System.Address; + + Result : Interfaces.C.int; + pragma Unreferenced (Result); + + begin + Result := st_getspecific (ATCB_Key, Value'Address); + -- Is it OK not to check this result??? + + -- If the key value is Null, then it is a non-Ada task. + + if Value /= System.Null_Address then + return To_Task_Id (Value); + else + return Register_Foreign_Thread; + end if; + end Self; + + end Specific; diff -Nrc3pad gcc-3.3.3/gcc/ada/57system.ads gcc-3.4.0/gcc/ada/57system.ads *** gcc-3.3.3/gcc/ada/57system.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/57system.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 0 **** --- 1,150 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (LynxOS PPC Version) -- + -- -- + -- Copyright (C) 1992-2003 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. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package System is + pragma Pure (System); + -- Note that we take advantage of the implementation permission to + -- make this unit Pure instead of Preelaborable, see RM 13.7(36) + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 254; + Max_Interrupt_Priority : constant Positive := 255; + + subtype Any_Priority is Integer range 0 .. 255; + subtype Priority is Any_Priority range 0 .. 254; + subtype Interrupt_Priority is Any_Priority range 255 .. 255; + + Default_Priority : constant Priority := 15; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + AAMP : constant Boolean := False; + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Functions_Return_By_DSP : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + OpenVMS : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + Front_End_ZCX_Support : constant Boolean := False; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/58system.ads gcc-3.4.0/gcc/ada/58system.ads *** gcc-3.3.3/gcc/ada/58system.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/58system.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 0 **** --- 1,150 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (LynxOS x86 Version) -- + -- -- + -- Copyright (C) 1992-2003 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. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package System is + pragma Pure (System); + -- Note that we take advantage of the implementation permission to + -- make this unit Pure instead of Preelaborable, see RM 13.7(36) + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 254; + Max_Interrupt_Priority : constant Positive := 255; + + subtype Any_Priority is Integer range 0 .. 255; + subtype Priority is Any_Priority range 0 .. 254; + subtype Interrupt_Priority is Any_Priority range 255 .. 255; + + Default_Priority : constant Priority := 15; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + AAMP : constant Boolean := False; + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Functions_Return_By_DSP : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + OpenVMS : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + Front_End_ZCX_Support : constant Boolean := False; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/59system.ads gcc-3.4.0/gcc/ada/59system.ads *** gcc-3.3.3/gcc/ada/59system.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/59system.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 0 **** --- 1,164 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (PPC ELF Version) -- + -- -- + -- Copyright (C) 1992-2003 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. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + pragma Restrictions (No_Exception_Handlers); + pragma Restrictions (No_Implicit_Dynamic_Code); + pragma Restrictions (No_Finalization); + pragma Discard_Names; + -- Above pragmas need commenting ??? + + package System is + pragma Pure (System); + -- Note that we take advantage of the implementation permission to + -- make this unit Pure instead of Preelaborable, see RM 13.7(36) + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 1.0 / 60.0; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + + -- Priority-related Declarations (RM D.1) + + -- 256 is reserved for the VxWorks kernel + -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 + -- 247 is a catchall default "interrupt" priority for signals, + -- allowing higher priority than normal tasks, but lower than + -- hardware priority levels. Protected Object ceilings can + -- override these values. + -- 246 is used by the Interrupt_Manager task + + Max_Priority : constant Positive := 245; + Max_Interrupt_Priority : constant Positive := 255; + + subtype Any_Priority is Integer range 0 .. 255; + subtype Priority is Any_Priority range 0 .. 245; + subtype Interrupt_Priority is Any_Priority range 246 .. 255; + + Default_Priority : constant Priority := 122; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + AAMP : constant Boolean := False; + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := False; + Configurable_Run_Time : constant Boolean := True; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := True; + Exit_Status_Supported : constant Boolean := False; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Functions_Return_By_DSP : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + OpenVMS : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := True; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + Front_End_ZCX_Support : constant Boolean := False; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := True; + Long_Shifts_Inlined : constant Boolean := False; + + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/5amastop.adb gcc-3.4.0/gcc/ada/5amastop.adb *** gcc-3.3.3/gcc/ada/5amastop.adb 2002-03-14 10:58:27.000000000 +0000 --- gcc-3.4.0/gcc/ada/5amastop.adb 2004-01-05 15:20:42.000000000 +0000 *************** *** 7,14 **** -- B o d y -- -- (Version for Alpha/Dec Unix) -- -- -- ! -- -- ! -- Copyright (C) 1999-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- -- --- 7,13 ---- -- B o d y -- -- (Version for Alpha/Dec Unix) -- -- -- ! -- Copyright (C) 1999-2003 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- -- *************** *** 29,35 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 28,34 ---- -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ *************** package body System.Machine_State_Operat *** 106,113 **** -- asm instruction takes 4 bytes. So we must remove this value from -- c_get_code_loc to have the call point. begin ! return c_get_code_loc (M) - Asm_Call_Size; end Get_Code_Loc; -------------------------- --- 105,118 ---- -- asm instruction takes 4 bytes. So we must remove this value from -- c_get_code_loc to have the call point. + Loc : constant Code_Loc := c_get_code_loc (M); + begin ! if Loc = 0 then ! return 0; ! else ! return Loc - Asm_Call_Size; ! end if; end Get_Code_Loc; -------------------------- *************** package body System.Machine_State_Operat *** 134,139 **** --- 139,146 ---- (M : Machine_State; Info : Subprogram_Info_Type) is + pragma Warnings (Off, Info); + procedure exc_virtual_unwind (Fcn : System.Address; M : Machine_State); *************** package body System.Machine_State_Operat *** 162,168 **** procedure Set_Signal_Machine_State (M : Machine_State; ! Context : System.Address) is begin null; end Set_Signal_Machine_State; --- 169,179 ---- procedure Set_Signal_Machine_State (M : Machine_State; ! Context : System.Address) ! is ! pragma Warnings (Off, M); ! pragma Warnings (Off, Context); ! begin null; end Set_Signal_Machine_State; diff -Nrc3pad gcc-3.3.3/gcc/ada/5aml-tgt.adb gcc-3.4.0/gcc/ada/5aml-tgt.adb *** gcc-3.3.3/gcc/ada/5aml-tgt.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5aml-tgt.adb 2004-01-05 15:20:42.000000000 +0000 *************** *** 0 **** --- 1,389 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T -- + -- (True64 Version) -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2002-2003 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. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package provides a set of target dependent routines to build + -- static, dynamic and shared libraries. + + -- This is the True64 version of the body. + + with MLib.Fil; + with MLib.Utl; + with Namet; use Namet; + with Opt; + with Output; use Output; + with Prj.Com; + with System; + + package body MLib.Tgt is + + use GNAT; + use MLib; + + Expect_Unresolved : aliased String := "-Wl,-expect_unresolved,*"; + + No_Arguments : aliased Argument_List := (1 .. 0 => null); + Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; + + Wl_Init_String : aliased String := "-Wl,-init"; + Wl_Init : constant String_Access := Wl_Init_String'Access; + Wl_Fini_String : aliased String := "-Wl,-fini"; + Wl_Fini : constant String_Access := Wl_Fini_String'Access; + + Init_Fini_List : constant Argument_List_Access := + new Argument_List'(1 => Wl_Init, + 2 => null, + 3 => Wl_Fini, + 4 => null); + -- Used to put switches for automatic elaboration/finalization + + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return "ar"; + end Archive_Builder; + + ----------------------------- + -- Archive_Builder_Options -- + ----------------------------- + + function Archive_Builder_Options return String_List_Access is + begin + return new String_List'(1 => new String'("cr")); + end Archive_Builder_Options; + + ----------------- + -- Archive_Ext -- + ----------------- + + function Archive_Ext return String is + begin + return "a"; + end Archive_Ext; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return "ranlib"; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Foreign : Argument_List; + Afiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Address : String := ""; + Lib_Version : String := ""; + Relocatable : Boolean := False; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Foreign); + pragma Unreferenced (Afiles); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Lib_Address); + pragma Unreferenced (Relocatable); + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Filename, DLL_Ext); + + Version_Arg : String_Access; + Symbolic_Link_Needed : Boolean := False; + + Init_Fini : Argument_List_Access := Empty_Argument_List; + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_File); + end if; + + -- If specified, add automatic elaboration/finalization + + if Auto_Init then + Init_Fini := Init_Fini_List; + Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init"); + Init_Fini (4) := new String'("-Wl," & Lib_Filename & "final"); + end if; + + if Lib_Version = "" then + Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles, + Options => + Options & + Expect_Unresolved'Access & + Init_Fini.all, + Driver_Name => Driver_Name); + + else + Version_Arg := new String'("-Wl,-soname," & Lib_Version); + + if Is_Absolute_Path (Lib_Version) then + Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => + Options & + Version_Arg & + Expect_Unresolved'Access & + Init_Fini.all, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := Lib_Version /= Lib_File; + + else + Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => + Options & + Version_Arg & + Expect_Unresolved'Access & + Init_Fini.all, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_File; + end if; + + if Symbolic_Link_Needed then + declare + Success : Boolean; + Oldpath : String (1 .. Lib_Version'Length + 1); + Newpath : String (1 .. Lib_File'Length + 1); + + Result : Integer; + pragma Unreferenced (Result); + + function Symlink + (Oldpath : System.Address; + Newpath : System.Address) + return Integer; + pragma Import (C, Symlink, "__gnat_symlink"); + + begin + Oldpath (1 .. Lib_Version'Length) := Lib_Version; + Oldpath (Oldpath'Last) := ASCII.NUL; + Newpath (1 .. Lib_File'Length) := Lib_File; + Newpath (Newpath'Last) := ASCII.NUL; + + Delete_File (Lib_File, Success); + + Result := Symlink (Oldpath'Address, Newpath'Address); + end; + end if; + end if; + end Build_Dynamic_Library; + + ------------------------- + -- Default_DLL_Address -- + ------------------------- + + function Default_DLL_Address return String is + begin + return ""; + end Default_DLL_Address; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "so"; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return "-shared"; + end Dynamic_Option; + + ------------------- + -- Is_Object_Ext -- + ------------------- + + function Is_Object_Ext (Ext : String) return Boolean is + begin + return Ext = ".o"; + end Is_Object_Ext; + + -------------- + -- Is_C_Ext -- + -------------- + + function Is_C_Ext (Ext : String) return Boolean is + begin + return Ext = ".c"; + end Is_C_Ext; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".so"; + end Is_Archive_Ext; + + ------------- + -- Libgnat -- + ------------- + + function Libgnat return String is + begin + return "libgnat.a"; + end Libgnat; + + ------------------------ + -- Library_Exists_For -- + ------------------------ + + function Library_Exists_For (Project : Project_Id) return Boolean is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & + "for non library project"); + return False; + + else + declare + Lib_Dir : constant String := + Get_Name_String (Projects.Table (Project).Library_Dir); + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + if Projects.Table (Project).Library_Kind = Static then + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + end; + end if; + end Library_Exists_For; + + --------------------------- + -- Library_File_Name_For -- + --------------------------- + + function Library_File_Name_For (Project : Project_Id) return Name_Id is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & + "for non library project"); + return No_Name; + + else + declare + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + Name_Len := 3; + Name_Buffer (1 .. Name_Len) := "lib"; + + if Projects.Table (Project).Library_Kind = Static then + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + + return Name_Find; + end; + end if; + end Library_File_Name_For; + + -------------------------------- + -- Linker_Library_Path_Option -- + -------------------------------- + + function Linker_Library_Path_Option return String_Access is + begin + return new String'("-Wl,-rpath,"); + end Linker_Library_Path_Option; + + ---------------- + -- Object_Ext -- + ---------------- + + function Object_Ext return String is + begin + return "o"; + end Object_Ext; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return ""; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return True; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Full; + end Support_For_Libraries; + + end MLib.Tgt; diff -Nrc3pad gcc-3.3.3/gcc/ada/5aosinte.adb gcc-3.4.0/gcc/ada/5aosinte.adb *** gcc-3.3.3/gcc/ada/5aosinte.adb 2002-03-14 10:58:27.000000000 +0000 --- gcc-3.4.0/gcc/ada/5aosinte.adb 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1991-2001 Florida State University -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2002, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- *************** *** 27,39 **** -- 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 and IRIX version of this package. -- This package encapsulates all direct interfaces to OS services -- that are needed by children of System. --- 26,37 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ ! -- This is the DEC Unix version of this package. -- This package encapsulates all direct interfaces to OS services -- that are needed by children of System. *************** pragma Polling (Off); *** 43,48 **** --- 41,48 ---- -- tasking operations. It causes infinite loops and other problems. with Interfaces.C; use Interfaces.C; + with System.Machine_Code; use System.Machine_Code; + package body System.OS_Interface is ------------------ *************** package body System.OS_Interface is *** 54,59 **** --- 54,73 ---- null; end pthread_init; + ------------------ + -- pthread_self -- + ------------------ + + function pthread_self return pthread_t is + Self : pthread_t; + begin + Asm ("call_pal 0x9e" & ASCII.LF & ASCII.HT & + "bis $31, $0, %0", + Outputs => pthread_t'Asm_Output ("=r", Self), + Clobber => "$0"); + return Self; + end pthread_self; + ----------------- -- To_Duration -- ----------------- *************** package body System.OS_Interface is *** 88,97 **** F := F + 1.0; end if; ! return timespec' (tv_sec => S, ! tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; function To_Timeval (D : Duration) return struct_timeval is S : time_t; F : Duration; --- 102,115 ---- F := F + 1.0; end if; ! return timespec'(tv_sec => S, ! tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; + ---------------- + -- To_Timeval -- + ---------------- + function To_Timeval (D : Duration) return struct_timeval is S : time_t; F : Duration; *************** package body System.OS_Interface is *** 108,115 **** F := F + 1.0; end if; ! return struct_timeval' (tv_sec => S, ! tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); end To_Timeval; end System.OS_Interface; --- 126,135 ---- F := F + 1.0; end if; ! return ! struct_timeval' ! (tv_sec => S, ! tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); end To_Timeval; end System.OS_Interface; diff -Nrc3pad gcc-3.3.3/gcc/ada/5aosinte.ads gcc-3.4.0/gcc/ada/5aosinte.ads *** gcc-3.3.3/gcc/ada/5aosinte.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5aosinte.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1998-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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1998-2002 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ *************** package System.OS_Interface is *** 437,443 **** pragma Import (C, pthread_exit, "__pthread_exit"); function pthread_self return pthread_t; ! pragma Import (C, pthread_self, "__pthread_self"); -------------------------- -- POSIX.1c Section 17 -- --- 436,442 ---- pragma Import (C, pthread_exit, "__pthread_exit"); function pthread_self return pthread_t; ! pragma Inline (pthread_self); -------------------------- -- POSIX.1c Section 17 -- diff -Nrc3pad gcc-3.3.3/gcc/ada/5asystem.ads gcc-3.4.0/gcc/ada/5asystem.ads *** gcc-3.3.3/gcc/ada/5asystem.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5asystem.ads 2003-11-27 11:40:45.000000000 +0000 *************** *** 7,14 **** -- S p e c -- -- (DEC Unix Version) -- -- -- ! -- -- ! -- Copyright (C) 1992-2002 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 -- --- 7,13 ---- -- S p e c -- -- (DEC Unix Version) -- -- -- ! -- Copyright (C) 1992-2003 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 -- *************** pragma Pure (System); *** 59,65 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := 1.0; -- Storage-related Declarations --- 58,64 ---- Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := 1.0 / 1024.0; -- Storage-related Declarations *************** private *** 119,141 **** Backend_Divide_Checks : constant Boolean := False; Backend_Overflow_Checks : constant Boolean := False; Command_Line_Args : constant Boolean := True; Denorm : constant Boolean := False; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; Functions_Return_By_DSP : constant Boolean := False; - Long_Shifts_Inlined : constant Boolean := True; - High_Integrity_Mode : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := True; Stack_Check_Probes : constant Boolean := True; Use_Ada_Main_Program_Name : constant Boolean := False; ! ZCX_By_Default : constant Boolean := False; ! GCC_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := False; -- Note: Denorm is False because denormals are only handled properly -- if the -mieee switch is set, and we do not require this usage. --- 118,152 ---- Backend_Divide_Checks : constant Boolean := False; Backend_Overflow_Checks : constant Boolean := False; Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; Denorm : constant Boolean := False; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; Functions_Return_By_DSP : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := True; Stack_Check_Probes : constant Boolean := True; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ! ZCX_By_Default : constant Boolean := True; ! GCC_ZCX_Support : constant Boolean := True; Front_End_ZCX_Support : constant Boolean := False; + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + -- Note: Denorm is False because denormals are only handled properly -- if the -mieee switch is set, and we do not require this usage. diff -Nrc3pad gcc-3.3.3/gcc/ada/5ataprop.adb gcc-3.4.0/gcc/ada/5ataprop.adb *** gcc-3.3.3/gcc/ada/5ataprop.adb 2002-10-23 08:27:54.000000000 +0000 --- gcc-3.4.0/gcc/ada/5ataprop.adb 2004-01-05 15:20:42.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2003, 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- -- *************** package body System.Task_Primitives.Oper *** 109,114 **** --- 108,116 ---- -- a time; it is used to execute in mutual exclusion from all other tasks. -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_ID associated with a thread + Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. *************** package body System.Task_Primitives.Oper *** 129,143 **** Curpid : pid_t; ! ----------------------- ! -- Local Subprograms -- ! ----------------------- ! ! procedure Abort_Handler (Sig : Signal); ! ! function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID); ! ! function To_Address is new Unchecked_Conversion (Task_ID, System.Address); -------------------- -- Local Packages -- --- 131,138 ---- Curpid : pid_t; ! Foreign_Task_Elaborated : aliased Boolean := True; ! -- Used to identified fake tasks (i.e., non-Ada Threads). -------------------- -- Local Packages -- *************** package body System.Task_Primitives.Oper *** 149,154 **** --- 144,153 ---- pragma Inline (Initialize); -- Initialize various data needed by this package. + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + procedure Set (Self_Id : Task_ID); pragma Inline (Set); -- Set the self id for the current task. *************** package body System.Task_Primitives.Oper *** 162,177 **** --- 161,204 ---- package body Specific is separate; -- The body of this package is target specific. + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; + -- Allocate and Initialize a new ATCB for the current Thread. + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_ID is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Abort_Handler (Sig : Signal); + -- Signal handler used to implement asynchronous abortion. + + function To_Address is new Unchecked_Conversion (Task_ID, System.Address); + ------------------- -- Abort_Handler -- ------------------- procedure Abort_Handler (Sig : Signal) is + pragma Unreferenced (Sig); + T : constant Task_ID := Self; Result : Interfaces.C.int; Old_Set : aliased sigset_t; begin + -- It is not safe to raise an exception when using ZCX and the GCC + -- exception handling mechanism. + + if ZCX_By_Default and then GCC_ZCX_Support then + return; + end if; + if T.Deferral_Level = 0 and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then not T.Aborting *************** package body System.Task_Primitives.Oper *** 196,201 **** --- 223,231 ---- -- bottom of a thread stack, so nothing is needed. procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Unreferenced (T); + pragma Unreferenced (On); + begin null; end Stack_Guard; *************** package body System.Task_Primitives.Oper *** 258,263 **** --- 288,295 ---- end Initialize_Lock; procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Unreferenced (Level); + Attributes : aliased pthread_mutexattr_t; Result : Interfaces.C.int; *************** package body System.Task_Primitives.Oper *** 399,412 **** (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is Result : Interfaces.C.int; begin if Single_Lock then Result := pthread_cond_wait ! (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); else Result := pthread_cond_wait ! (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); end if; -- EINTR is not considered a failure. --- 431,447 ---- (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin if Single_Lock then Result := pthread_cond_wait ! (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); else Result := pthread_cond_wait ! (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); end if; -- EINTR is not considered a failure. *************** package body System.Task_Primitives.Oper *** 430,435 **** --- 465,472 ---- Timedout : out Boolean; Yielded : out Boolean) is + pragma Unreferenced (Reason); + Check_Time : constant Duration := Monotonic_Clock; Abs_Time : Duration; Request : aliased timespec; *************** package body System.Task_Primitives.Oper *** 454,472 **** if Single_Lock then Result := pthread_cond_timedwait ! (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, ! Request'Access); else Result := pthread_cond_timedwait ! (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, ! Request'Access); end if; exit when Abs_Time <= Monotonic_Clock; if Result = 0 or Result = EINTR then ! -- somebody may have called Wakeup for us Timedout := False; exit; end if; --- 491,513 ---- if Single_Lock then Result := pthread_cond_timedwait ! (Self_ID.Common.LL.CV'Access, ! Single_RTS_Lock'Access, ! Request'Access); else Result := pthread_cond_timedwait ! (Self_ID.Common.LL.CV'Access, ! Self_ID.Common.LL.L'Access, ! Request'Access); end if; exit when Abs_Time <= Monotonic_Clock; if Result = 0 or Result = EINTR then ! ! -- Somebody may have called Wakeup for us ! Timedout := False; exit; end if; *************** package body System.Task_Primitives.Oper *** 527,534 **** exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; if Single_Lock then ! Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, ! Single_RTS_Lock'Access, Request'Access); else Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, Request'Access); --- 568,577 ---- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; if Single_Lock then ! Result := pthread_cond_timedwait ! (Self_ID.Common.LL.CV'Access, ! Single_RTS_Lock'Access, ! Request'Access); else Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, Request'Access); *************** package body System.Task_Primitives.Oper *** 582,587 **** --- 625,631 ---- ------------ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); Result : Interfaces.C.int; begin Result := pthread_cond_signal (T.Common.LL.CV'Access); *************** package body System.Task_Primitives.Oper *** 594,599 **** --- 638,644 ---- procedure Yield (Do_Yield : Boolean := True) is Result : Interfaces.C.int; + pragma Unreferenced (Result); begin if Do_Yield then Result := sched_yield; *************** package body System.Task_Primitives.Oper *** 605,614 **** ------------------ procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is Result : Interfaces.C.int; Param : aliased struct_sched_param; --- 650,661 ---- ------------------ procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is + pragma Unreferenced (Loss_Of_Inheritance); + Result : Interfaces.C.int; Param : aliased struct_sched_param; *************** package body System.Task_Primitives.Oper *** 618,632 **** if Time_Slice_Val > 0 then Result := pthread_setschedparam ! (T.Common.LL.Thread, SCHED_RR, Param'Access); elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then Result := pthread_setschedparam ! (T.Common.LL.Thread, SCHED_FIFO, Param'Access); else Result := pthread_setschedparam ! (T.Common.LL.Thread, SCHED_OTHER, Param'Access); end if; pragma Assert (Result = 0); --- 665,679 ---- if Time_Slice_Val > 0 then Result := pthread_setschedparam ! (T.Common.LL.Thread, SCHED_RR, Param'Access); elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then Result := pthread_setschedparam ! (T.Common.LL.Thread, SCHED_FIFO, Param'Access); else Result := pthread_setschedparam ! (T.Common.LL.Thread, SCHED_OTHER, Param'Access); end if; pragma Assert (Result = 0); *************** package body System.Task_Primitives.Oper *** 672,677 **** --- 719,743 ---- return new Ada_Task_Control_Block (Entry_Num); end New_ATCB; + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + -------------------- -- Initialize_TCB -- -------------------- *************** package body System.Task_Primitives.Oper *** 687,694 **** pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then ! Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, ! Mutex_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); end if; --- 753,760 ---- pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then ! Result := pthread_mutex_init ! (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); end if; *************** package body System.Task_Primitives.Oper *** 705,712 **** pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then ! Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, ! Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); end if; --- 771,778 ---- pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then ! Result := pthread_cond_init ! (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); end if; *************** package body System.Task_Primitives.Oper *** 766,817 **** end if; Result := pthread_attr_setdetachstate ! (Attributes'Access, PTHREAD_CREATE_DETACHED); pragma Assert (Result = 0); Result := pthread_attr_setstacksize ! (Attributes'Access, Adjusted_Stack_Size); ! pragma Assert (Result = 0); ! ! -- Set the scheduling parameters explicitly, since this is the only ! -- way to force the OS to take the scope attribute into account ! ! Result := pthread_attr_setinheritsched ! (Attributes'Access, PTHREAD_EXPLICIT_SCHED); pragma Assert (Result = 0); Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Priority)); Result := pthread_attr_setschedparam ! (Attributes'Access, Param'Access); pragma Assert (Result = 0); if Time_Slice_Val > 0 then Result := pthread_attr_setschedpolicy ! (Attributes'Access, System.OS_Interface.SCHED_RR); elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then Result := pthread_attr_setschedpolicy ! (Attributes'Access, System.OS_Interface.SCHED_FIFO); else Result := pthread_attr_setschedpolicy ! (Attributes'Access, System.OS_Interface.SCHED_OTHER); end if; pragma Assert (Result = 0); T.Common.Current_Priority := Priority; if T.Common.Task_Info /= null then case T.Common.Task_Info.Contention_Scope is when System.Task_Info.Process_Scope => Result := pthread_attr_setscope ! (Attributes'Access, PTHREAD_SCOPE_PROCESS); when System.Task_Info.System_Scope => Result := pthread_attr_setscope ! (Attributes'Access, PTHREAD_SCOPE_SYSTEM); when System.Task_Info.Default_Scope => Result := 0; --- 832,884 ---- end if; Result := pthread_attr_setdetachstate ! (Attributes'Access, PTHREAD_CREATE_DETACHED); pragma Assert (Result = 0); Result := pthread_attr_setstacksize ! (Attributes'Access, Adjusted_Stack_Size); pragma Assert (Result = 0); Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Priority)); Result := pthread_attr_setschedparam ! (Attributes'Access, Param'Access); pragma Assert (Result = 0); if Time_Slice_Val > 0 then Result := pthread_attr_setschedpolicy ! (Attributes'Access, System.OS_Interface.SCHED_RR); elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then Result := pthread_attr_setschedpolicy ! (Attributes'Access, System.OS_Interface.SCHED_FIFO); else Result := pthread_attr_setschedpolicy ! (Attributes'Access, System.OS_Interface.SCHED_OTHER); end if; pragma Assert (Result = 0); + -- Set the scheduling parameters explicitly, since this is the + -- only way to force the OS to take e.g. the sched policy and scope + -- attributes into account. + + Result := pthread_attr_setinheritsched + (Attributes'Access, PTHREAD_EXPLICIT_SCHED); + pragma Assert (Result = 0); + T.Common.Current_Priority := Priority; if T.Common.Task_Info /= null then case T.Common.Task_Info.Contention_Scope is when System.Task_Info.Process_Scope => Result := pthread_attr_setscope ! (Attributes'Access, PTHREAD_SCOPE_PROCESS); when System.Task_Info.System_Scope => Result := pthread_attr_setscope ! (Attributes'Access, PTHREAD_SCOPE_SYSTEM); when System.Task_Info.Default_Scope => Result := 0; *************** package body System.Task_Primitives.Oper *** 826,835 **** -- All tasks in RTS will have All_Tasks_Mask initially. Result := pthread_create ! (T.Common.LL.Thread'Access, ! Attributes'Access, ! Thread_Body_Access (Wrapper), ! To_Address (T)); pragma Assert (Result = 0 or else Result = EAGAIN); Succeeded := Result = 0; --- 893,902 ---- -- All tasks in RTS will have All_Tasks_Mask initially. Result := pthread_create ! (T.Common.LL.Thread'Access, ! Attributes'Access, ! Thread_Body_Access (Wrapper), ! To_Address (T)); pragma Assert (Result = 0 or else Result = EAGAIN); Succeeded := Result = 0; *************** package body System.Task_Primitives.Oper *** 838,843 **** --- 905,913 ---- pragma Assert (Result = 0); if T.Common.Task_Info /= null then + -- ??? We're using a process-wide function to implement a task + -- specific characteristic. + if T.Common.Task_Info.Bind_To_Cpu_Number = 0 then Result := bind_to_cpu (Curpid, 0); elsif T.Common.Task_Info.Bind_To_Cpu_Number > 0 then *************** package body System.Task_Primitives.Oper *** 859,864 **** --- 929,935 ---- procedure Finalize_TCB (T : Task_ID) is Result : Interfaces.C.int; Tmp : Task_ID := T; + Is_Self : constant Boolean := T = Self; procedure Free is new Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); *************** package body System.Task_Primitives.Oper *** 877,882 **** --- 948,959 ---- end if; Free (Tmp); + + if Is_Self then + Result := pthread_setspecific (ATCB_Key, System.Null_Address); + pragma Assert (Result = 0); + end if; + end Finalize_TCB; --------------- *************** package body System.Task_Primitives.Oper *** 885,891 **** procedure Exit_Task is begin ! pthread_exit (System.Null_Address); end Exit_Task; ---------------- --- 962,968 ---- procedure Exit_Task is begin ! Specific.Set (null); end Exit_Task; ---------------- *************** package body System.Task_Primitives.Oper *** 894,903 **** procedure Abort_Task (T : Task_ID) is Result : Interfaces.C.int; - begin ! Result := pthread_kill (T.Common.LL.Thread, ! Signal (System.Interrupt_Management.Abort_Task_Interrupt)); pragma Assert (Result = 0); end Abort_Task; --- 971,981 ---- procedure Abort_Task (T : Task_ID) is Result : Interfaces.C.int; begin ! Result := ! pthread_kill ! (T.Common.LL.Thread, ! Signal (System.Interrupt_Management.Abort_Task_Interrupt)); pragma Assert (Result = 0); end Abort_Task; *************** package body System.Task_Primitives.Oper *** 905,914 **** -- Check_Exit -- ---------------- ! -- Dummy versions. The only currently working versions is for solaris ! -- (native). function Check_Exit (Self_ID : ST.Task_ID) return Boolean is begin return True; end Check_Exit; --- 983,993 ---- -- Check_Exit -- ---------------- ! -- Dummy version function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + begin return True; end Check_Exit; *************** package body System.Task_Primitives.Oper *** 918,923 **** --- 997,1004 ---- -------------------- function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + begin return True; end Check_No_Locks; *************** package body System.Task_Primitives.Oper *** 955,961 **** function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin return False; end Suspend_Task; --- 1036,1046 ---- function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean ! is ! pragma Warnings (Off, T); ! pragma Warnings (Off, Thread_Self); ! begin return False; end Suspend_Task; *************** package body System.Task_Primitives.Oper *** 966,972 **** function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin return False; end Resume_Task; --- 1051,1061 ---- function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean ! is ! pragma Warnings (Off, T); ! pragma Warnings (Off, Thread_Self); ! begin return False; end Resume_Task; *************** package body System.Task_Primitives.Oper *** 976,1016 **** ---------------- procedure Initialize (Environment_Task : Task_ID) is ! act : aliased struct_sigaction; ! old_act : aliased struct_sigaction; ! Tmp_Set : aliased sigset_t; ! Result : Interfaces.C.int; begin Environment_Task_ID := Environment_Task; - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); -- Initialize the lock used to synchronize chain of all ATCBs. Specific.Initialize (Environment_Task); Enter_Task (Environment_Task); -- Install the abort-signal handler ! act.sa_flags := 0; ! act.sa_handler := Abort_Handler'Address; ! Result := sigemptyset (Tmp_Set'Access); ! pragma Assert (Result = 0); ! act.sa_mask := Tmp_Set; ! Result := ! sigaction ! (Signal (System.Interrupt_Management.Abort_Task_Interrupt), ! act'Unchecked_Access, ! old_act'Unchecked_Access); ! pragma Assert (Result = 0); end Initialize; begin declare Result : Interfaces.C.int; begin -- Mask Environment task for all signals. The original mask of the -- Environment task will be recovered by Interrupt_Server task --- 1065,1124 ---- ---------------- procedure Initialize (Environment_Task : Task_ID) is ! act : aliased struct_sigaction; ! old_act : aliased struct_sigaction; ! Tmp_Set : aliased sigset_t; ! Result : Interfaces.C.int; ! ! function State ! (Int : System.Interrupt_Management.Interrupt_ID) return Character; ! pragma Import (C, State, "__gnat_get_interrupt_state"); ! -- Get interrupt state. Defined in a-init.c. The input argument is ! -- the interrupt number, and the result is one of the following: ! ! Default : constant Character := 's'; ! -- 'n' this interrupt not set by any Interrupt_State pragma ! -- 'u' Interrupt_State pragma set state to User ! -- 'r' Interrupt_State pragma set state to Runtime ! -- 's' Interrupt_State pragma set state to System (use "default" ! -- system handler) begin Environment_Task_ID := Environment_Task; -- Initialize the lock used to synchronize chain of all ATCBs. + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + Specific.Initialize (Environment_Task); Enter_Task (Environment_Task); -- Install the abort-signal handler ! if State (System.Interrupt_Management.Abort_Task_Interrupt) ! /= Default ! then ! act.sa_flags := 0; ! act.sa_handler := Abort_Handler'Address; ! Result := sigemptyset (Tmp_Set'Access); ! pragma Assert (Result = 0); ! act.sa_mask := Tmp_Set; ! Result := ! sigaction ! (Signal (System.Interrupt_Management.Abort_Task_Interrupt), ! act'Unchecked_Access, ! old_act'Unchecked_Access); ! pragma Assert (Result = 0); ! end if; end Initialize; begin declare Result : Interfaces.C.int; + begin -- Mask Environment task for all signals. The original mask of the -- Environment task will be recovered by Interrupt_Server task diff -Nrc3pad gcc-3.3.3/gcc/ada/5atasinf.ads gcc-3.4.0/gcc/ada/5atasinf.ads *** gcc-3.3.3/gcc/ada/5atasinf.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5atasinf.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 7,14 **** -- S p e c -- -- (Compiler Interface) -- -- -- ! -- -- ! -- Copyright (C) 1998-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- -- --- 7,13 ---- -- S p e c -- -- (Compiler Interface) -- -- -- ! -- Copyright (C) 1998-2003 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- -- *************** *** 33,50 **** -- -- ------------------------------------------------------------------------------ - -- This is a DEC Unix 4.0d version of this package. - -- This package contains the definitions and routines associated with the ! -- implementation of the Task_Info pragma. -- Note: the compiler generates direct calls to this interface, via Rtsfind. -- Any changes to this interface may require corresponding compiler changes. ! with Unchecked_Deallocation; package System.Task_Info is ! pragma Elaborate_Body; ! -- To ensure that a body is allowed ----------------------------------------- -- Implementation of Task_Info Feature -- --- 32,52 ---- -- -- ------------------------------------------------------------------------------ -- This package contains the definitions and routines associated with the ! -- implementation and use of the Task_Info pragma. It is specialized ! -- appropriately for targets that make use of this pragma. -- Note: the compiler generates direct calls to this interface, via Rtsfind. -- Any changes to this interface may require corresponding compiler changes. ! -- This unit may be used directly from an application program by providing ! -- an appropriate WITH, and the interface can be expected to remain stable. ! ! -- This is a DEC Unix 4.0d version of this package. ! package System.Task_Info is ! pragma Elaborate_Body; ! -- To ensure that a body is allowed ----------------------------------------- -- Implementation of Task_Info Feature -- *************** pragma Elaborate_Body; *** 97,109 **** -- implementations, but it must be a type that can be used as a -- discriminant (i.e. a scalar or access type). - type Task_Image_Type is access String; - -- Used to generate a meaningful identifier for tasks that are variables - -- and components of variables. - - procedure Free_Task_Image is new - Unchecked_Deallocation (String, Task_Image_Type); - Unspecified_Thread_Attribute : aliased Thread_Attributes := Thread_Attributes'(-1, Default_Scope); --- 99,104 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5ataspri.ads gcc-3.4.0/gcc/ada/5ataspri.ads *** gcc-3.3.3/gcc/ada/5ataspri.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5ataspri.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1991-2000 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/5atpopsp.adb gcc-3.4.0/gcc/ada/5atpopsp.adb *** gcc-3.3.3/gcc/ada/5atpopsp.adb 2002-10-23 08:27:54.000000000 +0000 --- gcc-3.4.0/gcc/ada/5atpopsp.adb 2004-01-05 15:20:42.000000000 +0000 *************** *** 2,14 **** -- -- -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S . -- ! -- S P E C I F I C -- -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 2,12 ---- -- -- -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2003, 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- -- *************** *** 35,228 **** -- This is a POSIX version of this package where foreign threads are -- recognized. - -- Currently, DEC Unix, SCO UnixWare, Solaris pthread, HPUX pthread, - -- GNU/Linux threads and RTEMS use this version. - - with System.Task_Info; - -- Use for Unspecified_Task_Info ! with System.Soft_Links; ! -- used to initialize TSD for a C thread, in function Self separate (System.Task_Primitives.Operations) package body Specific is - ------------------ - -- Local Data -- - ------------------ - - -- The followings are logically constants, but need to be initialized - -- at run time. - - ATCB_Key : aliased pthread_key_t; - -- Key used to find the Ada Task_ID associated with a thread - - -- The following are used to allow the Self function to - -- automatically generate ATCB's for C threads that happen to call - -- Ada procedure, which in turn happen to call the Ada runtime system. - - type Fake_ATCB; - type Fake_ATCB_Ptr is access Fake_ATCB; - type Fake_ATCB is record - Stack_Base : Interfaces.C.unsigned := 0; - -- A value of zero indicates the node is not in use. - Next : Fake_ATCB_Ptr; - Real_ATCB : aliased Ada_Task_Control_Block (0); - end record; - - Fake_ATCB_List : Fake_ATCB_Ptr; - -- A linear linked list. - -- The list is protected by Single_RTS_Lock; - -- Nodes are added to this list from the front. - -- Once a node is added to this list, it is never removed. - - Fake_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads). - - Next_Fake_ATCB : Fake_ATCB_Ptr; - -- Used to allocate one Fake_ATCB in advance. See comment in New_Fake_ATCB - - ----------------------- - -- Local Subprograms -- - ----------------------- - - --------------------------------- - -- Support for New_Fake_ATCB -- - --------------------------------- - - function New_Fake_ATCB return Task_ID; - -- Allocate and Initialize a new ATCB. This code can safely be called from - -- a foreign thread, as it doesn't access implicitly or explicitly - -- "self" before having initialized the new ATCB. - - ------------------- - -- New_Fake_ATCB -- - ------------------- - - function New_Fake_ATCB return Task_ID is - Self_ID : Task_ID; - P, Q : Fake_ATCB_Ptr; - Succeeded : Boolean; - Result : Interfaces.C.int; - - begin - -- This section is ticklish. - -- We dare not call anything that might require an ATCB, until - -- we have the new ATCB in place. - - Lock_RTS; - Q := null; - P := Fake_ATCB_List; - - while P /= null loop - if P.Stack_Base = 0 then - Q := P; - end if; - - P := P.Next; - end loop; - - if Q = null then - - -- Create a new ATCB with zero entries. - - Self_ID := Next_Fake_ATCB.Real_ATCB'Access; - Next_Fake_ATCB.Stack_Base := 1; - Next_Fake_ATCB.Next := Fake_ATCB_List; - Fake_ATCB_List := Next_Fake_ATCB; - Next_Fake_ATCB := null; - - else - -- Reuse an existing fake ATCB. - - Self_ID := Q.Real_ATCB'Access; - Q.Stack_Base := 1; - end if; - - -- Record this as the Task_ID for the current thread. - - Self_ID.Common.LL.Thread := pthread_self; - Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID)); - pragma Assert (Result = 0); - - -- Do the standard initializations - - System.Tasking.Initialize_ATCB - (Self_ID, null, Null_Address, Null_Task, Fake_Task_Elaborated'Access, - System.Priority'First, Task_Info.Unspecified_Task_Info, 0, Self_ID, - Succeeded); - pragma Assert (Succeeded); - - -- Finally, it is safe to use an allocator in this thread. - - if Next_Fake_ATCB = null then - Next_Fake_ATCB := new Fake_ATCB; - end if; - - Self_ID.Master_of_Task := 0; - Self_ID.Master_Within := Self_ID.Master_of_Task + 1; - - for L in Self_ID.Entry_Calls'Range loop - Self_ID.Entry_Calls (L).Self := Self_ID; - Self_ID.Entry_Calls (L).Level := L; - end loop; - - Self_ID.Common.State := Runnable; - Self_ID.Awake_Count := 1; - - -- Since this is not an ordinary Ada task, we will start out undeferred - - Self_ID.Deferral_Level := 0; - - System.Soft_Links.Create_TSD (Self_ID.Common.Compiler_Data); - - -- ???? - -- The following call is commented out to avoid dependence on - -- the System.Tasking.Initialization package. - -- It seems that if we want Ada.Task_Attributes to work correctly - -- for C threads we will need to raise the visibility of this soft - -- link to System.Soft_Links. - -- We are putting that off until this new functionality is otherwise - -- stable. - -- System.Tasking.Initialization.Initialize_Attributes_Link.all (T); - - for J in Known_Tasks'Range loop - if Known_Tasks (J) = null then - Known_Tasks (J) := Self_ID; - Self_ID.Known_Tasks_Index := J; - exit; - end if; - end loop; - - -- Must not unlock until Next_ATCB is again allocated. - - Unlock_RTS; - return Self_ID; - end New_Fake_ATCB; - ---------------- -- Initialize -- ---------------- procedure Initialize (Environment_Task : Task_ID) is Result : Interfaces.C.int; begin Result := pthread_key_create (ATCB_Key'Access, null); pragma Assert (Result = 0); ! Result := pthread_setspecific (ATCB_Key, To_Address (Environment_Task)); ! pragma Assert (Result = 0); ! -- Create a free ATCB for use on the Fake_ATCB_List. ! Next_Fake_ATCB := new Fake_ATCB; ! end Initialize; --------- -- Set -- --------- procedure Set (Self_Id : Task_ID) is ! Result : Interfaces.C.int; begin Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id)); pragma Assert (Result = 0); --- 33,73 ---- -- This is a POSIX version of this package where foreign threads are -- recognized. ! -- Currently, DEC Unix, SCO UnixWare, Solaris pthread, HPUX pthread, ! -- GNU/Linux threads, and RTEMS use this version. separate (System.Task_Primitives.Operations) package body Specific is ---------------- -- Initialize -- ---------------- procedure Initialize (Environment_Task : Task_ID) is + pragma Warnings (Off, Environment_Task); Result : Interfaces.C.int; + begin Result := pthread_key_create (ATCB_Key'Access, null); pragma Assert (Result = 0); ! end Initialize; ! ------------------- ! -- Is_Valid_Task -- ! ------------------- ! function Is_Valid_Task return Boolean is ! begin ! return pthread_getspecific (ATCB_Key) /= System.Null_Address; ! end Is_Valid_Task; --------- -- Set -- --------- procedure Set (Self_Id : Task_ID) is ! Result : Interfaces.C.int; begin Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id)); pragma Assert (Result = 0); *************** package body Specific is *** 247,262 **** function Self return Task_ID is Result : System.Address; begin Result := pthread_getspecific (ATCB_Key); -- If the key value is Null, then it is a non-Ada task. ! if Result = System.Null_Address then ! return New_Fake_ATCB; end if; - - return To_Task_ID (Result); end Self; end Specific; --- 92,108 ---- function Self return Task_ID is Result : System.Address; + begin Result := pthread_getspecific (ATCB_Key); -- If the key value is Null, then it is a non-Ada task. ! if Result /= System.Null_Address then ! return To_Task_Id (Result); ! else ! return Register_Foreign_Thread; end if; end Self; end Specific; diff -Nrc3pad gcc-3.3.3/gcc/ada/5avxwork.ads gcc-3.4.0/gcc/ada/5avxwork.ads *** gcc-3.3.3/gcc/ada/5avxwork.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5avxwork.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/5bml-tgt.adb gcc-3.4.0/gcc/ada/5bml-tgt.adb *** gcc-3.3.3/gcc/ada/5bml-tgt.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5bml-tgt.adb 2003-11-20 09:53:57.000000000 +0000 *************** *** 0 **** --- 1,400 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T -- + -- (AIX Version) -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2003, 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. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package provides a set of target dependent routines to build + -- static, dynamic or relocatable libraries. + + -- This is the AIX version of the body. + + with Ada.Strings.Fixed; use Ada.Strings.Fixed; + with Ada.Text_IO; use Ada.Text_IO; + with MLib.Fil; + with MLib.Utl; + with Namet; use Namet; + with Osint; use Osint; + with Opt; + with Output; use Output; + with Prj.Com; + + package body MLib.Tgt is + + No_Arguments : aliased Argument_List := (1 .. 0 => null); + Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; + + Wl_Initfini_String : constant String := "-Wl,-binitfini:"; + + Init_Fini_List : constant Argument_List_Access := + new Argument_List'(1 => null); + -- Used to put switch for automatic elaboration/finalization + + Bexpall : aliased String := "-Wl,-bexpall"; + Bexpall_Option : constant String_Access := Bexpall'Access; + -- The switch to export all symbols + + Lpthreads : aliased String := "-lpthreads"; + Native_Thread_Options : aliased Argument_List := (1 => Lpthreads'Access); + -- The switch to use when linking a library against libgnarl when using + -- Native threads. + + Lgthreads : aliased String := "-lgthreads"; + Lmalloc : aliased String := "-lmalloc"; + FSU_Thread_Options : aliased Argument_List := + (1 => Lgthreads'Access, 2 => Lmalloc'Access); + -- The switches to use when linking a library against libgnarl when using + -- FSU threads. + + Thread_Options : Argument_List_Access := null; + -- Designate the thread switches to used when linking a library against + -- libgnarl. Depends on the thread library (Native or FSU). Resolved for + -- the first library linked against libgnarl. + + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return "ar"; + end Archive_Builder; + + ----------------------------- + -- Archive_Builder_Options -- + ----------------------------- + + function Archive_Builder_Options return String_List_Access is + begin + return new String_List'(1 => new String'("cr")); + end Archive_Builder_Options; + + ----------------- + -- Archive_Ext -- + ----------------- + + function Archive_Ext return String is + begin + return "a"; + end Archive_Ext; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return "ranlib"; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Foreign : Argument_List; + Afiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Address : String := ""; + Lib_Version : String := ""; + Relocatable : Boolean := False; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Foreign); + pragma Unreferenced (Afiles); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Lib_Address); + pragma Unreferenced (Lib_Version); + pragma Unreferenced (Relocatable); + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + MLib.Fil.Ext_To (Lib_Filename, DLL_Ext); + -- The file name of the library + + Init_Fini : Argument_List_Access := Empty_Argument_List; + -- The switch for automatic initialization of Stand-Alone Libraries. + -- Changed to a real switch when Auto_Init is True. + + Options_2 : Argument_List_Access := Empty_Argument_List; + -- Changed to the thread options, if -lgnarl is specified + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_File); + end if; + + -- If specified, add automatic elaboration/finalization + + if Auto_Init then + Init_Fini := Init_Fini_List; + Init_Fini (1) := + new String'(Wl_Initfini_String & Lib_Filename & "init:" & + Lib_Filename & "final"); + end if; + + -- Look for -lgnarl in Options. If found, set the thread options. + + for J in Options'Range loop + if Options (J).all = "-lgnarl" then + + -- If Thread_Options is null, read s-osinte.ads to discover the + -- thread library and set Thread_Options accordingly. + + if Thread_Options = null then + declare + File : Ada.Text_IO.File_Type; + Line : String (1 .. 100); + Last : Natural; + + begin + Open + (File, In_File, + Include_Dir_Default_Prefix & "/s-osinte.ads"); + + while not End_Of_File (File) loop + Get_Line (File, Line, Last); + + if Index (Line (1 .. Last), "-lpthreads") /= 0 then + Thread_Options := Native_Thread_Options'Access; + exit; + + elsif Index (Line (1 .. Last), "-lgthreads") /= 0 then + Thread_Options := FSU_Thread_Options'Access; + exit; + end if; + end loop; + + Close (File); + + if Thread_Options = null then + Prj.Com.Fail ("cannot find the thread library in use"); + end if; + + exception + when others => + Prj.Com.Fail ("cannot open s-osinte.ads"); + end; + end if; + + Options_2 := Thread_Options; + exit; + end if; + end loop; + + -- Finally, call GCC (or the driver specified) to build the library + + MLib.Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles, + Options => Options & Bexpall_Option & Init_Fini.all, + Driver_Name => Driver_Name, + Options_2 => Options_2.all); + end Build_Dynamic_Library; + + ------------------------- + -- Default_DLL_Address -- + ------------------------- + + function Default_DLL_Address return String is + begin + return ""; + end Default_DLL_Address; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "a"; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return "-shared"; + end Dynamic_Option; + + ------------------- + -- Is_Object_Ext -- + ------------------- + + function Is_Object_Ext (Ext : String) return Boolean is + begin + return Ext = ".o"; + end Is_Object_Ext; + + -------------- + -- Is_C_Ext -- + -------------- + + function Is_C_Ext (Ext : String) return Boolean is + begin + return Ext = ".c"; + end Is_C_Ext; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a"; + end Is_Archive_Ext; + + ------------- + -- Libgnat -- + ------------- + + function Libgnat return String is + begin + return "libgnat.a"; + end Libgnat; + + ------------------------ + -- Library_Exists_For -- + ------------------------ + + function Library_Exists_For (Project : Project_Id) return Boolean is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & + "for non library project"); + return False; + + else + declare + Lib_Dir : constant String := + Get_Name_String (Projects.Table (Project).Library_Dir); + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + if Projects.Table (Project).Library_Kind = Static then + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + end; + end if; + end Library_Exists_For; + + --------------------------- + -- Library_File_Name_For -- + --------------------------- + + function Library_File_Name_For (Project : Project_Id) return Name_Id is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & + "for non library project"); + return No_Name; + + else + declare + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + Name_Len := 3; + Name_Buffer (1 .. Name_Len) := "lib"; + + if Projects.Table (Project).Library_Kind = Static then + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + + return Name_Find; + end; + end if; + end Library_File_Name_For; + + -------------------------------- + -- Linker_Library_Path_Option -- + -------------------------------- + + function Linker_Library_Path_Option return String_Access is + begin + -- On AIX, any path specify with an -L switch is automatically added + -- to the library path. So, nothing is needed here. + + return null; + end Linker_Library_Path_Option; + + ---------------- + -- Object_Ext -- + ---------------- + + function Object_Ext return String is + begin + return "o"; + end Object_Ext; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return "-fPIC"; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return True; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Full; + end Support_For_Libraries; + + end MLib.Tgt; diff -Nrc3pad gcc-3.3.3/gcc/ada/5bosinte.adb gcc-3.4.0/gcc/ada/5bosinte.adb *** gcc-3.3.3/gcc/ada/5bosinte.adb 2002-10-23 08:27:54.000000000 +0000 --- gcc-3.4.0/gcc/ada/5bosinte.adb 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1997-2001, Free Software Fundation, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2002, Free Software Fundation, 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- -- *************** package body System.OS_Interface is *** 78,85 **** F := F + 1.0; end if; ! return timespec' (tv_sec => S, ! tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; ---------------- --- 77,84 ---- F := F + 1.0; end if; ! return timespec'(tv_sec => S, ! tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; ---------------- *************** package body System.OS_Interface is *** 102,109 **** F := F + 1.0; end if; ! return struct_timeval' (tv_sec => S, ! tv_usec => long (Long_Long_Integer (F * 10#1#E6))); end To_Timeval; ------------------- --- 101,110 ---- F := F + 1.0; end if; ! return ! struct_timeval' ! (tv_sec => S, ! tv_usec => long (Long_Long_Integer (F * 10#1#E6))); end To_Timeval; ------------------- *************** package body System.OS_Interface is *** 113,126 **** function clock_gettime (clock_id : clockid_t; tp : access timespec) ! return int is Result : int; tv : aliased struct_timeval; function gettimeofday ! (tv : access struct_timeval; ! tz : System.Address := System.Null_Address) return int; pragma Import (C, gettimeofday, "gettimeofday"); begin --- 114,130 ---- function clock_gettime (clock_id : clockid_t; tp : access timespec) ! return int is + pragma Warnings (Off, clock_id); + Result : int; tv : aliased struct_timeval; function gettimeofday ! (tv : access struct_timeval; ! tz : System.Address := System.Null_Address) ! return int; pragma Import (C, gettimeofday, "gettimeofday"); begin *************** package body System.OS_Interface is *** 146,151 **** --- 150,157 ---- end sched_yield; function Get_Stack_Base (thread : pthread_t) return Address is + pragma Warnings (Off, thread); + begin return Null_Address; end Get_Stack_Base; diff -Nrc3pad gcc-3.3.3/gcc/ada/5bosinte.ads gcc-3.4.0/gcc/ada/5bosinte.ads *** gcc-3.3.3/gcc/ada/5bosinte.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5bosinte.ads 2003-12-05 10:24:04.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1997-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2003 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- -- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ *************** package System.OS_Interface is *** 163,168 **** --- 162,168 ---- pragma Convention (C, struct_sigaction); type struct_sigaction_ptr is access all struct_sigaction; + SA_SIGINFO : constant := 16#0100#; SIG_BLOCK : constant := 0; SIG_UNBLOCK : constant := 1; diff -Nrc3pad gcc-3.3.3/gcc/ada/5bsystem.ads gcc-3.4.0/gcc/ada/5bsystem.ads *** gcc-3.3.3/gcc/ada/5bsystem.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5bsystem.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 7,14 **** -- S p e c -- -- (AIX/PPC Version) -- -- -- ! -- -- ! -- Copyright (C) 1992-2002 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 -- --- 7,13 ---- -- S p e c -- -- (AIX/PPC Version) -- -- -- ! -- Copyright (C) 1992-2003 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 -- *************** pragma Pure (System); *** 59,65 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := 1.0; -- Storage-related Declarations --- 58,64 ---- Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := 0.01; -- Storage-related Declarations *************** private *** 119,139 **** Backend_Divide_Checks : constant Boolean := False; Backend_Overflow_Checks : constant Boolean := False; Command_Line_Args : constant Boolean := True; Denorm : constant Boolean := True; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; Functions_Return_By_DSP : constant Boolean := False; - Long_Shifts_Inlined : constant Boolean := True; - High_Integrity_Mode : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; Stack_Check_Probes : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; GCC_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := False; end System; --- 118,150 ---- Backend_Divide_Checks : constant Boolean := False; Backend_Overflow_Checks : constant Boolean := False; Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; Functions_Return_By_DSP : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; GCC_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := False; + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/5cosinte.ads gcc-3.4.0/gcc/ada/5cosinte.ads *** gcc-3.3.3/gcc/ada/5cosinte.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5cosinte.ads 2003-12-05 10:24:04.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ *************** package System.OS_Interface is *** 163,168 **** --- 162,169 ---- pragma Convention (C, struct_sigaction); type struct_sigaction_ptr is access all struct_sigaction; + SA_SIGINFO : constant := 16#0100#; + SIG_BLOCK : constant := 0; SIG_UNBLOCK : constant := 1; SIG_SETMASK : constant := 2; diff -Nrc3pad gcc-3.3.3/gcc/ada/5csystem.ads gcc-3.4.0/gcc/ada/5csystem.ads *** gcc-3.3.3/gcc/ada/5csystem.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5csystem.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 0 **** --- 1,160 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (VxWorks Version Sparc/64) -- + -- -- + -- Copyright (C) 1992-2003 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. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package System is + pragma Pure (System); + -- Note that we take advantage of the implementation permission to + -- make this unit Pure instead of Preelaborable, see RM 13.7(36) + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 1.0 / 60.0; + + -- Storage-related Declarations + + -- VxWorks for UltraSparc uses 64bit words but 32bit pointers + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + + -- Priority-related Declarations (RM D.1) + + -- 256 is reserved for the VxWorks kernel + -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 + -- 247 is a catchall default "interrupt" priority for signals, + -- allowing higher priority than normal tasks, but lower than + -- hardware priority levels. Protected Object ceilings can + -- override these values. + -- 246 is used by the Interrupt_Manager task + + Max_Priority : constant Positive := 245; + Max_Interrupt_Priority : constant Positive := 255; + + subtype Any_Priority is Integer range 0 .. 255; + subtype Priority is Any_Priority range 0 .. 245; + subtype Interrupt_Priority is Any_Priority range 246 .. 255; + + Default_Priority : constant Priority := 122; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + AAMP : constant Boolean := False; + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := False; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Functions_Return_By_DSP : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + OpenVMS : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + Front_End_ZCX_Support : constant Boolean := False; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := False; + + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/5dosinte.ads gcc-3.4.0/gcc/ada/5dosinte.ads *** gcc-3.3.3/gcc/ada/5dosinte.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5dosinte.ads 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,537 **** - ------------------------------------------------------------------------------ - -- -- - -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- - -- -- - -- S Y S T E M . O S _ I N T E R F A C E -- - -- -- - -- S p e c -- - -- -- - -- -- - -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- - -- -- - -- GNARL is free software; you can redistribute it and/or modify it under -- - -- terms of the GNU General Public License as published by the Free Soft- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNARL; see file COPYING. If not, write -- - -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- - -- MA 02111-1307, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNARL was developed by the GNARL team at Florida State University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is a DOS/DJGPPv2 (FSU THREAD) version of this package. - - -- This package encapsulates all direct interfaces to OS services - -- that are needed by children of System. - - -- PLEASE DO NOT add any with-clauses to this package - -- or remove the pragma Elaborate_Body. - -- It is designed to be a bottom-level (leaf) package. - - with Interfaces.C; - package System.OS_Interface is - pragma Preelaborate; - - -- - -- A short name for libgthreads.a to keep Mike Feldman happy. - -- - pragma Linker_Options ("-lgthre"); - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 5; - EINTR : constant := 13; - EINVAL : constant := 14; - ENOMEM : constant := 25; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 319; - type Signal is new int range 0 .. Max_Interrupt; - - SIGHUP : constant := 294; -- hangup - SIGINT : constant := 295; -- interrupt (rubout) - SIGQUIT : constant := 298; -- quit (ASCD FS) - SIGILL : constant := 290; -- illegal instruction (not reset) - SIGABRT : constant := 288; -- used by abort - SIGFPE : constant := 289; -- floating point exception - SIGKILL : constant := 296; -- kill (cannot be caught or ignored) - SIGSEGV : constant := 291; -- segmentation violation - SIGPIPE : constant := 297; -- write on a pipe with no one to read it - SIGALRM : constant := 293; -- alarm clock - SIGTERM : constant := 292; -- software termination signal from kill - SIGUSR1 : constant := 299; -- user defined signal 1 - SIGUSR2 : constant := 300; -- user defined signal 2 - SIGBUS : constant := 0; - - SIGADAABORT : constant := SIGABRT; - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := (SIGTRAP, SIGALRM); - Reserved : constant Signal_Set := (0 .. 0 => SIGSTOP); - - type sigset_t is private; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type struct_sigaction is record - sa_flags : int; - sa_handler : System.Address; - sa_mask : sigset_t; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - SIG_BLOCK : constant := 1; - SIG_UNBLOCK : constant := 3; - SIG_SETMASK : constant := 2; - - SIG_DFL : constant := 0; - SIG_IGN : constant := -1; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - Time_Slice_Supported : constant Boolean := False; - -- Indicates wether time slicing is supported (i.e FSU threads have been - -- compiled with DEF_RR) - - type timespec is private; - - function nanosleep (rqtp, rmtp : access timespec) return int; - -- FSU_THREADS has nonstandard nanosleep - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int; - pragma Import (C, clock_gettime, "clock_gettime"); - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timeval is private; - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 0; - SCHED_RR : constant := 1; - SCHED_OTHER : constant := 2; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - --------- - -- LWP -- - --------- - - function lwp_self return System.Address; - -- lwp_self does not exist on this thread library, revert to pthread_self - -- which is the closest approximation (with getpid). This function is - -- needed to share 7staprop.adb across POSIX-like targets. - pragma Import (C, lwp_self, "pthread_self"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 1; - - ----------- - -- Stack -- - ----------- - - Stack_Base_Available : constant Boolean := False; - -- Indicates wether the stack base is available on this target. - -- This allows us to share s-osinte.adb between all the FSU run time. - -- Note that this value can only be true if pthread_t has a complete - -- definition that corresponds exactly to the C header files. - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- returns the stack base of the specified thread. - -- Only call this function when Stack_Base_Available is True. - - function Get_Page_Size return size_t; - function Get_Page_Size return Address; - pragma Import (C, Get_Page_Size, "getpagesize"); - -- returns the size of a page, or 0 if this is not relevant on this - -- target - - PROT_NONE : constant := 0; - PROT_READ : constant := 1; - PROT_WRITE : constant := 2; - PROT_EXEC : constant := 4; - PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; - - PROT_ON : constant := PROT_NONE; - PROT_OFF : constant := PROT_ALL; - - function mprotect - (addr : Address; len : size_t; prot : int) return int; - pragma Import (C, mprotect); - - --------------------------------------- - -- Nonstandard Thread Initialization -- - --------------------------------------- - - procedure pthread_init; - -- FSU_THREADS requires pthread_init, which is nonstandard - -- and this should be invoked during the elaboration of s-taprop.adb - pragma Import (C, pthread_init, "pthread_init"); - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait (set : access sigset_t; sig : access Signal) return int; - -- FSU_THREADS has a nonstandard sigwait - - function pthread_kill (thread : pthread_t; sig : Signal) return int; - pragma Import (C, pthread_kill, "pthread_kill"); - - type sigset_t_ptr is access all sigset_t; - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, pthread_sigmask, "sigprocmask"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - -- FSU_THREADS has nonstandard pthread_mutex_lock - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - -- FSU_THREADS has nonstandard pthread_mutex_lock - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "pthread_cond_init"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - -- FSU_THREADS has a nonstandard pthread_cond_wait - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - -- FSU_THREADS has a nonstandard pthread_cond_timedwait - - Relative_Timed_Wait : constant Boolean := False; - -- pthread_cond_timedwait requires an absolute delay time - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - PTHREAD_PRIO_NONE : constant := 0; - PTHREAD_PRIO_PROTECT : constant := 2; - PTHREAD_PRIO_INHERIT : constant := 1; - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) return int; - pragma Import (C, pthread_mutexattr_setprotocol); - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int; - pragma Import (C, pthread_mutexattr_setprioceiling); - - type struct_sched_param is record - sched_priority : int; -- scheduling priority - end record; - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - -- FSU_THREADS does not have pthread_setschedparam - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; - inheritsched : int) return int; - pragma Import (C, pthread_attr_setinheritsched); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; - policy : int) return int; - pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched"); - - function sched_yield return int; - -- FSU_THREADS does not have sched_yield; - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - -- FSU_THREADS has a nonstandard pthread_attr_setdetachstate - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "pthread_setspecific"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - -- FSU_THREADS has a nonstandard pthread_getspecific - - type destructor_pointer is access procedure (arg : System.Address); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "pthread_key_create"); - - private - - type bits_arr_t is array (Integer range 1 .. 10) of long; - type sigset_t is record - bits : bits_arr_t; - end record; - - type pid_t is new int; - - type time_t is new long; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 0; - - type struct_timeval is record - tv_sec : long; - tv_usec : long; - end record; - pragma Convention (C, struct_timeval); - - type pthread_attr_t is record - flags : int; - stacksize : int; - contentionscope : int; - inheritsched : int; - detachstate : int; - sched : int; - prio : int; - starttime : timespec; - deadline : timespec; - period : timespec; - end record; - pragma Convention (C, pthread_attr_t); - - type pthread_condattr_t is record - flags : int; - end record; - pragma Convention (C, pthread_condattr_t); - - type pthread_mutexattr_t is record - flags : int; - prio_ceiling : int; - protocol : int; - end record; - pragma Convention (C, pthread_mutexattr_t); - - type sigjmp_buf is array (Integer range 0 .. 43) of int; - - type pthread_t_struct is record - context : sigjmp_buf; - pbody : sigjmp_buf; - errno : int; - ret : int; - stack_base : System.Address; - end record; - pragma Convention (C, pthread_t_struct); - - type pthread_t is access all pthread_t_struct; - - type queue_t is record - head : System.Address; - tail : System.Address; - end record; - pragma Convention (C, queue_t); - - type pthread_mutex_t is record - queue : queue_t; - lock : plain_char; - owner : System.Address; - flags : int; - prio_ceiling : int; - protocol : int; - prev_max_ceiling_prio : int; - end record; - pragma Convention (C, pthread_mutex_t); - - type pthread_cond_t is record - queue : queue_t; - flags : int; - waiters : int; - mutex : System.Address; - end record; - pragma Convention (C, pthread_cond_t); - - type pthread_key_t is new int; - - end System.OS_Interface; --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5dsystem.ads gcc-3.4.0/gcc/ada/5dsystem.ads *** gcc-3.3.3/gcc/ada/5dsystem.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5dsystem.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (VxWorks Version Xscale) -- + -- -- + -- Copyright (C) 1992-2003 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. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package System is + pragma Pure (System); + -- Note that we take advantage of the implementation permission to + -- make this unit Pure instead of Preelaborable, see RM 13.7(36) + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 1.0 / 60.0; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + + -- Priority-related Declarations (RM D.1) + + -- 256 is reserved for the VxWorks kernel + -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 + -- 247 is a catchall default "interrupt" priority for signals, + -- allowing higher priority than normal tasks, but lower than + -- hardware priority levels. Protected Object ceilings can + -- override these values. + -- 246 is used by the Interrupt_Manager task + + Max_Priority : constant Positive := 245; + Max_Interrupt_Priority : constant Positive := 255; + + subtype Any_Priority is Integer range 0 .. 255; + subtype Priority is Any_Priority range 0 .. 245; + subtype Interrupt_Priority is Any_Priority range 246 .. 255; + + Default_Priority : constant Priority := 122; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + AAMP : constant Boolean := False; + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := False; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Functions_Return_By_DSP : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + OpenVMS : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + Front_End_ZCX_Support : constant Boolean := False; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := False; + + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/5esystem.ads gcc-3.4.0/gcc/ada/5esystem.ads *** gcc-3.3.3/gcc/ada/5esystem.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5esystem.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 5,14 **** -- S Y S T E M -- -- -- -- S p e c -- ! -- (X86 Solaris Version) -- ! -- -- -- -- ! -- Copyright (C) 1992-2002 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 -- --- 5,13 ---- -- S Y S T E M -- -- -- -- S p e c -- ! -- (x86 Solaris Version) -- -- -- ! -- Copyright (C) 1992-2003 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 -- *************** pragma Pure (System); *** 59,65 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := 1.0; -- Storage-related Declarations --- 58,64 ---- Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := 0.01; -- Storage-related Declarations *************** private *** 119,139 **** Backend_Divide_Checks : constant Boolean := False; Backend_Overflow_Checks : constant Boolean := False; Command_Line_Args : constant Boolean := True; Denorm : constant Boolean := True; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; Functions_Return_By_DSP : constant Boolean := False; - Long_Shifts_Inlined : constant Boolean := True; - High_Integrity_Mode : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; Stack_Check_Probes : constant Boolean := True; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; GCC_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := True; end System; --- 118,150 ---- Backend_Divide_Checks : constant Boolean := False; Backend_Overflow_Checks : constant Boolean := False; Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; Functions_Return_By_DSP : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; Stack_Check_Probes : constant Boolean := True; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; GCC_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := True; + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/5etpopse.adb gcc-3.4.0/gcc/ada/5etpopse.adb *** gcc-3.3.3/gcc/ada/5etpopse.adb 2002-03-14 10:58:29.000000000 +0000 --- gcc-3.4.0/gcc/ada/5etpopse.adb 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,52 **** - ------------------------------------------------------------------------------ - -- -- - -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- - -- -- - -- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SELF -- - -- -- - -- B o d y -- - -- -- - -- -- - -- Copyright (C) 1991-1998, Florida State University -- - -- -- - -- GNARL is free software; you can redistribute it and/or modify it under -- - -- terms of the GNU General Public License as published by the Free Soft- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNARL; see file COPYING. If not, write -- - -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- - -- MA 02111-1307, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNARL was developed by the GNARL team at Florida State University. It is -- - -- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- - -- State University (http://www.gnat.com). -- - -- -- - ------------------------------------------------------------------------------ - - -- This is a Solaris/X86 (native) version of this package. - - separate (System.Task_Primitives.Operations) - - ---------- - -- Self -- - ---------- - - function Self return Task_ID is - Temp : aliased System.Address; - Result : Interfaces.C.int; - - begin - Result := thr_getspecific (ATCB_Key, Temp'Unchecked_Access); - pragma Assert (Result = 0); - return To_Task_ID (Temp); - end Self; --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5fintman.adb gcc-3.4.0/gcc/ada/5fintman.adb *** gcc-3.3.3/gcc/ada/5fintman.adb 2002-03-14 10:58:29.000000000 +0000 --- gcc-3.4.0/gcc/ada/5fintman.adb 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1991-2001, Florida State University -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,13 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2003, Ada Core Technologies -- -- -- -- 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- -- *************** *** 27,35 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 27,34 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ *************** package body System.Interrupt_Management *** 64,70 **** -- Initialize_Interrupts -- --------------------------- ! -- Nothing needs to be done on this platform. procedure Initialize_Interrupts is begin --- 63,69 ---- -- Initialize_Interrupts -- --------------------------- ! -- Nothing needs to be done on this platform procedure Initialize_Interrupts is begin *************** package body System.Interrupt_Management *** 78,103 **** use type Interfaces.C.int; begin ! Abort_Task_Interrupt := SIGABRT; ! -- Change this if you want to use another signal for task abort. ! -- SIGTERM might be a good one. ! for I in Exception_Interrupts'Range loop ! Keep_Unmasked (Exception_Interrupts (I)) := True; ! end loop; ! -- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but in the ! -- same time, disable the ability of handling this signal via ! -- Ada.Interrupts. ! -- The pragma Unreserve_All_Interrupts let the user the ability to ! -- change this behavior. ! if Unreserve_All_Interrupts = 0 then ! Keep_Unmasked (SIGINT) := True; ! end if; ! Keep_Unmasked (Abort_Task_Interrupt) := True; ! Reserve := Keep_Unmasked or Keep_Masked; ! Reserve (0) := True; end System.Interrupt_Management; --- 77,152 ---- use type Interfaces.C.int; begin ! declare ! function State (Int : Interrupt_ID) return Character; ! pragma Import (C, State, "__gnat_get_interrupt_state"); ! -- Get interrupt state. Defined in a-init.c ! -- The input argument is the interrupt number, ! -- and the result is one of the following: ! User : constant Character := 'u'; ! Runtime : constant Character := 'r'; ! Default : constant Character := 's'; ! -- 'n' this interrupt not set by any Interrupt_State pragma ! -- 'u' Interrupt_State pragma set state to User ! -- 'r' Interrupt_State pragma set state to Runtime ! -- 's' Interrupt_State pragma set state to System (use "default" ! -- system handler) ! begin ! Abort_Task_Interrupt := SIGABRT; ! -- Change this if you want to use another signal for task abort. ! -- SIGTERM might be a good one. ! pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False)); ! pragma Assert (Reserve = (Interrupt_ID'Range => False)); ! ! -- Process state of exception signals ! ! for J in Exception_Interrupts'Range loop ! if State (Exception_Interrupts (J)) /= User then ! Keep_Unmasked (Exception_Interrupts (J)) := True; ! Reserve (Exception_Interrupts (J)) := True; ! end if; ! end loop; ! ! if State (Abort_Task_Interrupt) /= User then ! Keep_Unmasked (Abort_Task_Interrupt) := True; ! Reserve (Abort_Task_Interrupt) := True; ! end if; ! ! -- Set SIGINT to unmasked state as long as it's ! -- not in "User" state. Check for Unreserve_All_Interrupts last ! ! if State (SIGINT) /= User then ! Keep_Unmasked (SIGINT) := True; ! end if; ! ! -- Check all signals for state that requires keeping them ! -- unmasked and reserved ! ! for J in Interrupt_ID'Range loop ! if State (J) = Default or else State (J) = Runtime then ! Keep_Unmasked (J) := True; ! Reserve (J) := True; ! end if; ! end loop; ! ! -- Process pragma Unreserve_All_Interrupts. This overrides any ! -- settings due to pragma Interrupt_State: ! ! if Unreserve_All_Interrupts /= 0 then ! Keep_Unmasked (SIGINT) := False; ! Reserve (SIGINT) := False; ! end if; ! ! -- We do not have Signal 0 in reality. We just use this value ! -- to identify not existing signals (see s-intnam.ads). Therefore, ! -- Signal 0 should not be used in all signal related operations hence ! -- mark it as reserved. ! ! Reserve (0) := True; ! end; end System.Interrupt_Management; diff -Nrc3pad gcc-3.3.3/gcc/ada/5fosinte.adb gcc-3.4.0/gcc/ada/5fosinte.adb *** gcc-3.3.3/gcc/ada/5fosinte.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5fosinte.adb 2003-10-21 13:41:51.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . O S _ I N T E R F A C E -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 1992-2002, Free Software Foundation, Inc. -- + -- -- + -- GNARL is free software; you can redistribute it and/or modify it under -- + -- terms of the GNU General Public License as published by the Free Soft- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNARL; see file COPYING. If not, write -- + -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- + -- MA 02111-1307, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNARL was developed by the GNARL team at Florida State University. -- + -- Extensive contributions were provided by Ada Core Technologies, Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the IRIX version of this package. + + -- This package encapsulates all direct interfaces to OS services + -- that are needed by children of System. + + pragma Polling (Off); + -- Turn off polling, we do not want ATC polling to take place during + -- tasking operations. It causes infinite loops and other problems. + + with Interfaces.C; use Interfaces.C; + + package body System.OS_Interface is + + ------------------ + -- pthread_init -- + ------------------ + + procedure pthread_init is + begin + null; + end pthread_init; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; + end To_Duration; + + function To_Duration (TV : struct_timeval) return Duration is + begin + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end To_Duration; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ---------------- + -- To_Timeval -- + ---------------- + + function To_Timeval (D : Duration) return struct_timeval is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return + struct_timeval' + (tv_sec => S, + tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); + end To_Timeval; + + end System.OS_Interface; diff -Nrc3pad gcc-3.3.3/gcc/ada/5fosinte.ads gcc-3.4.0/gcc/ada/5fosinte.ads *** gcc-3.3.3/gcc/ada/5fosinte.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5fosinte.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1998-2001, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/5fsystem.ads gcc-3.4.0/gcc/ada/5fsystem.ads *** gcc-3.3.3/gcc/ada/5fsystem.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5fsystem.ads 2004-01-26 21:57:33.000000000 +0000 *************** *** 7,14 **** -- S p e c -- -- (SGI Irix, o32 ABI) -- -- -- ! -- -- ! -- Copyright (C) 1992-2002 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 -- --- 7,13 ---- -- S p e c -- -- (SGI Irix, o32 ABI) -- -- -- ! -- Copyright (C) 1992-2004 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 -- *************** pragma Pure (System); *** 59,65 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := 1.0; -- Storage-related Declarations --- 58,64 ---- Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := 0.01; -- Storage-related Declarations *************** private *** 119,140 **** Backend_Divide_Checks : constant Boolean := False; Backend_Overflow_Checks : constant Boolean := False; Command_Line_Args : constant Boolean := True; Denorm : constant Boolean := False; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; ! Functions_Return_By_DSP : constant Boolean := True; ! Long_Shifts_Inlined : constant Boolean := True; ! High_Integrity_Mode : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; Stack_Check_Probes : constant Boolean := True; Use_Ada_Main_Program_Name : constant Boolean := False; ! ZCX_By_Default : constant Boolean := True; GCC_ZCX_Support : constant Boolean := False; ! Front_End_ZCX_Support : constant Boolean := True; -- Note: Denorm is False because denormals are not supported on the -- R10000, and we want the code to be valid for this processor. --- 118,151 ---- Backend_Divide_Checks : constant Boolean := False; Backend_Overflow_Checks : constant Boolean := False; Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; Denorm : constant Boolean := False; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; ! Functions_Return_By_DSP : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; Stack_Check_Probes : constant Boolean := True; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ! ZCX_By_Default : constant Boolean := False; GCC_ZCX_Support : constant Boolean := False; ! Front_End_ZCX_Support : constant Boolean := False; ! ! -- Obsolete entries, to be removed eventually (bootstrap issues!) ! ! High_Integrity_Mode : constant Boolean := False; ! Long_Shifts_Inlined : constant Boolean := True; -- Note: Denorm is False because denormals are not supported on the -- R10000, and we want the code to be valid for this processor. diff -Nrc3pad gcc-3.3.3/gcc/ada/5ftaprop.adb gcc-3.4.0/gcc/ada/5ftaprop.adb *** gcc-3.3.3/gcc/ada/5ftaprop.adb 2002-10-23 08:27:54.000000000 +0000 --- gcc-3.4.0/gcc/ada/5ftaprop.adb 2004-01-05 15:20:42.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2003, 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- -- *************** *** 32,38 **** -- -- ------------------------------------------------------------------------------ ! -- This is a IRIX (pthread library) version of this package. -- This package contains all the GNULL primitives that interface directly -- with the underlying OS. --- 31,37 ---- -- -- ------------------------------------------------------------------------------ ! -- This is a IRIX (pthread library) version of this package -- This package contains all the GNULL primitives that interface directly -- with the underlying OS. *************** package body System.Task_Primitives.Oper *** 112,125 **** -- The followings are logically constants, but need to be initialized -- at run time. - ATCB_Key : aliased pthread_key_t; - -- Key used to find the Ada Task_ID associated with a thread - Single_RTS_Lock : aliased RTS_Lock; -- This is a lock to allow only one thread of control in the RTS at -- a time; it is used to execute in mutual exclusion from all other tasks. -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. --- 111,124 ---- -- The followings are logically constants, but need to be initialized -- at run time. Single_RTS_Lock : aliased RTS_Lock; -- This is a lock to allow only one thread of control in the RTS at -- a time; it is used to execute in mutual exclusion from all other tasks. -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_ID associated with a thread + Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. *************** package body System.Task_Primitives.Oper *** 130,155 **** Unblocked_Signal_Mask : aliased sigset_t; ----------------------- -- Local Subprograms -- ----------------------- - function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID); - function To_Address is new Unchecked_Conversion (Task_ID, System.Address); procedure Abort_Handler (Sig : Signal); ------------------- -- Abort_Handler -- ------------------- procedure Abort_Handler (Sig : Signal) is ! T : Task_ID := Self; Result : Interfaces.C.int; Old_Set : aliased sigset_t; begin if T.Deferral_Level = 0 and then T.Pending_ATC_Level < T.ATC_Nesting_Level then --- 129,202 ---- Unblocked_Signal_Mask : aliased sigset_t; + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads). + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_ID); + pragma Inline (Initialize); + -- Initialize various data needed by this package. + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_ID); + pragma Inline (Set); + -- Set the self id for the current task. + + function Self return Task_ID; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task. + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific. + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; + -- Allocate and Initialize a new ATCB for the current Thread. + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_ID is separate; + ----------------------- -- Local Subprograms -- ----------------------- function To_Address is new Unchecked_Conversion (Task_ID, System.Address); procedure Abort_Handler (Sig : Signal); + -- Signal handler used to implement asynchronous abort. ------------------- -- Abort_Handler -- ------------------- procedure Abort_Handler (Sig : Signal) is ! pragma Unreferenced (Sig); ! ! T : constant Task_ID := Self; Result : Interfaces.C.int; Old_Set : aliased sigset_t; begin + -- It is not safe to raise an exception when using ZCX and the GCC + -- exception handling mechanism. + + if ZCX_By_Default and then GCC_ZCX_Support then + return; + end if; + if T.Deferral_Level = 0 and then T.Pending_ATC_Level < T.ATC_Nesting_Level then *************** package body System.Task_Primitives.Oper *** 173,178 **** --- 220,227 ---- -- bottom of a thread stack, so nothing is needed. procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Unreferenced (On); + pragma Unreferenced (T); begin null; end Stack_Guard; *************** package body System.Task_Primitives.Oper *** 190,204 **** -- Self -- ---------- ! function Self return Task_ID is ! Result : System.Address; ! ! begin ! Result := pthread_getspecific (ATCB_Key); ! pragma Assert (Result /= System.Null_Address); ! ! return To_Task_ID (Result); ! end Self; --------------------- -- Initialize_Lock -- --- 239,245 ---- -- Self -- ---------- ! function Self return Task_ID renames Specific.Self; --------------------- -- Initialize_Lock -- *************** package body System.Task_Primitives.Oper *** 249,254 **** --- 290,297 ---- end Initialize_Lock; procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Unreferenced (Level); + Attributes : aliased pthread_mutexattr_t; Result : Interfaces.C.int; *************** package body System.Task_Primitives.Oper *** 288,294 **** procedure Finalize_Lock (L : access Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_destroy (L); pragma Assert (Result = 0); --- 331,336 ---- *************** package body System.Task_Primitives.Oper *** 296,302 **** procedure Finalize_Lock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_destroy (L); pragma Assert (Result = 0); --- 338,343 ---- *************** package body System.Task_Primitives.Oper *** 312,324 **** Result := pthread_mutex_lock (L); Ceiling_Violation := Result = EINVAL; ! -- assumes the cause of EINVAL is a priority ceiling violation pragma Assert (Result = 0 or else Result = EINVAL); end Write_Lock; procedure Write_Lock ! (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin --- 353,366 ---- Result := pthread_mutex_lock (L); Ceiling_Violation := Result = EINVAL; ! -- Assumes the cause of EINVAL is a priority ceiling violation pragma Assert (Result = 0 or else Result = EINVAL); end Write_Lock; procedure Write_Lock ! (L : access RTS_Lock; ! Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin *************** package body System.Task_Primitives.Oper *** 359,364 **** --- 401,407 ---- procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; + begin if not Single_Lock or else Global_Lock then Result := pthread_mutex_unlock (L); *************** package body System.Task_Primitives.Oper *** 368,373 **** --- 411,417 ---- procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; + begin if not Single_Lock then Result := pthread_mutex_unlock (T.Common.LL.L'Access); *************** package body System.Task_Primitives.Oper *** 383,389 **** --- 427,436 ---- (Self_ID : ST.Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin if Single_Lock then Result := pthread_cond_wait *************** package body System.Task_Primitives.Oper *** 410,415 **** --- 457,464 ---- Timedout : out Boolean; Yielded : out Boolean) is + pragma Unreferenced (Reason); + Check_Time : constant Duration := Monotonic_Clock; Abs_Time : Duration; Request : aliased timespec; *************** package body System.Task_Primitives.Oper *** 532,538 **** function Monotonic_Clock return Duration is TS : aliased timespec; Result : Interfaces.C.int; - begin Result := clock_gettime (Real_Time_Clock_Id, TS'Unchecked_Access); pragma Assert (Result = 0); --- 581,586 ---- *************** package body System.Task_Primitives.Oper *** 561,566 **** --- 609,615 ---- ------------ procedure Wakeup (T : ST.Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); Result : Interfaces.C.int; begin Result := pthread_cond_signal (T.Common.LL.CV'Access); *************** package body System.Task_Primitives.Oper *** 573,578 **** --- 622,628 ---- procedure Yield (Do_Yield : Boolean := True) is Result : Interfaces.C.int; + pragma Unreferenced (Result); begin if Do_Yield then Result := sched_yield; *************** package body System.Task_Primitives.Oper *** 588,593 **** --- 638,645 ---- Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is + pragma Unreferenced (Loss_Of_Inheritance); + Result : Interfaces.C.int; Param : aliased struct_sched_param; Sched_Policy : Interfaces.C.int; *************** package body System.Task_Primitives.Oper *** 635,642 **** begin Self_ID.Common.LL.Thread := pthread_self; ! Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID)); ! pragma Assert (Result = 0); if Self_ID.Common.Task_Info /= null and then Self_ID.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM --- 687,693 ---- begin Self_ID.Common.LL.Thread := pthread_self; ! Specific.Set (Self_ID); if Self_ID.Common.Task_Info /= null and then Self_ID.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM *************** package body System.Task_Primitives.Oper *** 669,674 **** --- 720,744 ---- return new Ada_Task_Control_Block (Entry_Num); end New_ATCB; + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + -------------------- -- Initialize_TCB -- -------------------- *************** package body System.Task_Primitives.Oper *** 760,766 **** pragma Assert (Result = 0); Result := pthread_attr_setstacksize ! (Attributes'Access, Interfaces.C.size_t (Adjusted_Stack_Size)); pragma Assert (Result = 0); if T.Common.Task_Info /= null then --- 830,836 ---- pragma Assert (Result = 0); Result := pthread_attr_setstacksize ! (Attributes'Access, Adjusted_Stack_Size); pragma Assert (Result = 0); if T.Common.Task_Info /= null then *************** package body System.Task_Primitives.Oper *** 808,814 **** System.IO.Put_Line ("Request for PTHREAD_SCOPE_SYSTEM in Task_Info pragma for task"); System.IO.Put (""""); ! System.IO.Put (T.Common.Task_Image.all); System.IO.Put_Line (""" could not be honored. "); System.IO.Put_Line ("Scope changed to PTHREAD_SCOPE_PROCESS"); --- 878,884 ---- System.IO.Put_Line ("Request for PTHREAD_SCOPE_SYSTEM in Task_Info pragma for task"); System.IO.Put (""""); ! System.IO.Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len)); System.IO.Put_Line (""" could not be honored. "); System.IO.Put_Line ("Scope changed to PTHREAD_SCOPE_PROCESS"); *************** package body System.Task_Primitives.Oper *** 828,834 **** Succeeded := Result = 0; ! Set_Priority (T, Priority); Result := pthread_attr_destroy (Attributes'Access); pragma Assert (Result = 0); --- 898,911 ---- Succeeded := Result = 0; ! -- The following needs significant commenting ??? ! ! if T.Common.Task_Info /= null then ! T.Common.Base_Priority := T.Common.Task_Info.Priority; ! Set_Priority (T, T.Common.Task_Info.Priority); ! else ! Set_Priority (T, Priority); ! end if; Result := pthread_attr_destroy (Attributes'Access); pragma Assert (Result = 0); *************** package body System.Task_Primitives.Oper *** 841,846 **** --- 918,924 ---- procedure Finalize_TCB (T : Task_ID) is Result : Interfaces.C.int; Tmp : Task_ID := T; + Is_Self : constant Boolean := T = Self; procedure Free is new Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); *************** package body System.Task_Primitives.Oper *** 859,864 **** --- 937,948 ---- end if; Free (Tmp); + + if Is_Self then + Result := pthread_setspecific (ATCB_Key, System.Null_Address); + pragma Assert (Result = 0); + end if; + end Finalize_TCB; --------------- *************** package body System.Task_Primitives.Oper *** 867,873 **** procedure Exit_Task is begin ! pthread_exit (System.Null_Address); end Exit_Task; ---------------- --- 951,957 ---- procedure Exit_Task is begin ! Specific.Set (null); end Exit_Task; ---------------- *************** package body System.Task_Primitives.Oper *** 876,881 **** --- 960,966 ---- procedure Abort_Task (T : Task_ID) is Result : Interfaces.C.int; + begin Result := pthread_kill (T.Common.LL.Thread, Signal (System.Interrupt_Management.Abort_Task_Interrupt)); *************** package body System.Task_Primitives.Oper *** 886,895 **** -- Check_Exit -- ---------------- ! -- Dummy versions. The only currently working versions is for solaris ! -- (native). function Check_Exit (Self_ID : ST.Task_ID) return Boolean is begin return True; end Check_Exit; --- 971,981 ---- -- Check_Exit -- ---------------- ! -- Dummy version function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + begin return True; end Check_Exit; *************** package body System.Task_Primitives.Oper *** 899,904 **** --- 985,992 ---- -------------------- function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + begin return True; end Check_No_Locks; *************** package body System.Task_Primitives.Oper *** 936,942 **** function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin return False; end Suspend_Task; --- 1024,1035 ---- function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) ! return Boolean ! is ! pragma Unreferenced (T); ! pragma Unreferenced (Thread_Self); ! begin return False; end Suspend_Task; *************** package body System.Task_Primitives.Oper *** 947,953 **** function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin return False; end Resume_Task; --- 1040,1051 ---- function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) ! return Boolean ! is ! pragma Unreferenced (T); ! pragma Unreferenced (Thread_Self); ! begin return False; end Resume_Task; *************** package body System.Task_Primitives.Oper *** 962,995 **** Tmp_Set : aliased sigset_t; Result : Interfaces.C.int; begin Environment_Task_ID := Environment_Task; -- Initialize the lock used to synchronize chain of all ATCBs. Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); Enter_Task (Environment_Task); -- Install the abort-signal handler ! act.sa_flags := 0; ! act.sa_handler := Abort_Handler'Address; ! Result := sigemptyset (Tmp_Set'Access); ! pragma Assert (Result = 0); ! act.sa_mask := Tmp_Set; ! Result := ! sigaction ( ! Signal (System.Interrupt_Management.Abort_Task_Interrupt), ! act'Unchecked_Access, ! old_act'Unchecked_Access); ! pragma Assert (Result = 0); end Initialize; begin declare Result : Interfaces.C.int; begin -- Mask Environment task for all signals. The original mask of the -- Environment task will be recovered by Interrupt_Server task --- 1060,1114 ---- Tmp_Set : aliased sigset_t; Result : Interfaces.C.int; + function State (Int : System.Interrupt_Management.Interrupt_ID) + return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state. Defined in a-init.c. The input argument is + -- the interrupt number, and the result is one of the following: + + Default : constant Character := 's'; + -- 'n' this interrupt not set by any Interrupt_State pragma + -- 'u' Interrupt_State pragma set state to User + -- 'r' Interrupt_State pragma set state to Runtime + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + begin Environment_Task_ID := Environment_Task; -- Initialize the lock used to synchronize chain of all ATCBs. + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + Specific.Initialize (Environment_Task); + Enter_Task (Environment_Task); -- Install the abort-signal handler ! if State (System.Interrupt_Management.Abort_Task_Interrupt) ! /= Default ! then ! act.sa_flags := 0; ! act.sa_handler := Abort_Handler'Address; ! Result := sigemptyset (Tmp_Set'Access); ! pragma Assert (Result = 0); ! act.sa_mask := Tmp_Set; ! Result := ! sigaction ( ! Signal (System.Interrupt_Management.Abort_Task_Interrupt), ! act'Unchecked_Access, ! old_act'Unchecked_Access); ! pragma Assert (Result = 0); ! end if; end Initialize; begin declare Result : Interfaces.C.int; + begin -- Mask Environment task for all signals. The original mask of the -- Environment task will be recovered by Interrupt_Server task *************** begin *** 1010,1018 **** end if; end loop; - Result := pthread_key_create (ATCB_Key'Access, null); - pragma Assert (Result = 0); - -- Pick the highest resolution Clock for Clock_Realtime -- ??? This code currently doesn't work (see c94007[ab] for example) -- --- 1129,1134 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5ftasinf.ads gcc-3.4.0/gcc/ada/5ftasinf.ads *** gcc-3.3.3/gcc/ada/5ftasinf.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5ftasinf.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 5,14 **** -- S Y S T E M . T A S K _ I N F O -- -- -- -- S p e c -- - -- (Compiler Interface) -- - -- -- -- -- ! -- 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- -- --- 5,12 ---- -- S Y S T E M . T A S K _ I N F O -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2003 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- -- *************** *** 34,52 **** ------------------------------------------------------------------------------ -- This package contains the definitions and routines associated with the ! -- implementation of the Task_Info pragma. It is specialized appropriately ! -- for targets that make use of this pragma. -- Note: the compiler generates direct calls to this interface, via Rtsfind. -- Any changes to this interface may require corresponding compiler changes. with Interfaces.C; with System.OS_Interface; - with Unchecked_Deallocation; package System.Task_Info is ! pragma Elaborate_Body; ! -- To ensure that a body is allowed package OSI renames System.OS_Interface; --- 32,54 ---- ------------------------------------------------------------------------------ -- This package contains the definitions and routines associated with the ! -- implementation and use of the Task_Info pragma. It is specialized ! -- appropriately for targets that make use of this pragma. -- Note: the compiler generates direct calls to this interface, via Rtsfind. -- Any changes to this interface may require corresponding compiler changes. + -- This unit may be used directly from an application program by providing + -- an appropriate WITH, and the interface can be expected to remain stable. + + -- This is the IRIX (kernel threads) version of this package + with Interfaces.C; with System.OS_Interface; package System.Task_Info is ! pragma Elaborate_Body; ! -- To ensure that a body is allowed package OSI renames System.OS_Interface; *************** pragma Elaborate_Body; *** 128,140 **** type Task_Info_Type is access all Thread_Attributes; - type Task_Image_Type is access String; - -- Used to generate a meaningful identifier for tasks that are variables - -- and components of variables. - - procedure Free_Task_Image is new - Unchecked_Deallocation (String, Task_Image_Type); - Unspecified_Task_Info : constant Task_Info_Type := null; -- Value passed to task in the absence of a Task_Info pragma --- 130,135 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5ginterr.adb gcc-3.4.0/gcc/ada/5ginterr.adb *** gcc-3.3.3/gcc/ada/5ginterr.adb 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5ginterr.adb 2004-01-05 15:20:42.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1998-2001 Free Software Fundation -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2003 Free Software Fundation -- -- -- -- 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- -- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ *************** package body System.Interrupts is *** 245,251 **** ------------------------------------- function Has_Interrupt_Or_Attach_Handler ! (Object : access Dynamic_Interrupt_Protection) return Boolean is begin return True; end Has_Interrupt_Or_Attach_Handler; --- 244,252 ---- ------------------------------------- function Has_Interrupt_Or_Attach_Handler ! (Object : access Dynamic_Interrupt_Protection) return Boolean ! is ! pragma Unreferenced (Object); begin return True; end Has_Interrupt_Or_Attach_Handler; *************** package body System.Interrupts is *** 276,284 **** ------------------------------------- function Has_Interrupt_Or_Attach_Handler ! (Object : access Static_Interrupt_Protection) ! return Boolean is begin return True; end Has_Interrupt_Or_Attach_Handler; --- 277,285 ---- ------------------------------------- function Has_Interrupt_Or_Attach_Handler ! (Object : access Static_Interrupt_Protection) return Boolean is + pragma Unreferenced (Object); begin return True; end Has_Interrupt_Or_Attach_Handler; *************** package body System.Interrupts is *** 289,295 **** procedure Install_Handlers (Object : access Static_Interrupt_Protection; ! New_Handlers : in New_Handler_Array) is begin for N in New_Handlers'Range loop --- 290,296 ---- procedure Install_Handlers (Object : access Static_Interrupt_Protection; ! New_Handlers : New_Handler_Array) is begin for N in New_Handlers'Range loop *************** package body System.Interrupts is *** 315,322 **** -- Current_Handler -- --------------------- ! function Current_Handler (Interrupt : Interrupt_ID) ! return Parameterless_Handler is begin if Is_Reserved (Interrupt) then raise Program_Error; --- 316,324 ---- -- Current_Handler -- --------------------- ! function Current_Handler ! (Interrupt : Interrupt_ID) return Parameterless_Handler ! is begin if Is_Reserved (Interrupt) then raise Program_Error; *************** package body System.Interrupts is *** 461,473 **** --------------- function Reference (Interrupt : Interrupt_ID) return System.Address is ! Signal : System.Address := ! System.Storage_Elements.To_Address ! (System.Storage_Elements.Integer_Address (Interrupt)); begin if Is_Reserved (Interrupt) then ! -- Only usable Interrupts can be used for binding it to an Entry. raise Program_Error; end if; --- 463,477 ---- --------------- function Reference (Interrupt : Interrupt_ID) return System.Address is ! Signal : constant System.Address := ! System.Storage_Elements.To_Address ! (System.Storage_Elements.Integer_Address (Interrupt)); begin if Is_Reserved (Interrupt) then ! ! -- Only usable Interrupts can be used for binding it to an Entry ! raise Program_Error; end if; diff -Nrc3pad gcc-3.3.3/gcc/ada/5gintman.adb gcc-3.4.0/gcc/ada/5gintman.adb *** gcc-3.3.3/gcc/ada/5gintman.adb 2002-03-14 10:58:30.000000000 +0000 --- gcc-3.4.0/gcc/ada/5gintman.adb 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1997-1998, Florida State University -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,13 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2003, Ada Core Technologies -- -- -- -- 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- -- *************** *** 27,35 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 27,34 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ *************** *** 41,52 **** --- 40,54 ---- -- Make a careful study of all signals available under the OS, -- to see which need to be reserved, kept always unmasked, -- or kept always unmasked. + -- Be on the lookout for special signals that -- may be used by the thread library. with System.OS_Interface; -- used for various Constants, Signal and types + with Interfaces.C; + -- used for "int" package body System.Interrupt_Management is use System.OS_Interface; *************** package body System.Interrupt_Management *** 76,81 **** --- 78,87 ---- -- unnamed signal number 48 for pthread_kill! -- + Unreserve_All_Interrupts : Interfaces.C.int; + pragma Import + (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); + ---------------------- -- Notify_Exception -- ---------------------- *************** package body System.Interrupt_Management *** 99,114 **** end Initialize_Interrupts; begin ! Abort_Task_Interrupt := Abort_Signal; ! for I in Reserved_Interrupts'Range loop ! Keep_Unmasked (Reserved_Interrupts (I)) := True; ! Reserve (Reserved_Interrupts (I)) := True; ! end loop; ! for I in Exception_Interrupts'Range loop ! Keep_Unmasked (Exception_Interrupts (I)) := True; ! Reserve (Reserved_Interrupts (I)) := True; ! end loop; end System.Interrupt_Management; --- 105,184 ---- end Initialize_Interrupts; begin ! declare ! function State (Int : Interrupt_ID) return Character; ! pragma Import (C, State, "__gnat_get_interrupt_state"); ! -- Get interrupt state. Defined in a-init.c ! -- The input argument is the interrupt number, ! -- and the result is one of the following: ! User : constant Character := 'u'; ! Runtime : constant Character := 'r'; ! Default : constant Character := 's'; ! -- 'n' this interrupt not set by any Interrupt_State pragma ! -- 'u' Interrupt_State pragma set state to User ! -- 'r' Interrupt_State pragma set state to Runtime ! -- 's' Interrupt_State pragma set state to System (use "default" ! -- system handler) ! use Interfaces.C; ! ! begin ! Abort_Task_Interrupt := Abort_Signal; ! ! pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False)); ! pragma Assert (Reserve = (Interrupt_ID'Range => False)); ! ! -- Process state of exception signals ! ! for J in Exception_Interrupts'Range loop ! if State (Exception_Interrupts (J)) /= User then ! Keep_Unmasked (Exception_Interrupts (J)) := True; ! Reserve (Exception_Interrupts (J)) := True; ! end if; ! end loop; + if State (Abort_Task_Interrupt) /= User then + Keep_Unmasked (Abort_Task_Interrupt) := True; + Reserve (Abort_Task_Interrupt) := True; + end if; + + -- Set SIGINT to unmasked state as long as it's + -- not in "User" state. Check for Unreserve_All_Interrupts last + + if State (SIGINT) /= User then + Keep_Unmasked (SIGINT) := True; + end if; + + -- Check all signals for state that requires keeping them + -- unmasked and reserved + + for J in Interrupt_ID'Range loop + if State (J) = Default or else State (J) = Runtime then + Keep_Unmasked (J) := True; + Reserve (J) := True; + end if; + end loop; + + -- Add target-specific reserved signals + + for J in Reserved_Interrupts'Range loop + Reserve (Interrupt_ID (Reserved_Interrupts (J))) := True; + end loop; + + -- Process pragma Unreserve_All_Interrupts. This overrides any + -- settings due to pragma Interrupt_State: + + if Unreserve_All_Interrupts /= 0 then + Keep_Unmasked (SIGINT) := False; + Reserve (SIGINT) := False; + end if; + + -- We do not have Signal 0 in reality. We just use this value + -- to identify not existing signals (see s-intnam.ads). Therefore, + -- Signal 0 should not be used in all signal related operations hence + -- mark it as reserved. + + Reserve (0) := True; + end; end System.Interrupt_Management; diff -Nrc3pad gcc-3.3.3/gcc/ada/5gmastop.adb gcc-3.4.0/gcc/ada/5gmastop.adb *** gcc-3.3.3/gcc/ada/5gmastop.adb 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5gmastop.adb 2004-01-05 15:20:42.000000000 +0000 *************** *** 7,14 **** -- B o d y -- -- (Version for IRIX/MIPS) -- -- -- ! -- -- ! -- Copyright (C) 1999-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- -- --- 7,13 ---- -- B o d y -- -- (Version for IRIX/MIPS) -- -- -- ! -- Copyright (C) 1999-2003 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- -- *************** package body System.Machine_State_Operat *** 109,126 **** -- ABI-Dependent Declarations -- -------------------------------- ! o32 : constant Natural := Boolean'Pos (System.Word_Size = 32); ! n32 : constant Natural := Boolean'Pos (System.Word_Size = 64); -- Flags to indicate which ABI is in effect for this compilation. For the -- purposes of this unit, the n32 and n64 ABI's are identical. ! LSC : constant Character := Character'Val (o32 * Character'Pos ('w') + ! n32 * Character'Pos ('d')); -- This is 'w' for o32, and 'd' for n32/n64, used for constructing the -- load/store instructions used to save/restore machine instructions. ! Roff : constant Character := Character'Val (o32 * Character'Pos ('4') + ! n32 * Character'Pos (' ')); -- Offset from first byte of a __uint64 register save location where -- the register value is stored. For n32/64 we store the entire 64 -- bit register into the uint64. For o32, only 32 bits are stored --- 108,127 ---- -- ABI-Dependent Declarations -- -------------------------------- ! o32 : constant Boolean := System.Word_Size = 32; ! n32 : constant Boolean := System.Word_Size = 64; ! o32n : constant Natural := Boolean'Pos (o32); ! n32n : constant Natural := Boolean'Pos (n32); -- Flags to indicate which ABI is in effect for this compilation. For the -- purposes of this unit, the n32 and n64 ABI's are identical. ! LSC : constant Character := Character'Val (o32n * Character'Pos ('w') + ! n32n * Character'Pos ('d')); -- This is 'w' for o32, and 'd' for n32/n64, used for constructing the -- load/store instructions used to save/restore machine instructions. ! Roff : constant Character := Character'Val (o32n * Character'Pos ('4') + ! n32n * Character'Pos (' ')); -- Offset from first byte of a __uint64 register save location where -- the register value is stored. For n32/64 we store the entire 64 -- bit register into the uint64. For o32, only 32 bits are stored *************** package body System.Machine_State_Operat *** 157,163 **** function To_I_Type_Ptr is new Unchecked_Conversion (Address_Int, I_Type_Ptr); ! Ret_Ins : I_Type_Ptr := To_I_Type_Ptr (Address_Int (Scp.SC_PC)); GP_Ptr : Uns32_Ptr; begin --- 158,164 ---- function To_I_Type_Ptr is new Unchecked_Conversion (Address_Int, I_Type_Ptr); ! Ret_Ins : constant I_Type_Ptr := To_I_Type_Ptr (Address_Int (Scp.SC_PC)); GP_Ptr : Uns32_Ptr; begin *************** package body System.Machine_State_Operat *** 184,189 **** --- 185,192 ---- ------------------- procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is + pragma Warnings (Off, M); + pragma Warnings (Off, Handler); LOADI : constant String (1 .. 2) := 'l' & LSC; -- This is "lw" in o32 mode, and "ld" in n32/n64 mode *************** package body System.Machine_State_Operat *** 283,288 **** --- 286,293 ---- (M : Machine_State; Info : Subprogram_Info_Type) is + pragma Warnings (Off, Info); + Scp : Sigcontext_Ptr := To_Sigcontext_Ptr (M); procedure Exc_Unwind (Scp : Sigcontext_Ptr; Fde : Long_Integer := 0); *************** package body System.Machine_State_Operat *** 308,319 **** Scp.SC_PC := 0; else - -- Set the GP to restore to the caller value (not callee value) -- This is done only in o32 mode. In n32/n64 mode, GP is a normal -- callee save register ! if o32 = 1 then Update_GP (Scp); end if; --- 313,323 ---- Scp.SC_PC := 0; else -- Set the GP to restore to the caller value (not callee value) -- This is done only in o32 mode. In n32/n64 mode, GP is a normal -- callee save register ! if o32 then Update_GP (Scp); end if; *************** package body System.Machine_State_Operat *** 407,413 **** procedure Set_Signal_Machine_State (M : Machine_State; ! Context : System.Address) is begin null; end Set_Signal_Machine_State; --- 411,421 ---- procedure Set_Signal_Machine_State (M : Machine_State; ! Context : System.Address) ! is ! pragma Warnings (Off, M); ! pragma Warnings (Off, Context); ! begin null; end Set_Signal_Machine_State; diff -Nrc3pad gcc-3.3.3/gcc/ada/5gml-tgt.adb gcc-3.4.0/gcc/ada/5gml-tgt.adb *** gcc-3.3.3/gcc/ada/5gml-tgt.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5gml-tgt.adb 2004-01-05 15:20:42.000000000 +0000 *************** *** 0 **** --- 1,372 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T -- + -- (IRIX Version) -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2003, 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. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package provides a set of target dependent routines to build + -- static, dynamic and shared libraries. + + -- This is the IRIX version of the body. + + with MLib.Fil; + with MLib.Utl; + with Namet; use Namet; + with Opt; + with Output; use Output; + with Prj.Com; + with System; + + package body MLib.Tgt is + + No_Arguments : aliased Argument_List := (1 .. 0 => null); + Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; + + Wl_Init_String : aliased String := "-Wl,-init"; + Wl_Init : constant String_Access := Wl_Init_String'Access; + Wl_Fini_String : aliased String := "-Wl,-fini"; + Wl_Fini : constant String_Access := Wl_Fini_String'Access; + + Init_Fini_List : constant Argument_List_Access := + new Argument_List'(1 => Wl_Init, + 2 => null, + 3 => Wl_Fini, + 4 => null); + -- Used to put switches for automatic elaboration/finalization + + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return "ar"; + end Archive_Builder; + + ----------------------------- + -- Archive_Builder_Options -- + ----------------------------- + + function Archive_Builder_Options return String_List_Access is + begin + return new String_List'(1 => new String'("cr")); + end Archive_Builder_Options; + + ----------------- + -- Archive_Ext -- + ----------------- + + function Archive_Ext return String is + begin + return "a"; + end Archive_Ext; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return "ranlib"; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Foreign : Argument_List; + Afiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Address : String := ""; + Lib_Version : String := ""; + Relocatable : Boolean := False; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Foreign); + pragma Unreferenced (Afiles); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Lib_Address); + pragma Unreferenced (Relocatable); + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + MLib.Fil.Ext_To (Lib_Filename, DLL_Ext); + + Version_Arg : String_Access; + Symbolic_Link_Needed : Boolean := False; + + Init_Fini : Argument_List_Access := Empty_Argument_List; + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_File); + end if; + + -- If specified, add automatic elaboration/finalization + if Auto_Init then + Init_Fini := Init_Fini_List; + Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init"); + Init_Fini (4) := new String'("-Wl," & Lib_Filename & "final"); + end if; + + if Lib_Version = "" then + MLib.Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles, + Options => Options & Init_Fini.all, + Driver_Name => Driver_Name); + + else + Version_Arg := new String'("-Wl,-soname," & Lib_Version); + + if Is_Absolute_Path (Lib_Version) then + MLib.Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => Options & Version_Arg & Init_Fini.all, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := Lib_Version /= Lib_File; + + else + MLib.Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => Options & Version_Arg & Init_Fini.all, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_File; + end if; + + if Symbolic_Link_Needed then + declare + Success : Boolean; + Oldpath : String (1 .. Lib_Version'Length + 1); + Newpath : String (1 .. Lib_File'Length + 1); + + Result : Integer; + pragma Unreferenced (Result); + + function Symlink + (Oldpath : System.Address; + Newpath : System.Address) + return Integer; + pragma Import (C, Symlink, "__gnat_symlink"); + + begin + Oldpath (1 .. Lib_Version'Length) := Lib_Version; + Oldpath (Oldpath'Last) := ASCII.NUL; + Newpath (1 .. Lib_File'Length) := Lib_File; + Newpath (Newpath'Last) := ASCII.NUL; + + Delete_File (Lib_File, Success); + + Result := Symlink (Oldpath'Address, Newpath'Address); + end; + end if; + end if; + end Build_Dynamic_Library; + + ------------------------- + -- Default_DLL_Address -- + ------------------------- + + function Default_DLL_Address return String is + begin + return ""; + end Default_DLL_Address; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "so"; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return "-shared"; + end Dynamic_Option; + + ------------------- + -- Is_Object_Ext -- + ------------------- + + function Is_Object_Ext (Ext : String) return Boolean is + begin + return Ext = ".o"; + end Is_Object_Ext; + + -------------- + -- Is_C_Ext -- + -------------- + + function Is_C_Ext (Ext : String) return Boolean is + begin + return Ext = ".c"; + end Is_C_Ext; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".so"; + end Is_Archive_Ext; + + ------------- + -- Libgnat -- + ------------- + + function Libgnat return String is + begin + return "libgnat.a"; + end Libgnat; + + ------------------------ + -- Library_Exists_For -- + ------------------------ + + function Library_Exists_For (Project : Project_Id) return Boolean is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & + "for non library project"); + return False; + + else + declare + Lib_Dir : constant String := + Get_Name_String (Projects.Table (Project).Library_Dir); + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + if Projects.Table (Project).Library_Kind = Static then + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + end; + end if; + end Library_Exists_For; + + --------------------------- + -- Library_File_Name_For -- + --------------------------- + + function Library_File_Name_For (Project : Project_Id) return Name_Id is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & + "for non library project"); + return No_Name; + + else + declare + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + Name_Len := 3; + Name_Buffer (1 .. Name_Len) := "lib"; + + if Projects.Table (Project).Library_Kind = Static then + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + + return Name_Find; + end; + end if; + end Library_File_Name_For; + + -------------------------------- + -- Linker_Library_Path_Option -- + -------------------------------- + + function Linker_Library_Path_Option return String_Access is + begin + return new String'("-Wl,-rpath,"); + end Linker_Library_Path_Option; + + ---------------- + -- Object_Ext -- + ---------------- + + function Object_Ext return String is + begin + return "o"; + end Object_Ext; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return "-fPIC"; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return True; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Full; + end Support_For_Libraries; + + end MLib.Tgt; diff -Nrc3pad gcc-3.3.3/gcc/ada/5gosinte.ads gcc-3.4.0/gcc/ada/5gosinte.ads *** gcc-3.3.3/gcc/ada/5gosinte.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5gosinte.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1997-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/5gproinf.adb gcc-3.4.0/gcc/ada/5gproinf.adb *** gcc-3.3.3/gcc/ada/5gproinf.adb 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5gproinf.adb 2003-04-24 17:53:51.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1997-1999 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5gproinf.ads gcc-3.4.0/gcc/ada/5gproinf.ads *** gcc-3.3.3/gcc/ada/5gproinf.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5gproinf.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1997 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1997-2003 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- -- *************** *** 31,36 **** --- 30,36 ---- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ + -- This package contains the definitions and routines used as parameters -- to the run-time system at program startup for the SGI implementation. diff -Nrc3pad gcc-3.3.3/gcc/ada/5gsystem.ads gcc-3.4.0/gcc/ada/5gsystem.ads *** gcc-3.3.3/gcc/ada/5gsystem.ads 2002-10-23 07:33:19.000000000 +0000 --- gcc-3.4.0/gcc/ada/5gsystem.ads 2003-11-12 21:24:19.000000000 +0000 *************** *** 7,14 **** -- S p e c -- -- (SGI Irix, n32 ABI) -- -- -- ! -- -- ! -- Copyright (C) 1992-2002 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 -- --- 7,13 ---- -- S p e c -- -- (SGI Irix, n32 ABI) -- -- -- ! -- Copyright (C) 1992-2003 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 -- *************** pragma Pure (System); *** 59,65 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := 1.0; -- Storage-related Declarations --- 58,64 ---- Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := 0.01; -- Storage-related Declarations *************** private *** 119,140 **** Backend_Divide_Checks : constant Boolean := False; Backend_Overflow_Checks : constant Boolean := False; Command_Line_Args : constant Boolean := True; Denorm : constant Boolean := False; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; ! Functions_Return_By_DSP : constant Boolean := True; ! Long_Shifts_Inlined : constant Boolean := True; ! High_Integrity_Mode : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; Stack_Check_Probes : constant Boolean := True; Use_Ada_Main_Program_Name : constant Boolean := False; ! ZCX_By_Default : constant Boolean := True; GCC_ZCX_Support : constant Boolean := False; ! Front_End_ZCX_Support : constant Boolean := True; -- Note: Denorm is False because denormals are not supported on the -- R10000, and we want the code to be valid for this processor. --- 118,151 ---- Backend_Divide_Checks : constant Boolean := False; Backend_Overflow_Checks : constant Boolean := False; Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; Denorm : constant Boolean := False; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; ! Functions_Return_By_DSP : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; Stack_Check_Probes : constant Boolean := True; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ! ZCX_By_Default : constant Boolean := False; GCC_ZCX_Support : constant Boolean := False; ! Front_End_ZCX_Support : constant Boolean := False; ! ! -- Obsolete entries, to be removed eventually (bootstrap issues!) ! ! High_Integrity_Mode : constant Boolean := False; ! Long_Shifts_Inlined : constant Boolean := True; -- Note: Denorm is False because denormals are not supported on the -- R10000, and we want the code to be valid for this processor. diff -Nrc3pad gcc-3.3.3/gcc/ada/5gtaprop.adb gcc-3.4.0/gcc/ada/5gtaprop.adb *** gcc-3.3.3/gcc/ada/5gtaprop.adb 2002-10-23 08:27:54.000000000 +0000 --- gcc-3.4.0/gcc/ada/5gtaprop.adb 2004-01-26 21:57:33.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2004, 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- -- *************** package body System.Task_Primitives.Oper *** 97,105 **** package SSL renames System.Soft_Links; ! ------------------ ! -- Local Data -- ! ------------------ -- The followings are logically constants, but need to be initialized -- at run time. --- 96,104 ---- package SSL renames System.Soft_Links; ! ----------------- ! -- Local Data -- ! ----------------- -- The followings are logically constants, but need to be initialized -- at run time. *************** package body System.Task_Primitives.Oper *** 140,145 **** --- 139,147 ---- -- ??? Check the comment above procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Unreferenced (T); + pragma Unreferenced (On); + begin null; end Stack_Guard; *************** package body System.Task_Primitives.Oper *** 211,218 **** --- 213,223 ---- end Initialize_Lock; procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Unreferenced (Level); + Attributes : aliased pthread_mutexattr_t; Result : Interfaces.C.int; + begin Result := pthread_mutexattr_init (Attributes'Access); *************** package body System.Task_Primitives.Oper *** 266,271 **** --- 271,277 ---- procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is Result : Interfaces.C.int; + begin Result := pthread_mutex_lock (L); *************** package body System.Task_Primitives.Oper *** 277,282 **** --- 283,289 ---- (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; + begin if not Single_Lock or else Global_Lock then Result := pthread_mutex_lock (L); *************** package body System.Task_Primitives.Oper *** 286,291 **** --- 293,299 ---- procedure Write_Lock (T : Task_ID) is Result : Interfaces.C.int; + begin if not Single_Lock then Result := pthread_mutex_lock (T.Common.LL.L'Access); *************** package body System.Task_Primitives.Oper *** 308,313 **** --- 316,322 ---- procedure Unlock (L : access Lock) is Result : Interfaces.C.int; + begin Result := pthread_mutex_unlock (L); pragma Assert (Result = 0); *************** package body System.Task_Primitives.Oper *** 315,320 **** --- 324,330 ---- procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; + begin if not Single_Lock or else Global_Lock then Result := pthread_mutex_unlock (L); *************** package body System.Task_Primitives.Oper *** 324,329 **** --- 334,340 ---- procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; + begin if not Single_Lock then Result := pthread_mutex_unlock (T.Common.LL.L'Access); *************** package body System.Task_Primitives.Oper *** 339,345 **** --- 350,359 ---- (Self_ID : ST.Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin if Single_Lock then Result := pthread_cond_wait *************** package body System.Task_Primitives.Oper *** 350,355 **** --- 364,370 ---- end if; -- EINTR is not considered a failure. + pragma Assert (Result = 0 or else Result = EINTR); end Sleep; *************** package body System.Task_Primitives.Oper *** 365,374 **** --- 380,392 ---- Timedout : out Boolean; Yielded : out Boolean) is + pragma Unreferenced (Reason); + Check_Time : constant Duration := Monotonic_Clock; Abs_Time : Duration; Request : aliased struct_timeval; Result : Interfaces.C.int; + begin Timedout := True; Yielded := False; *************** package body System.Task_Primitives.Oper *** 428,434 **** begin -- Only the little window between deferring abort and -- locking Self_ID is the reason we need to ! -- check for pending abort and priority change below! :( SSL.Abort_Defer.all; --- 446,452 ---- begin -- Only the little window between deferring abort and -- locking Self_ID is the reason we need to ! -- check for pending abort and priority change below! SSL.Abort_Defer.all; *************** package body System.Task_Primitives.Oper *** 524,529 **** --- 542,549 ---- (T : ST.Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; begin Result := pthread_cond_signal (T.Common.LL.CV'Access); *************** package body System.Task_Primitives.Oper *** 546,556 **** ------------------ procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is Result : Interfaces.C.int; begin T.Common.Current_Priority := Prio; Result := pthread_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio)); --- 566,579 ---- ------------------ procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is + pragma Unreferenced (Loss_Of_Inheritance); + Result : Interfaces.C.int; + begin T.Common.Current_Priority := Prio; Result := pthread_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio)); *************** package body System.Task_Primitives.Oper *** 573,578 **** --- 596,602 ---- procedure Enter_Task (Self_ID : Task_ID) is Result : Interfaces.C.int; + begin Self_ID.Common.LL.Thread := pthread_self; Self_ID.Common.LL.LWP := sproc_self; *************** package body System.Task_Primitives.Oper *** 604,609 **** --- 628,651 ---- return new Ada_Task_Control_Block (Entry_Num); end New_ATCB; + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + begin + return False; + end Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + return null; + end Register_Foreign_Thread; + ---------------------- -- Initialize_TCB -- ---------------------- *************** package body System.Task_Primitives.Oper *** 770,777 **** --------------- procedure Exit_Task is begin ! pthread_exit (System.Null_Address); end Exit_Task; ---------------- --- 812,823 ---- --------------- procedure Exit_Task is + Result : Interfaces.C.int; + begin ! Result := pthread_set_ada_tcb (pthread_self, System.Null_Address); ! ! pragma Assert (Result = 0); end Exit_Task; ---------------- *************** package body System.Task_Primitives.Oper *** 780,788 **** procedure Abort_Task (T : Task_ID) is Result : Interfaces.C.int; begin ! Result := pthread_kill (T.Common.LL.Thread, ! Interfaces.C.int (System.Interrupt_Management.Abort_Task_Interrupt)); pragma Assert (Result = 0); end Abort_Task; --- 826,837 ---- procedure Abort_Task (T : Task_ID) is Result : Interfaces.C.int; + begin ! Result := ! pthread_kill (T.Common.LL.Thread, ! Interfaces.C.int ! (System.Interrupt_Management.Abort_Task_Interrupt)); pragma Assert (Result = 0); end Abort_Task; *************** package body System.Task_Primitives.Oper *** 790,799 **** -- Check_Exit -- ---------------- ! -- Dummy versions. The only currently working versions is for solaris ! -- (native). function Check_Exit (Self_ID : ST.Task_ID) return Boolean is begin return True; end Check_Exit; --- 839,849 ---- -- Check_Exit -- ---------------- ! -- Dummy version function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + begin return True; end Check_Exit; *************** package body System.Task_Primitives.Oper *** 803,808 **** --- 853,860 ---- -------------------- function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + begin return True; end Check_No_Locks; *************** package body System.Task_Primitives.Oper *** 840,846 **** function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin if T.Common.LL.Thread /= Thread_Self then return pthread_suspend (T.Common.LL.Thread) = 0; --- 892,899 ---- function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean ! is begin if T.Common.LL.Thread /= Thread_Self then return pthread_suspend (T.Common.LL.Thread) = 0; *************** package body System.Task_Primitives.Oper *** 855,861 **** function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin if T.Common.LL.Thread /= Thread_Self then return pthread_resume (T.Common.LL.Thread) = 0; --- 908,915 ---- function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean ! is begin if T.Common.LL.Thread /= Thread_Self then return pthread_resume (T.Common.LL.Thread) = 0; *************** package body System.Task_Primitives.Oper *** 881,886 **** --- 935,944 ---- Environment_Task.Common.Current_Priority); end Initialize; + -------------------------------- + -- Initialize_Athread_Library -- + -------------------------------- + procedure Initialize_Athread_Library is Result : Interfaces.C.int; Init : aliased pthread_init_struct; diff -Nrc3pad gcc-3.3.3/gcc/ada/5gtasinf.adb gcc-3.4.0/gcc/ada/5gtasinf.adb *** gcc-3.3.3/gcc/ada/5gtasinf.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5gtasinf.adb 2004-01-26 21:57:33.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- *************** package body System.Task_Info is *** 221,227 **** NDPRI : Non_Degrading_Priority := NDP_NONE) return sproc_t is ! Attr : Sproc_Attributes := (Sproc_Resources, CPU, Resident, NDPRI); begin --- 220,226 ---- NDPRI : Non_Degrading_Priority := NDP_NONE) return sproc_t is ! Attr : constant Sproc_Attributes := (Sproc_Resources, CPU, Resident, NDPRI); begin *************** package body System.Task_Info is *** 268,274 **** NDPRI : Non_Degrading_Priority := NDP_NONE) return Thread_Attributes is ! Sproc : sproc_t := New_Sproc (Sproc_Resources, CPU, Resident, NDPRI); begin --- 267,273 ---- NDPRI : Non_Degrading_Priority := NDP_NONE) return Thread_Attributes is ! Sproc : constant sproc_t := New_Sproc (Sproc_Resources, CPU, Resident, NDPRI); begin *************** package body System.Task_Info is *** 317,323 **** NDPRI : Non_Degrading_Priority := NDP_NONE) return Task_Info_Type is ! Sproc : sproc_t := New_Sproc (Sproc_Resources, CPU, Resident, NDPRI); begin --- 316,322 ---- NDPRI : Non_Degrading_Priority := NDP_NONE) return Task_Info_Type is ! Sproc : constant sproc_t := New_Sproc (Sproc_Resources, CPU, Resident, NDPRI); begin diff -Nrc3pad gcc-3.3.3/gcc/ada/5gtasinf.ads gcc-3.4.0/gcc/ada/5gtasinf.ads *** gcc-3.3.3/gcc/ada/5gtasinf.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5gtasinf.ads 2003-10-21 13:41:51.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2003 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- -- *************** *** 33,48 **** ------------------------------------------------------------------------------ -- This package contains the definitions and routines associated with the ! -- implementation of the Task_Info pragma. -- This is the SGI (libathread) specific version of this module. with System.OS_Interface; - with Unchecked_Deallocation; package System.Task_Info is ! pragma Elaborate_Body; ! -- To ensure that a body is allowed --------------------------------------------------------- -- Binding of Tasks to sprocs and sprocs to processors -- --- 32,53 ---- ------------------------------------------------------------------------------ -- This package contains the definitions and routines associated with the ! -- implementation and use of the Task_Info pragma. It is specialized ! -- appropriately for targets that make use of this pragma. ! ! -- Note: the compiler generates direct calls to this interface, via Rtsfind. ! -- Any changes to this interface may require corresponding compiler changes. ! ! -- This unit may be used directly from an application program by providing ! -- an appropriate WITH, and the interface can be expected to remain stable. -- This is the SGI (libathread) specific version of this module. with System.OS_Interface; package System.Task_Info is ! pragma Elaborate_Body; ! -- To ensure that a body is allowed --------------------------------------------------------- -- Binding of Tasks to sprocs and sprocs to processors -- *************** pragma Elaborate_Body; *** 274,286 **** NDPRI : Non_Degrading_Priority := NDP_NONE) return Task_Info_Type; - type Task_Image_Type is access String; - -- Used to generate a meaningful identifier for tasks that are variables - -- and components of variables. - - procedure Free_Task_Image is new - Unchecked_Deallocation (String, Task_Image_Type); - Unspecified_Task_Info : constant Task_Info_Type := null; end System.Task_Info; --- 279,284 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5gtpgetc.adb gcc-3.4.0/gcc/ada/5gtpgetc.adb *** gcc-3.3.3/gcc/ada/5gtpgetc.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5gtpgetc.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1999-2000 Free Software Fundation -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/5hml-tgt.adb gcc-3.4.0/gcc/ada/5hml-tgt.adb *** gcc-3.3.3/gcc/ada/5hml-tgt.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5hml-tgt.adb 2004-01-05 15:20:42.000000000 +0000 *************** *** 0 **** --- 1,377 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T -- + -- (HP-UX Version) -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2003, 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. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package provides a set of target dependent routines to build + -- libraries (static only on HP-UX). + + -- This is the HP-UX version of the body. + + with MLib.Fil; + with MLib.Utl; + with Namet; use Namet; + with Opt; + with Output; use Output; + with Prj.Com; + with System; + + package body MLib.Tgt is + + No_Arguments : aliased Argument_List := (1 .. 0 => null); + Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; + + Wl_Init_String : aliased String := "-Wl,+init"; + Wl_Init : constant String_Access := Wl_Init_String'Access; + Wl_Fini_String : aliased String := "-Wl,+fini"; + Wl_Fini : constant String_Access := Wl_Fini_String'Access; + + Init_Fini_List : constant Argument_List_Access := + new Argument_List'(1 => Wl_Init, + 2 => null, + 3 => Wl_Fini, + 4 => null); + -- Used to put switches for automatic elaboration/finalization + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return "ar"; + end Archive_Builder; + + ----------------------------- + -- Archive_Builder_Options -- + ----------------------------- + + function Archive_Builder_Options return String_List_Access is + begin + return new String_List'(1 => new String'("cr")); + end Archive_Builder_Options; + + ----------------- + -- Archive_Ext -- + ----------------- + + function Archive_Ext return String is + begin + return "a"; + end Archive_Ext; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return "ranlib"; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Foreign : Argument_List; + Afiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Address : String := ""; + Lib_Version : String := ""; + Relocatable : Boolean := False; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Foreign); + pragma Unreferenced (Afiles); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Lib_Address); + pragma Unreferenced (Relocatable); + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + MLib.Fil.Ext_To (Lib_Filename, DLL_Ext); + + Version_Arg : String_Access; + Symbolic_Link_Needed : Boolean := False; + + Init_Fini : Argument_List_Access := Empty_Argument_List; + + Common_Options : constant Argument_List := + Options & new String'(PIC_Option); + -- Common set of options to the gcc command performing the link. + -- On HPUX, this command eventually resorts to collect2, which may + -- generate a C file and compile it on the fly. This compilation shall + -- also generate position independant code for the final link to + -- succeed. + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_File); + end if; + + -- If specified, add automatic elaboration/finalization + if Auto_Init then + Init_Fini := Init_Fini_List; + Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init"); + Init_Fini (4) := new String'("-Wl," & Lib_Filename & "final"); + end if; + + if Lib_Version = "" then + MLib.Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles, + Options => Common_Options & Init_Fini.all, + Driver_Name => Driver_Name); + + else + Version_Arg := new String'("-Wl,+h," & Lib_Version); + + if Is_Absolute_Path (Lib_Version) then + MLib.Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => Common_Options & Version_Arg & Init_Fini.all, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := Lib_Version /= Lib_File; + + else + MLib.Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => Common_Options & Version_Arg & Init_Fini.all, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_File; + end if; + + if Symbolic_Link_Needed then + declare + Success : Boolean; + Oldpath : String (1 .. Lib_Version'Length + 1); + Newpath : String (1 .. Lib_File'Length + 1); + + Result : Integer; + pragma Unreferenced (Result); + + function Symlink + (Oldpath : System.Address; + Newpath : System.Address) return Integer; + pragma Import (C, Symlink, "__gnat_symlink"); + + begin + Oldpath (1 .. Lib_Version'Length) := Lib_Version; + Oldpath (Oldpath'Last) := ASCII.NUL; + Newpath (1 .. Lib_File'Length) := Lib_File; + Newpath (Newpath'Last) := ASCII.NUL; + + Delete_File (Lib_File, Success); + + Result := Symlink (Oldpath'Address, Newpath'Address); + end; + end if; + end if; + end Build_Dynamic_Library; + + ------------------------- + -- Default_DLL_Address -- + ------------------------- + + function Default_DLL_Address return String is + begin + return ""; + end Default_DLL_Address; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "sl"; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return "-shared"; + end Dynamic_Option; + + ------------------- + -- Is_Object_Ext -- + ------------------- + + function Is_Object_Ext (Ext : String) return Boolean is + begin + return Ext = ".o"; + end Is_Object_Ext; + + -------------- + -- Is_C_Ext -- + -------------- + + function Is_C_Ext (Ext : String) return Boolean is + begin + return Ext = ".c"; + end Is_C_Ext; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".so"; + end Is_Archive_Ext; + + ------------- + -- Libgnat -- + ------------- + + function Libgnat return String is + begin + return "libgnat.a"; + end Libgnat; + + ------------------------ + -- Library_Exists_For -- + ------------------------ + + function Library_Exists_For (Project : Project_Id) return Boolean is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & + "for non library project"); + return False; + + else + declare + Lib_Dir : constant String := + Get_Name_String (Projects.Table (Project).Library_Dir); + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + if Projects.Table (Project).Library_Kind = Static then + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + end; + end if; + end Library_Exists_For; + + --------------------------- + -- Library_File_Name_For -- + --------------------------- + + function Library_File_Name_For (Project : Project_Id) return Name_Id is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & + "for non library project"); + return No_Name; + + else + declare + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + Name_Len := 3; + Name_Buffer (1 .. Name_Len) := "lib"; + + if Projects.Table (Project).Library_Kind = Static then + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + + return Name_Find; + end; + end if; + end Library_File_Name_For; + + -------------------------------- + -- Linker_Library_Path_Option -- + -------------------------------- + + function Linker_Library_Path_Option return String_Access is + begin + return new String'("-Wl,+b,"); + end Linker_Library_Path_Option; + + ---------------- + -- Object_Ext -- + ---------------- + + function Object_Ext return String is + begin + return "o"; + end Object_Ext; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return "-fPIC"; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return True; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Full; + end Support_For_Libraries; + + end MLib.Tgt; diff -Nrc3pad gcc-3.3.3/gcc/ada/5hosinte.adb gcc-3.4.0/gcc/ada/5hosinte.adb *** gcc-3.3.3/gcc/ada/5hosinte.adb 2002-03-14 10:58:31.000000000 +0000 --- gcc-3.4.0/gcc/ada/5hosinte.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1991-2001, Florida State University -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,13 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2003, Ada Core Technologies -- -- -- -- 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- -- *************** *** 27,35 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 27,34 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ *************** package body System.OS_Interface is *** 75,82 **** F := F + 1.0; end if; ! return timespec' (tv_sec => S, ! tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; function To_Duration (TV : struct_timeval) return Duration is --- 74,81 ---- F := F + 1.0; end if; ! return timespec'(tv_sec => S, ! tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; function To_Duration (TV : struct_timeval) return Duration is *************** package body System.OS_Interface is *** 99,106 **** F := F + 1.0; end if; ! return struct_timeval' (tv_sec => S, ! tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); end To_Timeval; --------------------------- --- 98,107 ---- F := F + 1.0; end if; ! return ! struct_timeval' ! (tv_sec => S, ! tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); end To_Timeval; --------------------------- *************** package body System.OS_Interface is *** 129,134 **** --- 130,136 ---- -- DCE_THREADS does not have pthread_kill. Instead, we just ignore it. function pthread_kill (thread : pthread_t; sig : Signal) return int is + pragma Unreferenced (thread, sig); begin return 0; end pthread_kill; *************** package body System.OS_Interface is *** 540,545 **** --- 542,549 ---- end pthread_key_create; function Get_Stack_Base (thread : pthread_t) return Address is + pragma Warnings (Off, thread); + begin return Null_Address; end Get_Stack_Base; diff -Nrc3pad gcc-3.3.3/gcc/ada/5hosinte.ads gcc-3.4.0/gcc/ada/5hosinte.ads *** gcc-3.3.3/gcc/ada/5hosinte.ads 2002-03-14 10:58:31.000000000 +0000 --- gcc-3.4.0/gcc/ada/5hosinte.ads 2003-12-05 10:24:04.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1997-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- -- --- 6,13 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2003, Ada Core Technologies -- -- -- -- 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- -- *************** *** 27,35 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 27,34 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ *************** package System.OS_Interface is *** 165,170 **** --- 164,170 ---- type struct_sigaction_ptr is access all struct_sigaction; SA_RESTART : constant := 16#40#; + SA_SIGINFO : constant := 16#10#; SIG_BLOCK : constant := 0; SIG_UNBLOCK : constant := 1; diff -Nrc3pad gcc-3.3.3/gcc/ada/5hparame.ads gcc-3.4.0/gcc/ada/5hparame.ads *** gcc-3.3.3/gcc/ada/5hparame.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5hparame.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2003 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- -- *************** pragma Pure (Parameters); *** 95,100 **** --- 94,104 ---- -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size -- otherwise return given Size + Default_Env_Stack_Size : constant Size_Type := 8_192_000; + -- Assumed size of the environment task, if no other information + -- is available. This value is used when stack checking is + -- enabled and no GNAT_STACK_LIMIT environment variable is set. + Stack_Grows_Down : constant Boolean := False; -- This constant indicates whether the stack grows up (False) or -- down (True) in memory as functions are called. It is used for *************** pragma Pure (Parameters); *** 137,144 **** --------------------- -- In the following sections, constant parameters are defined to ! -- allow some optimizations within the tasking run time based on ! -- restrictions on the tasking features. ---------------------- -- Locking Strategy -- --- 141,148 ---- --------------------- -- In the following sections, constant parameters are defined to ! -- allow some optimizations and fine tuning within the tasking run time ! -- based on restrictions on the tasking features. ---------------------- -- Locking Strategy -- *************** pragma Pure (Parameters); *** 178,183 **** --- 182,195 ---- -- point. A value of False for Dynamic_Priority_Support corresponds -- to pragma Restrictions (No_Dynamic_Priorities); + --------------------- + -- Task Attributes -- + --------------------- + + Default_Attribute_Count : constant := 4; + -- Number of pre-allocated Address-sized task attributes stored in the + -- task control block. + -------------------- -- Runtime Traces -- -------------------- diff -Nrc3pad gcc-3.3.3/gcc/ada/5hsystem.ads gcc-3.4.0/gcc/ada/5hsystem.ads *** gcc-3.3.3/gcc/ada/5hsystem.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5hsystem.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 7,14 **** -- S p e c -- -- (HP-UX Version) -- -- -- ! -- -- ! -- Copyright (C) 1992-2002 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 -- --- 7,13 ---- -- S p e c -- -- (HP-UX Version) -- -- -- ! -- Copyright (C) 1992-2003 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 -- *************** pragma Pure (System); *** 59,65 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := 1.0; -- Storage-related Declarations --- 58,64 ---- Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := 0.01; -- Storage-related Declarations *************** private *** 119,141 **** Backend_Divide_Checks : constant Boolean := False; Backend_Overflow_Checks : constant Boolean := False; Command_Line_Args : constant Boolean := True; ! Denorm : constant Boolean := False; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; Functions_Return_By_DSP : constant Boolean := False; - Long_Shifts_Inlined : constant Boolean := False; - High_Integrity_Mode : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; Signed_Zeros : constant Boolean := False; Stack_Check_Default : constant Boolean := False; Stack_Check_Probes : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; ! GCC_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := False; -------------------------- -- Underlying Priorities -- --------------------------- --- 118,152 ---- Backend_Divide_Checks : constant Boolean := False; Backend_Overflow_Checks : constant Boolean := False; Command_Line_Args : constant Boolean := True; ! Configurable_Run_Time : constant Boolean := False; ! Denorm : constant Boolean := True; ! Duration_32_Bits : constant Boolean := False; ! Exit_Status_Supported : constant Boolean := True; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; Functions_Return_By_DSP : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; Signed_Zeros : constant Boolean := False; Stack_Check_Default : constant Boolean := False; Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; ! GCC_ZCX_Support : constant Boolean := True; Front_End_ZCX_Support : constant Boolean := False; + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := False; + -------------------------- -- Underlying Priorities -- --------------------------- diff -Nrc3pad gcc-3.3.3/gcc/ada/5htaprop.adb gcc-3.4.0/gcc/ada/5htaprop.adb *** gcc-3.3.3/gcc/ada/5htaprop.adb 2002-10-23 08:27:54.000000000 +0000 --- gcc-3.4.0/gcc/ada/5htaprop.adb 2004-01-05 15:20:42.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2003, 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- -- *************** *** 32,38 **** -- -- ------------------------------------------------------------------------------ ! -- This is a HP-UX DCE threads version of this package -- This package contains all the GNULL primitives that interface directly -- with the underlying OS. --- 31,37 ---- -- -- ------------------------------------------------------------------------------ ! -- This is a HP-UX DCE threads (HPUX 10) version of this package -- This package contains all the GNULL primitives that interface directly -- with the underlying OS. *************** package body System.Task_Primitives.Oper *** 101,114 **** -- The followings are logically constants, but need to be initialized -- at run time. - ATCB_Key : aliased pthread_key_t; - -- Key used to find the Ada Task_ID associated with a thread - Single_RTS_Lock : aliased RTS_Lock; -- This is a lock to allow only one thread of control in the RTS at -- a time; it is used to execute in mutual exclusion from all other tasks. -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. --- 100,113 ---- -- The followings are logically constants, but need to be initialized -- at run time. Single_RTS_Lock : aliased RTS_Lock; -- This is a lock to allow only one thread of control in the RTS at -- a time; it is used to execute in mutual exclusion from all other tasks. -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_ID associated with a thread + Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. *************** package body System.Task_Primitives.Oper *** 118,133 **** Time_Slice_Val : Integer; pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - Locking_Policy : Character; - pragma Import (C, Locking_Policy, "__gl_locking_policy"); - Dispatching_Policy : Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; -- Indicates whether FIFO_Within_Priorities is set. ! -- The followings are internal configuration constants needed. ----------------------- -- Local Subprograms -- --- 117,171 ---- Time_Slice_Val : Integer; pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); Dispatching_Policy : Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + -- Note: the reason that Locking_Policy is not needed is that this + -- is not implemented for DCE threads. The HPUX 10 port is at this + -- stage considered dead, and no further work is planned on it. + FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; -- Indicates whether FIFO_Within_Priorities is set. ! Foreign_Task_Elaborated : aliased Boolean := True; ! -- Used to identified fake tasks (i.e., non-Ada Threads). ! ! -------------------- ! -- Local Packages -- ! -------------------- ! ! package Specific is ! ! procedure Initialize (Environment_Task : Task_ID); ! pragma Inline (Initialize); ! -- Initialize various data needed by this package. ! ! function Is_Valid_Task return Boolean; ! pragma Inline (Is_Valid_Task); ! -- Does the executing thread have a TCB? ! ! procedure Set (Self_Id : Task_ID); ! pragma Inline (Set); ! -- Set the self id for the current task. ! ! function Self return Task_ID; ! pragma Inline (Self); ! -- Return a pointer to the Ada Task Control Block of the calling task. ! ! end Specific; ! ! package body Specific is separate; ! -- The body of this package is target specific. ! ! --------------------------------- ! -- Support for foreign threads -- ! --------------------------------- ! ! function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; ! -- Allocate and Initialize a new ATCB for the current Thread. ! ! function Register_Foreign_Thread ! (Thread : Thread_Id) return Task_ID is separate; ----------------------- -- Local Subprograms -- *************** package body System.Task_Primitives.Oper *** 135,142 **** procedure Abort_Handler (Sig : Signal); - function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID); - function To_Address is new Unchecked_Conversion (Task_ID, System.Address); ------------------- --- 173,178 ---- *************** package body System.Task_Primitives.Oper *** 144,149 **** --- 180,187 ---- ------------------- procedure Abort_Handler (Sig : Signal) is + pragma Unreferenced (Sig); + Self_Id : constant Task_ID := Self; Result : Interfaces.C.int; Old_Set : aliased sigset_t; *************** package body System.Task_Primitives.Oper *** 174,179 **** --- 212,218 ---- -- ??? Check the comment above procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Unreferenced (T, On); begin null; end Stack_Guard; *************** package body System.Task_Primitives.Oper *** 191,203 **** -- Self -- ---------- ! function Self return Task_ID is ! Result : System.Address; ! begin ! Result := pthread_getspecific (ATCB_Key); ! pragma Assert (Result /= System.Null_Address); ! return To_Task_ID (Result); ! end Self; --------------------- -- Initialize_Lock -- --- 230,236 ---- -- Self -- ---------- ! function Self return Task_ID renames Specific.Self; --------------------- -- Initialize_Lock -- *************** package body System.Task_Primitives.Oper *** 239,244 **** --- 272,279 ---- end Initialize_Lock; procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Unreferenced (Level); + Attributes : aliased pthread_mutexattr_t; Result : Interfaces.C.int; *************** package body System.Task_Primitives.Oper *** 286,291 **** --- 321,327 ---- procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is Result : Interfaces.C.int; + begin L.Owner_Priority := Get_Priority (Self); *************** package body System.Task_Primitives.Oper *** 303,308 **** --- 339,345 ---- (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; + begin if not Single_Lock or else Global_Lock then Result := pthread_mutex_lock (L); *************** package body System.Task_Primitives.Oper *** 312,317 **** --- 349,355 ---- procedure Write_Lock (T : Task_ID) is Result : Interfaces.C.int; + begin if not Single_Lock then Result := pthread_mutex_lock (T.Common.LL.L'Access); *************** package body System.Task_Primitives.Oper *** 334,339 **** --- 372,378 ---- procedure Unlock (L : access Lock) is Result : Interfaces.C.int; + begin Result := pthread_mutex_unlock (L.L'Access); pragma Assert (Result = 0); *************** package body System.Task_Primitives.Oper *** 350,355 **** --- 389,395 ---- procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; + begin if not Single_Lock then Result := pthread_mutex_unlock (T.Common.LL.L'Access); *************** package body System.Task_Primitives.Oper *** 365,370 **** --- 405,412 ---- (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; begin if Single_Lock then *************** package body System.Task_Primitives.Oper *** 391,396 **** --- 433,440 ---- Timedout : out Boolean; Yielded : out Boolean) is + pragma Unreferenced (Reason); + Check_Time : constant Duration := Monotonic_Clock; Abs_Time : Duration; Request : aliased timespec; *************** package body System.Task_Primitives.Oper *** 427,433 **** exit when Abs_Time <= Monotonic_Clock; if Result = 0 or Result = EINTR then ! -- somebody may have called Wakeup for us Timedout := False; exit; end if; --- 471,479 ---- exit when Abs_Time <= Monotonic_Clock; if Result = 0 or Result = EINTR then ! ! -- Somebody may have called Wakeup for us ! Timedout := False; exit; end if; *************** package body System.Task_Primitives.Oper *** 539,545 **** --- 585,594 ---- ------------ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin Result := pthread_cond_signal (T.Common.LL.CV'Access); pragma Assert (Result = 0); *************** package body System.Task_Primitives.Oper *** 551,556 **** --- 600,606 ---- procedure Yield (Do_Yield : Boolean := True) is Result : Interfaces.C.int; + pragma Unreferenced (Result); begin if Do_Yield then Result := sched_yield; *************** package body System.Task_Primitives.Oper *** 572,579 **** -- scheduling. procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is Result : Interfaces.C.int; --- 622,629 ---- -- scheduling. procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is Result : Interfaces.C.int; *************** package body System.Task_Primitives.Oper *** 644,656 **** ---------------- procedure Enter_Task (Self_ID : Task_ID) is - Result : Interfaces.C.int; - begin Self_ID.Common.LL.Thread := pthread_self; ! ! Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID)); ! pragma Assert (Result = 0); Lock_RTS; --- 694,702 ---- ---------------- procedure Enter_Task (Self_ID : Task_ID) is begin Self_ID.Common.LL.Thread := pthread_self; ! Specific.Set (Self_ID); Lock_RTS; *************** package body System.Task_Primitives.Oper *** 674,679 **** --- 720,744 ---- return new Ada_Task_Control_Block (Entry_Num); end New_ATCB; + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + -------------------- -- Initialize_TCB -- -------------------- *************** package body System.Task_Primitives.Oper *** 799,804 **** --- 864,870 ---- procedure Finalize_TCB (T : Task_ID) is Result : Interfaces.C.int; Tmp : Task_ID := T; + Is_Self : constant Boolean := T = Self; procedure Free is new Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); *************** package body System.Task_Primitives.Oper *** 817,822 **** --- 883,894 ---- end if; Free (Tmp); + + if Is_Self then + Result := pthread_setspecific (ATCB_Key, System.Null_Address); + pragma Assert (Result = 0); + end if; + end Finalize_TCB; --------------- *************** package body System.Task_Primitives.Oper *** 825,831 **** procedure Exit_Task is begin ! pthread_exit (System.Null_Address); end Exit_Task; ---------------- --- 897,903 ---- procedure Exit_Task is begin ! Specific.Set (null); end Exit_Task; ---------------- *************** package body System.Task_Primitives.Oper *** 852,857 **** --- 924,930 ---- -- (native). function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); begin return True; end Check_Exit; *************** package body System.Task_Primitives.Oper *** 861,866 **** --- 934,940 ---- -------------------- function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); begin return True; end Check_No_Locks; *************** package body System.Task_Primitives.Oper *** 898,904 **** function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin return False; end Suspend_Task; --- 972,983 ---- function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) ! return Boolean ! is ! pragma Unreferenced (T); ! pragma Unreferenced (Thread_Self); ! begin return False; end Suspend_Task; *************** package body System.Task_Primitives.Oper *** 909,915 **** function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin return False; end Resume_Task; --- 988,999 ---- function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) ! return Boolean ! is ! pragma Unreferenced (T); ! pragma Unreferenced (Thread_Self); ! begin return False; end Resume_Task; *************** package body System.Task_Primitives.Oper *** 924,973 **** Tmp_Set : aliased sigset_t; Result : Interfaces.C.int; ! begin Environment_Task_ID := Environment_Task; - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); -- Initialize the lock used to synchronize chain of all ATCBs. Enter_Task (Environment_Task); -- Install the abort-signal handler ! act.sa_flags := 0; ! act.sa_handler := Abort_Handler'Address; ! Result := sigemptyset (Tmp_Set'Access); ! pragma Assert (Result = 0); ! act.sa_mask := Tmp_Set; ! Result := ! sigaction ( ! Signal (System.Interrupt_Management.Abort_Task_Interrupt), ! act'Unchecked_Access, ! old_act'Unchecked_Access); ! pragma Assert (Result = 0); end Initialize; ! procedure do_nothing (arg : System.Address); ! ! procedure do_nothing (arg : System.Address) is ! begin ! null; ! end do_nothing; ! ! begin ! declare ! Result : Interfaces.C.int; ! begin ! -- NOTE: Unlike other pthread implementations, we do *not* mask all ! -- signals here since we handle signals using the process-wide primitive ! -- signal, rather than using sigthreadmask and sigwait. The reason of ! -- this difference is that sigwait doesn't work when some critical ! -- signals (SIGABRT, SIGPIPE) are masked. - Result := pthread_key_create (ATCB_Key'Access, do_nothing'Access); - pragma Assert (Result = 0); - end; end System.Task_Primitives.Operations; --- 1008,1063 ---- Tmp_Set : aliased sigset_t; Result : Interfaces.C.int; ! function State (Int : System.Interrupt_Management.Interrupt_ID) ! return Character; ! pragma Import (C, State, "__gnat_get_interrupt_state"); ! -- Get interrupt state. Defined in a-init.c ! -- The input argument is the interrupt number, ! -- and the result is one of the following: + Default : constant Character := 's'; + -- 'n' this interrupt not set by any Interrupt_State pragma + -- 'u' Interrupt_State pragma set state to User + -- 'r' Interrupt_State pragma set state to Runtime + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + begin Environment_Task_ID := Environment_Task; -- Initialize the lock used to synchronize chain of all ATCBs. + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Specific.Initialize (Environment_Task); + Enter_Task (Environment_Task); -- Install the abort-signal handler ! if State (System.Interrupt_Management.Abort_Task_Interrupt) ! /= Default ! then ! act.sa_flags := 0; ! act.sa_handler := Abort_Handler'Address; ! Result := sigemptyset (Tmp_Set'Access); ! pragma Assert (Result = 0); ! act.sa_mask := Tmp_Set; ! Result := ! sigaction ( ! Signal (System.Interrupt_Management.Abort_Task_Interrupt), ! act'Unchecked_Access, ! old_act'Unchecked_Access); ! pragma Assert (Result = 0); ! end if; end Initialize; ! -- NOTE: Unlike other pthread implementations, we do *not* mask all ! -- signals here since we handle signals using the process-wide primitive ! -- signal, rather than using sigthreadmask and sigwait. The reason of ! -- this difference is that sigwait doesn't work when some critical ! -- signals (SIGABRT, SIGPIPE) are masked. end System.Task_Primitives.Operations; diff -Nrc3pad gcc-3.3.3/gcc/ada/5htaspri.ads gcc-3.4.0/gcc/ada/5htaspri.ads *** gcc-3.3.3/gcc/ada/5htaspri.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5htaspri.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1991-2000 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/5htraceb.adb gcc-3.4.0/gcc/ada/5htraceb.adb *** gcc-3.3.3/gcc/ada/5htraceb.adb 2002-03-14 10:58:32.000000000 +0000 --- gcc-3.4.0/gcc/ada/5htraceb.adb 2004-01-05 15:20:42.000000000 +0000 *************** *** 7,14 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1999-2002 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- -- --- 7,13 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2003 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- -- *************** *** 29,35 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 28,34 ---- -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ *************** package body System.Traceback is *** 222,229 **** (Pc : Address; Space : Address; Table_Start : Address; ! Table_End : Address) ! return Address; pragma Import (C, U_get_unwind_entry, "U_get_unwind_entry"); -- Given the bounds of an unwind table, return the address of the -- unwind descriptor associated with a code location/space. In the case --- 221,227 ---- (Pc : Address; Space : Address; Table_Start : Address; ! Table_End : Address) return Address; pragma Import (C, U_get_unwind_entry, "U_get_unwind_entry"); -- Given the bounds of an unwind table, return the address of the -- unwind descriptor associated with a code location/space. In the case *************** package body System.Traceback is *** 255,262 **** function U_get_previous_frame_x (current_frame : access CFD; previous_frame : access PFD; ! previous_size : Integer) ! return Integer; pragma Import (C, U_get_previous_frame_x, "U_get_previous_frame_x"); -- Fetch the data describing the "previous" frame relatively to the -- "current" one. "previous_size" should be the size of the "previous" --- 253,259 ---- function U_get_previous_frame_x (current_frame : access CFD; previous_frame : access PFD; ! previous_size : Integer) return Integer; pragma Import (C, U_get_previous_frame_x, "U_get_previous_frame_x"); -- Fetch the data describing the "previous" frame relatively to the -- "current" one. "previous_size" should be the size of the "previous" *************** package body System.Traceback is *** 271,279 **** ------------------ function C_Call_Chain ! (Traceback : System.Address; ! Max_Len : Natural) ! return Natural is Val : Natural; --- 268,275 ---- ------------------ function C_Call_Chain ! (Traceback : System.Address; ! Max_Len : Natural) return Natural is Val : Natural; *************** package body System.Traceback is *** 291,297 **** Max_Len : Natural; Len : out Natural; Exclude_Min : System.Address := System.Null_Address; ! Exclude_Max : System.Address := System.Null_Address) is type Tracebacks_Array is array (1 .. Max_Len) of System.Address; pragma Suppress_Initialization (Tracebacks_Array); --- 287,294 ---- Max_Len : Natural; Len : out Natural; Exclude_Min : System.Address := System.Null_Address; ! Exclude_Max : System.Address := System.Null_Address; ! Skip_Frames : Natural := 1) is type Tracebacks_Array is array (1 .. Max_Len) of System.Address; pragma Suppress_Initialization (Tracebacks_Array); *************** package body System.Traceback is *** 530,539 **** and then U_is_shared_pc (Frame.cur_rlo, Frame.cur_r19) /= 0 then declare ! Shlib_UWT : UWT := U_get_shLib_unwind_table (Frame.cur_r19); ! Shlib_Start : Address := U_get_shLib_text_addr (Frame.cur_r19); ! Rlo_Offset : Address := Frame.cur_rlo - Shlib_Start; ! begin UWD_Address := U_get_unwind_entry (Rlo_Offset, Frame.cur_rls, --- 527,538 ---- and then U_is_shared_pc (Frame.cur_rlo, Frame.cur_r19) /= 0 then declare ! Shlib_UWT : constant UWT := ! U_get_shLib_unwind_table (Frame.cur_r19); ! Shlib_Start : constant Address := ! U_get_shLib_text_addr (Frame.cur_r19); ! Rlo_Offset : constant Address := ! Frame.cur_rlo - Shlib_Start; begin UWD_Address := U_get_unwind_entry (Rlo_Offset, Frame.cur_rls, *************** package body System.Traceback is *** 552,560 **** -- Start of processing for Call_Chain begin ! -- Fetch the state for this subprogram's frame and pop it so that the ! -- backtrace starts at the right point for our caller, that is at its ! -- own frame. U_init_frame_record (Frame'Access); Frame.top_sr0 := 0; --- 551,558 ---- -- Start of processing for Call_Chain begin ! -- Fetch the state for this subprogram's frame and pop it so that we ! -- start with an initial out_rlo "here". U_init_frame_record (Frame'Access); Frame.top_sr0 := 0; *************** package body System.Traceback is *** 564,569 **** --- 562,573 ---- Pop_Success := Pop_Frame (Frame'Access); + -- Skip the requested number of frames. + + for I in 1 .. Skip_Frames loop + Pop_Success := Pop_Frame (Frame'Access); + end loop; + -- Loop popping frames and storing locations until either a problem -- occurs, or the top of the call chain is reached, or the provided -- array is full. diff -Nrc3pad gcc-3.3.3/gcc/ada/5iosinte.adb gcc-3.4.0/gcc/ada/5iosinte.adb *** gcc-3.3.3/gcc/ada/5iosinte.adb 2002-03-14 10:58:32.000000000 +0000 --- gcc-3.4.0/gcc/ada/5iosinte.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1991-2001 Florida State University -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,13 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2003, Ada Core Technologies -- -- -- -- 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- -- *************** *** 27,35 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 27,34 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ *************** package body System.OS_Interface is *** 51,56 **** --- 50,57 ---- -------------------- function Get_Stack_Base (thread : pthread_t) return Address is + pragma Warnings (Off, thread); + begin return Null_Address; end Get_Stack_Base; *************** package body System.OS_Interface is *** 98,105 **** F := F + 1.0; end if; ! return timespec' ! (tv_sec => S, tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; ---------------- --- 99,106 ---- F := F + 1.0; end if; ! return timespec'(tv_sec => S, ! tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; ---------------- *************** package body System.OS_Interface is *** 122,129 **** F := F + 1.0; end if; ! return struct_timeval' ! (tv_sec => S, tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); end To_Timeval; end System.OS_Interface; --- 123,132 ---- F := F + 1.0; end if; ! return ! struct_timeval' ! (tv_sec => S, ! tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); end To_Timeval; end System.OS_Interface; diff -Nrc3pad gcc-3.3.3/gcc/ada/5iosinte.ads gcc-3.4.0/gcc/ada/5iosinte.ads *** gcc-3.3.3/gcc/ada/5iosinte.ads 2003-05-02 17:22:50.000000000 +0000 --- gcc-3.4.0/gcc/ada/5iosinte.ads 2003-12-05 10:24:04.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2003 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- -- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ *************** package System.OS_Interface is *** 197,202 **** --- 196,203 ---- end record; type Machine_State_Ptr is access all Machine_State; + SA_SIGINFO : constant := 16#04#; + SIG_BLOCK : constant := 0; SIG_UNBLOCK : constant := 1; SIG_SETMASK : constant := 2; *************** package System.OS_Interface is *** 235,240 **** --- 236,246 ---- tz : System.Address := System.Null_Address) return int; pragma Import (C, gettimeofday, "gettimeofday"); + function sysconf (name : int) return long; + pragma Import (C, sysconf); + + SC_CLK_TCK : constant := 2; + ------------------------- -- Priority Scheduling -- ------------------------- *************** private *** 503,516 **** end record; pragma Convention (C, pthread_mutex_t); ! type pthread_cond_padding_t is array (0 .. 35) of unsigned_char; ! pragma Convention (C, pthread_cond_padding_t); ! ! type pthread_cond_t is record ! c_lock : struct_pthread_fast_lock; ! c_waiting : System.Address; ! c_padding : pthread_cond_padding_t; ! end record; pragma Convention (C, pthread_cond_t); type pthread_key_t is new unsigned; --- 509,515 ---- end record; pragma Convention (C, pthread_mutex_t); ! type pthread_cond_t is array (0 .. 47) of unsigned_char; pragma Convention (C, pthread_cond_t); type pthread_key_t is new unsigned; diff -Nrc3pad gcc-3.3.3/gcc/ada/5isystem.ads gcc-3.4.0/gcc/ada/5isystem.ads *** gcc-3.3.3/gcc/ada/5isystem.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5isystem.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 0 **** --- 1,166 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (VxWorks/LEVEL B Version PPC) -- + -- -- + -- Copyright (C) 1992-2003 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. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- Level B certifiable VxWorks version + + pragma Restrictions (No_Finalization); + pragma Restrictions (No_Exception_Registration); + pragma Restrictions (No_Abort_Statements); + + pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + package System is + pragma Pure (System); + -- Note that we take advantage of the implementation permission to + -- make this unit Pure instead of Preelaborable, see RM 13.7(36) + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 1.0 / 60.0; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + + -- Priority-related Declarations (RM D.1) + + -- 256 is reserved for the VxWorks kernel + -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 + -- 247 is a catchall default "interrupt" priority for signals, + -- allowing higher priority than normal tasks, but lower than + -- hardware priority levels. Protected Object ceilings can + -- override these values. + -- 246 is used by the Interrupt_Manager task + + Max_Priority : constant Positive := 245; + Max_Interrupt_Priority : constant Positive := 255; + + subtype Any_Priority is Integer range 0 .. 255; + subtype Priority is Any_Priority range 0 .. 245; + subtype Interrupt_Priority is Any_Priority range 246 .. 255; + + Default_Priority : constant Priority := 122; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + AAMP : constant Boolean := False; + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := False; + Configurable_Run_Time : constant Boolean := True; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := True; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Functions_Return_By_DSP : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + OpenVMS : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + Front_End_ZCX_Support : constant Boolean := False; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := True; + Long_Shifts_Inlined : constant Boolean := False; + + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/5itaprop.adb gcc-3.4.0/gcc/ada/5itaprop.adb *** gcc-3.3.3/gcc/ada/5itaprop.adb 2002-03-14 10:58:33.000000000 +0000 --- gcc-3.4.0/gcc/ada/5itaprop.adb 2004-01-13 11:51:31.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2003, 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- -- *************** *** 27,34 **** -- 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. (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ --- 26,33 ---- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ! -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ *************** package body System.Task_Primitives.Oper *** 102,112 **** -- Local Data -- ------------------ - Max_Stack_Size : constant := 2000 * 1024; - -- GNU/LinuxThreads does not return an error value when requesting - -- a task stack size which is too large, so we have to check this - -- ourselves. - -- The followings are logically constants, but need to be initialized -- at run time. --- 101,106 ---- *************** package body System.Task_Primitives.Oper *** 115,120 **** --- 109,117 ---- -- a time; it is used to execute in mutual exclusion from all other tasks. -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_ID associated with a thread + Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. *************** package body System.Task_Primitives.Oper *** 144,187 **** Mutex_Attr : aliased pthread_mutexattr_t; Cond_Attr : aliased pthread_condattr_t; ! ----------------------- ! -- Local Subprograms -- ! ----------------------- ! ! subtype unsigned_short is Interfaces.C.unsigned_short; ! subtype unsigned_long is Interfaces.C.unsigned_long; ! ! procedure Abort_Handler ! (signo : Signal; ! gs : unsigned_short; ! fs : unsigned_short; ! es : unsigned_short; ! ds : unsigned_short; ! edi : unsigned_long; ! esi : unsigned_long; ! ebp : unsigned_long; ! esp : unsigned_long; ! ebx : unsigned_long; ! edx : unsigned_long; ! ecx : unsigned_long; ! eax : unsigned_long; ! trapno : unsigned_long; ! err : unsigned_long; ! eip : unsigned_long; ! cs : unsigned_short; ! eflags : unsigned_long; ! esp_at_signal : unsigned_long; ! ss : unsigned_short; ! fpstate : System.Address; ! oldmask : unsigned_long; ! cr2 : unsigned_long); ! ! function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID); ! ! function To_Address is new Unchecked_Conversion (Task_ID, System.Address); ! ! function To_pthread_t is new Unchecked_Conversion ! (Integer, System.OS_Interface.pthread_t); -------------------- -- Local Packages -- --- 141,148 ---- Mutex_Attr : aliased pthread_mutexattr_t; Cond_Attr : aliased pthread_condattr_t; ! Foreign_Task_Elaborated : aliased Boolean := True; ! -- Used to identified fake tasks (i.e., non-Ada Threads). -------------------- -- Local Packages -- *************** package body System.Task_Primitives.Oper *** 193,198 **** --- 154,163 ---- pragma Inline (Initialize); -- Initialize various data needed by this package. + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + procedure Set (Self_Id : Task_ID); pragma Inline (Set); -- Set the self id for the current task. *************** package body System.Task_Primitives.Oper *** 206,297 **** package body Specific is separate; -- The body of this package is target specific. ! ------------------- ! -- Abort_Handler -- ! ------------------- ! ! -- Target-dependent binding of inter-thread Abort signal to ! -- the raising of the Abort_Signal exception. ! ! -- The technical issues and alternatives here are essentially ! -- the same as for raising exceptions in response to other ! -- signals (e.g. Storage_Error). See code and comments in ! -- the package body System.Interrupt_Management. ! -- Some implementations may not allow an exception to be propagated ! -- out of a handler, and others might leave the signal or ! -- interrupt that invoked this handler masked after the exceptional ! -- return to the application code. ! -- GNAT exceptions are originally implemented using setjmp()/longjmp(). ! -- On most UNIX systems, this will allow transfer out of a signal handler, ! -- which is usually the only mechanism available for implementing ! -- asynchronous handlers of this kind. However, some ! -- systems do not restore the signal mask on longjmp(), leaving the ! -- abort signal masked. ! -- Alternative solutions include: ! -- 1. Change the PC saved in the system-dependent Context ! -- parameter to point to code that raises the exception. ! -- Normal return from this handler will then raise ! -- the exception after the mask and other system state has ! -- been restored (see example below). ! -- 2. Use siglongjmp()/sigsetjmp() to implement exceptions. ! -- 3. Unmask the signal in the Abortion_Signal exception handler ! -- (in the RTS). ! -- Note that with the new exception mechanism, it is not correct to ! -- simply "raise" an exception from a signal handler, that's why we ! -- use Raise_From_Signal_Handler ! procedure Abort_Handler ! (signo : Signal; ! gs : unsigned_short; ! fs : unsigned_short; ! es : unsigned_short; ! ds : unsigned_short; ! edi : unsigned_long; ! esi : unsigned_long; ! ebp : unsigned_long; ! esp : unsigned_long; ! ebx : unsigned_long; ! edx : unsigned_long; ! ecx : unsigned_long; ! eax : unsigned_long; ! trapno : unsigned_long; ! err : unsigned_long; ! eip : unsigned_long; ! cs : unsigned_short; ! eflags : unsigned_long; ! esp_at_signal : unsigned_long; ! ss : unsigned_short; ! fpstate : System.Address; ! oldmask : unsigned_long; ! cr2 : unsigned_long) ! is ! Self_Id : Task_ID := Self; ! Result : Interfaces.C.int; ! Old_Set : aliased sigset_t; ! function To_Machine_State_Ptr is new ! Unchecked_Conversion (Address, Machine_State_Ptr); ! -- These are not directly visible ! procedure Raise_From_Signal_Handler ! (E : Ada.Exceptions.Exception_Id; ! M : System.Address); ! pragma Import ! (Ada, Raise_From_Signal_Handler, ! "ada__exceptions__raise_from_signal_handler"); ! pragma No_Return (Raise_From_Signal_Handler); ! mstate : Machine_State_Ptr; ! message : aliased constant String := "" & ASCII.Nul; ! -- a null terminated String. begin if Self_Id.Deferral_Level = 0 and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level and then not Self_Id.Aborting --- 171,215 ---- package body Specific is separate; -- The body of this package is target specific. ! --------------------------------- ! -- Support for foreign threads -- ! --------------------------------- ! function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; ! -- Allocate and Initialize a new ATCB for the current Thread. ! function Register_Foreign_Thread ! (Thread : Thread_Id) return Task_ID is separate; ! ----------------------- ! -- Local Subprograms -- ! ----------------------- ! subtype unsigned_long is Interfaces.C.unsigned_long; ! procedure Abort_Handler (signo : Signal); ! function To_Address is new Unchecked_Conversion (Task_ID, System.Address); ! function To_pthread_t is new Unchecked_Conversion ! (unsigned_long, System.OS_Interface.pthread_t); ! ------------------- ! -- Abort_Handler -- ! ------------------- ! procedure Abort_Handler (signo : Signal) is ! pragma Unreferenced (signo); ! Self_Id : constant Task_ID := Self; ! Result : Interfaces.C.int; ! Old_Set : aliased sigset_t; begin + if ZCX_By_Default and then GCC_ZCX_Support then + return; + end if; + if Self_Id.Deferral_Level = 0 and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level and then not Self_Id.Aborting *************** package body System.Task_Primitives.Oper *** 304,319 **** Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); pragma Assert (Result = 0); ! mstate := To_Machine_State_Ptr (SSL.Get_Machine_State_Addr.all); ! mstate.eip := eip; ! mstate.ebx := ebx; ! mstate.esp := esp_at_signal; ! mstate.ebp := ebp; ! mstate.esi := esi; ! mstate.edi := edi; ! ! Raise_From_Signal_Handler ! (Standard'Abort_Signal'Identity, message'Address); end if; end Abort_Handler; --- 222,228 ---- Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); pragma Assert (Result = 0); ! raise Standard'Abort_Signal; end if; end Abort_Handler; *************** package body System.Task_Primitives.Oper *** 339,348 **** -- Stack_Guard -- ----------------- ! -- The underlying thread system extends the memory (up to 2MB) when ! -- needed. procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is begin null; end Stack_Guard; --- 248,259 ---- -- Stack_Guard -- ----------------- ! -- The underlying thread system extends the memory (up to 2MB) when needed procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Unreferenced (T); + pragma Unreferenced (On); + begin null; end Stack_Guard; *************** package body System.Task_Primitives.Oper *** 367,383 **** --------------------- -- Note: mutexes and cond_variables needed per-task basis are ! -- initialized in Initialize_TCB and the Storage_Error is ! -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) ! -- used in RTS is initialized before any status change of RTS. ! -- Therefore rasing Storage_Error in the following routines ! -- should be able to be handled safely. procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is Result : Interfaces.C.int; begin if Priority_Ceiling_Emulation then L.Ceiling := Prio; --- 278,295 ---- --------------------- -- Note: mutexes and cond_variables needed per-task basis are ! -- initialized in Initialize_TCB and the Storage_Error is ! -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) ! -- used in RTS is initialized before any status change of RTS. ! -- Therefore rasing Storage_Error in the following routines ! -- should be able to be handled safely. procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is Result : Interfaces.C.int; + begin if Priority_Ceiling_Emulation then L.Ceiling := Prio; *************** package body System.Task_Primitives.Oper *** 394,399 **** --- 306,313 ---- end Initialize_Lock; procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Unreferenced (Level); + Result : Interfaces.C.int; begin *************** package body System.Task_Primitives.Oper *** 432,466 **** procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is Result : Interfaces.C.int; begin if Priority_Ceiling_Emulation then declare Self_ID : constant Task_ID := Self; begin if Self_ID.Common.LL.Active_Priority > L.Ceiling then Ceiling_Violation := True; return; end if; L.Saved_Priority := Self_ID.Common.LL.Active_Priority; if Self_ID.Common.LL.Active_Priority < L.Ceiling then Self_ID.Common.LL.Active_Priority := L.Ceiling; end if; Result := pthread_mutex_lock (L.L'Access); pragma Assert (Result = 0); Ceiling_Violation := False; end; else Result := pthread_mutex_lock (L.L'Access); Ceiling_Violation := Result = EINVAL; ! -- assumes the cause of EINVAL is a priority ceiling violation pragma Assert (Result = 0 or else Result = EINVAL); end if; end Write_Lock; procedure Write_Lock ! (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin if not Single_Lock or else Global_Lock then Result := pthread_mutex_lock (L); --- 346,390 ---- procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is Result : Interfaces.C.int; + begin if Priority_Ceiling_Emulation then declare Self_ID : constant Task_ID := Self; + begin if Self_ID.Common.LL.Active_Priority > L.Ceiling then Ceiling_Violation := True; return; end if; + L.Saved_Priority := Self_ID.Common.LL.Active_Priority; + if Self_ID.Common.LL.Active_Priority < L.Ceiling then Self_ID.Common.LL.Active_Priority := L.Ceiling; end if; + Result := pthread_mutex_lock (L.L'Access); pragma Assert (Result = 0); Ceiling_Violation := False; end; + else Result := pthread_mutex_lock (L.L'Access); Ceiling_Violation := Result = EINVAL; ! ! -- Assume the cause of EINVAL is a priority ceiling violation ! pragma Assert (Result = 0 or else Result = EINVAL); end if; end Write_Lock; procedure Write_Lock ! (L : access RTS_Lock; ! Global_Lock : Boolean := False) is Result : Interfaces.C.int; + begin if not Single_Lock or else Global_Lock then Result := pthread_mutex_lock (L); *************** package body System.Task_Primitives.Oper *** 470,475 **** --- 394,400 ---- procedure Write_Lock (T : Task_ID) is Result : Interfaces.C.int; + begin if not Single_Lock then Result := pthread_mutex_lock (T.Common.LL.L'Access); *************** package body System.Task_Primitives.Oper *** 492,508 **** --- 417,437 ---- procedure Unlock (L : access Lock) is Result : Interfaces.C.int; + begin if Priority_Ceiling_Emulation then declare Self_ID : constant Task_ID := Self; + begin Result := pthread_mutex_unlock (L.L'Access); pragma Assert (Result = 0); + if Self_ID.Common.LL.Active_Priority > L.Saved_Priority then Self_ID.Common.LL.Active_Priority := L.Saved_Priority; end if; end; + else Result := pthread_mutex_unlock (L.L'Access); pragma Assert (Result = 0); *************** package body System.Task_Primitives.Oper *** 511,516 **** --- 440,446 ---- procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; + begin if not Single_Lock or else Global_Lock then Result := pthread_mutex_unlock (L); *************** package body System.Task_Primitives.Oper *** 520,525 **** --- 450,456 ---- procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; + begin if not Single_Lock then Result := pthread_mutex_unlock (T.Common.LL.L'Access); *************** package body System.Task_Primitives.Oper *** 532,541 **** ----------- procedure Sleep ! (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is Result : Interfaces.C.int; begin pragma Assert (Self_ID = Self); --- 463,475 ---- ----------- procedure Sleep ! (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin pragma Assert (Self_ID = Self); *************** package body System.Task_Primitives.Oper *** 567,576 **** --- 501,513 ---- Timedout : out Boolean; Yielded : out Boolean) is + pragma Unreferenced (Reason); + Check_Time : constant Duration := Monotonic_Clock; Abs_Time : Duration; Request : aliased timespec; Result : Interfaces.C.int; + begin Timedout := True; Yielded := False; *************** package body System.Task_Primitives.Oper *** 718,725 **** ------------ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is Result : Interfaces.C.int; - begin Result := pthread_cond_signal (T.Common.LL.CV'Access); pragma Assert (Result = 0); --- 655,662 ---- ------------ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); Result : Interfaces.C.int; begin Result := pthread_cond_signal (T.Common.LL.CV'Access); pragma Assert (Result = 0); *************** package body System.Task_Primitives.Oper *** 731,737 **** procedure Yield (Do_Yield : Boolean := True) is Result : Interfaces.C.int; ! begin if Do_Yield then Result := sched_yield; --- 668,674 ---- procedure Yield (Do_Yield : Boolean := True) is Result : Interfaces.C.int; ! pragma Unreferenced (Result); begin if Do_Yield then Result := sched_yield; *************** package body System.Task_Primitives.Oper *** 743,752 **** ------------------ procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is Result : Interfaces.C.int; Param : aliased struct_sched_param; --- 680,691 ---- ------------------ procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is + pragma Unreferenced (Loss_Of_Inheritance); + Result : Interfaces.C.int; Param : aliased struct_sched_param; *************** package body System.Task_Primitives.Oper *** 821,826 **** --- 760,784 ---- return new Ada_Task_Control_Block (Entry_Num); end New_ATCB; + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + -------------------- -- Initialize_TCB -- -------------------- *************** package body System.Task_Primitives.Oper *** 875,880 **** --- 833,840 ---- Priority : System.Any_Priority; Succeeded : out Boolean) is + Adjusted_Stack_Size : Interfaces.C.size_t; + Attributes : aliased pthread_attr_t; Result : Interfaces.C.int; *************** package body System.Task_Primitives.Oper *** 882,897 **** Unchecked_Conversion (System.Address, Thread_Body); begin Result := pthread_attr_init (Attributes'Access); pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 or else Stack_Size > Max_Stack_Size then Succeeded := False; return; end if; ! Result := pthread_attr_setdetachstate ! (Attributes'Access, PTHREAD_CREATE_DETACHED); pragma Assert (Result = 0); -- Since the initial signal mask of a thread is inherited from the --- 842,873 ---- Unchecked_Conversion (System.Address, Thread_Body); begin + if Stack_Size = Unspecified_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size); + + elsif Stack_Size < Minimum_Stack_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); + + else + Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); + end if; + Result := pthread_attr_init (Attributes'Access); pragma Assert (Result = 0 or else Result = ENOMEM); ! if Result /= 0 then Succeeded := False; return; end if; ! Result := ! pthread_attr_setstacksize ! (Attributes'Access, Adjusted_Stack_Size); ! pragma Assert (Result = 0); ! ! Result := ! pthread_attr_setdetachstate ! (Attributes'Access, PTHREAD_CREATE_DETACHED); pragma Assert (Result = 0); -- Since the initial signal mask of a thread is inherited from the *************** package body System.Task_Primitives.Oper *** 921,926 **** --- 897,903 ---- procedure Finalize_TCB (T : Task_ID) is Result : Interfaces.C.int; Tmp : Task_ID := T; + Is_Self : constant Boolean := T = Self; procedure Free is new Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); *************** package body System.Task_Primitives.Oper *** 939,944 **** --- 916,927 ---- end if; Free (Tmp); + + if Is_Self then + Result := pthread_setspecific (ATCB_Key, System.Null_Address); + pragma Assert (Result = 0); + end if; + end Finalize_TCB; --------------- *************** package body System.Task_Primitives.Oper *** 947,953 **** procedure Exit_Task is begin ! pthread_exit (System.Null_Address); end Exit_Task; ---------------- --- 930,936 ---- procedure Exit_Task is begin ! Specific.Set (null); end Exit_Task; ---------------- *************** package body System.Task_Primitives.Oper *** 967,976 **** -- Check_Exit -- ---------------- ! -- Dummy versions. The only currently working versions is for solaris ! -- (native). function Check_Exit (Self_ID : ST.Task_ID) return Boolean is begin return True; end Check_Exit; --- 950,960 ---- -- Check_Exit -- ---------------- ! -- Dummy version function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + begin return True; end Check_Exit; *************** package body System.Task_Primitives.Oper *** 980,985 **** --- 964,971 ---- -------------------- function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + begin return True; end Check_No_Locks; *************** package body System.Task_Primitives.Oper *** 999,1005 **** function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin if T.Common.LL.Thread /= Thread_Self then return pthread_kill (T.Common.LL.Thread, SIGSTOP) = 0; --- 985,992 ---- function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean ! is begin if T.Common.LL.Thread /= Thread_Self then return pthread_kill (T.Common.LL.Thread, SIGSTOP) = 0; *************** package body System.Task_Primitives.Oper *** 1014,1020 **** function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin if T.Common.LL.Thread /= Thread_Self then return pthread_kill (T.Common.LL.Thread, SIGCONT) = 0; --- 1001,1008 ---- function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean ! is begin if T.Common.LL.Thread /= Thread_Self then return pthread_kill (T.Common.LL.Thread, SIGCONT) = 0; *************** package body System.Task_Primitives.Oper *** 1028,1037 **** ---------------- procedure Initialize (Environment_Task : Task_ID) is ! act : aliased struct_sigaction; ! old_act : aliased struct_sigaction; ! Tmp_Set : aliased sigset_t; ! Result : Interfaces.C.int; begin Environment_Task_ID := Environment_Task; --- 1016,1039 ---- ---------------- procedure Initialize (Environment_Task : Task_ID) is ! act : aliased struct_sigaction; ! old_act : aliased struct_sigaction; ! Tmp_Set : aliased sigset_t; ! Result : Interfaces.C.int; ! ! function State (Int : System.Interrupt_Management.Interrupt_ID) ! return Character; ! pragma Import (C, State, "__gnat_get_interrupt_state"); ! -- Get interrupt state. Defined in a-init.c ! -- The input argument is the interrupt number, ! -- and the result is one of the following: ! ! Default : constant Character := 's'; ! -- 'n' this interrupt not set by any Interrupt_State pragma ! -- 'u' Interrupt_State pragma set state to User ! -- 'r' Interrupt_State pragma set state to Runtime ! -- 's' Interrupt_State pragma set state to System (use "default" ! -- system handler) begin Environment_Task_ID := Environment_Task; *************** package body System.Task_Primitives.Oper *** 1043,1048 **** --- 1045,1051 ---- pragma Assert (Result = 0 or else Result = ENOMEM); Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + -- Initialize the global RTS lock Specific.Initialize (Environment_Task); *************** package body System.Task_Primitives.Oper *** 1051,1074 **** -- Install the abort-signal handler ! act.sa_flags := 0; ! act.sa_handler := Abort_Handler'Address; ! Result := sigemptyset (Tmp_Set'Access); ! pragma Assert (Result = 0); ! act.sa_mask := Tmp_Set; ! Result := ! sigaction ! (Signal (Interrupt_Management.Abort_Task_Interrupt), ! act'Unchecked_Access, ! old_act'Unchecked_Access); ! pragma Assert (Result = 0); end Initialize; begin declare Result : Interfaces.C.int; begin -- Mask Environment task for all signals. The original mask of the -- Environment task will be recovered by Interrupt_Server task --- 1054,1082 ---- -- Install the abort-signal handler ! if State (System.Interrupt_Management.Abort_Task_Interrupt) ! /= Default ! then ! act.sa_flags := 0; ! act.sa_handler := Abort_Handler'Address; ! Result := sigemptyset (Tmp_Set'Access); ! pragma Assert (Result = 0); ! act.sa_mask := Tmp_Set; ! Result := ! sigaction ! (Signal (Interrupt_Management.Abort_Task_Interrupt), ! act'Unchecked_Access, ! old_act'Unchecked_Access); ! pragma Assert (Result = 0); ! end if; end Initialize; begin declare Result : Interfaces.C.int; + begin -- Mask Environment task for all signals. The original mask of the -- Environment task will be recovered by Interrupt_Server task diff -Nrc3pad gcc-3.3.3/gcc/ada/5itaspri.ads gcc-3.4.0/gcc/ada/5itaspri.ads *** gcc-3.3.3/gcc/ada/5itaspri.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5itaspri.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1991-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/5ksystem.ads gcc-3.4.0/gcc/ada/5ksystem.ads *** gcc-3.3.3/gcc/ada/5ksystem.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5ksystem.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 7,14 **** -- S p e c -- -- (VxWorks version M68K) -- -- -- ! -- -- ! -- Copyright (C) 1992-2002 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 -- --- 7,13 ---- -- S p e c -- -- (VxWorks version M68K) -- -- -- ! -- Copyright (C) 1992-2003 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 -- *************** pragma Pure (System); *** 59,65 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := 1.0; -- Storage-related Declarations --- 58,64 ---- Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := 1.0 / 60.0; -- Storage-related Declarations *************** private *** 127,147 **** Backend_Divide_Checks : constant Boolean := False; Backend_Overflow_Checks : constant Boolean := False; Command_Line_Args : constant Boolean := False; Denorm : constant Boolean := True; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; Functions_Return_By_DSP : constant Boolean := False; - Long_Shifts_Inlined : constant Boolean := False; - High_Integrity_Mode : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; Signed_Zeros : constant Boolean := False; Stack_Check_Default : constant Boolean := False; Stack_Check_Probes : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := True; ZCX_By_Default : constant Boolean := False; GCC_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := False; end System; --- 126,158 ---- Backend_Divide_Checks : constant Boolean := False; Backend_Overflow_Checks : constant Boolean := False; Command_Line_Args : constant Boolean := False; + Configurable_Run_Time : constant Boolean := False; Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; Functions_Return_By_DSP : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; Signed_Zeros : constant Boolean := False; Stack_Check_Default : constant Boolean := False; Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := True; ZCX_By_Default : constant Boolean := False; GCC_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := False; + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := False; + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/5kvxwork.ads gcc-3.4.0/gcc/ada/5kvxwork.ads *** gcc-3.3.3/gcc/ada/5kvxwork.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5kvxwork.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/5lintman.adb gcc-3.4.0/gcc/ada/5lintman.adb *** gcc-3.3.3/gcc/ada/5lintman.adb 2002-03-14 10:58:34.000000000 +0000 --- gcc-3.4.0/gcc/ada/5lintman.adb 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,345 **** - ------------------------------------------------------------------------------ - -- -- - -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- - -- -- - -- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- - -- -- - -- B o d y -- - -- -- - -- -- - -- Copyright (C) 1991-2002 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 GNU/Linux version of this package - - -- This file performs the system-dependent translation between machine - -- exceptions and the Ada exceptions, if any, that should be raised when they - -- occur. This version works for the x86 running linux. - - -- This is a Sun OS (FSU THREADS) version of this package - - -- PLEASE DO NOT add any dependences on other packages. ??? why not ??? - -- This package is designed to work with or without tasking support. - - -- Make a careful study of all signals available under the OS, to see which - -- need to be reserved, kept always unmasked, or kept always unmasked. Be on - -- the lookout for special signals that may be used by the thread library. - - -- The definitions of "reserved" differ slightly between the ARM and POSIX. - -- Here is the ARM definition of reserved interrupt: - - -- The set of reserved interrupts is implementation defined. A reserved - -- interrupt is either an interrupt for which user-defined handlers are not - -- supported, or one which already has an attached handler by some other - -- implementation-defined means. Program units can be connected to - -- non-reserved interrupts. - - -- POSIX.5b/.5c specifies further: - - -- Signals which the application cannot accept, and for which the application - -- cannot modify the signal action or masking, because the signals are - -- reserved for use by the Ada language implementation. The reserved signals - -- defined by this standard are Signal_Abort, Signal_Alarm, - -- Signal_Floating_Point_Error, Signal_Illegal_Instruction, - -- Signal_Segmentation_Violation, Signal_Bus_Error. If the implementation - -- supports any signals besides those defined by this standard, the - -- implementation may also reserve some of those. - - -- The signals defined by POSIX.5b/.5c that are not specified as being - -- reserved are SIGHUP, SIGINT, SIGPIPE, SIGQUIT, SIGTERM, SIGUSR1, SIGUSR2, - -- SIGCHLD, SIGCONT, SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU, SIGIO SIGURG, and all - -- the real-time signals. - - -- Beware of reserving signals that POSIX.5b/.5c require to be available for - -- users. POSIX.5b/.5c say: - - -- An implementation shall not impose restrictions on the ability of an - -- application to send, accept, block, or ignore the signals defined by this - -- standard, except as specified in this standard. - - -- Here are some other relevant requirements from POSIX.5b/.5c: - - -- For the environment task, the initial signal mask is that specified for - -- the process... - - -- It is anticipated that the paragraph above may be modified by a future - -- revision of this standard, to require that the realtime signals always be - -- initially masked for a process that is an Ada active partition. - - -- For all other tasks, the initial signal mask shall include all the signals - -- that are not reserved signals and are not bound to entries of the task. - - with Interfaces.C; - -- used for int and other types - - with System.Error_Reporting; - -- used for Shutdown - - with System.OS_Interface; - -- used for various Constants, Signal and types - - with Ada.Exceptions; - -- used for Exception_Id - -- Raise_From_Signal_Handler - - with System.Soft_Links; - -- used for Get_Machine_State_Addr - - with Unchecked_Conversion; - - package body System.Interrupt_Management is - - use Interfaces.C; - use System.Error_Reporting; - use System.OS_Interface; - - package TSL renames System.Soft_Links; - - type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID; - Exception_Interrupts : constant Interrupt_List := - (SIGFPE, SIGILL, SIGSEGV); - - Unreserve_All_Interrupts : Interfaces.C.int; - pragma Import - (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); - - subtype int is Interfaces.C.int; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - - ---------------------- - -- Notify_Exception -- - ---------------------- - - Signal_Mask : aliased sigset_t; - -- The set of signals handled by Notify_Exception - - -- This function identifies the Ada exception to be raised using - -- the information when the system received a synchronous signal. - -- Since this function is machine and OS dependent, different code - -- has to be provided for different target. - - procedure Notify_Exception - (signo : Signal; - gs : unsigned_short; - fs : unsigned_short; - es : unsigned_short; - ds : unsigned_short; - edi : unsigned_long; - esi : unsigned_long; - ebp : unsigned_long; - esp : unsigned_long; - ebx : unsigned_long; - edx : unsigned_long; - ecx : unsigned_long; - eax : unsigned_long; - trapno : unsigned_long; - err : unsigned_long; - eip : unsigned_long; - cs : unsigned_short; - eflags : unsigned_long; - esp_at_signal : unsigned_long; - ss : unsigned_short; - fpstate : System.Address; - oldmask : unsigned_long; - cr2 : unsigned_long); - - procedure Notify_Exception - (signo : Signal; - gs : unsigned_short; - fs : unsigned_short; - es : unsigned_short; - ds : unsigned_short; - edi : unsigned_long; - esi : unsigned_long; - ebp : unsigned_long; - esp : unsigned_long; - ebx : unsigned_long; - edx : unsigned_long; - ecx : unsigned_long; - eax : unsigned_long; - trapno : unsigned_long; - err : unsigned_long; - eip : unsigned_long; - cs : unsigned_short; - eflags : unsigned_long; - esp_at_signal : unsigned_long; - ss : unsigned_short; - fpstate : System.Address; - oldmask : unsigned_long; - cr2 : unsigned_long) - is - - function To_Machine_State_Ptr is new - Unchecked_Conversion (Address, Machine_State_Ptr); - - -- These are not directly visible - - procedure Raise_From_Signal_Handler - (E : Ada.Exceptions.Exception_Id; - M : System.Address); - pragma Import - (Ada, Raise_From_Signal_Handler, - "ada__exceptions__raise_from_signal_handler"); - pragma No_Return (Raise_From_Signal_Handler); - - mstate : Machine_State_Ptr; - message : aliased constant String := "" & ASCII.Nul; - -- a null terminated String. - - Result : int; - - begin - - -- Raise_From_Signal_Handler makes sure that the exception is raised - -- safely from this signal handler. - - -- ??? The original signal mask (the one we had before coming into this - -- signal catching function) should be restored by - -- Raise_From_Signal_Handler. For now, restore it explicitly - - Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null); - pragma Assert (Result = 0); - - -- Check that treatment of exception propagation here - -- is consistent with treatment of the abort signal in - -- System.Task_Primitives.Operations. - - mstate := To_Machine_State_Ptr (TSL.Get_Machine_State_Addr.all); - mstate.eip := eip; - mstate.ebx := ebx; - mstate.esp := esp_at_signal; - mstate.ebp := ebp; - mstate.esi := esi; - mstate.edi := edi; - - case signo is - when SIGFPE => - Raise_From_Signal_Handler - (Constraint_Error'Identity, message'Address); - when SIGILL => - Raise_From_Signal_Handler - (Constraint_Error'Identity, message'Address); - when SIGSEGV => - Raise_From_Signal_Handler - (Storage_Error'Identity, message'Address); - when others => - if Shutdown ("Unexpected signal") then - null; - end if; - end case; - end Notify_Exception; - - --------------------------- - -- Initialize_Interrupts -- - --------------------------- - - -- Nothing needs to be done on this platform. - - procedure Initialize_Interrupts is - begin - null; - end Initialize_Interrupts; - - begin - declare - act : aliased struct_sigaction; - old_act : aliased struct_sigaction; - Result : int; - - begin - - -- Need to call pthread_init very early because it is doing signal - -- initializations. - - pthread_init; - - Abort_Task_Interrupt := SIGADAABORT; - - act.sa_handler := Notify_Exception'Address; - - act.sa_flags := 0; - -- On some targets, we set sa_flags to SA_NODEFER so that during the - -- handler execution we do not change the Signal_Mask to be masked for - -- the Signal. - -- This is a temporary fix to the problem that the Signal_Mask is - -- not restored after the exception (longjmp) from the handler. - -- The right fix should be made in sigsetjmp so that we save - -- the Signal_Set and restore it after a longjmp. - -- Since SA_NODEFER is obsolete, instead we reset explicitly - -- the mask in the exception handler. - - Result := sigemptyset (Signal_Mask'Access); - pragma Assert (Result = 0); - - for J in Exception_Interrupts'Range loop - Result := - sigaddset (Signal_Mask'Access, Signal (Exception_Interrupts (J))); - pragma Assert (Result = 0); - end loop; - - act.sa_mask := Signal_Mask; - - for J in Exception_Interrupts'Range loop - Keep_Unmasked (Exception_Interrupts (J)) := True; - Result := - sigaction - (Signal (Exception_Interrupts (J)), - act'Unchecked_Access, - old_act'Unchecked_Access); - pragma Assert (Result = 0); - end loop; - - Keep_Unmasked (Abort_Task_Interrupt) := True; - - -- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but in the - -- same time, disable the ability of handling this signal - -- via Ada.Interrupts. - -- The pragma Unreserve_All_Interrupts allows the user to - -- change this behavior. - - if Unreserve_All_Interrupts = 0 then - Keep_Unmasked (SIGINT) := True; - end if; - - for J in Unmasked'Range loop - Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True; - end loop; - - Reserve := Keep_Unmasked or Keep_Masked; - - for J in Reserved'Range loop - Reserve (Interrupt_ID (Reserved (J))) := True; - end loop; - - Reserve (0) := True; - -- We do not have Signal 0 in reality. We just use this value - -- to identify non-existent signals (see s-intnam.ads). Therefore, - -- Signal 0 should not be used in all signal related operations hence - -- mark it as reserved. - - end; - end System.Interrupt_Management; --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5lml-tgt.adb gcc-3.4.0/gcc/ada/5lml-tgt.adb *** gcc-3.3.3/gcc/ada/5lml-tgt.adb 2002-03-14 10:58:34.000000000 +0000 --- gcc-3.4.0/gcc/ada/5lml-tgt.adb 2004-01-05 15:20:42.000000000 +0000 *************** *** 7,14 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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- -- --- 7,13 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2003, 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- -- *************** *** 22,28 **** -- MA 02111-1307, USA. -- -- -- -- 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). -- -- -- ------------------------------------------------------------------------------ --- 21,27 ---- -- MA 02111-1307, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ *************** *** 31,44 **** -- This is the GNU/Linux version of the body. - with Ada.Characters.Handling; use Ada.Characters.Handling; - with GNAT.Directory_Operations; use GNAT.Directory_Operations; with MLib.Fil; with MLib.Utl; ! with Namet; use Namet; with Opt; ! with Osint; use Osint; ! with Output; use Output; with System; package body MLib.Tgt is --- 30,41 ---- -- This is the GNU/Linux version of the body. with MLib.Fil; with MLib.Utl; ! with Namet; use Namet; with Opt; ! with Output; use Output; ! with Prj.Com; with System; package body MLib.Tgt is *************** package body MLib.Tgt is *** 46,85 **** use GNAT; use MLib; ! -- ??? serious lack of comments below, all these declarations need to ! -- be commented, none are: ! ! package Files renames MLib.Fil; ! package Tools renames MLib.Utl; ! ! Args : Argument_List_Access := new Argument_List (1 .. 20); ! Last_Arg : Natural := 0; ! Cp : constant String_Access := Locate_Exec_On_Path ("cp"); ! Force : constant String_Access := new String'("-f"); ! procedure Add_Arg (Arg : String); ! ------------- ! -- Add_Arg -- ! ------------- ! procedure Add_Arg (Arg : String) is begin ! if Last_Arg = Args'Last then ! declare ! New_Args : constant Argument_List_Access := ! new Argument_List (1 .. Args'Last * 2); ! begin ! New_Args (Args'Range) := Args.all; ! Args := New_Args; ! end; ! end if; ! Last_Arg := Last_Arg + 1; ! Args (Last_Arg) := new String'(Arg); ! end Add_Arg; ----------------- -- Archive_Ext -- --- 43,80 ---- use GNAT; use MLib; ! No_Arguments : aliased Argument_List := (1 .. 0 => null); ! Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; ! Wl_Init_String : aliased String := "-Wl,-init"; ! Wl_Init : constant String_Access := Wl_Init_String'Access; ! Wl_Fini_String : aliased String := "-Wl,-fini"; ! Wl_Fini : constant String_Access := Wl_Fini_String'Access; ! Init_Fini_List : constant Argument_List_Access := ! new Argument_List'(1 => Wl_Init, ! 2 => null, ! 3 => Wl_Fini, ! 4 => null); ! -- Used to put switches for automatic elaboration/finalization ! --------------------- ! -- Archive_Builder -- ! --------------------- ! function Archive_Builder return String is begin ! return "ar"; ! end Archive_Builder; ! ----------------------------- ! -- Archive_Builder_Options -- ! ----------------------------- ! function Archive_Builder_Options return String_List_Access is ! begin ! return new String_List'(1 => new String'("cr")); ! end Archive_Builder_Options; ----------------- -- Archive_Ext -- *************** package body MLib.Tgt is *** 87,103 **** function Archive_Ext return String is begin ! return "a"; end Archive_Ext; ! ----------------- ! -- Base_Option -- ! ----------------- ! function Base_Option return String is begin ! return ""; ! end Base_Option; --------------------------- -- Build_Dynamic_Library -- --- 82,98 ---- function Archive_Ext return String is begin ! return "a"; end Archive_Ext; ! --------------------- ! -- Archive_Indexer -- ! --------------------- ! function Archive_Indexer return String is begin ! return "ranlib"; ! end Archive_Indexer; --------------------------- -- Build_Dynamic_Library -- *************** package body MLib.Tgt is *** 108,157 **** Foreign : Argument_List; Afiles : Argument_List; Options : Argument_List; Lib_Filename : String; Lib_Dir : String; Lib_Address : String := ""; Lib_Version : String := ""; ! Relocatable : Boolean := False) is Lib_File : constant String := Lib_Dir & Directory_Separator & "lib" & ! Files.Ext_To (Lib_Filename, DLL_Ext); ! ! use type Argument_List; ! use type String_Access; ! ! Version_Arg : String_Access; Symbolic_Link_Needed : Boolean := False; begin if Opt.Verbose_Mode then Write_Str ("building relocatable shared library "); Write_Line (Lib_File); end if; if Lib_Version = "" then ! Tools.Gcc (Output_File => Lib_File, Objects => Ofiles, ! Options => Options); else Version_Arg := new String'("-Wl,-soname," & Lib_Version); if Is_Absolute_Path (Lib_Version) then ! Tools.Gcc (Output_File => Lib_Version, Objects => Ofiles, ! Options => Options & Version_Arg); Symbolic_Link_Needed := Lib_Version /= Lib_File; else ! Tools.Gcc (Output_File => Lib_Dir & Directory_Separator & Lib_Version, Objects => Ofiles, ! Options => Options & Version_Arg); Symbolic_Link_Needed := Lib_Dir & Directory_Separator & Lib_Version /= Lib_File; end if; --- 103,171 ---- Foreign : Argument_List; Afiles : Argument_List; Options : Argument_List; + Interfaces : Argument_List; Lib_Filename : String; Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; Lib_Address : String := ""; Lib_Version : String := ""; ! Relocatable : Boolean := False; ! Auto_Init : Boolean := False) is + pragma Unreferenced (Foreign); + pragma Unreferenced (Afiles); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Lib_Address); + pragma Unreferenced (Relocatable); + Lib_File : constant String := Lib_Dir & Directory_Separator & "lib" & ! Fil.Ext_To (Lib_Filename, DLL_Ext); + Version_Arg : String_Access; Symbolic_Link_Needed : Boolean := False; + Init_Fini : Argument_List_Access := Empty_Argument_List; + begin if Opt.Verbose_Mode then Write_Str ("building relocatable shared library "); Write_Line (Lib_File); end if; + -- If specified, add automatic elaboration/finalization + if Auto_Init then + Init_Fini := Init_Fini_List; + Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init"); + Init_Fini (4) := new String'("-Wl," & Lib_Filename & "final"); + end if; + if Lib_Version = "" then ! Utl.Gcc (Output_File => Lib_File, Objects => Ofiles, ! Options => Options & Init_Fini.all, ! Driver_Name => Driver_Name); else Version_Arg := new String'("-Wl,-soname," & Lib_Version); if Is_Absolute_Path (Lib_Version) then ! Utl.Gcc (Output_File => Lib_Version, Objects => Ofiles, ! Options => Options & Version_Arg & Init_Fini.all, ! Driver_Name => Driver_Name); Symbolic_Link_Needed := Lib_Version /= Lib_File; else ! Utl.Gcc (Output_File => Lib_Dir & Directory_Separator & Lib_Version, Objects => Ofiles, ! Options => Options & Version_Arg & Init_Fini.all, ! Driver_Name => Driver_Name); Symbolic_Link_Needed := Lib_Dir & Directory_Separator & Lib_Version /= Lib_File; end if; *************** package body MLib.Tgt is *** 161,172 **** Success : Boolean; Oldpath : String (1 .. Lib_Version'Length + 1); Newpath : String (1 .. Lib_File'Length + 1); ! Result : Integer; function Symlink (Oldpath : System.Address; ! Newpath : System.Address) ! return Integer; pragma Import (C, Symlink, "__gnat_symlink"); begin --- 175,187 ---- Success : Boolean; Oldpath : String (1 .. Lib_Version'Length + 1); Newpath : String (1 .. Lib_File'Length + 1); ! ! Result : Integer; ! pragma Unreferenced (Result); function Symlink (Oldpath : System.Address; ! Newpath : System.Address) return Integer; pragma Import (C, Symlink, "__gnat_symlink"); begin *************** package body MLib.Tgt is *** 183,242 **** end if; end Build_Dynamic_Library; - -------------------- - -- Copy_ALI_Files -- - -------------------- - - procedure Copy_ALI_Files - (From : Name_Id; - To : Name_Id) - is - Dir : Dir_Type; - Name : String (1 .. 1_000); - Last : Natural; - Success : Boolean; - From_Dir : constant String := Get_Name_String (From); - To_Dir : constant String_Access := - new String'(Get_Name_String (To)); - - begin - Last_Arg := 0; - Open (Dir, From_Dir); - - loop - Read (Dir, Name, Last); - exit when Last = 0; - if Last > 4 - - and then - To_Lower (Name (Last - 3 .. Last)) = ".ali" - then - Add_Arg (From_Dir & Directory_Separator & Name (1 .. Last)); - end if; - end loop; - - if Last_Arg /= 0 then - if not Opt.Quiet_Output then - Write_Str ("cp -f "); - - for J in 1 .. Last_Arg loop - Write_Str (Args (J).all); - Write_Char (' '); - end loop; - - Write_Line (To_Dir.all); - end if; - - Spawn (Cp.all, - Force & Args (1 .. Last_Arg) & To_Dir, - Success); - - if not Success then - Fail ("could not copy ALI files to library dir"); - end if; - end if; - end Copy_ALI_Files; - ------------------------- -- Default_DLL_Address -- ------------------------- --- 198,203 ---- *************** package body MLib.Tgt is *** 261,267 **** function Dynamic_Option return String is begin ! return "-shared"; end Dynamic_Option; ------------------- --- 222,228 ---- function Dynamic_Option return String is begin ! return "-shared"; end Dynamic_Option; ------------------- *************** package body MLib.Tgt is *** 300,324 **** return "libgnat.a"; end Libgnat; ! ----------------------------- ! -- Libraries_Are_Supported -- ! ----------------------------- ! function Libraries_Are_Supported return Boolean is begin ! return True; ! end Libraries_Are_Supported; -------------------------------- -- Linker_Library_Path_Option -- -------------------------------- ! function Linker_Library_Path_Option ! (Directory : String) ! return String_Access ! is begin ! return new String'("-Wl,-rpath," & Directory); end Linker_Library_Path_Option; ---------------- --- 261,338 ---- return "libgnat.a"; end Libgnat; ! ------------------------ ! -- Library_Exists_For -- ! ------------------------ ! function Library_Exists_For (Project : Project_Id) return Boolean is begin ! if not Projects.Table (Project).Library then ! Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & ! "for non library project"); ! return False; ! ! else ! declare ! Lib_Dir : constant String := ! Get_Name_String (Projects.Table (Project).Library_Dir); ! Lib_Name : constant String := ! Get_Name_String (Projects.Table (Project).Library_Name); ! ! begin ! if Projects.Table (Project).Library_Kind = Static then ! return Is_Regular_File ! (Lib_Dir & Directory_Separator & "lib" & ! Fil.Ext_To (Lib_Name, Archive_Ext)); ! ! else ! return Is_Regular_File ! (Lib_Dir & Directory_Separator & "lib" & ! Fil.Ext_To (Lib_Name, DLL_Ext)); ! end if; ! end; ! end if; ! end Library_Exists_For; ! ! --------------------------- ! -- Library_File_Name_For -- ! --------------------------- ! ! function Library_File_Name_For (Project : Project_Id) return Name_Id is ! begin ! if not Projects.Table (Project).Library then ! Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & ! "for non library project"); ! return No_Name; ! ! else ! declare ! Lib_Name : constant String := ! Get_Name_String (Projects.Table (Project).Library_Name); ! ! begin ! Name_Len := 3; ! Name_Buffer (1 .. Name_Len) := "lib"; ! ! if Projects.Table (Project).Library_Kind = Static then ! Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); ! ! else ! Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); ! end if; ! ! return Name_Find; ! end; ! end if; ! end Library_File_Name_For; -------------------------------- -- Linker_Library_Path_Option -- -------------------------------- ! function Linker_Library_Path_Option return String_Access is begin ! return new String'("-Wl,-rpath,"); end Linker_Library_Path_Option; ---------------- *************** package body MLib.Tgt is *** 327,333 **** function Object_Ext return String is begin ! return "o"; end Object_Ext; ---------------- --- 341,347 ---- function Object_Ext return String is begin ! return "o"; end Object_Ext; ---------------- *************** package body MLib.Tgt is *** 336,342 **** function PIC_Option return String is begin ! return "-fPIC"; end PIC_Option; end MLib.Tgt; --- 350,374 ---- function PIC_Option return String is begin ! return "-fPIC"; end PIC_Option; + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return True; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Full; + end Support_For_Libraries; + end MLib.Tgt; diff -Nrc3pad gcc-3.3.3/gcc/ada/5losinte.ads gcc-3.4.0/gcc/ada/5losinte.ads *** gcc-3.3.3/gcc/ada/5losinte.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5losinte.ads 2003-12-05 10:24:04.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1991-2003 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- -- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ *************** package System.OS_Interface is *** 163,168 **** --- 162,169 ---- end record; type Machine_State_Ptr is access all Machine_State; + SA_SIGINFO : constant := 16#04#; + SIG_BLOCK : constant := 0; SIG_UNBLOCK : constant := 1; SIG_SETMASK : constant := 2; diff -Nrc3pad gcc-3.3.3/gcc/ada/5lparame.adb gcc-3.4.0/gcc/ada/5lparame.adb *** gcc-3.3.3/gcc/ada/5lparame.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5lparame.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- S Y S T E M . P A R A M E T E R S -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 1995-2003 Free Software Foundation, Inc. -- + -- -- + -- GNAT is free software; you can redistribute it and/or modify it under -- + -- terms of the GNU General Public License as published by the Free Soft- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- + -- MA 02111-1307, USA. -- + -- -- + -- As a special exception, if other files instantiate generics from this -- + -- unit, or you link this unit with other files to produce an executable, -- + -- this unit does not by itself cause the resulting executable to be -- + -- covered by the GNU General Public License. This exception does not -- + -- however invalidate any other reasons why the executable file might be -- + -- covered by the GNU Public License. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the Linux (native) specific version + + package body System.Parameters is + + ------------------------- + -- Adjust_Storage_Size -- + ------------------------- + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type is + begin + if Size = Unspecified_Size then + return Default_Stack_Size; + + elsif Size < Minimum_Stack_Size then + return Minimum_Stack_Size; + + else + return Size; + end if; + end Adjust_Storage_Size; + + ------------------------ + -- Default_Stack_Size -- + ------------------------ + + function Default_Stack_Size return Size_Type is + begin + return 2 * 1024 * 1024; + end Default_Stack_Size; + + ------------------------ + -- Minimum_Stack_Size -- + ------------------------ + + function Minimum_Stack_Size return Size_Type is + begin + return 8 * 1024; + end Minimum_Stack_Size; + + end System.Parameters; diff -Nrc3pad gcc-3.3.3/gcc/ada/5lsystem.ads gcc-3.4.0/gcc/ada/5lsystem.ads *** gcc-3.3.3/gcc/ada/5lsystem.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5lsystem.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 7,14 **** -- S p e c -- -- (GNU-Linux/x86 Version) -- -- -- ! -- -- ! -- Copyright (C) 1992-2002 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 -- --- 7,13 ---- -- S p e c -- -- (GNU-Linux/x86 Version) -- -- -- ! -- Copyright (C) 1992-2003 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 -- *************** pragma Pure (System); *** 59,65 **** Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := 1.0; -- Storage-related Declarations --- 58,64 ---- Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); ! Tick : constant := 0.000_001; -- Storage-related Declarations *************** private *** 119,138 **** Backend_Divide_Checks : constant Boolean := False; Backend_Overflow_Checks : constant Boolean := False; Command_Line_Args : constant Boolean := True; Denorm : constant Boolean := True; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; Functions_Return_By_DSP : constant Boolean := False; - Long_Shifts_Inlined : constant Boolean := True; - High_Integrity_Mode : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; Stack_Check_Probes : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ! ZCX_By_Default : constant Boolean := False; ! GCC_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := False; end System; --- 118,150 ---- Backend_Divide_Checks : constant Boolean := False; Backend_Overflow_Checks : constant Boolean := False; Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; Functions_Return_By_DSP : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ! ZCX_By_Default : constant Boolean := True; ! GCC_ZCX_Support : constant Boolean := True; Front_End_ZCX_Support : constant Boolean := False; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/5mosinte.ads gcc-3.4.0/gcc/ada/5mosinte.ads *** gcc-3.3.3/gcc/ada/5mosinte.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5mosinte.ads 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,560 **** - ------------------------------------------------------------------------------ - -- -- - -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- - -- -- - -- S Y S T E M . O S _ I N T E R F A C E -- - -- -- - -- S p e c -- - -- -- - -- -- - -- Copyright (C) 1997-2001, Free Software Foundation, Inc. -- - -- -- - -- GNARL is free software; you can redistribute it and/or modify it under -- - -- terms of the GNU General Public License as published by the Free Soft- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNARL; see file COPYING. If not, write -- - -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- - -- MA 02111-1307, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNARL was developed by the GNARL team at Florida State University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This is a MACOS (FSU THREAD) version of this package. - - -- This package encapsulates all direct interfaces to OS services - -- that are needed by children of System. - - -- PLEASE DO NOT add any with-clauses to this package - -- or remove the pragma Elaborate_Body. - -- It is designed to be a bottom-level (leaf) package. - - with Interfaces.C; - package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-lgthreads"); - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 35; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - ETIMEDOUT : constant := 60; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 31; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGEMT : constant := 7; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGUSR1 : constant := 30; -- user defined signal 1 - SIGUSR2 : constant := 31; -- user defined signal 2 - SIGCLD : constant := 20; -- alias for SIGCHLD - SIGCHLD : constant := 20; -- child status change - SIGWINCH : constant := 28; -- window size change - SIGURG : constant := 16; -- urgent condition on IO channel - SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) - SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 18; -- user stop requested from tty - SIGCONT : constant := 19; -- stopped process has been continued - SIGTTIN : constant := 21; -- background tty read attempted - SIGTTOU : constant := 22; -- background tty write attempted - SIGVTALRM : constant := 26; -- virtual timer expired - SIGPROF : constant := 27; -- profiling timer expired - SIGXCPU : constant := 24; -- CPU time limit exceeded - SIGXFSZ : constant := 25; -- filesize limit exceeded - - SIGADAABORT : constant := SIGABRT; - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := (SIGTRAP, SIGALRM, SIGEMT, SIGCHLD); - Reserved : constant Signal_Set := (SIGKILL, SIGSTOP); - - type sigset_t is private; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : int; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - SIG_BLOCK : constant := 1; - SIG_UNBLOCK : constant := 2; - SIG_SETMASK : constant := 3; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - Time_Slice_Supported : constant Boolean := False; - -- Indicates wether time slicing is supported (i.e FSU threads have been - -- compiled with DEF_RR) - - type timespec is private; - - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int; - pragma Import (C, clock_gettime, "clock_gettime"); - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timeval is private; - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 0; - SCHED_RR : constant := 1; - SCHED_OTHER : constant := 2; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - --------- - -- LWP -- - --------- - - function lwp_self return System.Address; - -- lwp_self does not exist on this thread library, revert to pthread_self - -- which is the closest approximation (with getpid). This function is - -- needed to share 7staprop.adb across POSIX-like targets. - pragma Import (C, lwp_self, "pthread_self"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 1; - - ----------- - -- Stack -- - ----------- - - Stack_Base_Available : constant Boolean := False; - -- Indicates wether the stack base is available on this target. - -- This allows us to share s-osinte.adb between all the FSU run time. - -- Note that this value can only be true if pthread_t has a complete - -- definition that corresponds exactly to the C header files. - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- returns the stack base of the specified thread. - -- Only call this function when Stack_Base_Available is True. - - function Get_Page_Size return size_t; - function Get_Page_Size return Address; - pragma Import (C, Get_Page_Size, "getpagesize"); - -- returns the size of a page, or 0 if this is not relevant on this - -- target - - PROT_NONE : constant := 0; - PROT_READ : constant := 1; - PROT_WRITE : constant := 2; - PROT_EXEC : constant := 4; - PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; - - PROT_ON : constant := PROT_NONE; - PROT_OFF : constant := PROT_ALL; - - function mprotect (addr : Address; len : size_t; prot : int) return int; - pragma Import (C, mprotect); - - --------------------------------------- - -- Nonstandard Thread Initialization -- - --------------------------------------- - - procedure pthread_init; - -- FSU_THREADS requires pthread_init, which is nonstandard - -- and this should be invoked during the elaboration of s-taprop.adb - pragma Import (C, pthread_init, "pthread_init"); - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait - (set : access sigset_t; - sig : access Signal) return int; - -- FSU_THREADS has a nonstandard sigwait - - function pthread_kill - (thread : pthread_t; - sig : Signal) return int; - pragma Import (C, pthread_kill, "pthread_kill"); - - type sigset_t_ptr is access all sigset_t; - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) - return int; - pragma Import (C, pthread_sigmask, "sigprocmask"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - -- FSU_THREADS has nonstandard pthread_mutex_lock - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - -- FSU_THREADS has nonstandard pthread_mutex_lock - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "pthread_cond_init"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - -- FSU_THREADS has a nonstandard pthread_cond_wait - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - -- FSU_THREADS has a nonstandard pthread_cond_timedwait - - Relative_Timed_Wait : constant Boolean := False; - -- pthread_cond_timedwait requires an absolute delay time - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - PTHREAD_PRIO_NONE : constant := 0; - PTHREAD_PRIO_PROTECT : constant := 2; - PTHREAD_PRIO_INHERIT : constant := 1; - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) return int; - pragma Import (C, pthread_mutexattr_setprotocol); - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int; - pragma Import - (C, pthread_mutexattr_setprioceiling, - "pthread_mutexattr_setprio_ceiling"); - - type struct_sched_param is record - sched_priority : int; -- scheduling priority - end record; - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - -- FSU_THREADS does not have pthread_setschedparam - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; - inheritsched : int) return int; - pragma Import (C, pthread_attr_setinheritsched); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; - policy : int) return int; - pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched"); - - function pthread_attr_setschedparam - (attr : access pthread_attr_t; - sched_param : int) return int; - pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam"); - - function sched_yield return int; - -- FSU_THREADS does not have sched_yield; - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "pthread_attr_init"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - -- FSU_THREADS has a nonstandard pthread_attr_setdetachstate - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "pthread_create"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "pthread_setspecific"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - -- FSU_THREADS has a nonstandard pthread_getspecific - - type destructor_pointer is access procedure (arg : System.Address); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "pthread_key_create"); - - private - - type sigset_t is new int; - - type pid_t is new int; - - type time_t is new long; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 0; - - type struct_timeval is record - tv_sec : long; - tv_usec : long; - end record; - pragma Convention (C, struct_timeval); - - type pthread_attr_t is record - flags : int; - stacksize : int; - contentionscope : int; - inheritsched : int; - detachstate : int; - sched : int; - prio : int; - starttime : timespec; - deadline : timespec; - period : timespec; - end record; - pragma Convention (C, pthread_attr_t); - - type pthread_condattr_t is record - flags : int; - end record; - pragma Convention (C, pthread_condattr_t); - - type pthread_mutexattr_t is record - flags : int; - prio_ceiling : int; - protocol : int; - end record; - pragma Convention (C, pthread_mutexattr_t); - - type sigjmp_buf is array (Integer range 0 .. 9) of int; - - type pthread_t_struct is record - context : sigjmp_buf; - pbody : sigjmp_buf; - errno : int; - ret : int; - stack_base : System.Address; - end record; - pragma Convention (C, pthread_t_struct); - - type pthread_t is access all pthread_t_struct; - - type queue_t is record - head : System.Address; - tail : System.Address; - end record; - pragma Convention (C, queue_t); - - type pthread_mutex_t is record - queue : queue_t; - lock : plain_char; - owner : System.Address; - flags : int; - prio_ceiling : int; - protocol : int; - prev_max_ceiling_prio : int; - end record; - pragma Convention (C, pthread_mutex_t); - - type pthread_cond_t is record - queue : queue_t; - flags : int; - waiters : int; - mutex : System.Address; - end record; - pragma Convention (C, pthread_cond_t); - - type pthread_key_t is new int; - - end System.OS_Interface; --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5msystem.ads gcc-3.4.0/gcc/ada/5msystem.ads *** gcc-3.3.3/gcc/ada/5msystem.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5msystem.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (VxWorks Version Mips) -- + -- -- + -- Copyright (C) 1992-2003 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. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package System is + pragma Pure (System); + -- Note that we take advantage of the implementation permission to + -- make this unit Pure instead of Preelaborable, see RM 13.7(36) + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 1.0 / 60.0; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + + -- Priority-related Declarations (RM D.1) + + -- 256 is reserved for the VxWorks kernel + -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 + -- 247 is a catchall default "interrupt" priority for signals, + -- allowing higher priority than normal tasks, but lower than + -- hardware priority levels. Protected Object ceilings can + -- override these values. + -- 246 is used by the Interrupt_Manager task + + Max_Priority : constant Positive := 245; + Max_Interrupt_Priority : constant Positive := 255; + + subtype Any_Priority is Integer range 0 .. 255; + subtype Priority is Any_Priority range 0 .. 245; + subtype Interrupt_Priority is Any_Priority range 246 .. 255; + + Default_Priority : constant Priority := 122; + + private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + AAMP : constant Boolean := False; + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := False; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := False; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Functions_Return_By_DSP : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + OpenVMS : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + Front_End_ZCX_Support : constant Boolean := False; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := False; + + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/5mvxwork.ads gcc-3.4.0/gcc/ada/5mvxwork.ads *** gcc-3.3.3/gcc/ada/5mvxwork.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5mvxwork.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/5ninmaop.adb gcc-3.4.0/gcc/ada/5ninmaop.adb *** gcc-3.3.3/gcc/ada/5ninmaop.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5ninmaop.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/5nintman.adb gcc-3.4.0/gcc/ada/5nintman.adb *** gcc-3.3.3/gcc/ada/5nintman.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5nintman.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1991-1996, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2002 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- *************** *** 28,37 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ package body System.Interrupt_Management is --------------------------- --- 27,38 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ + -- This is a NO tasking version of this package. + package body System.Interrupt_Management is --------------------------- diff -Nrc3pad gcc-3.3.3/gcc/ada/5nosinte.ads gcc-3.4.0/gcc/ada/5nosinte.ads *** gcc-3.3.3/gcc/ada/5nosinte.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5nosinte.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 28,34 **** -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- ! -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/5nsystem.ads gcc-3.4.0/gcc/ada/5nsystem.ads *** gcc-3.3.3/gcc/ada/5nsystem.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5nsystem.ads 2003-11-14 13:56:34.000000000 +0000 *************** *** 0 **** --- 1,150 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (GNU-Linux/x86-64 Version) -- + -- -- + -- Copyright (C) 1992-2003 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. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + package System is + pragma Pure (System); + -- Note that we take advantage of the implementation permission to + -- make this unit Pure instead of Preelaborable, see RM 13.7(36) + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant :=