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 := 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 := 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/5ntaprop.adb gcc-3.4.0/gcc/ada/5ntaprop.adb *** gcc-3.3.3/gcc/ada/5ntaprop.adb 2002-05-31 19:27:59.000000000 +0000 --- gcc-3.4.0/gcc/ada/5ntaprop.adb 2003-10-21 13:41:52.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-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,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 *** 53,58 **** --- 52,60 ---- use System.Tasking; use System.Parameters; + pragma Warnings (Off); + -- Turn off warnings since so many unreferenced parameters + ----------------- -- Stack_Guard -- ----------------- *************** package body System.Task_Primitives.Oper *** 86,92 **** procedure Initialize_Lock (Prio : System.Any_Priority; ! L : access Lock) is begin null; end Initialize_Lock; --- 88,95 ---- procedure Initialize_Lock (Prio : System.Any_Priority; ! L : access Lock) ! is begin null; end Initialize_Lock; *************** package body System.Task_Primitives.Oper *** 120,126 **** end Write_Lock; procedure Write_Lock ! (L : access RTS_Lock; Global_Lock : Boolean := False) is begin null; --- 123,130 ---- end Write_Lock; procedure Write_Lock ! (L : access RTS_Lock; ! Global_Lock : Boolean := False) is begin null; *************** package body System.Task_Primitives.Oper *** 262,267 **** --- 266,289 ---- 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 *** 375,381 **** function Suspend_Task (T : ST.Task_ID; ! Thread_Self : OSI.Thread_Id) return Boolean is begin return False; end Suspend_Task; --- 397,405 ---- function Suspend_Task (T : ST.Task_ID; ! Thread_Self : OSI.Thread_Id) ! return Boolean ! is begin return False; end Suspend_Task; *************** package body System.Task_Primitives.Oper *** 386,392 **** function Resume_Task (T : ST.Task_ID; ! Thread_Self : OSI.Thread_Id) return Boolean is begin return False; end Resume_Task; --- 410,418 ---- function Resume_Task (T : ST.Task_ID; ! Thread_Self : OSI.Thread_Id) ! return Boolean ! is begin return False; end Resume_Task; diff -Nrc3pad gcc-3.3.3/gcc/ada/5ntaspri.ads gcc-3.4.0/gcc/ada/5ntaspri.ads *** gcc-3.3.3/gcc/ada/5ntaspri.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5ntaspri.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/5ointerr.adb gcc-3.4.0/gcc/ada/5ointerr.adb *** gcc-3.3.3/gcc/ada/5ointerr.adb 2002-03-14 10:58:35.000000000 +0000 --- gcc-3.4.0/gcc/ada/5ointerr.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.Interrupts is *** 59,67 **** -------------------- procedure Attach_Handler ! (New_Handler : in Parameterless_Handler; ! Interrupt : in Interrupt_ID; ! Static : in Boolean := False) is begin Unimplemented; --- 58,66 ---- -------------------- procedure Attach_Handler ! (New_Handler : Parameterless_Handler; ! Interrupt : Interrupt_ID; ! Static : Boolean := False) is begin Unimplemented; *************** package body System.Interrupts is *** 107,114 **** -------------------- procedure Detach_Handler ! (Interrupt : in Interrupt_ID; ! Static : in Boolean := False) is begin Unimplemented; --- 106,113 ---- -------------------- procedure Detach_Handler ! (Interrupt : Interrupt_ID; ! Static : Boolean := False) is begin Unimplemented; *************** package body System.Interrupts is *** 129,137 **** procedure Exchange_Handler (Old_Handler : out Parameterless_Handler; ! New_Handler : in Parameterless_Handler; ! Interrupt : in Interrupt_ID; ! Static : in Boolean := False) is begin Old_Handler := null; --- 128,136 ---- procedure Exchange_Handler (Old_Handler : out Parameterless_Handler; ! New_Handler : Parameterless_Handler; ! Interrupt : Interrupt_ID; ! Static : Boolean := False) is begin Old_Handler := null; *************** package body System.Interrupts is *** 155,160 **** --- 154,161 ---- (Object : access Dynamic_Interrupt_Protection) return Boolean is + pragma Warnings (Off, Object); + begin Unimplemented; return True; *************** package body System.Interrupts is *** 164,169 **** --- 165,172 ---- (Object : access Static_Interrupt_Protection) return Boolean is + pragma Warnings (Off, Object); + begin Unimplemented; return True; *************** package body System.Interrupts is *** 184,190 **** procedure Install_Handlers (Object : access Static_Interrupt_Protection; ! New_Handlers : in New_Handler_Array) is begin Unimplemented; --- 187,193 ---- procedure Install_Handlers (Object : access Static_Interrupt_Protection; ! New_Handlers : New_Handler_Array) is begin Unimplemented; diff -Nrc3pad gcc-3.3.3/gcc/ada/5omastop.adb gcc-3.4.0/gcc/ada/5omastop.adb *** gcc-3.3.3/gcc/ada/5omastop.adb 2002-03-14 10:58:35.000000000 +0000 --- gcc-3.4.0/gcc/ada/5omastop.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 7,13 **** -- B o d y -- -- (Version for x86) -- -- -- - -- -- -- Copyright (C) 1999-2002 Ada Core Technologies, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- --- 7,12 ---- *************** *** 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 *** 464,470 **** return To_Address (MS.eip); else -- When doing a call the return address is pushed to the stack. ! -- We want to return the call point address, so we subtract -- Asm_Call_Size from the return address. This value is set -- to 5 as an asm call takes 5 bytes on x86 architectures. --- 463,469 ---- return To_Address (MS.eip); else -- When doing a call the return address is pushed to the stack. ! -- We want to return the call point address, so we substract -- Asm_Call_Size from the return address. This value is set -- to 5 as an asm call takes 5 bytes on x86 architectures. diff -Nrc3pad gcc-3.3.3/gcc/ada/5oosinte.adb gcc-3.4.0/gcc/ada/5oosinte.adb *** gcc-3.3.3/gcc/ada/5oosinte.adb 2002-03-14 10:58:35.000000000 +0000 --- gcc-3.4.0/gcc/ada/5oosinte.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,13 **** -- -- -- 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- -- --- 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 *** 111,118 **** Tick_Count : aliased QWORD; begin - -- Read nr of clock ticks since boot time Must_Not_Fail (DosTmrQueryTime (Tick_Count'Access)); return Tick_Count * Tick_Duration; --- 110,117 ---- Tick_Count : aliased QWORD; begin -- Read nr of clock ticks since boot time + Must_Not_Fail (DosTmrQueryTime (Tick_Count'Access)); return Tick_Count * Tick_Duration; diff -Nrc3pad gcc-3.3.3/gcc/ada/5oosinte.ads gcc-3.4.0/gcc/ada/5oosinte.ads *** gcc-3.3.3/gcc/ada/5oosinte.ads 2002-03-14 10:58:35.000000000 +0000 --- gcc-3.4.0/gcc/ada/5oosinte.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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 ---- -- -- -- 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/5oosprim.adb gcc-3.4.0/gcc/ada/5oosprim.adb *** gcc-3.3.3/gcc/ada/5oosprim.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5oosprim.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- 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/5oparame.adb gcc-3.4.0/gcc/ada/5oparame.adb *** gcc-3.3.3/gcc/ada/5oparame.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5oparame.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1997-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- -- --- 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- -- diff -Nrc3pad gcc-3.3.3/gcc/ada/5osystem.ads gcc-3.4.0/gcc/ada/5osystem.ads *** gcc-3.3.3/gcc/ada/5osystem.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5osystem.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 7,14 **** -- S p e c -- -- (OS/2 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 -- -- (OS/2 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 := 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 := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; GCC_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := True; + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/5otaprop.adb gcc-3.4.0/gcc/ada/5otaprop.adb *** gcc-3.3.3/gcc/ada/5otaprop.adb 2002-03-14 10:58:36.000000000 +0000 --- gcc-3.4.0/gcc/ada/5otaprop.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,13 **** -- -- -- 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- -- --- 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 *** 201,208 **** -- ??? Check the comment above procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is ! pragma Warnings (Off, T); ! pragma Warnings (Off, On); begin null; --- 200,207 ---- -- ??? Check the comment above procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is ! pragma Unreferenced (T); ! pragma Unreferenced (On); begin null; *************** package body System.Task_Primitives.Oper *** 254,260 **** end Initialize_Lock; procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is ! pragma Warnings (Off, Level); begin if DosCreateMutexSem --- 253,259 ---- end Initialize_Lock; procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is ! pragma Unreferenced (Level); begin if DosCreateMutexSem *************** package body System.Task_Primitives.Oper *** 290,296 **** procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is Self_ID : constant Task_ID := Thread_Local_Data_Ptr.Self_ID; Old_Priority : constant Any_Priority := ! Self_ID.Common.LL.Current_Priority; begin if L.Priority < Old_Priority then --- 289,295 ---- procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is Self_ID : constant Task_ID := Thread_Local_Data_Ptr.Self_ID; Old_Priority : constant Any_Priority := ! Self_ID.Common.LL.Current_Priority; begin if L.Priority < Old_Priority then *************** package body System.Task_Primitives.Oper *** 317,323 **** end Write_Lock; procedure Write_Lock ! (L : access RTS_Lock; Global_Lock : Boolean := False) is Self_ID : Task_ID; Old_Priority : Any_Priority; --- 316,323 ---- end Write_Lock; procedure Write_Lock ! (L : access RTS_Lock; ! Global_Lock : Boolean := False) is Self_ID : Task_ID; Old_Priority : Any_Priority; *************** package body System.Task_Primitives.Oper *** 348,353 **** --- 348,354 ---- procedure Write_Lock (T : Task_ID) is begin if not Single_Lock then + -- Request the lock and then update the lock owner data Must_Not_Fail *************** package body System.Task_Primitives.Oper *** 418,423 **** --- 419,425 ---- Must_Not_Fail (DosReleaseMutexSem (L.Mutex)); -- Reset priority after unlocking to avoid priority inversion + Thread_Local_Data_Ptr.Lock_Prio_Level := Thread_Local_Data_Ptr.Lock_Prio_Level - 1; *************** package body System.Task_Primitives.Oper *** 430,435 **** --- 432,438 ---- procedure Unlock (T : Task_ID) is begin if not Single_Lock then + -- Check the owner data pragma Assert (Suppress_Owner_Check *************** package body System.Task_Primitives.Oper *** 450,456 **** (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is ! pragma Warnings (Off, Reason); Count : aliased ULONG; -- Used to store dummy result --- 453,459 ---- (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is ! pragma Unreferenced (Reason); Count : aliased ULONG; -- Used to store dummy result *************** package body System.Task_Primitives.Oper *** 503,509 **** Timedout : out Boolean; Yielded : out Boolean) is ! pragma Warnings (Off, Reason); Check_Time : constant Duration := OSP.Monotonic_Clock; Rel_Time : Duration; --- 506,512 ---- Timedout : out Boolean; Yielded : out Boolean) is ! pragma Unreferenced (Reason); Check_Time : constant Duration := OSP.Monotonic_Clock; Rel_Time : Duration; *************** package body System.Task_Primitives.Oper *** 677,683 **** ------------ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is ! pragma Warnings (Off, Reason); begin Sem_Must_Not_Fail (DosPostEventSem (T.Common.LL.CV)); end Wakeup; --- 680,687 ---- ------------ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is ! pragma Unreferenced (Reason); ! begin Sem_Must_Not_Fail (DosPostEventSem (T.Common.LL.CV)); end Wakeup; *************** package body System.Task_Primitives.Oper *** 743,749 **** Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is ! pragma Warnings (Off, Loss_Of_Inheritance); begin T.Common.Current_Priority := Prio; --- 747,753 ---- Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is ! pragma Unreferenced (Loss_Of_Inheritance); begin T.Common.Current_Priority := Prio; *************** package body System.Task_Primitives.Oper *** 800,808 **** return new Ada_Task_Control_Block (Entry_Num); end New_ATCB; ! ---------------------- ! -- Initialize_TCB -- ! ---------------------- procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is begin --- 804,830 ---- return new Ada_Task_Control_Block (Entry_Num); end New_ATCB; ! ------------------- ! -- Is_Valid_Task -- ! ------------------- ! ! function Is_Valid_Task return Boolean is ! begin ! return False; ! end Is_Valid_Task; ! ! ----------------------------- ! -- Register_Foreign_Thread -- ! ----------------------------- ! ! function Register_Foreign_Thread return Task_ID is ! begin ! return null; ! end Register_Foreign_Thread; ! ! -------------------- ! -- Initialize_TCB -- ! -------------------- procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is begin *************** package body System.Task_Primitives.Oper *** 880,886 **** -- recommend a minimum size of 32 kB. (The original was 4 kB) -- Systems that use many tasks (say > 30) and require much -- memory may run out of virtual address space, since OS/2 ! -- has a per-process limit of 512 MB, of which max. 300 MB is -- usable in practise. if Stack_Size = Unspecified_Size then --- 902,908 ---- -- recommend a minimum size of 32 kB. (The original was 4 kB) -- Systems that use many tasks (say > 30) and require much -- memory may run out of virtual address space, since OS/2 ! -- has a per-proces limit of 512 MB, of which max. 300 MB is -- usable in practise. if Stack_Size = Unspecified_Size then *************** package body System.Task_Primitives.Oper *** 974,984 **** procedure Exit_Task is begin ! DosExit (EXIT_THREAD, 0); ! ! -- Do not finalize TCB here. ! -- GNARL layer is responsible for that. ! end Exit_Task; ---------------- --- 996,1002 ---- procedure Exit_Task is begin ! Thread_Local_Data_Ptr := null; end Exit_Task; ---------------- *************** package body System.Task_Primitives.Oper *** 986,992 **** ---------------- procedure Abort_Task (T : Task_ID) is ! pragma Warnings (Off, T); begin null; --- 1004,1010 ---- ---------------- procedure Abort_Task (T : Task_ID) is ! pragma Unreferenced (T); begin null; *************** package body System.Task_Primitives.Oper *** 1000,1007 **** -- 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 --- 1018,1024 ---- -- Check_Exit -- ---------------- ! -- Dummy version function Check_Exit (Self_ID : ST.Task_ID) return Boolean is begin *************** package body System.Task_Primitives.Oper *** 1014,1019 **** --- 1031,1037 ---- function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is TLD : constant Access_Thread_Local_Data := Thread_Local_Data_Ptr; + begin return Self_ID = TLD.Self_ID and then TLD.Lock_Prio_Level = 0; *************** package body System.Task_Primitives.Oper *** 1052,1058 **** function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin if Thread_Id (T.Common.LL.Thread) /= Thread_Self then return DosSuspendThread (T.Common.LL.Thread) = NO_ERROR; --- 1070,1078 ---- function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) ! return Boolean ! is begin if Thread_Id (T.Common.LL.Thread) /= Thread_Self then return DosSuspendThread (T.Common.LL.Thread) = NO_ERROR; *************** package body System.Task_Primitives.Oper *** 1067,1073 **** function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin if Thread_Id (T.Common.LL.Thread) /= Thread_Self then return DosResumeThread (T.Common.LL.Thread) = NO_ERROR; --- 1087,1095 ---- function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) ! return Boolean ! is begin if Thread_Id (T.Common.LL.Thread) /= Thread_Self then return DosResumeThread (T.Common.LL.Thread) = NO_ERROR; diff -Nrc3pad gcc-3.3.3/gcc/ada/5otaspri.ads gcc-3.4.0/gcc/ada/5otaspri.ads *** gcc-3.3.3/gcc/ada/5otaspri.ads 2002-03-14 10:58:36.000000000 +0000 --- gcc-3.4.0/gcc/ada/5otaspri.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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 ---- -- -- -- 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/5posinte.ads gcc-3.4.0/gcc/ada/5posinte.ads *** gcc-3.3.3/gcc/ada/5posinte.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5posinte.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 *** 156,161 **** --- 155,164 ---- SIG_DFL : constant := 0; SIG_IGN : constant := 1; + SA_SIGINFO : constant := 0; + -- Dummy constant for a sa_flags bit. A proper definition is needed only + -- for the GCC/ZCX EH scheme (see System.Interrupt_Management). + function sigaction (sig : Signal; act : struct_sigaction_ptr; diff -Nrc3pad gcc-3.3.3/gcc/ada/5posprim.adb gcc-3.4.0/gcc/ada/5posprim.adb *** gcc-3.3.3/gcc/ada/5posprim.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5posprim.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-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- -- *************** *** 33,39 **** ------------------------------------------------------------------------------ -- This version uses gettimeofday and select ! -- Currently OpenNT, Dec Unix, Solaris and SCO UnixWare use this file. package body System.OS_Primitives is --- 32,38 ---- ------------------------------------------------------------------------------ -- This version uses gettimeofday and select ! -- This file is suitable for OpenNT, Dec Unix and SCO UnixWare. package body System.OS_Primitives is *************** package body System.OS_Primitives is *** 42,74 **** -- these declarations in System.OS_Interface and move these ones in -- the spec. - type struct_timezone is record - tz_minuteswest : Integer; - tz_dsttime : Integer; - end record; - pragma Convention (C, struct_timezone); - type struct_timezone_ptr is access all struct_timezone; - type struct_timeval is record ! tv_sec : Integer; ! tv_usec : Integer; end record; pragma Convention (C, struct_timeval); ! function gettimeofday (tv : access struct_timeval; ! tz : struct_timezone_ptr) return Integer; pragma Import (C, gettimeofday, "gettimeofday"); ! type fd_set is null record; ! type fd_set_ptr is access all fd_set; ! ! function C_select ! (n : Integer := 0; readfds, writefds, ! exceptfds : fd_set_ptr := null; ! timeout : access struct_timeval) return Integer; pragma Import (C, C_select, "select"); ----------- --- 41,63 ---- -- these declarations in System.OS_Interface and move these ones in -- the spec. type struct_timeval is record ! tv_sec : Integer; ! tv_usec : Integer; end record; pragma Convention (C, struct_timeval); ! procedure gettimeofday (tv : access struct_timeval; ! tz : Address := Null_Address); pragma Import (C, gettimeofday, "gettimeofday"); ! procedure C_select ! (n : Integer := 0; readfds, writefds, ! exceptfds : Address := Null_Address; ! timeout : access struct_timeval); pragma Import (C, C_select, "select"); ----------- *************** package body System.OS_Primitives is *** 76,86 **** ----------- function Clock return Duration is ! TV : aliased struct_timeval; ! Result : Integer; begin ! Result := gettimeofday (TV'Access, null); return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; end Clock; --- 65,74 ---- ----------- function Clock return Duration is ! TV : aliased struct_timeval; begin ! gettimeofday (TV'Access); return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; end Clock; *************** package body System.OS_Primitives is *** 98,104 **** (Time : Duration; Mode : Integer) is - Result : Integer; Rel_Time : Duration; Abs_Time : Duration; Check_Time : Duration := Clock; --- 86,91 ---- *************** package body System.OS_Primitives is *** 124,130 **** timeval.tv_usec := Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6); ! Result := C_select (timeout => timeval'Unchecked_Access); Check_Time := Clock; exit when Abs_Time <= Check_Time; --- 111,117 ---- timeval.tv_usec := Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6); ! C_select (timeout => timeval'Unchecked_Access); Check_Time := Clock; exit when Abs_Time <= Check_Time; diff -Nrc3pad gcc-3.3.3/gcc/ada/5psystem.ads gcc-3.4.0/gcc/ada/5psystem.ads *** gcc-3.3.3/gcc/ada/5psystem.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5psystem.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 0 **** --- 1,150 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (OpenNT/Interix 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/5pvxwork.ads gcc-3.4.0/gcc/ada/5pvxwork.ads *** gcc-3.3.3/gcc/ada/5pvxwork.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5pvxwork.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/5qosinte.adb gcc-3.4.0/gcc/ada/5qosinte.adb *** gcc-3.3.3/gcc/ada/5qosinte.adb 2002-03-14 10:58:37.000000000 +0000 --- gcc-3.4.0/gcc/ada/5qosinte.adb 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,49 **** - ------------------------------------------------------------------------------ - -- -- - -- 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) 1991-2001 Florida State University -- - -- -- - -- GNARL is free software; you can redistribute it and/or modify it under -- - -- terms of the GNU General Public License as published by the Free Soft- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNARL; see file COPYING. If not, write -- - -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- - -- MA 02111-1307, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNARL was developed by the GNARL team at Florida State University. It is -- - -- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- - -- State University (http://www.gnat.com). -- - -- -- - ------------------------------------------------------------------------------ - - -- RT GNU/Linux version. - - -- 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. - - package body System.OS_Interface is - - type Require_Body is new Integer; - - end System.OS_Interface; --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5qosinte.ads gcc-3.4.0/gcc/ada/5qosinte.ads *** gcc-3.3.3/gcc/ada/5qosinte.ads 2002-03-14 10:58:37.000000000 +0000 --- gcc-3.4.0/gcc/ada/5qosinte.ads 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,187 **** - ------------------------------------------------------------------------------ - -- -- - -- 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) 1991-2001 Florida State University -- - -- -- - -- GNARL is free software; you can redistribute it and/or modify it under -- - -- terms of the GNU General Public License as published by the Free Soft- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNARL; see file COPYING. If not, write -- - -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- - -- MA 02111-1307, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNARL was developed by the GNARL team at Florida State University. It is -- - -- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- - -- State University (http://www.gnat.com). -- - -- -- - ------------------------------------------------------------------------------ - - -- RT GNU/Linux version. - - -- 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; - - subtype int is Interfaces.C.int; - subtype unsigned_long is Interfaces.C.unsigned_long; - - -- RT GNU/Linux kernel threads should not use the - -- OS signal interfaces. - - Max_Interrupt : constant := 2; - type Signal is new int range 0 .. Max_Interrupt; - type sigset_t is new Integer; - - ---------- - -- Time -- - ---------- - - RT_TICKS_PER_SEC : constant := 1193180; - -- the amount of time units in one second. - - RT_TIME_END : constant := 16#7fffFfffFfffFfff#; - - type RTIME is range -2 ** 63 .. 2 ** 63 - 1; - -- the introduction of type RTIME is due to the fact that RT-GNU/Linux - -- uses this type to represent time. In RT-GNU/Linux, it's a long long - -- integer that takes 64 bits for storage - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - RT_LOWEST_PRIORITY : constant System.Any_Priority := - System.Any_Priority'First; - -- for the lowest priority task in RT-GNU/Linux. By the design, this - -- task is the regular GNU/Linux kernel. - - RT_TASK_MAGIC : constant := 16#754d2774#; - -- a special constant used as a label for a task that has been created - - ---------------------------- - -- RT constants and types -- - ---------------------------- - - SFIF : Integer; - pragma Import (C, SFIF, "SFIF"); - -- Interrupt emulation flag used by RT-GNU/Linux. If it's 0, the regular - -- GNU/Linux kernel is preempted. Otherwise, the regular Linux kernel is - -- running - - GFP_ATOMIC : constant := 16#1#; - GFP_KERNEL : constant := 16#3#; - -- constants to indicate the priority of a call to kmalloc. - -- GFP_KERNEL is used in the current implementation to allocate - -- stack space for a task. Since GFP_ATOMIC has higher priority, - -- if necessary, replace GFP_KERNEL with GFP_ATOMIC - - type Rt_Task_States is (RT_TASK_READY, RT_TASK_DELAYED, RT_TASK_DORMANT); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - -- ??? need to define a type for references to (IDs of) - -- RT GNU/Linux lock objects, and implement the lock objects. - - subtype Thread_Id is System.Address; - - ------------------------------- - -- Useful imported functions -- - ------------------------------- - - ------------------------------------- - -- Functions from GNU/Linux kernel -- - ------------------------------------- - - function Kmalloc (size : Integer; Priority : Integer) return System.Address; - pragma Import (C, Kmalloc, "kmalloc"); - - procedure Kfree (Ptr : System.Address); - pragma Import (C, Kfree, "kfree"); - - procedure Printk (Msg : String); - pragma Import (C, Printk, "printk"); - - --------------------- - -- RT time related -- - --------------------- - - function Rt_Get_Time return RTIME; - pragma Import (C, Rt_Get_Time, "rt_get_time"); - - function Rt_Request_Timer (Fn : System.Address) return Integer; - procedure Rt_Request_Timer (Fn : System.Address); - pragma Import (C, Rt_Request_Timer, "rt_request_timer"); - - procedure Rt_Free_Timer; - pragma Import (C, Rt_Free_Timer, "rt_free_timer"); - - procedure Rt_Set_Timer (T : RTIME); - pragma Import (C, Rt_Set_Timer, "rt_set_timer"); - - procedure Rt_No_Timer; - pragma Import (C, Rt_No_Timer, "rt_no_timer"); - - --------------------- - -- RT FIFO related -- - --------------------- - - function Rtf_Create (Fifo : Integer; Size : Integer) return Integer; - pragma Import (C, Rtf_Create, "rtf_create"); - - function Rtf_Destroy (Fifo : Integer) return Integer; - pragma Import (C, Rtf_Destroy, "rtf_destroy"); - - function Rtf_Resize (Minor : Integer; Size : Integer) return Integer; - pragma Import (C, Rtf_Resize, "rtf_resize"); - - function Rtf_Put - (Fifo : Integer; - Buf : System.Address; - Count : Integer) return Integer; - pragma Import (C, Rtf_Put, "rtf_put"); - - function Rtf_Get - (Fifo : Integer; - Buf : System.Address; - Count : Integer) return Integer; - pragma Import (C, Rtf_Get, "rtf_get"); - - function Rtf_Create_Handler - (Fifo : Integer; - Handler : System.Address) return Integer; - pragma Import (C, Rtf_Create_Handler, "rtf_create_handler"); - - private - type Require_Body; - end System.OS_Interface; --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5qstache.adb gcc-3.4.0/gcc/ada/5qstache.adb *** gcc-3.3.3/gcc/ada/5qstache.adb 2002-03-14 10:58:37.000000000 +0000 --- gcc-3.4.0/gcc/ada/5qstache.adb 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,78 **** - ------------------------------------------------------------------------------ - -- -- - -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- - -- -- - -- S Y S T E M . S T A C K _ C H E C K I N G -- - -- -- - -- B o d y -- - -- (Dummy version) -- - -- -- - -- -- - -- Copyright (C) 2000 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. It is -- - -- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- - -- State University (http://www.gnat.com). -- - -- -- - ------------------------------------------------------------------------------ - - package body System.Stack_Checking is - - ----------------- - -- Stack_Check -- - ----------------- - - function Stack_Check (Stack_Address : System.Address) return Stack_Access is - begin - return null; - end Stack_Check; - - ---------------------------- - -- Invalidate_Stack_Cache -- - ---------------------------- - - procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is - begin - null; - end Invalidate_Stack_Cache; - - -------------------- - -- Set_Stack_Size -- - -------------------- - - -- Specify the stack size for the current frame. - - procedure Set_Stack_Size - (Stack_Size : System.Storage_Elements.Storage_Offset) is - begin - null; - end Set_Stack_Size; - - ------------------------ - -- Update_Stack_Cache -- - ------------------------ - - procedure Update_Stack_Cache (Stack : Stack_Access) is - begin - null; - end Update_Stack_Cache; - - end System.Stack_Checking; --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5qtaprop.adb gcc-3.4.0/gcc/ada/5qtaprop.adb *** gcc-3.3.3/gcc/ada/5qtaprop.adb 2002-03-14 10:58:37.000000000 +0000 --- gcc-3.4.0/gcc/ada/5qtaprop.adb 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,1777 **** - ------------------------------------------------------------------------------ - -- -- - -- 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-2001, Free Software Foundation, Inc. -- - -- -- - -- GNARL is free software; you can redistribute it and/or modify it under -- - -- terms of the GNU General Public License as published by the Free Soft- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNARL; see file COPYING. If not, write -- - -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- - -- MA 02111-1307, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNARL was developed by the GNARL team at Florida State University. It is -- - -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). -- - -- -- - ------------------------------------------------------------------------------ - - -- RT GNU/Linux version - - -- ???? Later, look at what we might want to provide for interrupt - -- management. - - pragma Suppress (All_Checks); - - 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.Machine_Code; - -- used for Asm - - with System.OS_Interface; - -- used for various types, constants, and operations - - with System.OS_Primitives; - -- used for Delay_Modes - - with System.Parameters; - -- used for Size_Type - - with System.Storage_Elements; - - with System.Tasking; - -- used for Ada_Task_Control_Block - -- Task_ID - - with Ada.Unchecked_Conversion; - - package body System.Task_Primitives.Operations is - - use System.Machine_Code, - System.OS_Interface, - System.OS_Primitives, - System.Parameters, - System.Tasking, - System.Storage_Elements; - - -------------------------------- - -- RT GNU/Linux specific Data -- - -------------------------------- - - -- Define two important parameters necessary for a GNU/Linux kernel module. - -- Any module that is going to be loaded into the kernel space needs these - -- parameters. - - Mod_Use_Count : Integer; - pragma Export (C, Mod_Use_Count, "mod_use_count_"); - -- for module usage tracking by the kernel - - type Aliased_String is array (Positive range <>) of aliased Character; - pragma Convention (C, Aliased_String); - - Kernel_Version : constant Aliased_String := "2.0.33" & ASCII.Nul; - pragma Export (C, Kernel_Version, "kernel_version"); - -- So that insmod can find the version number. - - -- The following procedures have their name specified by the GNU/Linux - -- module loader. Note that they simply correspond to adainit/adafinal. - - function Init_Module return Integer; - pragma Export (C, Init_Module, "init_module"); - - procedure Cleanup_Module; - pragma Export (C, Cleanup_Module, "cleanup_module"); - - ---------------- - -- Local Data -- - ---------------- - - LF : constant String := ASCII.LF & ASCII.Nul; - - LFHT : constant String := ASCII.LF & ASCII.HT; - -- used in inserted assembly code - - Max_Tasks : constant := 10; - -- ??? Eventually, this should probably be in System.Parameters. - - Known_Tasks : array (0 .. Max_Tasks) of Task_ID; - -- Global array of tasks read by gdb, and updated by Create_Task and - -- Finalize_TCB. It's from System.Tasking.Debug. We moved it here to - -- cut the dependence on that package. Consider moving it here or to - -- this package specification, permanently???? - - Max_Sensible_Delay : constant RTIME := - 365 * 24 * 60 * 60 * RT_TICKS_PER_SEC; - -- Max of one year delay, needed to prevent exceptions for large - -- delay values. It seems unlikely that any test will notice this - -- restriction. - -- ??? This is really declared in System.OS_Primitives, - -- and the type is Duration, here its type is RTIME. - - Tick_Count : constant := RT_TICKS_PER_SEC / 20; - Nano_Count : constant := 50_000_000; - -- two constants used in conversions between RTIME and Duration. - - Addr_Bytes : constant Storage_Offset := - System.Address'Max_Size_In_Storage_Elements; - -- number of bytes needed for storing an address. - - Guess : constant RTIME := 10; - -- an approximate amount of RTIME used in scheduler to awake a task having - -- its resume time within 'current time + Guess' - -- The value of 10 is estimated here and may need further refinement - - TCB_Array : array (0 .. Max_Tasks) - of aliased Restricted_Ada_Task_Control_Block (Entry_Num => 0); - pragma Volatile_Components (TCB_Array); - - Available_TCBs : Task_ID; - pragma Atomic (Available_TCBs); - -- Head of linear linked list of available TCB's, linked using TCB's - -- LL.Next. This list is Initialized to contain a fixed number of tasks, - -- when the runtime system starts up. - - Current_Task : Task_ID; - pragma Export (C, Current_Task, "current_task"); - pragma Atomic (Current_Task); - -- This is the task currently running. We need the pragma here to specify - -- the link-name for Current_Task is "current_task", rather than the long - -- name (including the package name) that the Ada compiler would normally - -- generate. "current_task" is referenced in procedure Rt_Switch_To below - - Idle_Task : aliased Restricted_Ada_Task_Control_Block (Entry_Num => 0); - -- Tail of the circular queue of ready to run tasks. - - Scheduler_Idle : Boolean := False; - -- True when the scheduler is idle (no task other than the idle task - -- is on the ready queue). - - In_Elab_Code : Boolean := True; - -- True when we are elaborating our application. - -- Init_Module will set this flag to false and never revert it. - - Timer_Queue : aliased Restricted_Ada_Task_Control_Block (Entry_Num => 0); - -- Header of the queue of delayed real-time tasks. - -- Timer_Queue.LL has to be initialized properly before being used - - Timer_Expired : Boolean := False; - -- flag to show whether the Timer_Queue needs to be checked - -- when it becomes true, it means there is a task in the - -- Timer_Queue having to be awakened and be moved to ready queue - - Environment_Task_ID : Task_ID; - -- A variable to hold Task_ID for the environment task. - -- Once initialized, this behaves as a constant. - -- In the current implementation, this is the task assigned permanently - -- as the regular GNU/Linux kernel. - - 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 - - -- The followings are internal configuration constants needed. - Next_Serial_Number : Task_Serial_Number := 100; - pragma Volatile (Next_Serial_Number); - -- We start at 100, to reserve some special values for - -- using in error checking. - - GNU_Linux_Irq_State : Integer := 0; - -- This needs comments ??? - - type Duration_As_Integer is delta 1.0 - range -2.0**(Duration'Size - 1) .. 2.0**(Duration'Size - 1) - 1.0; - -- used for output RTIME value during debugging - - type Address_Ptr is access all System.Address; - pragma Convention (C, Address_Ptr); - - -------------------------------- - -- Local conversion functions -- - -------------------------------- - - function To_Task_ID is new - Ada.Unchecked_Conversion (System.Address, Task_ID); - - function To_Address is new - Ada.Unchecked_Conversion (Task_ID, System.Address); - - function RTIME_To_D_Int is new - Ada.Unchecked_Conversion (RTIME, Duration_As_Integer); - - function Raw_RTIME is new - Ada.Unchecked_Conversion (Duration, RTIME); - - function Raw_Duration is new - Ada.Unchecked_Conversion (RTIME, Duration); - - function To_Duration (T : RTIME) return Duration; - pragma Inline (To_Duration); - - function To_RTIME (D : Duration) return RTIME; - pragma Inline (To_RTIME); - - function To_Integer is new - Ada.Unchecked_Conversion (System.Parameters.Size_Type, Integer); - - function To_Address_Ptr is - new Ada.Unchecked_Conversion (System.Address, Address_Ptr); - - function To_RTS_Lock_Ptr is new - Ada.Unchecked_Conversion (Lock_Ptr, RTS_Lock_Ptr); - - ----------------------------------- - -- Local Subprogram Declarations -- - ----------------------------------- - - procedure Rt_Switch_To (Tsk : Task_ID); - pragma Inline (Rt_Switch_To); - -- switch from the 'current_task' to 'Tsk' - -- and 'Tsk' then becomes 'current_task' - - procedure R_Save_Flags (F : out Integer); - pragma Inline (R_Save_Flags); - -- save EFLAGS register to 'F' - - procedure R_Restore_Flags (F : Integer); - pragma Inline (R_Restore_Flags); - -- restore EFLAGS register from 'F' - - procedure R_Cli; - pragma Inline (R_Cli); - -- disable interrupts - - procedure R_Sti; - pragma Inline (R_Sti); - -- enable interrupts - - procedure Timer_Wrapper; - -- the timer handler. It sets Timer_Expired flag to True and - -- then calls Rt_Schedule - - procedure Rt_Schedule; - -- the scheduler - - procedure Insert_R (T : Task_ID); - pragma Inline (Insert_R); - -- insert 'T' into the tail of the ready queue for its active - -- priority - -- if original queue is 6 5 4 4 3 2 and T has priority of 4 - -- then after T is inserted the queue becomes 6 5 4 4 T 3 2 - - procedure Insert_RF (T : Task_ID); - pragma Inline (Insert_RF); - -- insert 'T' into the front of the ready queue for its active - -- priority - -- if original queue is 6 5 4 4 3 2 and T has priority of 4 - -- then after T is inserted the queue becomes 6 5 T 4 4 3 2 - - procedure Delete_R (T : Task_ID); - pragma Inline (Delete_R); - -- delete 'T' from the ready queue. If 'T' is not in any queue - -- the operation has no effect - - procedure Insert_T (T : Task_ID); - pragma Inline (Insert_T); - -- insert 'T' into the waiting queue according to its Resume_Time. - -- If there are tasks in the waiting queue that have the same - -- Resume_Time as 'T', 'T' is then inserted into the queue for - -- its active priority - - procedure Delete_T (T : Task_ID); - pragma Inline (Delete_T); - -- delete 'T' from the waiting queue. - - procedure Move_Top_Task_From_Timer_Queue_To_Ready_Queue; - pragma Inline (Move_Top_Task_From_Timer_Queue_To_Ready_Queue); - -- remove the task in the front of the waiting queue and insert it - -- into the tail of the ready queue for its active priority - - ------------------------- - -- Local Subprograms -- - ------------------------- - - procedure Rt_Switch_To (Tsk : Task_ID) is - begin - pragma Debug (Printk ("procedure Rt_Switch_To called" & LF)); - - Asm ( - "pushl %%eax" & LFHT & - "pushl %%ebp" & LFHT & - "pushl %%edi" & LFHT & - "pushl %%esi" & LFHT & - "pushl %%edx" & LFHT & - "pushl %%ecx" & LFHT & - "pushl %%ebx" & LFHT & - - "movl current_task, %%edx" & LFHT & - "cmpl $0, 36(%%edx)" & LFHT & - -- 36 is hard-coded, 36(%%edx) is actually - -- Current_Task.Common.LL.Uses_Fp - - "jz 25f" & LFHT & - "sub $108,%%esp" & LFHT & - "fsave (%%esp)" & LFHT & - "25: pushl $1f" & LFHT & - "movl %%esp, 32(%%edx)" & LFHT & - -- 32 is hard-coded, 32(%%edx) is actually - -- Current_Task.Common.LL.Stack - - "movl 32(%%ecx), %%esp" & LFHT & - -- 32 is hard-coded, 32(%%ecx) is actually Tsk.Common.LL.Stack. - -- Tsk is the task to be switched to - - "movl %%ecx, current_task" & LFHT & - "ret" & LFHT & - "1: cmpl $0, 36(%%ecx)" & LFHT & - -- 36(%%exc) is Tsk.Common.LL.Stack (hard coded) - "jz 26f" & LFHT & - "frstor (%%esp)" & LFHT & - "add $108,%%esp" & LFHT & - "26: popl %%ebx" & LFHT & - "popl %%ecx" & LFHT & - "popl %%edx" & LFHT & - "popl %%esi" & LFHT & - "popl %%edi" & LFHT & - "popl %%ebp" & LFHT & - "popl %%eax", - Outputs => No_Output_Operands, - Inputs => Task_ID'Asm_Input ("c", Tsk), - Clobber => "cx", - Volatile => True); - end Rt_Switch_To; - - procedure R_Save_Flags (F : out Integer) is - begin - Asm ( - "pushfl" & LFHT & - "popl %0", - Outputs => Integer'Asm_Output ("=g", F), - Inputs => No_Input_Operands, - Clobber => "memory", - Volatile => True); - end R_Save_Flags; - - procedure R_Restore_Flags (F : Integer) is - begin - Asm ( - "pushl %0" & LFHT & - "popfl", - Outputs => No_Output_Operands, - Inputs => Integer'Asm_Input ("g", F), - Clobber => "memory", - Volatile => True); - end R_Restore_Flags; - - procedure R_Sti is - begin - Asm ( - "sti", - Outputs => No_Output_Operands, - Inputs => No_Input_Operands, - Clobber => "memory", - Volatile => True); - end R_Sti; - - procedure R_Cli is - begin - Asm ( - "cli", - Outputs => No_Output_Operands, - Inputs => No_Input_Operands, - Clobber => "memory", - Volatile => True); - end R_Cli; - - -- A wrapper for Rt_Schedule, works as the timer handler - - procedure Timer_Wrapper is - begin - pragma Debug (Printk ("procedure Timer_Wrapper called" & LF)); - - Timer_Expired := True; - Rt_Schedule; - end Timer_Wrapper; - - procedure Rt_Schedule is - Now : RTIME; - Top_Task : Task_ID; - Flags : Integer; - - procedure Debug_Timer_Queue; - -- Check the state of the Timer Queue. - - procedure Debug_Timer_Queue is - begin - if Timer_Queue.Common.LL.Succ /= Timer_Queue'Address then - Printk ("Timer_Queue not empty" & LF); - end if; - - if To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time < - Now + Guess - then - Printk ("and need to move top task to ready queue" & LF); - end if; - end Debug_Timer_Queue; - - begin - pragma Debug (Printk ("procedure Rt_Schedule called" & LF)); - - -- Scheduler_Idle means that this call comes from an interrupt - -- handler (e.g timer) that interrupted the idle loop below. - - if Scheduler_Idle then - return; - end if; - - <> - R_Save_Flags (Flags); - R_Cli; - - Scheduler_Idle := False; - - if Timer_Expired then - pragma Debug (Printk ("Timer expired" & LF)); - Timer_Expired := False; - - -- Check for expired time delays. - Now := Rt_Get_Time; - - -- Need another (circular) queue for delayed tasks, this one ordered - -- by wakeup time, so the one at the front has the earliest resume - -- time. Wake up all the tasks sleeping on time delays that should - -- be awakened at this time. - - -- ??? This is not very good, since we may waste time here waking - -- up a bunch of lower priority tasks, adding to the blocking time - -- of higher priority ready tasks, but we don't see how to get - -- around this without adding more wasted time elsewhere. - - pragma Debug (Debug_Timer_Queue); - - while Timer_Queue.Common.LL.Succ /= Timer_Queue'Address and then - To_Task_ID - (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time < Now + Guess - loop - To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.State := - RT_TASK_READY; - Move_Top_Task_From_Timer_Queue_To_Ready_Queue; - end loop; - - -- Arm the timer if necessary. - -- ??? This may be wasteful, if the tasks on the timer queue are - -- of lower priority than the current task's priority. The problem - -- is that we can't tell this without scanning the whole timer - -- queue. This scanning takes extra time. - - if Timer_Queue.Common.LL.Succ /= Timer_Queue'Address then - -- Timer_Queue is not empty, so set the timer to interrupt at - -- the next resume time. The Wakeup procedure must also do this, - -- and must do it while interrupts are disabled so that there is - -- no danger of interleaving with this code. - Rt_Set_Timer - (To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time); - else - Rt_No_Timer; - end if; - end if; - - Top_Task := To_Task_ID (Idle_Task.Common.LL.Succ); - - -- If the ready queue is empty, the kernel has to wait until the timer - -- or another interrupt makes a task ready. - - if Top_Task = To_Task_ID (Idle_Task'Address) then - Scheduler_Idle := True; - R_Restore_Flags (Flags); - pragma Debug (Printk ("!!!kernel idle!!!" & LF)); - goto Idle; - end if; - - if Top_Task = Current_Task then - pragma Debug (Printk ("Rt_Schedule: Top_Task = Current_Task" & LF)); - -- if current task continues, just return. - - R_Restore_Flags (Flags); - return; - end if; - - if Top_Task = Environment_Task_ID then - pragma Debug (Printk - ("Rt_Schedule: Top_Task = Environment_Task" & LF)); - -- If there are no RT tasks ready, we execute the regular - -- GNU/Linux kernel, and allow the regular GNU/Linux interrupt - -- handlers to preempt the current task again. - - if not In_Elab_Code then - SFIF := GNU_Linux_Irq_State; - end if; - - elsif Current_Task = Environment_Task_ID then - pragma Debug (Printk - ("Rt_Schedule: Current_Task = Environment_Task" & LF)); - -- We are going to preempt the regular GNU/Linux kernel to - -- execute an RT task, so don't allow the regular GNU/Linux - -- interrupt handlers to preempt the current task any more. - - GNU_Linux_Irq_State := SFIF; - SFIF := 0; - end if; - - Top_Task.Common.LL.State := RT_TASK_READY; - Rt_Switch_To (Top_Task); - R_Restore_Flags (Flags); - end Rt_Schedule; - - procedure Insert_R (T : Task_ID) is - Q : Task_ID := To_Task_ID (Idle_Task.Common.LL.Succ); - begin - pragma Debug (Printk ("procedure Insert_R called" & LF)); - - pragma Assert (T.Common.LL.Succ = To_Address (T)); - pragma Assert (T.Common.LL.Pred = To_Address (T)); - - -- T is inserted in the queue between a task that has higher - -- or the same Active_Priority as T and a task that has lower - -- Active_Priority than T - - while Q /= To_Task_ID (Idle_Task'Address) - and then T.Common.LL.Active_Priority <= Q.Common.LL.Active_Priority - loop - Q := To_Task_ID (Q.Common.LL.Succ); - end loop; - - -- Q is successor of T - - T.Common.LL.Succ := To_Address (Q); - T.Common.LL.Pred := Q.Common.LL.Pred; - To_Task_ID (T.Common.LL.Pred).Common.LL.Succ := To_Address (T); - Q.Common.LL.Pred := To_Address (T); - end Insert_R; - - procedure Insert_RF (T : Task_ID) is - Q : Task_ID := To_Task_ID (Idle_Task.Common.LL.Succ); - begin - pragma Debug (Printk ("procedure Insert_RF called" & LF)); - - pragma Assert (T.Common.LL.Succ = To_Address (T)); - pragma Assert (T.Common.LL.Pred = To_Address (T)); - - -- T is inserted in the queue between a task that has higher - -- Active_Priority as T and a task that has lower or the same - -- Active_Priority as T - - while Q /= To_Task_ID (Idle_Task'Address) and then - T.Common.LL.Active_Priority < Q.Common.LL.Active_Priority - loop - Q := To_Task_ID (Q.Common.LL.Succ); - end loop; - - -- Q is successor of T - - T.Common.LL.Succ := To_Address (Q); - T.Common.LL.Pred := Q.Common.LL.Pred; - To_Task_ID (T.Common.LL.Pred).Common.LL.Succ := To_Address (T); - Q.Common.LL.Pred := To_Address (T); - end Insert_RF; - - procedure Delete_R (T : Task_ID) is - Tpred : constant Task_ID := To_Task_ID (T.Common.LL.Pred); - Tsucc : constant Task_ID := To_Task_ID (T.Common.LL.Succ); - - begin - pragma Debug (Printk ("procedure Delete_R called" & LF)); - - -- checking whether T is in the queue is not necessary because - -- if T is not in the queue, following statements changes - -- nothing. But T cannot be in the Timer_Queue, otherwise - -- activate the check below, note that checking whether T is - -- in a queue is a relatively expensive operation - - Tpred.Common.LL.Succ := To_Address (Tsucc); - Tsucc.Common.LL.Pred := To_Address (Tpred); - T.Common.LL.Succ := To_Address (T); - T.Common.LL.Pred := To_Address (T); - end Delete_R; - - procedure Insert_T (T : Task_ID) is - Q : Task_ID := To_Task_ID (Timer_Queue.Common.LL.Succ); - begin - pragma Debug (Printk ("procedure Insert_T called" & LF)); - - pragma Assert (T.Common.LL.Succ = To_Address (T)); - - while Q /= To_Task_ID (Timer_Queue'Address) and then - T.Common.LL.Resume_Time > Q.Common.LL.Resume_Time - loop - Q := To_Task_ID (Q.Common.LL.Succ); - end loop; - - -- Q is the task that has Resume_Time equal to or greater than that - -- of T. If they have the same Resume_Time, continue looking for the - -- location T is to be inserted using its Active_Priority - - while Q /= To_Task_ID (Timer_Queue'Address) and then - T.Common.LL.Resume_Time = Q.Common.LL.Resume_Time - loop - exit when T.Common.LL.Active_Priority > Q.Common.LL.Active_Priority; - Q := To_Task_ID (Q.Common.LL.Succ); - end loop; - - -- Q is successor of T - - T.Common.LL.Succ := To_Address (Q); - T.Common.LL.Pred := Q.Common.LL.Pred; - To_Task_ID (T.Common.LL.Pred).Common.LL.Succ := To_Address (T); - Q.Common.LL.Pred := To_Address (T); - end Insert_T; - - procedure Delete_T (T : Task_ID) is - Tpred : constant Task_ID := To_Task_ID (T.Common.LL.Pred); - Tsucc : constant Task_ID := To_Task_ID (T.Common.LL.Succ); - - begin - pragma Debug (Printk ("procedure Delete_T called" & LF)); - - pragma Assert (T /= To_Task_ID (Timer_Queue'Address)); - - Tpred.Common.LL.Succ := To_Address (Tsucc); - Tsucc.Common.LL.Pred := To_Address (Tpred); - T.Common.LL.Succ := To_Address (T); - T.Common.LL.Pred := To_Address (T); - end Delete_T; - - procedure Move_Top_Task_From_Timer_Queue_To_Ready_Queue is - Top_Task : Task_ID := To_Task_ID (Timer_Queue.Common.LL.Succ); - begin - pragma Debug (Printk ("procedure Move_Top_Task called" & LF)); - - if Top_Task /= To_Task_ID (Timer_Queue'Address) then - Delete_T (Top_Task); - Top_Task.Common.LL.State := RT_TASK_READY; - Insert_R (Top_Task); - end if; - end Move_Top_Task_From_Timer_Queue_To_Ready_Queue; - - ---------- - -- Self -- - ---------- - - function Self return Task_ID is - begin - pragma Debug (Printk ("function Self called" & LF)); - - return Current_Task; - end Self; - - --------------------- - -- Initialize_Lock -- - --------------------- - - procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is - begin - pragma Debug (Printk ("procedure Initialize_Lock called" & LF)); - - L.Ceiling_Priority := Prio; - L.Owner := System.Null_Address; - end Initialize_Lock; - - procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is - begin - pragma Debug (Printk ("procedure Initialize_Lock (RTS) called" & LF)); - - L.Ceiling_Priority := System.Any_Priority'Last; - L.Owner := System.Null_Address; - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : access Lock) is - begin - pragma Debug (Printk ("procedure Finalize_Lock called" & LF)); - null; - end Finalize_Lock; - - procedure Finalize_Lock (L : access RTS_Lock) is - begin - pragma Debug (Printk ("procedure Finalize_Lock (RTS) called" & LF)); - null; - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - Prio : constant System.Any_Priority := - Current_Task.Common.LL.Active_Priority; - - begin - pragma Debug (Printk ("procedure Write_Lock called" & LF)); - - Ceiling_Violation := False; - - if Prio > L.Ceiling_Priority then - -- Ceiling violation. - -- This should never happen, unless something is seriously - -- wrong with task T or the entire run-time system. - -- ???? extreme error recovery, e.g. shut down the system or task - - Ceiling_Violation := True; - pragma Debug (Printk ("Ceiling Violation in Write_Lock" & LF)); - return; - end if; - - L.Pre_Locking_Priority := Prio; - L.Owner := To_Address (Current_Task); - Current_Task.Common.LL.Active_Priority := L.Ceiling_Priority; - - if Current_Task.Common.LL.Outer_Lock = null then - -- If this lock is not nested, record a pointer to it. - - Current_Task.Common.LL.Outer_Lock := - To_RTS_Lock_Ptr (L.all'Unchecked_Access); - end if; - end Write_Lock; - - procedure Write_Lock - (L : access RTS_Lock; Global_Lock : Boolean := False) - is - Prio : constant System.Any_Priority := - Current_Task.Common.LL.Active_Priority; - - begin - pragma Debug (Printk ("procedure Write_Lock (RTS) called" & LF)); - - if Prio > L.Ceiling_Priority then - -- Ceiling violation. - -- This should never happen, unless something is seriously - -- wrong with task T or the entire runtime system. - -- ???? extreme error recovery, e.g. shut down the system or task - - Printk ("Ceiling Violation in Write_Lock (RTS)" & LF); - return; - end if; - - L.Pre_Locking_Priority := Prio; - L.Owner := To_Address (Current_Task); - Current_Task.Common.LL.Active_Priority := L.Ceiling_Priority; - - if Current_Task.Common.LL.Outer_Lock = null then - Current_Task.Common.LL.Outer_Lock := L.all'Unchecked_Access; - end if; - end Write_Lock; - - procedure Write_Lock (T : Task_ID) is - Prio : constant System.Any_Priority := - Current_Task.Common.LL.Active_Priority; - - begin - pragma Debug (Printk ("procedure Write_Lock (Task_ID) called" & LF)); - - if Prio > T.Common.LL.L.Ceiling_Priority then - -- Ceiling violation. - -- This should never happen, unless something is seriously - -- wrong with task T or the entire runtime system. - -- ???? extreme error recovery, e.g. shut down the system or task - - Printk ("Ceiling Violation in Write_Lock (Task)" & LF); - return; - end if; - - T.Common.LL.L.Pre_Locking_Priority := Prio; - T.Common.LL.L.Owner := To_Address (Current_Task); - Current_Task.Common.LL.Active_Priority := T.Common.LL.L.Ceiling_Priority; - - if Current_Task.Common.LL.Outer_Lock = null then - Current_Task.Common.LL.Outer_Lock := T.Common.LL.L'Access; - end if; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - begin - pragma Debug (Printk ("procedure Read_Lock called" & LF)); - Write_Lock (L, Ceiling_Violation); - end Read_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : access Lock) is - Flags : Integer; - begin - pragma Debug (Printk ("procedure Unlock called" & LF)); - - if L.Owner /= To_Address (Current_Task) then - -- ...error recovery - - null; - Printk ("The caller is not the owner of the lock" & LF); - return; - end if; - - L.Owner := System.Null_Address; - - -- Now that the lock is released, lower own priority, - - if Current_Task.Common.LL.Outer_Lock = - To_RTS_Lock_Ptr (L.all'Unchecked_Access) - then - -- This lock is the outer-most one, reset own priority to - -- Current_Priority; - - Current_Task.Common.LL.Active_Priority := - Current_Task.Common.Current_Priority; - Current_Task.Common.LL.Outer_Lock := null; - - else - -- If this lock is nested, pop the old active priority. - - Current_Task.Common.LL.Active_Priority := L.Pre_Locking_Priority; - end if; - - -- Reschedule the task if necessary. Note we only need to reschedule - -- the task if its Active_Priority becomes less than the one following - -- it. The check depends on the fact that Environment_Task (tail of - -- the ready queue) has the lowest Active_Priority - - if Current_Task.Common.LL.Active_Priority - < To_Task_ID (Current_Task.Common.LL.Succ).Common.LL.Active_Priority - then - R_Save_Flags (Flags); - R_Cli; - Delete_R (Current_Task); - Insert_RF (Current_Task); - R_Restore_Flags (Flags); - Rt_Schedule; - end if; - end Unlock; - - procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is - Flags : Integer; - begin - pragma Debug (Printk ("procedure Unlock (RTS_Lock) called" & LF)); - - if L.Owner /= To_Address (Current_Task) then - null; - Printk ("The caller is not the owner of the lock" & LF); - return; - end if; - - L.Owner := System.Null_Address; - - if Current_Task.Common.LL.Outer_Lock = L.all'Unchecked_Access then - Current_Task.Common.LL.Active_Priority := - Current_Task.Common.Current_Priority; - Current_Task.Common.LL.Outer_Lock := null; - - else - Current_Task.Common.LL.Active_Priority := L.Pre_Locking_Priority; - end if; - - -- Reschedule the task if necessary - - if Current_Task.Common.LL.Active_Priority - < To_Task_ID (Current_Task.Common.LL.Succ).Common.LL.Active_Priority - then - R_Save_Flags (Flags); - R_Cli; - Delete_R (Current_Task); - Insert_RF (Current_Task); - R_Restore_Flags (Flags); - Rt_Schedule; - end if; - end Unlock; - - procedure Unlock (T : Task_ID) is - begin - pragma Debug (Printk ("procedure Unlock (Task_ID) called" & LF)); - Unlock (T.Common.LL.L'Access); - end Unlock; - - ----------- - -- Sleep -- - ----------- - - -- Unlock Self_ID.Common.LL.L and suspend Self_ID, atomically. - -- Before return, lock Self_ID.Common.LL.L again - -- Self_ID can only be reactivated by calling Wakeup. - -- Unlock code is repeated intentionally. - - procedure Sleep - (Self_ID : Task_ID; - Reason : ST.Task_States) - is - Flags : Integer; - begin - pragma Debug (Printk ("procedure Sleep called" & LF)); - - -- Note that Self_ID is actually Current_Task, that is, only the - -- task that is running can put itself into sleep. To preserve - -- consistency, we use Self_ID throughout the code here - - Self_ID.Common.State := Reason; - Self_ID.Common.LL.State := RT_TASK_DORMANT; - - R_Save_Flags (Flags); - R_Cli; - - Delete_R (Self_ID); - - -- Arrange to unlock Self_ID's ATCB lock. The following check - -- may be unnecessary because the specification of Sleep says - -- the caller shoud hold its own ATCB lock before calling Sleep - - if Self_ID.Common.LL.L.Owner = To_Address (Self_ID) then - Self_ID.Common.LL.L.Owner := System.Null_Address; - - if Self_ID.Common.LL.Outer_Lock = Self_ID.Common.LL.L'Access then - Self_ID.Common.LL.Active_Priority := - Self_ID.Common.Current_Priority; - Self_ID.Common.LL.Outer_Lock := null; - - else - Self_ID.Common.LL.Active_Priority := - Self_ID.Common.LL.L.Pre_Locking_Priority; - end if; - end if; - - R_Restore_Flags (Flags); - Rt_Schedule; - - -- Before leave, regain the lock - - Write_Lock (Self_ID); - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - -- Arrange to be awakened after/at Time (depending on Mode) then Unlock - -- Self_ID.Common.LL.L and suspend self. If the timeout expires first, - -- that should awaken the task. If it's awakened (by some other task - -- calling Wakeup) before the timeout expires, the timeout should be - -- cancelled. - - -- 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 - Flags : Integer; - Abs_Time : RTIME; - - begin - pragma Debug (Printk ("procedure Timed_Sleep called" & LF)); - - Timedout := True; - Yielded := False; - -- ??? These two boolean seems not relevant here - - if Mode = Relative then - Abs_Time := To_RTIME (Time) + Rt_Get_Time; - else - Abs_Time := To_RTIME (Time); - end if; - - Self_ID.Common.LL.Resume_Time := Abs_Time; - Self_ID.Common.LL.State := RT_TASK_DELAYED; - - R_Save_Flags (Flags); - R_Cli; - Delete_R (Self_ID); - Insert_T (Self_ID); - - -- Check if the timer needs to be set - - if Timer_Queue.Common.LL.Succ = To_Address (Self_ID) then - Rt_Set_Timer (Abs_Time); - end if; - - -- Another way to do it - -- - -- if Abs_Time < - -- To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time - -- then - -- Rt_Set_Timer (Abs_Time); - -- end if; - - -- Arrange to unlock Self_ID's ATCB lock. see comments in Sleep - - if Self_ID.Common.LL.L.Owner = To_Address (Self_ID) then - Self_ID.Common.LL.L.Owner := System.Null_Address; - - if Self_ID.Common.LL.Outer_Lock = Self_ID.Common.LL.L'Access then - Self_ID.Common.LL.Active_Priority := - Self_ID.Common.Current_Priority; - Self_ID.Common.LL.Outer_Lock := null; - - else - Self_ID.Common.LL.Active_Priority := - Self_ID.Common.LL.L.Pre_Locking_Priority; - end if; - end if; - - R_Restore_Flags (Flags); - Rt_Schedule; - - -- Before leaving, regain the lock - - Write_Lock (Self_ID); - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - -- This is for use in implementing delay statements, so we assume - -- the caller is not abort-deferred and is holding no locks. - -- Self_ID can only be awakened after the timeout, no Wakeup on it. - - procedure Timed_Delay - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes) - is - Flags : Integer; - Abs_Time : RTIME; - - begin - pragma Debug (Printk ("procedure Timed_Delay called" & LF)); - - -- 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! :( - - Write_Lock (Self_ID); - - -- Take the lock in case its ATCB needs to be modified - - if Mode = Relative then - Abs_Time := To_RTIME (Time) + Rt_Get_Time; - else - Abs_Time := To_RTIME (Time); - end if; - - Self_ID.Common.LL.Resume_Time := Abs_Time; - Self_ID.Common.LL.State := RT_TASK_DELAYED; - - R_Save_Flags (Flags); - R_Cli; - Delete_R (Self_ID); - Insert_T (Self_ID); - - -- Check if the timer needs to be set - - if Timer_Queue.Common.LL.Succ = To_Address (Self_ID) then - Rt_Set_Timer (Abs_Time); - end if; - - -- Arrange to unlock Self_ID's ATCB lock. - -- Note that the code below is slightly different from Unlock, so - -- it is more than inline it. - - if To_Task_ID (Self_ID.Common.LL.L.Owner) = Self_ID then - Self_ID.Common.LL.L.Owner := System.Null_Address; - - if Self_ID.Common.LL.Outer_Lock = Self_ID.Common.LL.L'Access then - Self_ID.Common.LL.Active_Priority := - Self_ID.Common.Current_Priority; - Self_ID.Common.LL.Outer_Lock := null; - - else - Self_ID.Common.LL.Active_Priority := - Self_ID.Common.LL.L.Pre_Locking_Priority; - end if; - end if; - - R_Restore_Flags (Flags); - Rt_Schedule; - end Timed_Delay; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - -- RTIME is represented as a 64-bit signed count of ticks, - -- where there are 1_193_180 ticks per second. - - -- Let T be a count of ticks and N the corresponding count of nanoseconds. - -- From the following relationship - -- T / (ticks_per_second) = N / (ns_per_second) - -- where ns_per_second is 1_000_000_000 (number of nanoseconds in - -- a second), we get - -- T * (ns_per_second) = N * (ticks_per_second) - -- or - -- T * 1_000_000_000 = N * 1_193_180 - -- which can be reduced to - -- T * 50_000_000 = N * 59_659 - -- Let Nano_Count = 50_000_000 and Tick_Count = 59_659, we then have - -- T * Nano_Count = N * Tick_Count - - -- IMPORTANT FACT: - -- These numbers are small enough that we can do arithmetic - -- on them without overflowing 64 bits. To see this, observe - - -- 10**3 = 1000 < 1024 = 2**10 - -- Tick_Count < 60 * 1000 < 64 * 1024 < 2**16 - -- Nano_Count < 50 * 1000 * 1000 < 64 * 1024 * 1024 < 2**26 - - -- It follows that if 0 <= R < Tick_Count, we can compute - -- R * Nano_Count < 2**42 without overflow in 64 bits. - -- Similarly, if 0 <= R < Nano_Count, we can compute - -- R * Tick_Count < 2**42 without overflow in 64 bits. - - -- GNAT represents Duration as a count of nanoseconds internally. - - -- To convert T from RTIME to Duration, let - -- Q = T / Tick_Count, with truncation - -- R = T - Q * Tick_Count, the remainder 0 <= R < Tick_Count - -- so - -- N * Tick_Count - -- = T * Nano_Count - Q * Tick_Count * Nano_Count - -- + Q * Tick_Count * Nano_Count - -- = (T - Q * Tick_Count) * Nano_Count - -- + (Q * Nano_Count) * Tick_Count - -- = R * Nano_Count + (Q * Nano_Count) * Tick_Count - - -- Now, let - -- Q1 = R * Nano_Count / Tick_Count, with truncation - -- R1 = R * Nano_Count - Q1 * Tick_Count, 0 <= R1 True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ----------------- - -- Stack_Guard -- - ----------------- - - -- Not implemented for now - - procedure Stack_Guard (T : Task_ID; On : Boolean) is - begin - null; - end Stack_Guard; - - -------------------- - -- Get_Thread_Id -- - -------------------- - - function Get_Thread_Id (T : Task_ID) return OSI.Thread_Id is - begin - return To_Address (T); - end Get_Thread_Id; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : Task_ID; - Thread_Self : OSI.Thread_Id) return Boolean is - begin - return False; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_ID; - Thread_Self : OSI.Thread_Id) return Boolean is - begin - return False; - end Resume_Task; - - ----------------- - -- Init_Module -- - ----------------- - - function Init_Module return Integer is - procedure adainit; - pragma Import (C, adainit); - - begin - adainit; - In_Elab_Code := False; - Set_Priority (Environment_Task_ID, Any_Priority'First); - return 0; - end Init_Module; - - -------------------- - -- Cleanup_Module -- - -------------------- - - procedure Cleanup_Module is - procedure adafinal; - pragma Import (C, adafinal); - - begin - adafinal; - end Cleanup_Module; - - ---------------- - -- Initialize -- - ---------------- - - -- The environment task is "special". The TCB of the environment task is - -- not in the TCB_Array above. Logically, all initialization code for the - -- runtime system is executed by the environment task, but until the - -- environment task has initialized its own TCB we dare not execute any - -- calls that try to access the TCB of Current_Task. It is allocated by - -- target-independent runtime system code, in System.Tasking.Initializa- - -- tion.Init_RTS, before the call to this procedure Initialize. The - -- target-independent runtime system initializes all the components that - -- are target-independent, but this package needs to be given a chance to - -- initialize the target-dependent data. We do that in this procedure. - - -- In the present implementation, Environment_Task is set to be the - -- regular GNU/Linux kernel task. - - procedure Initialize (Environment_Task : Task_ID) is - begin - pragma Debug (Printk ("procedure Initialize called" & LF)); - - Environment_Task_ID := Environment_Task; - - -- Build the list of available ATCB's. - - Available_TCBs := To_Task_ID (TCB_Array (1)'Address); - - for J in TCB_Array'First + 1 .. TCB_Array'Last - 1 loop - -- Note that the zeroth element in TCB_Array is not used, see - -- comments following the declaration of TCB_Array - - TCB_Array (J).Common.LL.Next := TCB_Array (J + 1)'Address; - end loop; - - TCB_Array (TCB_Array'Last).Common.LL.Next := System.Null_Address; - - -- Initialize the idle task, which is the head of Ready_Queue. - - Idle_Task.Common.LL.Magic := RT_TASK_MAGIC; - Idle_Task.Common.LL.State := RT_TASK_READY; - Idle_Task.Common.Current_Priority := System.Any_Priority'First; - Idle_Task.Common.LL.Active_Priority := System.Any_Priority'First; - Idle_Task.Common.LL.Succ := Idle_Task'Address; - Idle_Task.Common.LL.Pred := Idle_Task'Address; - - -- Initialize the regular GNU/Linux kernel task. - - Environment_Task.Common.LL.Magic := RT_TASK_MAGIC; - Environment_Task.Common.LL.State := RT_TASK_READY; - Environment_Task.Common.Current_Priority := System.Any_Priority'First; - Environment_Task.Common.LL.Active_Priority := System.Any_Priority'First; - Environment_Task.Common.LL.Succ := To_Address (Environment_Task); - Environment_Task.Common.LL.Pred := To_Address (Environment_Task); - - -- Initialize the head of Timer_Queue - - Timer_Queue.Common.LL.Succ := Timer_Queue'Address; - Timer_Queue.Common.LL.Pred := Timer_Queue'Address; - Timer_Queue.Common.LL.Resume_Time := Max_Sensible_Delay; - - -- Set the current task to regular GNU/Linux kernel task - - Current_Task := Environment_Task; - - -- Set Timer_Wrapper to be the timer handler - - Rt_Free_Timer; - Rt_Request_Timer (Timer_Wrapper'Address); - - -- Initialize the lock used to synchronize chain of all ATCBs. - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - - -- Single_Lock isn't supported in this configuration - pragma Assert (not Single_Lock); - - Enter_Task (Environment_Task); - end Initialize; - - end System.Task_Primitives.Operations; --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5qtaspri.ads gcc-3.4.0/gcc/ada/5qtaspri.ads *** gcc-3.3.3/gcc/ada/5qtaspri.ads 2002-03-14 10:58:37.000000000 +0000 --- gcc-3.4.0/gcc/ada/5qtaspri.ads 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,139 **** - ------------------------------------------------------------------------------ - -- -- - -- 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-2001, Florida State University -- - -- -- - -- GNARL is free software; you can redistribute it and/or modify it under -- - -- terms of the GNU General Public License as published by the Free Soft- -- - -- ware Foundation; either version 2, or (at your option) any later ver- -- - -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNARL; see file COPYING. If not, write -- - -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- - -- MA 02111-1307, USA. -- - -- -- - -- As a special exception, if other files instantiate generics from this -- - -- unit, or you link this unit with other files to produce an executable, -- - -- this unit does not by itself cause the resulting executable to be -- - -- covered by the GNU General Public License. This exception does not -- - -- however invalidate any other reasons why the executable file might be -- - -- covered by the GNU Public License. -- - -- -- - -- GNARL was developed by the GNARL team at Florida State University. It is -- - -- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- - -- State University (http://www.gnat.com). -- - -- -- - ------------------------------------------------------------------------------ - - -- RT_GNU/Linux version - - 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; - - package System.Task_Primitives is - - type Lock is limited private; - -- Used for implementation of protected objects. - - type Lock_Ptr is limited private; - - type RTS_Lock is limited private; - -- 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 RTS_Lock_Ptr is limited private; - - 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 RT_GNU_Linux_Lock is record - Ceiling_Priority : System.Any_Priority; - Pre_Locking_Priority : System.Any_Priority; - -- Used to store the task's active priority before it - -- acquires the lock - - Owner : System.Address; - -- This is really a Task_ID, but we can't use that type - -- here because this System.Tasking is "with" - -- the current package -- a circularity. - end record; - - type Lock is new RT_GNU_Linux_Lock; - type RTS_Lock is new RT_GNU_Linux_Lock; - - type RTS_Lock_Ptr is access all RTS_Lock; - type Lock_Ptr is access all Lock; - - type Private_Data is record - Stack : System.Address; - -- A stack space needed for the task. the space is allocated - -- when the task is being created and is deallocated when - -- the TCB for the task is finalized - - Uses_Fp : Integer; - -- A flag to indicate whether the task is going to use floating- - -- point unit. It's set to 1, indicating FP unit is always going - -- to be used. The reason is that it is in this private record and - -- necessary operation has to be provided for a user to call so as - -- to change its value - - Magic : Integer; - -- A special value is going to be stored in it when a task is - -- created. The value is RT_TASK_MAGIC (16#754d2774#) as declared - -- in System.OS_Interface - - State : System.OS_Interface.Rt_Task_States; - -- Shows whether the task is RT_TASK_READY, RT_TASK_DELAYED or - -- RT_TASK_DORMANT to support suspend, wait, wakeup. - - Stack_Bottom : System.Address; - - Active_Priority : System.Any_Priority; - -- Active priority of the task - - Period : System.OS_Interface.RTIME; - -- Intended originally to store the period of the task, but not used - -- in the current implementation - - Resume_Time : System.OS_Interface.RTIME; - -- Store the time the task has to be awakened - - Next : System.Address; - -- This really is a Task_ID, used to link the Available_TCBs. - - Succ : System.Address; - pragma Volatile (Succ); - Pred : System.Address; - pragma Volatile (Pred); - -- These really are Task_ID, used to implement a circular doubly - -- linked list for task queue - - L : aliased RTS_Lock; - - Outer_Lock : RTS_Lock_Ptr := null; - -- Used to track which Lock the task is holding is the outermost - -- one in order to implement priority setting and inheritance - end record; - - -- ???? May need to use pragma Atomic or Volatile on some - -- components; may also need to specify aliased for some. - end System.Task_Primitives; --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5rosinte.adb gcc-3.4.0/gcc/ada/5rosinte.adb *** gcc-3.3.3/gcc/ada/5rosinte.adb 2002-03-14 10:58:37.000000000 +0000 --- gcc-3.4.0/gcc/ada/5rosinte.adb 2004-04-08 17:40:05.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,12 ---- -- -- -- 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- -- *************** package body System.OS_Interface is *** 69,82 **** 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; - function To_Duration (TV : struct_timeval) return Duration is begin return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; --- 68,80 ---- S := time_t (Long_Long_Integer (D)); F := D - Duration (S); ! -- If F has negative value due to 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; function To_Duration (TV : struct_timeval) return Duration is begin return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; *************** package body System.OS_Interface is *** 92,99 **** -- 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 => int (Long_Long_Integer (F * 10#1#E6))); end To_Timeval; procedure pthread_init is --- 90,99 ---- -- 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 => int (Long_Long_Integer (F * 10#1#E6))); end To_Timeval; procedure pthread_init is *************** package body System.OS_Interface is *** 102,107 **** --- 102,109 ---- end pthread_init; 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 *** 116,125 **** return 0; end Get_Page_Size; - function mprotect - (addr : Address; len : size_t; prot : int) return int is - begin - return 0; - end mprotect; - end System.OS_Interface; --- 118,121 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5rosinte.ads gcc-3.4.0/gcc/ada/5rosinte.ads *** gcc-3.3.3/gcc/ada/5rosinte.ads 2003-01-29 17:40:47.000000000 +0000 --- gcc-3.4.0/gcc/ada/5rosinte.ads 2004-04-08 17:40:05.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- -- *************** package System.OS_Interface is *** 88,93 **** --- 87,93 ---- Max_Interrupt : constant := 31; type Signal is new int range 0 .. Max_Interrupt; + SIGXCPU : constant := 0; -- XCPU SIGHUP : constant := 1; -- hangup SIGINT : constant := 2; -- interrupt (rubout) SIGQUIT : constant := 3; -- quit (ASCD FS) *************** package System.OS_Interface is *** 106,112 **** SIGTERM : constant := 15; -- software termination signal from kill SIGUSR1 : constant := 16; -- user defined signal 1 SIGUSR2 : constant := 17; -- user defined signal 2 - SIGXCPU : constant := 0; -- XCPU SIGADAABORT : constant := SIGABRT; --- 106,111 ---- *************** package System.OS_Interface is *** 140,145 **** --- 139,146 ---- pragma Convention (C, struct_sigaction); type struct_sigaction_ptr is access all struct_sigaction; + SA_SIGINFO : constant := 16#02#; + SIG_BLOCK : constant := 1; SIG_UNBLOCK : constant := 2; SIG_SETMASK : constant := 3; *************** package System.OS_Interface is *** 230,236 **** type pthread_attr_t is limited private; type pthread_mutexattr_t is limited private; type pthread_condattr_t is limited private; ! type pthread_key_t is private; PTHREAD_CREATE_DETACHED : constant := 0; --- 231,237 ---- 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 new Interfaces.C.unsigned; PTHREAD_CREATE_DETACHED : constant := 0; *************** package System.OS_Interface is *** 262,268 **** PROT_OFF : constant := 0; function mprotect (addr : Address; len : size_t; prot : int) return int; ! -- Do nothing on RTEMS. ----------------------------------------- -- Nonstandard Thread Initialization -- --- 263,269 ---- PROT_OFF : constant := 0; function mprotect (addr : Address; len : size_t; prot : int) return int; ! pragma Import (C, mprotect); ----------------------------------------- -- Nonstandard Thread Initialization -- *************** private *** 521,526 **** type pthread_cond_t is new rtems_id; - type pthread_key_t is new rtems_id; - end System.OS_Interface; --- 522,525 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5rparame.adb gcc-3.4.0/gcc/ada/5rparame.adb *** gcc-3.3.3/gcc/ada/5rparame.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5rparame.adb 2003-04-24 17:53:51.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1997-1998 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/5rtpopsp.adb gcc-3.4.0/gcc/ada/5rtpopsp.adb *** gcc-3.3.3/gcc/ada/5rtpopsp.adb 2003-01-29 17:40:47.000000000 +0000 --- gcc-3.4.0/gcc/ada/5rtpopsp.adb 2004-04-08 17:40:05.000000000 +0000 *************** *** 7,15 **** -- -- -- B o d y -- -- -- ! -- $Revision: 1.1.4.1 $ -- -- ! -- Copyright (C) 1991-1999, 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- -- --- 7,15 ---- -- -- -- B o d y -- -- -- ! -- $Revision: 1.2 $ -- -- ! -- Copyright (C) 1991-2003, 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- -- *************** *** 35,217 **** -- -- ------------------------------------------------------------------------------ ! -- This is a POSIX version of this package where foreign threads are ! -- recognized. ! -- Currently, DEC Unix, SCO UnixWare 7 and RTEMS use this version. ! ! 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. - -- The following gives the Ada run-time direct access to a variable -- context switched by RTEMS at the lowest level. RTEMS_Ada_Self : System.Address; pragma Import (C, RTEMS_Ada_Self, "rtems_ada_self"); - -- 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 All_Tasks_L; - -- 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 implicitely or explicitely - -- "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; - - begin - -- This section is ticklish. - -- We dare not call anything that might require an ATCB, until - -- we have the new ATCB in place. - - Write_Lock (All_Tasks_L'Access); - 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; - - RTEMS_Ada_Self := To_Address (Self_ID); - - -- 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.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 (All_Tasks_L'Access); - return Self_ID; - end New_Fake_ATCB; - ---------------- -- Initialize -- ---------------- procedure Initialize (Environment_Task : Task_ID) is begin RTEMS_Ada_Self := To_Address (Environment_Task); ! -- 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 ! begin RTEMS_Ada_Self := To_Address (Self_Id); end Set; --- 35,82 ---- -- -- ------------------------------------------------------------------------------ ! -- This is a RTEMS version of this package which uses a special ! -- variable for Ada self which is contexted switch implicitly by RTEMS. ! -- ! -- This is the same as the POSIX version except that an RTEMS variable ! -- is used instead of a POSIX key. separate (System.Task_Primitives.Operations) package body Specific is -- The following gives the Ada run-time direct access to a variable -- context switched by RTEMS at the lowest level. RTEMS_Ada_Self : System.Address; pragma Import (C, RTEMS_Ada_Self, "rtems_ada_self"); ---------------- -- Initialize -- ---------------- procedure Initialize (Environment_Task : Task_ID) is + pragma Warnings (Off, Environment_Task); + Result : Interfaces.C.int; begin RTEMS_Ada_Self := To_Address (Environment_Task); + end Initialize; ! ------------------- ! -- Is_Valid_Task -- ! ------------------- ! function Is_Valid_Task return Boolean is ! begin ! return RTEMS_Ada_Self /= System.Null_Address; ! end Is_Valid_Task; --------- -- Set -- --------- procedure Set (Self_Id : Task_ID) is ! Result : Interfaces.C.int; begin RTEMS_Ada_Self := To_Address (Self_Id); end Set; *************** package body Specific is *** 220,252 **** -- 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. ! ! -- (The entire Ada run-time system may not have been elaborated, ! -- either, but that is a different problem, that we will need to ! -- solve another way.) ! ! -- 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. ! -- We will also use such points to poll for disappearance of the ! -- threads associated with any implicit ATCBs that we created ! -- earlier, and take the opportunity to recover them. ! -- A nasty problem here is the limitations of the compilation ! -- order dependency, and in particular the GNARL/GNULLI layering. ! -- To initialize an ATCB we need to assume System.Tasking has ! -- been elaborated. function Self return Task_ID is Result : System.Address; --- 85,102 ---- -- 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 Result : System.Address; *************** package body Specific is *** 256,266 **** -- 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; --- 106,116 ---- -- 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/5sintman.adb gcc-3.4.0/gcc/ada/5sintman.adb *** gcc-3.3.3/gcc/ada/5sintman.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5sintman.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 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 body System.Interrupt_Management *** 78,87 **** info : access siginfo_t; context : access ucontext_t); procedure Notify_Exception (signo : Signal; info : access siginfo_t; ! context : access ucontext_t) is begin -- Check that treatment of exception propagation here -- is consistent with treatment of the abort signal in --- 77,93 ---- info : access siginfo_t; context : access ucontext_t); + ---------------------- + -- Notify_Exception -- + ---------------------- + procedure Notify_Exception (signo : Signal; info : access siginfo_t; ! context : access ucontext_t) ! is ! pragma Warnings (Off, context); ! begin -- Check that treatment of exception propagation here -- is consistent with treatment of the abort signal in *************** begin *** 137,142 **** --- 143,163 ---- mask : aliased sigset_t; Result : Interfaces.C.int; + 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 -- Need to call pthread_init very early because it is doing signal -- initializations. *************** begin *** 170,206 **** act.sa_mask := mask; ! 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 let the user the ability to ! -- change this behavior. ! if Unreserve_All_Interrupts = 0 then Keep_Unmasked (SIGINT) := True; end if; ! 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; 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; -- 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 --- 191,258 ---- act.sa_mask := mask; ! pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False)); ! pragma Assert (Reserve = (Interrupt_ID'Range => False)); ! 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; ! if State (Exception_Interrupts (J)) /= Default then ! Result := ! sigaction ! (Signal (Exception_Interrupts (J)), act'Unchecked_Access, ! old_act'Unchecked_Access); ! pragma Assert (Result = 0); ! end if; ! 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; + Reserve (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 the set of signals that must always be unmasked for this target + for J in Unmasked'Range loop Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True; + Reserve (Interrupt_ID (Unmasked (J))) := True; end loop; ! -- Add target-specific reserved signals for J in Reserved'Range loop Reserve (Interrupt_ID (Reserved (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 diff -Nrc3pad gcc-3.3.3/gcc/ada/5sml-tgt.adb gcc-3.4.0/gcc/ada/5sml-tgt.adb *** gcc-3.3.3/gcc/ada/5sml-tgt.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5sml-tgt.adb 2004-01-05 15:20:43.000000000 +0000 *************** *** 0 **** --- 1,371 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T -- + -- (Solaris 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 Solaris 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 : constant String := "-Wl,-zinitarray="; + Wl_Fini_String : constant String := "-Wl,-zfiniarray="; + + Init_Fini_List : constant Argument_List_Access := + new Argument_List'(1 => null, + 2 => 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 (1) := + new String'(Wl_Init_String & Lib_Filename & "init"); + Init_Fini (2) := + new String'(Wl_Fini_String & 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,-h," & 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; + + 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,-R,"); + 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/5sosinte.adb gcc-3.4.0/gcc/ada/5sosinte.adb *** gcc-3.3.3/gcc/ada/5sosinte.adb 2002-03-14 10:58:37.000000000 +0000 --- gcc-3.4.0/gcc/ada/5sosinte.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 *** 68,75 **** -- 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; function To_Duration (TV : struct_timeval) return Duration is --- 67,74 ---- -- 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; function To_Duration (TV : struct_timeval) return Duration is *************** package body System.OS_Interface is *** 87,94 **** -- 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; procedure pthread_init is --- 86,95 ---- -- 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; procedure pthread_init is diff -Nrc3pad gcc-3.3.3/gcc/ada/5sosinte.ads gcc-3.4.0/gcc/ada/5sosinte.ads *** gcc-3.3.3/gcc/ada/5sosinte.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5sosinte.ads 2003-10-21 13:41:52.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-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 *** 127,133 **** -- Following signals should not be disturbed. -- See c-posix-signals.c in FLORIST ! Reserved : constant Signal_Set := (SIGKILL, SIGSTOP, SIGWAITING, SIGCANCEL); type sigset_t is private; --- 126,133 ---- -- Following signals should not be disturbed. -- See c-posix-signals.c in FLORIST ! Reserved : constant Signal_Set := ! (SIGKILL, SIGSTOP, SIGWAITING, SIGCANCEL, SIGTRAP, SIGSEGV); type sigset_t is private; *************** package System.OS_Interface is *** 259,264 **** --- 259,268 ---- (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); diff -Nrc3pad gcc-3.3.3/gcc/ada/5sosprim.adb gcc-3.4.0/gcc/ada/5sosprim.adb *** gcc-3.3.3/gcc/ada/5sosprim.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5sosprim.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 0 **** --- 1,124 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . O S _ P R I M I T I V E S -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 1998-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 version uses gettimeofday and select + -- This file is suitable for Solaris (32 and 64 bits). + + package body System.OS_Primitives is + + -- ??? These definitions are duplicated from System.OS_Interface + -- because we don't want to depend on any package. Consider removing + -- these declarations in System.OS_Interface and move these ones in + -- the spec. + + type struct_timeval is record + tv_sec : Long_Integer; + tv_usec : Long_Integer; + end record; + pragma Convention (C, struct_timeval); + + procedure gettimeofday + (tv : access struct_timeval; + tz : Address := Null_Address); + pragma Import (C, gettimeofday, "gettimeofday"); + + procedure C_select + (n : Integer := 0; + readfds, + writefds, + exceptfds : Address := Null_Address; + timeout : access struct_timeval); + pragma Import (C, C_select, "select"); + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + TV : aliased struct_timeval; + + begin + gettimeofday (TV'Access); + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end Clock; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration renames Clock; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Rel_Time : Duration; + Abs_Time : Duration; + Check_Time : Duration := Clock; + timeval : aliased struct_timeval; + + begin + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Time + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + timeval.tv_sec := Long_Integer (Rel_Time); + + if Duration (timeval.tv_sec) > Rel_Time then + timeval.tv_sec := timeval.tv_sec - 1; + end if; + + timeval.tv_usec := + Long_Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6); + + C_select (timeout => timeval'Unchecked_Access); + Check_Time := Clock; + + exit when Abs_Time <= Check_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + + end System.OS_Primitives; diff -Nrc3pad gcc-3.3.3/gcc/ada/5sparame.adb gcc-3.4.0/gcc/ada/5sparame.adb *** gcc-3.3.3/gcc/ada/5sparame.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5sparame.adb 2003-04-24 17:53:52.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1998-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/5ssystem.ads gcc-3.4.0/gcc/ada/5ssystem.ads *** gcc-3.3.3/gcc/ada/5ssystem.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5ssystem.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 7,14 **** -- S p e c -- -- (SUN 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 -- --- 7,13 ---- -- S p e c -- -- (SUN 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 := 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 := 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; + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/5staprop.adb gcc-3.4.0/gcc/ada/5staprop.adb *** gcc-3.3.3/gcc/ada/5staprop.adb 2002-10-23 08:27:55.000000000 +0000 --- gcc-3.4.0/gcc/ada/5staprop.adb 2004-01-05 15:20:43.000000000 +0000 *************** *** 6,13 **** -- -- -- 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- -- --- 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 *** 102,110 **** package SSL renames System.Soft_Links; ! ------------------ ! -- Local Data -- ! ------------------ -- The following are logically constants, but need to be initialized -- at run time. --- 101,109 ---- package SSL renames System.Soft_Links; ! ---------------- ! -- Local Data -- ! ---------------- -- The following are logically constants, but need to be initialized -- at run time. *************** package body System.Task_Primitives.Oper *** 131,139 **** -- using in error checking. -- The following are internal configuration constants needed. ! ------------------------ ! -- Priority Support -- ! ------------------------ Priority_Ceiling_Emulation : constant Boolean := True; -- controls whether we emulate priority ceiling locking --- 130,138 ---- -- using in error checking. -- The following are internal configuration constants needed. ! ---------------------- ! -- Priority Support -- ! ---------------------- Priority_Ceiling_Emulation : constant Boolean := True; -- controls whether we emulate priority ceiling locking *************** package body System.Task_Primitives.Oper *** 154,162 **** -- Hold priority info (Real_Time) initialized during the package -- elaboration. ! ------------------------------------- ! -- External Configuration Values -- ! ------------------------------------- Time_Slice_Val : Interfaces.C.long; pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); --- 153,161 ---- -- Hold priority info (Real_Time) initialized during the package -- elaboration. ! ----------------------------------- ! -- External Configuration Values -- ! ----------------------------------- Time_Slice_Val : Interfaces.C.long; pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); *************** package body System.Task_Primitives.Oper *** 167,217 **** Dispatching_Policy : Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); ! -------------------------------- ! -- Foreign Threads Detection -- ! -------------------------------- ! ! -- 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 run-time 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 - - ------------ - -- Checks -- - ------------ - - Check_Count : Integer := 0; - Old_Owner : Task_ID; - Lock_Count : Integer := 0; - Unlock_Count : Integer := 0; - - function To_Lock_Ptr is - new Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr); - function To_Task_ID is - new Unchecked_Conversion (Owner_ID, Task_ID); - function To_Owner_ID is - new Unchecked_Conversion (Task_ID, Owner_ID); - ----------------------- -- Local Subprograms -- ----------------------- --- 166,174 ---- Dispatching_Policy : Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); ! Foreign_Task_Elaborated : aliased Boolean := True; -- Used to identified fake tasks (i.e., non-Ada Threads). ----------------------- -- Local Subprograms -- ----------------------- *************** package body System.Task_Primitives.Oper *** 229,234 **** --- 186,194 ---- (Sig : Signal; Code : access siginfo_t; Context : access ucontext_t); + -- Target-dependent binding of inter-thread Abort signal to + -- the raising of the Abort_Signal exception. + -- See also comments in 7staprop.adb function To_thread_t is new Unchecked_Conversion (Integer, System.OS_Interface.thread_t); *************** package body System.Task_Primitives.Oper *** 240,253 **** function Thread_Body_Access is new Unchecked_Conversion (System.Address, Thread_Body); - function New_Fake_ATCB (Stack_Base : Interfaces.C.unsigned) 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. - pragma Warnings (Off, New_Fake_ATCB); - -- Disable warning on this function, since the Solaris x86 version does - -- not use it. - ------------ -- Checks -- ------------ --- 200,205 ---- *************** package body System.Task_Primitives.Oper *** 281,482 **** function Check_Finalize_Lock (L : Lock_Ptr) return Boolean; pragma Inline (Check_Finalize_Lock); ! ------------------- ! -- New_Fake_ATCB -- ! ------------------- ! ! function New_Fake_ATCB (Stack_Base : Interfaces.C.unsigned) ! 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. ! -- Note: we don't use Lock_RTS because we don't yet have an ATCB, and ! -- so can't pass the safety check. ! ! Result := mutex_lock (Single_RTS_Lock.L'Access); ! Q := null; ! P := Fake_ATCB_List; ! ! while P /= null loop ! if P.Stack_Base = 0 then ! Q := P; ! elsif thr_kill (P.Real_ATCB.Common.LL.Thread, 0) /= 0 then ! -- ???? ! -- If a C thread that has dependent Ada tasks terminates ! -- abruptly, e.g. as a result of cancellation, any dependent ! -- tasks are likely to hang up in termination. ! P.Stack_Base := 0; ! 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 := Stack_Base; ! 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 := Stack_Base; ! end if; ! ! -- 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); ! ! -- Record this as the Task_ID for the current thread. ! ! Self_ID.Common.LL.Thread := thr_self; ! Result := thr_setspecific (ATCB_Key, To_Address (Self_ID)); ! pragma Assert (Result = 0); ! ! -- 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; ! -- 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); ! 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); ! -- Must not unlock until Next_ATCB is again allocated. ! 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; ! Result := mutex_unlock (Single_RTS_Lock.L'Access); ! -- We cannot use Unlock_RTS because we did not use Write_Lock, and so ! -- would not pass the checks. ! return Self_ID; ! end New_Fake_ATCB; ------------------- -- 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). - - -- The following procedure would be needed if we can't longjmp out of - -- a signal handler. (See below.) - - -- procedure Raise_Abort_Signal is - -- begin - -- raise Standard'Abort_Signal; - -- end if; - - -- ??? - -- The comments above need revising. They are partly obsolete. - procedure Abort_Handler (Sig : Signal; Code : access siginfo_t; Context : access ucontext_t) is Self_ID : Task_ID := Self; - Result : Interfaces.C.int; Old_Set : aliased sigset_t; begin ! -- Assuming it is safe to longjmp out of a signal handler, the ! -- following code can be used: if Self_ID.Deferral_Level = 0 and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level and then not Self_ID.Aborting then - -- You can comment the following out, - -- to make all aborts synchronous, for debugging. - Self_ID.Aborting := True; -- Make sure signals used for RTS internal purpose are unmasked --- 233,319 ---- function Check_Finalize_Lock (L : Lock_Ptr) return Boolean; pragma Inline (Check_Finalize_Lock); ! -------------------- ! -- 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; ! ------------ ! -- Checks -- ! ------------ ! Check_Count : Integer := 0; ! Lock_Count : Integer := 0; ! Unlock_Count : Integer := 0; ! function To_Lock_Ptr is ! new Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr); ! function To_Owner_ID is ! new Unchecked_Conversion (Task_ID, Owner_ID); ------------------- -- Abort_Handler -- ------------------- procedure Abort_Handler (Sig : Signal; Code : access siginfo_t; Context : access ucontext_t) is + pragma Unreferenced (Sig); + pragma Unreferenced (Code); + pragma Unreferenced (Context); + Self_ID : Task_ID := Self; Old_Set : aliased sigset_t; + Result : Interfaces.C.int; + pragma Unreferenced (Result); + 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 Self_ID.Deferral_Level = 0 and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level and then not Self_ID.Aborting then Self_ID.Aborting := True; -- Make sure signals used for RTS internal purpose are unmasked *************** package body System.Task_Primitives.Oper *** 486,508 **** pragma Assert (Result = 0); raise Standard'Abort_Signal; - - -- ????? - -- Must be certain that the implementation of "raise" - -- does not make any OS/thread calls, or at least that - -- if it makes any, they are safe for interruption by - -- async. signals. end if; - - -- Otherwise, something like this is required: - -- if not Abort_Is_Deferred.all then - -- -- Overwrite the return PC address with the address of the - -- -- special raise routine, and "return" to that routine's - -- -- starting address. - -- Context.PC := Raise_Abort_Signal'Address; - -- return; - -- end if; - end Abort_Handler; ------------------- --- 323,329 ---- *************** package body System.Task_Primitives.Oper *** 513,518 **** --- 334,342 ---- -- 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 *** 526,536 **** return T.Common.LL.Thread; end Get_Thread_Id; ! ----------- ! -- Self -- ! ----------- ! function Self return Task_ID is separate; --------------------- -- Initialize_Lock -- --- 350,493 ---- return T.Common.LL.Thread; end Get_Thread_Id; ! ---------------- ! -- Initialize -- ! ---------------- ! procedure Initialize (Environment_Task : ST.Task_ID) is ! act : aliased struct_sigaction; ! old_act : aliased struct_sigaction; ! Tmp_Set : aliased sigset_t; ! Result : Interfaces.C.int; ! ! procedure Configure_Processors; ! -- Processors configuration ! -- The user can specify a processor which the program should run ! -- on to emulate a single-processor system. This can be easily ! -- done by setting environment variable GNAT_PROCESSOR to one of ! -- the following : ! -- ! -- -2 : use the default configuration (run the program on all ! -- available processors) - this is the same as having ! -- GNAT_PROCESSOR unset ! -- -1 : let the RTS choose one processor and run the program on ! -- that processor ! -- 0 .. Last_Proc : run the program on the specified processor ! -- ! -- Last_Proc is equal to the value of the system variable ! -- _SC_NPROCESSORS_CONF, minus one. ! ! procedure Configure_Processors is ! Proc_Acc : constant GNAT.OS_Lib.String_Access := ! GNAT.OS_Lib.Getenv ("GNAT_PROCESSOR"); ! Proc : aliased processorid_t; -- User processor # ! Last_Proc : processorid_t; -- Last processor # ! ! begin ! if Proc_Acc.all'Length /= 0 then ! -- Environment variable is defined ! ! Last_Proc := Num_Procs - 1; ! ! if Last_Proc /= -1 then ! Proc := processorid_t'Value (Proc_Acc.all); ! ! if Proc <= -2 or else Proc > Last_Proc then ! -- Use the default configuration ! null; ! elsif Proc = -1 then ! -- Choose a processor ! ! Result := 0; ! ! while Proc < Last_Proc loop ! Proc := Proc + 1; ! Result := p_online (Proc, PR_STATUS); ! exit when Result = PR_ONLINE; ! end loop; ! ! pragma Assert (Result = PR_ONLINE); ! Result := processor_bind (P_PID, P_MYID, Proc, null); ! pragma Assert (Result = 0); ! ! else ! -- Use user processor ! ! Result := processor_bind (P_PID, P_MYID, Proc, null); ! pragma Assert (Result = 0); ! end if; ! end if; ! end if; ! ! exception ! when Constraint_Error => ! ! -- Illegal environment variable GNAT_PROCESSOR - ignored ! ! null; ! end Configure_Processors; ! ! 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) ! ! -- Start of processing for Initialize ! ! begin ! Environment_Task_ID := Environment_Task; ! ! -- This is done in Enter_Task, but this is too late for the ! -- Environment Task, since we need to call Self in Check_Locks when ! -- the run time is compiled with assertions on. ! ! Specific.Initialize (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 ! ! if State (System.Interrupt_Management.Abort_Task_Interrupt) ! /= Default ! then ! -- Set sa_flags to SA_NODEFER so that during the handler execution ! -- we do not change the Signal_Mask to be masked for the Abort_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. ! -- In that case, this field should be changed back to 0. ??? ! ! act.sa_flags := 16; ! ! 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; ! ! Configure_Processors; ! end Initialize; --------------------- -- Initialize_Lock -- *************** package body System.Task_Primitives.Oper *** 647,655 **** 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 pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); --- 604,614 ---- 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 pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); *************** package body System.Task_Primitives.Oper *** 661,666 **** --- 620,626 ---- procedure Write_Lock (T : Task_ID) is Result : Interfaces.C.int; + begin if not Single_Lock then pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access))); *************** package body System.Task_Primitives.Oper *** 685,690 **** --- 645,651 ---- procedure Unlock (L : access Lock) is Result : Interfaces.C.int; + begin pragma Assert (Check_Unlock (Lock_Ptr (L))); *************** package body System.Task_Primitives.Oper *** 708,713 **** --- 669,675 ---- 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 pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); *************** package body System.Task_Primitives.Oper *** 718,723 **** --- 680,686 ---- procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; + begin if not Single_Lock then pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access))); *************** package body System.Task_Primitives.Oper *** 777,792 **** end if; end Yield; ------------------ -- Set_Priority -- ------------------ procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is ! Result : Interfaces.C.int; Param : aliased struct_pcparms; use Task_Info; --- 740,765 ---- end if; end Yield; + ----------- + -- Self --- + ----------- + + function Self return Task_ID renames Specific.Self; + ------------------ -- Set_Priority -- ------------------ procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is ! pragma Unreferenced (Loss_Of_Inheritance); ! ! Result : Interfaces.C.int; ! pragma Unreferenced (Result); ! Param : aliased struct_pcparms; use Task_Info; *************** package body System.Task_Primitives.Oper *** 886,893 **** end if; end if; ! Result := thr_setspecific (ATCB_Key, To_Address (Self_ID)); ! pragma Assert (Result = 0); -- We need the above code even if we do direct fetch of Task_ID in Self -- for the main task on Sun, x86 Solaris and for gcc 2.7.2. --- 859,865 ---- end if; end if; ! Specific.Set (Self_ID); -- We need the above code even if we do direct fetch of Task_ID in Self -- for the main task on Sun, x86 Solaris and for gcc 2.7.2. *************** package body System.Task_Primitives.Oper *** 914,925 **** --- 886,918 ---- 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 (thr_self); + end if; + end Register_Foreign_Thread; + -------------------- -- Initialize_TCB -- -------------------- procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is Result : Interfaces.C.int := 0; + begin -- Give the task a unique serial number. *************** package body System.Task_Primitives.Oper *** 965,970 **** --- 958,965 ---- Priority : System.Any_Priority; Succeeded : out Boolean) is + pragma Unreferenced (Priority); + Result : Interfaces.C.int; Adjusted_Stack_Size : Interfaces.C.size_t; Opts : Interfaces.C.int := THR_DETACHED; *************** package body System.Task_Primitives.Oper *** 977,982 **** --- 972,978 ---- -- actual use. use System.Task_Info; + begin if Stack_Size = System.Parameters.Unspecified_Size then Adjusted_Stack_Size := *************** package body System.Task_Primitives.Oper *** 997,1003 **** -- All tasks in RTS will have All_Tasks_Mask initially. if T.Common.Task_Info /= null then - if T.Common.Task_Info.New_LWP then Opts := Opts + THR_NEW_LWP; end if; --- 993,998 ---- *************** package body System.Task_Primitives.Oper *** 1032,1037 **** --- 1027,1033 ---- 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 *** 1052,1057 **** --- 1048,1058 ---- end if; Free (Tmp); + + if Is_Self then + Specific.Set (null); + end if; + end Finalize_TCB; --------------- *************** package body System.Task_Primitives.Oper *** 1064,1070 **** procedure Exit_Task is begin ! thr_exit (System.Null_Address); end Exit_Task; ---------------- --- 1065,1071 ---- procedure Exit_Task is begin ! Specific.Set (null); end Exit_Task; ---------------- *************** package body System.Task_Primitives.Oper *** 1092,1097 **** --- 1093,1099 ---- Reason : Task_States) is Result : Interfaces.C.int; + begin pragma Assert (Check_Sleep (Reason)); *************** package body System.Task_Primitives.Oper *** 1237,1243 **** 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; --- 1239,1247 ---- 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 *** 1345,1350 **** --- 1349,1355 ---- Reason : Task_States) is Result : Interfaces.C.int; + begin pragma Assert (Check_Wakeup (T, Reason)); Result := cond_signal (T.Common.LL.CV'Access); *************** package body System.Task_Primitives.Oper *** 1387,1393 **** ---------------- function Check_Lock (L : Lock_Ptr) return Boolean is ! Self_ID : Task_ID := Self; P : Lock_Ptr; begin --- 1392,1398 ---- ---------------- function Check_Lock (L : Lock_Ptr) return Boolean is ! Self_ID : constant Task_ID := Self; P : Lock_Ptr; begin *************** package body System.Task_Primitives.Oper *** 1476,1481 **** --- 1481,1488 ---- ----------------- function Check_Sleep (Reason : Task_States) return Boolean is + pragma Unreferenced (Reason); + Self_ID : Task_ID := Self; P : Lock_Ptr; *************** package body System.Task_Primitives.Oper *** 1520,1525 **** --- 1527,1534 ---- Reason : Task_States) return Boolean is + pragma Unreferenced (Reason); + Self_ID : Task_ID := Self; P : Lock_Ptr; *************** package body System.Task_Primitives.Oper *** 1554,1560 **** Reason : Task_States) return Boolean is ! Self_ID : Task_ID := Self; begin -- Is caller holding T's lock? --- 1563,1569 ---- Reason : Task_States) return Boolean is ! Self_ID : constant Task_ID := Self; begin -- Is caller holding T's lock? *************** package body System.Task_Primitives.Oper *** 1597,1603 **** if Unlock_Count - Check_Count > 1000 then Check_Count := Unlock_Count; - Old_Owner := To_Task_ID (Single_RTS_Lock.Owner); end if; -- Check that caller is abort-deferred --- 1606,1611 ---- *************** package body System.Task_Primitives.Oper *** 1626,1632 **** -------------------- function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is ! Self_ID : Task_ID := Self; begin -- Check that caller is abort-deferred --- 1634,1641 ---- -------------------- function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is ! Self_ID : constant Task_ID := Self; ! begin -- Check that caller is abort-deferred *************** package body System.Task_Primitives.Oper *** 1718,1724 **** function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin if T.Common.LL.Thread /= Thread_Self then return thr_suspend (T.Common.LL.Thread) = 0; --- 1727,1735 ---- function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) ! return Boolean ! is begin if T.Common.LL.Thread /= Thread_Self then return thr_suspend (T.Common.LL.Thread) = 0; *************** package body System.Task_Primitives.Oper *** 1733,1739 **** function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin if T.Common.LL.Thread /= Thread_Self then return thr_continue (T.Common.LL.Thread) = 0; --- 1744,1752 ---- function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) ! return Boolean ! is begin if T.Common.LL.Thread /= Thread_Self then return thr_continue (T.Common.LL.Thread) = 0; *************** package body System.Task_Primitives.Oper *** 1742,1876 **** end if; end Resume_Task; - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : ST.Task_ID) is - act : aliased struct_sigaction; - old_act : aliased struct_sigaction; - Tmp_Set : aliased sigset_t; - Result : Interfaces.C.int; - - procedure Configure_Processors; - -- Processors configuration - -- The user can specify a processor which the program should run - -- on to emulate a single-processor system. This can be easily - -- done by setting environment variable GNAT_PROCESSOR to one of - -- the following : - -- - -- -2 : use the default configuration (run the program on all - -- available processors) - this is the same as having - -- GNAT_PROCESSOR unset - -- -1 : let the RTS choose one processor and run the program on - -- that processor - -- 0 .. Last_Proc : run the program on the specified processor - -- - -- Last_Proc is equal to the value of the system variable - -- _SC_NPROCESSORS_CONF, minus one. - - procedure Configure_Processors is - Proc_Acc : constant GNAT.OS_Lib.String_Access := - GNAT.OS_Lib.Getenv ("GNAT_PROCESSOR"); - Proc : aliased processorid_t; -- User processor # - Last_Proc : processorid_t; -- Last processor # - - begin - if Proc_Acc.all'Length /= 0 then - -- Environment variable is defined - - Last_Proc := Num_Procs - 1; - - if Last_Proc /= -1 then - Proc := processorid_t'Value (Proc_Acc.all); - - if Proc <= -2 or else Proc > Last_Proc then - -- Use the default configuration - null; - elsif Proc = -1 then - -- Choose a processor - - Result := 0; - - while Proc < Last_Proc loop - Proc := Proc + 1; - Result := p_online (Proc, PR_STATUS); - exit when Result = PR_ONLINE; - end loop; - - pragma Assert (Result = PR_ONLINE); - Result := processor_bind (P_PID, P_MYID, Proc, null); - pragma Assert (Result = 0); - - else - -- Use user processor - - Result := processor_bind (P_PID, P_MYID, Proc, null); - pragma Assert (Result = 0); - end if; - end if; - end if; - - exception - when Constraint_Error => - -- Illegal environment variable GNAT_PROCESSOR - ignored - null; - end Configure_Processors; - - -- Start of processing for Initialize - - begin - Environment_Task_ID := Environment_Task; - - -- This is done in Enter_Task, but this is too late for the - -- Environment Task, since we need to call Self in Check_Locks when - -- the run time is compiled with assertions on. - - Result := thr_setspecific (ATCB_Key, To_Address (Environment_Task)); - pragma Assert (Result = 0); - - -- 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 - - -- Set sa_flags to SA_NODEFER so that during the handler execution - -- we do not change the Signal_Mask to be masked for the Abort_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. - -- In that case, this field should be changed back to 0. ??? - - act.sa_flags := 16; - - 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); - - Configure_Processors; - - -- Create a free ATCB for use on the Fake_ATCB_List. - - Next_Fake_ATCB := new Fake_ATCB; - end Initialize; - -- Package elaboration 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 --- 1755,1766 ---- end if; end Resume_Task; -- Package elaboration 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/5stasinf.adb gcc-3.4.0/gcc/ada/5stasinf.adb *** gcc-3.3.3/gcc/ada/5stasinf.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5stasinf.adb 2003-04-24 17:53:52.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-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 System.Task_Info is *** 57,74 **** function New_Unbound_Thread_Attributes return Task_Info_Type is begin ! return new Thread_Attributes' (False, False); end New_Unbound_Thread_Attributes; function New_Bound_Thread_Attributes return Task_Info_Type is begin ! return new Thread_Attributes' (False, True); end New_Bound_Thread_Attributes; function New_Bound_Thread_Attributes (CPU : CPU_Number) return Task_Info_Type is begin ! return new Thread_Attributes' (True, True, CPU); end New_Bound_Thread_Attributes; end System.Task_Info; --- 56,73 ---- function New_Unbound_Thread_Attributes return Task_Info_Type is begin ! return new Thread_Attributes'(False, False); end New_Unbound_Thread_Attributes; function New_Bound_Thread_Attributes return Task_Info_Type is begin ! return new Thread_Attributes'(False, True); end New_Bound_Thread_Attributes; function New_Bound_Thread_Attributes (CPU : CPU_Number) return Task_Info_Type is begin ! return new Thread_Attributes'(True, True, CPU); end New_Bound_Thread_Attributes; end System.Task_Info; diff -Nrc3pad gcc-3.3.3/gcc/ada/5stasinf.ads gcc-3.4.0/gcc/ada/5stasinf.ads *** gcc-3.3.3/gcc/ada/5stasinf.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5stasinf.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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 ---- -- -- -- 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,47 **** ------------------------------------------------------------------------------ -- This package contains the definitions and routines associated with the ! -- implementation of the Task_Info pragma. -- This is the Solaris (native) 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 LWPs and LWPs 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 Solaris (native) 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 LWPs and LWPs to processors -- *************** pragma Elaborate_Body; *** 131,143 **** function New_Bound_Thread_Attributes (CPU : CPU_Number) 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; --- 137,142 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5staspri.ads gcc-3.4.0/gcc/ada/5staspri.ads *** gcc-3.3.3/gcc/ada/5staspri.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5staspri.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-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/5stpopse.adb gcc-3.4.0/gcc/ada/5stpopse.adb *** gcc-3.3.3/gcc/ada/5stpopse.adb 2002-10-23 08:27:55.000000000 +0000 --- gcc-3.4.0/gcc/ada/5stpopse.adb 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,205 **** - ------------------------------------------------------------------------------ - -- -- - -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- - -- -- - -- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SELF -- - -- -- - -- 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 a Solaris Sparc (native) version of this package. - - with System.Machine_Code; - -- used for Asm - - separate (System.Task_Primitives.Operations) - - ---------- - -- Self -- - ---------- - - -- For Solaris version of RTS, we use a short cut to get the self - -- information faster: - - -- We have noticed that on Sparc Solaris, the register g7 always - -- contains the address near the frame pointer (fp) of the active - -- thread (fixed offset). This means, if we declare a variable near - -- the top of the stack for each threads (in our case in the task wrapper) - -- and let the variable hold the Task_ID information, we can get the - -- value without going through the thr_getspecific kernel call. - -- - -- There are two things to take care in this trick. - -- - -- 1) We need to calculate the offset between the g7 value and the - -- local variable address. - -- Possible Solutions : - -- a) Use gdb to figure out the offset. - -- b) Figure it out during the elaboration of RTS by, say, - -- creating a dummy task. - -- We used solution a) mainly because it is more efficient and keeps - -- the RTS from being cluttered with stuff that we won't be used - -- for all environments (i.e., we would have to at least introduce - -- new interfaces). - -- - -- On Sparc Solaris the offset was #10#108# (= #16#6b#) with gcc 2.7.2. - -- With gcc 2.8.0, the offset is #10#116# (= #16#74#). - -- - -- 2) We can not use the same offset business for the main thread - -- because we do not use a wrapper for the main thread. - -- Previousely, we used the difference between g7 and fp to determine - -- wether a task was the main task or not. But this was obviousely - -- wrong since it worked only for tasks that use small amount of - -- stack. - -- So, we now take advantage of the code that recognizes foreign - -- threads (see below) for the main task. - -- - -- NOTE: What we are doing here is ABSOLUTELY for Solaris 2.4, 2.5 and 2.6 - -- on Sun. - - -- We need to make sure this is OK when we move to other versions - -- of the same OS. - - -- We always can go back to the old way of doing this and we include - -- the code which use thr_getspecifics. Also, look for %%%%% - -- in comments for other necessary modifications. - - -- This code happens to work with Solaris 2.5.1 too, but with gcc - -- 2.8.0, this offset is different. - - -- ??? Try to rethink the approach here to get a more flexible - -- solution at run time ? - - -- One other solution (close to 1-b) would be to add some scanning - -- routine in Enter_Task to compute the offset since now we have - -- a magic number at the beginning of the task code. - - -- 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; - - -- 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 run-time 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. - - -- (The entire Ada run-time system may not have been elaborated, - -- either, but that is a different problem, that we will need to - -- solve another way.) - - -- 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. - - -- We will also use such points to poll for disappearance of the - -- threads associated with any implicit ATCBs that we created - -- earlier, and take the opportunity to recover them. - - -- A nasty problem here is the limitations of the compilation - -- order dependency, and in particular the GNARL/GNULLI layering. - -- To initialize an ATCB we need to assume System.Tasking has - -- been elaborated. - - function Self return Task_ID is - ATCB_Magic_Code : constant := 16#ADAADAAD#; - -- This is used to allow us to catch attempts to call Self - -- from outside an Ada task, with high probability. - -- For an Ada task, Task_Wrapper.Magic_Number = ATCB_Magic_Code. - - type Iptr is access Interfaces.C.unsigned; - function To_Iptr is new Unchecked_Conversion (Interfaces.C.unsigned, Iptr); - - type Ptr is access Task_ID; - function To_Ptr is new Unchecked_Conversion (Interfaces.C.unsigned, Ptr); - - X : Ptr; - Result : Interfaces.C.int; - - function Get_G7 return Interfaces.C.unsigned; - pragma Inline (Get_G7); - - use System.Machine_Code; - - ------------ - -- Get_G7 -- - ------------ - - function Get_G7 return Interfaces.C.unsigned is - Result : Interfaces.C.unsigned; - - begin - Asm ("mov %%g7,%0", Interfaces.C.unsigned'Asm_Output ("=r", Result)); - return Result; - end Get_G7; - - -- Start of processing for Self - - begin - if To_Iptr (Get_G7 - 120).all /= - Interfaces.C.unsigned (ATCB_Magic_Code) - then - -- Check whether this is a thread we have seen before (e.g the - -- main task). - -- 120 = 116 + Magic_Type'Size/System.Storage_Unit - - declare - Unknown_Task : aliased System.Address; - - begin - Result := - thr_getspecific (ATCB_Key, Unknown_Task'Unchecked_Access); - - pragma Assert (Result = 0); - - if Unknown_Task = System.Null_Address then - - -- We are seeing this thread for the first time. - - return New_Fake_ATCB (Get_G7); - - else - return To_Task_ID (Unknown_Task); - end if; - end; - end if; - - X := To_Ptr (Get_G7 - 116); - return X.all; - - end Self; --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5stpopsp.adb gcc-3.4.0/gcc/ada/5stpopsp.adb *** gcc-3.3.3/gcc/ada/5stpopsp.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5stpopsp.adb 2004-01-05 15:20:43.000000000 +0000 *************** *** 0 **** --- 1,107 ---- + ------------------------------------------------------------------------------ + -- -- + -- 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 version for Solaris native threads + + separate (System.Task_Primitives.Operations) + package body Specific is + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_ID) is + Result : Interfaces.C.int; + begin + Result := thr_setspecific (ATCB_Key, To_Address (Environment_Task)); + pragma Assert (Result = 0); + end Initialize; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + Unknown_Task : aliased System.Address; + Result : Interfaces.C.int; + begin + Result := thr_getspecific (ATCB_Key, Unknown_Task'Unchecked_Access); + pragma Assert (Result = 0); + return Unknown_Task /= System.Null_Address; + end Is_Valid_Task; + + --------- + -- Set -- + --------- + + procedure Set (Self_Id : Task_ID) is + Result : Interfaces.C.int; + begin + Result := thr_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 run-time 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 + Result : Interfaces.C.int; + Self_Id : aliased System.Address; + begin + Result := thr_getspecific (ATCB_Key, Self_Id'Unchecked_Access); + pragma Assert (Result = 0); + + if Self_Id = System.Null_Address then + return Register_Foreign_Thread; + else + return To_Task_ID (Self_Id); + end if; + end Self; + + end Specific; diff -Nrc3pad gcc-3.3.3/gcc/ada/5svxwork.ads gcc-3.4.0/gcc/ada/5svxwork.ads *** gcc-3.3.3/gcc/ada/5svxwork.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5svxwork.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 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 -- --- 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/5tosinte.ads gcc-3.4.0/gcc/ada/5tosinte.ads *** gcc-3.3.3/gcc/ada/5tosinte.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5tosinte.ads 2003-12-05 10:52:03.000000000 +0000 *************** *** 6,13 **** -- -- -- 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- -- --- 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 *** 250,255 **** --- 249,256 ---- pragma Convention (C, struct_sigaction); type struct_sigaction_ptr is access all struct_sigaction; + SA_SIGINFO : constant := 16#08#; + SIG_BLOCK : constant := 1; SIG_UNBLOCK : constant := 2; SIG_SETMASK : constant := 3; diff -Nrc3pad gcc-3.3.3/gcc/ada/5tsystem.ads gcc-3.4.0/gcc/ada/5tsystem.ads *** gcc-3.3.3/gcc/ada/5tsystem.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5tsystem.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 0 **** --- 1,236 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (OpenVMS DEC Threads Version) -- + -- -- + -- Copyright (C) 2002-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 := 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 := True; + 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 := 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; + + -------------------------- + -- Underlying Priorities -- + --------------------------- + + -- Important note: this section of the file must come AFTER the + -- definition of the system implementation parameters to ensure + -- that the value of these parameters is available for analysis + -- of the declarations here (using Rtsfind at compile time). + + -- The underlying priorities table provides a generalized mechanism + -- for mapping from Ada priorities to system priorities. In some + -- cases a 1-1 mapping is not the convenient or optimal choice. + + -- For DEC Threads OpenVMS, we use the full range of 31 priorities + -- in the Ada model, but map them by compression onto the more limited + -- range of priorities available in OpenVMS. + + -- To replace the default values of the Underlying_Priorities mapping, + -- copy this source file into your build directory, edit the file to + -- reflect your desired behavior, and recompile with the command: + + -- $ gcc -c -O3 -gnatpgn system.ads + + -- then recompile the run-time parts that depend on this package: + + -- $ gnatmake -a -gnatn -O3 + + -- then force rebuilding your application if you need different options: + + -- $ gnatmake -f + + type Priorities_Mapping is array (Any_Priority) of Integer; + pragma Suppress_Initialization (Priorities_Mapping); + -- Suppress initialization in case gnat.adc specifies Normalize_Scalars + + Underlying_Priorities : constant Priorities_Mapping := + + (Priority'First => 16, + + 1 => 17, + 2 => 18, + 3 => 18, + 4 => 18, + 5 => 18, + 6 => 19, + 7 => 19, + 8 => 19, + 9 => 20, + 10 => 20, + 11 => 21, + 12 => 21, + 13 => 22, + 14 => 23, + + Default_Priority => 24, + + 16 => 25, + 17 => 25, + 18 => 25, + 19 => 26, + 20 => 26, + 21 => 26, + 22 => 27, + 23 => 27, + 24 => 27, + 25 => 28, + 26 => 28, + 27 => 29, + 28 => 29, + 29 => 30, + + Priority'Last => 30, + + Interrupt_Priority => 31); + + ---------------------------- + -- Special VMS Interfaces -- + ---------------------------- + + procedure Lib_Stop (I : in Integer); + pragma Interface (C, Lib_Stop); + pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); + -- Interface to VMS condition handling. Used by RTSfind and pragma + -- {Import,Export}_Exception. Put here because this is the only + -- VMS specific package that doesn't drag in tasking. + + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/5uintman.adb gcc-3.4.0/gcc/ada/5uintman.adb *** gcc-3.3.3/gcc/ada/5uintman.adb 2002-03-14 10:58:38.000000000 +0000 --- gcc-3.4.0/gcc/ada/5uintman.adb 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,258 **** - ------------------------------------------------------------------------------ - -- -- - -- 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 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. - - with Interfaces.C; - -- used for int - - with System.Error_Reporting; - -- used for Shutdown - - with System.OS_Interface; - -- used for various Constants, Signal and types - - package body System.Interrupt_Management is - - use Interfaces.C; - use System.Error_Reporting; - use System.OS_Interface; - - 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"); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Notify_Exception - (signo : Signal; - info : access siginfo_t; - context : access struct_sigcontext); - -- 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. - - ---------------------- - -- Notify_Exception -- - ---------------------- - - -- The following code is intended for SunOS on Sparcstation. - - procedure Notify_Exception - (signo : Signal; - info : access siginfo_t; - context : access struct_sigcontext) - is - begin - -- As long as we are using a longjmp to return control to the - -- exception handler on the runtime stack, we are safe. The original - -- signal mask (the one we had before coming into this signal catching - -- function) will be restored by the longjmp. Therefore, raising - -- an exception in this handler should be a safe operation. - - -- Check that treatment of exception propagation here - -- is consistent with treatment of the abort signal in - -- System.Task_Primitives.Operations. - - case signo is - when SIGFPE => - case info.si_code is - when FPE_INTOVF_TRAP | - FPE_STARTSIG_TRAP | - FPE_INTDIV_TRAP | - FPE_FLTDIV_TRAP | - FPE_FLTUND_TRAP | - FPE_FLTOPERR_TRAP | - FPE_FLTOVF_TRAP => - raise Constraint_Error; - - when others => - pragma Assert (Shutdown ("Unexpected SIGFPE signal")); - null; - end case; - - when SIGILL => - case info.si_code is - when ILL_STACK | - ILL_ILLINSTR_FAULT | - ILL_PRIVINSTR_FAULT => - raise Constraint_Error; - - when others => - pragma Assert (Shutdown ("Unexpected SIGILL signal")); - null; - end case; - - when SIGSEGV => - - -- was caused by accessing a null pointer. - - -- ???? Origin of this code is unclear, may be broken ??? - - if context.sc_o0 in 0 .. 16#2000# then - raise Constraint_Error; - else - raise Storage_Error; - end if; - - when others => - pragma Assert (Shutdown ("Unexpected signal")); - null; - end case; - end Notify_Exception; - - --------------------------- - -- Initialize_Interrupts -- - --------------------------- - - -- Nothing needs to be done on this platform - - procedure Initialize_Interrupts is - begin - null; - end Initialize_Interrupts; - - ------------------------- - -- Package Elaboration -- - ------------------------- - - begin - declare - act : aliased struct_sigaction; - old_act : aliased struct_sigaction; - mask : aliased sigset_t; - Result : Interfaces.C.int; - - begin - -- Need to call pthread_init very early because it is doing signal - -- initializations. - - pthread_init; - - -- Change the following assignment to use another signal for task abort. - -- For example, SIGTERM might be a good one if SIGABRT is required for - -- use elsewhere. - - Abort_Task_Interrupt := SIGABRT; - - act.sa_handler := Notify_Exception'Address; - - -- 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. - - -- In that case, this field should be changed back to 0. ??? - - act.sa_flags := 16; - - Result := sigemptyset (mask'Access); - pragma Assert (Result = 0); - - for J in Exception_Interrupts'Range loop - Result := sigaddset (mask'Access, Signal (Exception_Interrupts (J))); - pragma Assert (Result = 0); - end loop; - - act.sa_mask := 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; - Keep_Unmasked (SIGALRM) := True; - Keep_Unmasked (SIGSTOP) := True; - Keep_Unmasked (SIGKILL) := True; - - -- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but at - -- the same time, disable the ability of handling this signal using - -- package Ada.Interrupts. - - -- The pragma Unreserve_All_Interrupts allows the user the ability to - -- change this behavior. - - if Unreserve_All_Interrupts = 0 then - Keep_Unmasked (SIGINT) := True; - end if; - - -- Reserve this not to interfere with thread scheduling - - -- ??? consider adding this to interrupt exceptions - -- Keep_Unmasked (SIGALRM) := True; - - -- An earlier version had a comment about SIGALRM needing to be unmasked - -- in at least one thread for cond_timedwait to work. - - -- It is unclear whether this is True for Solaris threads, FSU threads, - -- both, or maybe just an old version of FSU threads. ???? - - -- Following signals should not be disturbed. Found by experiment - - Keep_Unmasked (SIGEMT) := True; - Keep_Unmasked (SIGCHLD) := True; - - -- 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 := Reserve or Keep_Unmasked or Keep_Masked; - Reserve (0) := True; - end; - end System.Interrupt_Management; --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5uosinte.ads gcc-3.4.0/gcc/ada/5uosinte.ads *** gcc-3.3.3/gcc/ada/5uosinte.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5uosinte.ads 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,553 **** - ------------------------------------------------------------------------------ - -- -- - -- 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 Sun OS (FSU THREADS) version of this package. - - -- This package encapsulates all direct interfaces to OS services - -- that are needed by children of System. - - -- PLEASE DO NOT add any with-clauses to this package - -- or remove the pragma 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"); - pragma Linker_Options ("-lmalloc"); - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 11; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - ETIMEDOUT : constant := 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 - SIGPOLL : constant := 23; -- pollable event occurred - SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) - SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 18; -- user stop requested from tty - SIGCONT : constant := 19; -- stopped process has been continued - SIGTTIN : constant := 21; -- background tty read attempted - SIGTTOU : constant := 22; -- background tty write attempted - SIGVTALRM : constant := 26; -- virtual timer expired - SIGPROF : constant := 27; -- profiling timer expired - SIGXCPU : constant := 24; -- CPU time limit exceeded - SIGXFSZ : constant := 25; -- filesize limit exceeded - - 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 := 4; - - 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 -- - --------------------------------------- - -- FSU_THREADS requires pthread_init, which is nonstandard - -- and this should be invoked during the elaboration of s-taprop.adb - procedure pthread_init; - pragma Import (C, pthread_init, "pthread_init"); - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait (set : access sigset_t; sig : access Signal) return int; - -- FSU_THREADS has a nonstandard sigwait - - function pthread_kill (thread : pthread_t; sig : Signal) return int; - pragma Import (C, pthread_kill, "pthread_kill"); - - -- FSU threads does not have pthread_sigmask. Instead, it uses - -- sigprocmask to do the signal handling when the thread library is - -- sucked in. - - type sigset_t_ptr is access all sigset_t; - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, pthread_sigmask, "sigprocmask"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - -- 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, "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/5usystem.ads gcc-3.4.0/gcc/ada/5usystem.ads *** gcc-3.3.3/gcc/ada/5usystem.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5usystem.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 0 **** --- 1,150 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (Solaris Sparcv9 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 := 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; + 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 := 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/5vasthan.adb gcc-3.4.0/gcc/ada/5vasthan.adb *** gcc-3.3.3/gcc/ada/5vasthan.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vasthan.adb 2004-01-05 15:20:43.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1996-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-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- -- *************** with System; use System; *** 39,44 **** --- 38,44 ---- with System.IO; with System.Machine_Code; + with System.Parameters; with System.Storage_Elements; with System.Tasking; *************** package body System.AST_Handling is *** 64,69 **** --- 64,70 ---- package ATID renames Ada.Task_Identification; + package SP renames System.Parameters; package ST renames System.Tasking; package STR renames System.Tasking.Rendezvous; package STI renames System.Tasking.Initialization; *************** package body System.AST_Handling is *** 87,109 **** -- All nested locks must be released before other tasks competing for the -- tasking lock are released. ! --------------- -- Lock_AST -- ! --------------- procedure Lock_AST (Self_ID : ST.Task_ID) is begin STI.Defer_Abort_Nestable (Self_ID); ! STPO.Write_Lock (AST_Lock'Access); end Lock_AST; ! ----------------- -- Unlock_AST -- ! ----------------- procedure Unlock_AST (Self_ID : ST.Task_ID) is begin ! STPO.Unlock (AST_Lock'Access); STI.Undefer_Abort_Nestable (Self_ID); end Unlock_AST; --- 88,110 ---- -- All nested locks must be released before other tasks competing for the -- tasking lock are released. ! -------------- -- Lock_AST -- ! -------------- procedure Lock_AST (Self_ID : ST.Task_ID) is begin STI.Defer_Abort_Nestable (Self_ID); ! STPO.Write_Lock (AST_Lock'Access, Global_Lock => True); end Lock_AST; ! ---------------- -- Unlock_AST -- ! ---------------- procedure Unlock_AST (Self_ID : ST.Task_ID) is begin ! STPO.Unlock (AST_Lock'Access, Global_Lock => True); STI.Undefer_Abort_Nestable (Self_ID); end Unlock_AST; *************** package body System.AST_Handling is *** 135,140 **** --- 136,145 ---- type Descriptor_Type is new SSE.Storage_Array (1 .. 48); for Descriptor_Type'Alignment use Standard'Maximum_Alignment; + pragma Warnings (Off, Descriptor_Type); + -- Suppress harmless warnings about alignment. + -- Should explain why this warning is harmless ??? + type Descriptor_Ref is access all Descriptor_Type; -- Normally, there is only one such descriptor for a given procedure, but *************** package body System.AST_Handling is *** 315,320 **** --- 320,326 ---- procedure Allocate_New_AST_Server is Dummy : AST_Server_Task_Ptr; + pragma Unreferenced (Dummy); begin if Num_AST_Servers = Max_AST_Servers then *************** package body System.AST_Handling is *** 369,374 **** --- 375,385 ---- Unlock_AST (Self_Id); STI.Defer_Abort (Self_Id); + + if SP.Single_Lock then + STPO.Lock_RTS; + end if; + STPO.Write_Lock (Self_Id); Is_Waiting (Num) := True; *************** package body System.AST_Handling is *** 379,384 **** --- 390,399 ---- STPO.Unlock (Self_Id); + if SP.Single_Lock then + STPO.Unlock_RTS; + end if; + -- If the process is finalizing, Undefer_Abort will simply end -- this task. *************** package body System.AST_Handling is *** 414,434 **** (Acceptor => To_ST_Task_Id (Taskid), E => ST.Task_Entry_Index (Entryno), Uninterpreted_Data => P'Address); exception when E : others => System.IO.Put_Line ("%Debugging event"); System.IO.Put_Line (Exception_Name (E) & " raised when trying to deliver an AST."); if Exception_Message (E)'Length /= 0 then System.IO.Put_Line (Exception_Message (E)); end if; System.IO.Put_Line ("Task type is " & "Receiver_Type"); System.IO.Put_Line ("Task id is " & ATID.Image (Taskid)); end; Lock_AST (Self_Id); end loop; end loop; - end AST_Server_Task; ------------------------ --- 429,452 ---- (Acceptor => To_ST_Task_Id (Taskid), E => ST.Task_Entry_Index (Entryno), Uninterpreted_Data => P'Address); + exception when E : others => System.IO.Put_Line ("%Debugging event"); System.IO.Put_Line (Exception_Name (E) & " raised when trying to deliver an AST."); + if Exception_Message (E)'Length /= 0 then System.IO.Put_Line (Exception_Message (E)); end if; + System.IO.Put_Line ("Task type is " & "Receiver_Type"); System.IO.Put_Line ("Task id is " & ATID.Image (Taskid)); end; + Lock_AST (Self_Id); end loop; end loop; end AST_Server_Task; ------------------------ *************** package body System.AST_Handling is *** 437,444 **** function Create_AST_Handler (Taskid : ATID.Task_Id; ! Entryno : Natural) ! return System.Aux_DEC.AST_Handler is Attr_Ref : Attribute_Handle; --- 455,461 ---- function Create_AST_Handler (Taskid : ATID.Task_Id; ! Entryno : Natural) return System.Aux_DEC.AST_Handler is Attr_Ref : Attribute_Handle; *************** package body System.AST_Handling is *** 448,454 **** function To_Descriptor_Ref is new Ada.Unchecked_Conversion (AST_Handler, Descriptor_Ref); ! Original_Descriptor_Ref : Descriptor_Ref := To_Descriptor_Ref (Process_AST_Ptr); begin --- 465,471 ---- function To_Descriptor_Ref is new Ada.Unchecked_Conversion (AST_Handler, Descriptor_Ref); ! Original_Descriptor_Ref : constant Descriptor_Ref := To_Descriptor_Ref (Process_AST_Ptr); begin *************** package body System.AST_Handling is *** 505,510 **** --- 522,528 ---- Actual_Number : out Natural; Total_Number : out Natural) is + pragma Unreferenced (Requested_Packets); begin -- The AST implementation of GNAT does not permit dynamic expansion -- of the pool, so we simply add no entries and return the total. If *************** package body System.AST_Handling is *** 547,555 **** Entryno => Handler_Data_Ptr.Entryno, Param => Param); ! -- ??? What is the protection of this variable ? ! -- It seems that trying to use any lock in this procedure will get ! -- an ACCVIO. AST_Service_Queue_Put := AST_Service_Queue_Put + 1; --- 565,577 ---- Entryno => Handler_Data_Ptr.Entryno, Param => Param); ! -- OpenVMS Programming Concepts manual, chapter 8.2.3: ! -- "Implicit synchronization can be achieved for data that is shared ! -- for write by using only AST routines to write the data, since only ! -- one AST can be running at any one time." ! ! -- This subprogram runs at AST level so is guaranteed to be ! -- called sequentially at a given access level. AST_Service_Queue_Put := AST_Service_Queue_Put + 1; *************** package body System.AST_Handling is *** 563,572 **** Is_Waiting (J) := False; -- Sleeps are handled by ASTs on VMS, so don't call Wakeup. - -- ??? We should lock AST_Task_Ids (J) here. What's the story ? ! STPOD.Interrupt_AST_Handler ! (To_Address (AST_Task_Ids (J))); exit; end if; end loop; --- 585,592 ---- Is_Waiting (J) := False; -- Sleeps are handled by ASTs on VMS, so don't call Wakeup. ! STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J))); exit; end if; end loop; diff -Nrc3pad gcc-3.3.3/gcc/ada/5vinmaop.adb gcc-3.4.0/gcc/ada/5vinmaop.adb *** gcc-3.3.3/gcc/ada/5vinmaop.adb 2002-03-14 10:58:40.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vinmaop.adb 2004-01-05 15:20:43.000000000 +0000 *************** *** 7,14 **** -- -- -- 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- -- --- 7,13 ---- -- -- -- 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- -- *************** *** 28,36 **** -- 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. -- -- -- ------------------------------------------------------------------------------ *************** *** 39,44 **** --- 37,44 ---- with System.OS_Interface; -- used for various type, constant, and operations + with System.Parameters; + with System.Tasking; with System.Tasking.Initialization; *************** with Unchecked_Conversion; *** 52,57 **** --- 52,58 ---- package body System.Interrupt_Management.Operations is use System.OS_Interface; + use System.Parameters; use System.Tasking; use type unsigned_short; *************** package body System.Interrupt_Management *** 63,68 **** --- 64,70 ---- ---------------------------- procedure Thread_Block_Interrupt (Interrupt : Interrupt_ID) is + pragma Warnings (Off, Interrupt); begin null; end Thread_Block_Interrupt; *************** package body System.Interrupt_Management *** 72,77 **** --- 74,80 ---- ------------------------------ procedure Thread_Unblock_Interrupt (Interrupt : Interrupt_ID) is + pragma Warnings (Off, Interrupt); begin null; end Thread_Unblock_Interrupt; *************** package body System.Interrupt_Management *** 81,93 **** ------------------------ procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is begin null; end Set_Interrupt_Mask; procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask; ! OMask : access Interrupt_Mask) is begin null; end Set_Interrupt_Mask; --- 84,100 ---- ------------------------ procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is + pragma Warnings (Off, Mask); begin null; end Set_Interrupt_Mask; procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask; ! OMask : access Interrupt_Mask) ! is ! pragma Warnings (Off, Mask); ! pragma Warnings (Off, OMask); begin null; end Set_Interrupt_Mask; *************** package body System.Interrupt_Management *** 97,102 **** --- 104,110 ---- ------------------------ procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is + pragma Warnings (Off, Mask); begin null; end Get_Interrupt_Mask; *************** package body System.Interrupt_Management *** 111,117 **** function Interrupt_Wait (Mask : access Interrupt_Mask) return Interrupt_ID is ! Self_ID : Task_ID := Self; Iosb : IO_Status_Block_Type := (0, 0, 0); Status : Cond_Value_Type; --- 119,125 ---- function Interrupt_Wait (Mask : access Interrupt_Mask) return Interrupt_ID is ! Self_ID : constant Task_ID := Self; Iosb : IO_Status_Block_Type := (0, 0, 0); Status : Cond_Value_Type; *************** package body System.Interrupt_Management *** 154,161 **** --- 162,179 ---- end if; else POP.Unlock (Self_ID); + + if Single_Lock then + POP.Unlock_RTS; + end if; + System.Tasking.Initialization.Undefer_Abort (Self_ID); System.Tasking.Initialization.Defer_Abort (Self_ID); + + if Single_Lock then + POP.Lock_RTS; + end if; + POP.Write_Lock (Self_ID); end if; end loop; *************** package body System.Interrupt_Management *** 166,171 **** --- 184,190 ---- ---------------------------- procedure Install_Default_Action (Interrupt : Interrupt_ID) is + pragma Warnings (Off, Interrupt); begin null; end Install_Default_Action; *************** package body System.Interrupt_Management *** 175,180 **** --- 194,200 ---- --------------------------- procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is + pragma Warnings (Off, Interrupt); begin null; end Install_Ignore_Action; *************** package body System.Interrupt_Management *** 260,278 **** P2 => Interrupt_ID'Size / 8); pragma Assert ((Status and 1) = 1); - end Interrupt_Self_Process; begin - Environment_Mask := (others => False); All_Tasks_Mask := (others => True); ! for I in Interrupt_ID loop ! if Keep_Unmasked (I) then ! Environment_Mask (Signal (I)) := True; ! All_Tasks_Mask (Signal (I)) := False; end if; end loop; - end System.Interrupt_Management.Operations; --- 280,295 ---- P2 => Interrupt_ID'Size / 8); pragma Assert ((Status and 1) = 1); end Interrupt_Self_Process; begin Environment_Mask := (others => False); All_Tasks_Mask := (others => True); ! for J in Interrupt_ID loop ! if Keep_Unmasked (J) then ! Environment_Mask (Signal (J)) := True; ! All_Tasks_Mask (Signal (J)) := False; end if; end loop; end System.Interrupt_Management.Operations; diff -Nrc3pad gcc-3.3.3/gcc/ada/5vinterr.adb gcc-3.4.0/gcc/ada/5vinterr.adb *** gcc-3.3.3/gcc/ada/5vinterr.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vinterr.adb 2004-01-05 15:20:43.000000000 +0000 *************** *** 6,13 **** -- -- -- 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- -- --- 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- -- *************** *** 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 *** 129,135 **** use System.Parameters; use Ada.Exceptions; - package PRI renames System.Task_Primitives; package POP renames System.Task_Primitives.Operations; package PIO renames System.Task_Primitives.Interrupt_Operations; package IMNG renames System.Interrupt_Management; --- 128,133 ---- *************** package body System.Interrupts is *** 152,171 **** entry Initialize (Mask : IMNG.Interrupt_Mask); entry Attach_Handler ! (New_Handler : in Parameterless_Handler; ! Interrupt : in Interrupt_ID; ! Static : in Boolean; ! Restoration : in Boolean := False); entry Exchange_Handler (Old_Handler : out Parameterless_Handler; ! New_Handler : in Parameterless_Handler; ! Interrupt : in Interrupt_ID; ! Static : in Boolean); entry Detach_Handler ! (Interrupt : in Interrupt_ID; ! Static : in Boolean); entry Bind_Interrupt_To_Entry (T : Task_ID; --- 150,169 ---- entry Initialize (Mask : IMNG.Interrupt_Mask); entry Attach_Handler ! (New_Handler : Parameterless_Handler; ! Interrupt : Interrupt_ID; ! Static : Boolean; ! Restoration : Boolean := False); entry Exchange_Handler (Old_Handler : out Parameterless_Handler; ! New_Handler : Parameterless_Handler; ! Interrupt : Interrupt_ID; ! Static : Boolean); entry Detach_Handler ! (Interrupt : Interrupt_ID; ! Static : Boolean); entry Bind_Interrupt_To_Entry (T : Task_ID; *************** package body System.Interrupts is *** 185,190 **** --- 183,193 ---- task type Server_Task (Interrupt : Interrupt_ID) is pragma Priority (System.Interrupt_Priority'Last); + -- Note: the above pragma Priority is strictly speaking improper + -- since it is outside the range of allowed priorities, but the + -- compiler treats system units specially and does not apply + -- this range checking rule to system units. + end Server_Task; type Server_Task_Access is access Server_Task; *************** package body System.Interrupts is *** 216,232 **** pragma Volatile_Components (User_Entry); -- Holds the task and entry index (if any) for each interrupt ! Blocked : array (Interrupt_ID'Range) of Boolean := (others => False); ! pragma Volatile_Components (Blocked); -- True iff the corresponding interrupt is blocked in the process level Ignored : array (Interrupt_ID'Range) of Boolean := (others => False); pragma Volatile_Components (Ignored); -- True iff the corresponding interrupt is blocked in the process level ! Last_Unblocker : ! array (Interrupt_ID'Range) of Task_ID := (others => Null_Task); ! pragma Volatile_Components (Last_Unblocker); -- Holds the ID of the last Task which Unblocked this Interrupt. -- It contains Null_Task if no tasks have ever requested the -- Unblocking operation or the Interrupt is currently Blocked. --- 219,236 ---- pragma Volatile_Components (User_Entry); -- Holds the task and entry index (if any) for each interrupt ! Blocked : constant array (Interrupt_ID'Range) of Boolean := ! (others => False); ! -- ??? pragma Volatile_Components (Blocked); -- True iff the corresponding interrupt is blocked in the process level Ignored : array (Interrupt_ID'Range) of Boolean := (others => False); pragma Volatile_Components (Ignored); -- True iff the corresponding interrupt is blocked in the process level ! Last_Unblocker : constant array (Interrupt_ID'Range) of Task_ID := ! (others => Null_Task); ! -- ??? pragma Volatile_Components (Last_Unblocker); -- Holds the ID of the last Task which Unblocked this Interrupt. -- It contains Null_Task if no tasks have ever requested the -- Unblocking operation or the Interrupt is currently Blocked. *************** package body System.Interrupts is *** 321,327 **** Ptr := Registered_Handler_Head; ! while (Ptr /= null) loop if Ptr.H = Fat.Handler_Addr then return True; end if; --- 325,331 ---- Ptr := Registered_Handler_Head; ! while Ptr /= null loop if Ptr.H = Fat.Handler_Addr then return True; end if; *************** package body System.Interrupts is *** 430,438 **** -- can detach handlers attached through pragma Attach_Handler. procedure Attach_Handler ! (New_Handler : in Parameterless_Handler; ! Interrupt : in Interrupt_ID; ! Static : in Boolean := False) is begin if Is_Reserved (Interrupt) then Raise_Exception (Program_Error'Identity, "Interrupt" & --- 434,442 ---- -- can detach handlers attached through pragma Attach_Handler. procedure Attach_Handler ! (New_Handler : Parameterless_Handler; ! Interrupt : Interrupt_ID; ! Static : Boolean := False) is begin if Is_Reserved (Interrupt) then Raise_Exception (Program_Error'Identity, "Interrupt" & *************** package body System.Interrupts is *** 457,465 **** procedure Exchange_Handler (Old_Handler : out Parameterless_Handler; ! New_Handler : in Parameterless_Handler; ! Interrupt : in Interrupt_ID; ! Static : in Boolean := False) is begin if Is_Reserved (Interrupt) then Raise_Exception (Program_Error'Identity, "Interrupt" & --- 461,469 ---- procedure Exchange_Handler (Old_Handler : out Parameterless_Handler; ! New_Handler : Parameterless_Handler; ! Interrupt : Interrupt_ID; ! Static : Boolean := False) is begin if Is_Reserved (Interrupt) then Raise_Exception (Program_Error'Identity, "Interrupt" & *************** package body System.Interrupts is *** 483,490 **** -- detach handlers attached through pragma Attach_Handler. procedure Detach_Handler ! (Interrupt : in Interrupt_ID; ! Static : in Boolean := False) is begin if Is_Reserved (Interrupt) then Raise_Exception (Program_Error'Identity, "Interrupt" & --- 487,495 ---- -- detach handlers attached through pragma Attach_Handler. procedure Detach_Handler ! (Interrupt : Interrupt_ID; ! Static : Boolean := False) ! is begin if Is_Reserved (Interrupt) then Raise_Exception (Program_Error'Identity, "Interrupt" & *************** package body System.Interrupts is *** 622,649 **** task body Interrupt_Manager is --------------------- - -- Local Variables -- - --------------------- - - Intwait_Mask : aliased IMNG.Interrupt_Mask; - Ret_Interrupt : Interrupt_ID; - Old_Mask : aliased IMNG.Interrupt_Mask; - Self_ID : Task_ID := POP.Self; - - --------------------- -- Local Routines -- --------------------- procedure Unprotected_Exchange_Handler (Old_Handler : out Parameterless_Handler; ! New_Handler : in Parameterless_Handler; ! Interrupt : in Interrupt_ID; ! Static : in Boolean; ! Restoration : in Boolean := False); procedure Unprotected_Detach_Handler ! (Interrupt : in Interrupt_ID; ! Static : in Boolean); ---------------------------------- -- Unprotected_Exchange_Handler -- --- 627,645 ---- task body Interrupt_Manager is --------------------- -- Local Routines -- --------------------- procedure Unprotected_Exchange_Handler (Old_Handler : out Parameterless_Handler; ! New_Handler : Parameterless_Handler; ! Interrupt : Interrupt_ID; ! Static : Boolean; ! Restoration : Boolean := False); procedure Unprotected_Detach_Handler ! (Interrupt : Interrupt_ID; ! Static : Boolean); ---------------------------------- -- Unprotected_Exchange_Handler -- *************** package body System.Interrupts is *** 651,660 **** procedure Unprotected_Exchange_Handler (Old_Handler : out Parameterless_Handler; ! New_Handler : in Parameterless_Handler; ! Interrupt : in Interrupt_ID; ! Static : in Boolean; ! Restoration : in Boolean := False) is begin if User_Entry (Interrupt).T /= Null_Task then -- In case we have an Interrupt Entry already installed. --- 647,657 ---- procedure Unprotected_Exchange_Handler (Old_Handler : out Parameterless_Handler; ! New_Handler : Parameterless_Handler; ! Interrupt : Interrupt_ID; ! Static : Boolean; ! Restoration : Boolean := False) ! is begin if User_Entry (Interrupt).T /= Null_Task then -- In case we have an Interrupt Entry already installed. *************** package body System.Interrupts is *** 727,737 **** -------------------------------- procedure Unprotected_Detach_Handler ! (Interrupt : in Interrupt_ID; ! Static : in Boolean) is - Old_Handler : Parameterless_Handler; - begin if User_Entry (Interrupt).T /= Null_Task then -- In case we have an Interrupt Entry installed. --- 724,732 ---- -------------------------------- procedure Unprotected_Detach_Handler ! (Interrupt : Interrupt_ID; ! Static : Boolean) is begin if User_Entry (Interrupt).T /= Null_Task then -- In case we have an Interrupt Entry installed. *************** package body System.Interrupts is *** 758,765 **** Ignored (Interrupt) := False; - Old_Handler := User_Handler (Interrupt).H; - -- The new handler User_Handler (Interrupt).H := null; --- 753,758 ---- *************** package body System.Interrupts is *** 787,792 **** --- 780,786 ---- -- during elaboration of the body of this package. accept Initialize (Mask : IMNG.Interrupt_Mask) do + pragma Warnings (Off, Mask); null; end Initialize; *************** package body System.Interrupts is *** 796,802 **** -- Abort_Task_Interrupt is one of the Interrupt unmasked -- in all tasks. We mask the Interrupt in this particular task ! -- so that "sigwait" is possible to catch an explicitly sent -- Abort_Task_Interrupt from the Server_Tasks. -- This sigwaiting is needed so that we make sure a Server_Task is --- 790,796 ---- -- Abort_Task_Interrupt is one of the Interrupt unmasked -- in all tasks. We mask the Interrupt in this particular task ! -- so that "sigwait" is possible to catch an explicitely sent -- Abort_Task_Interrupt from the Server_Tasks. -- This sigwaiting is needed so that we make sure a Server_Task is *************** package body System.Interrupts is *** 825,834 **** select accept Attach_Handler ! (New_Handler : in Parameterless_Handler; ! Interrupt : in Interrupt_ID; ! Static : in Boolean; ! Restoration : in Boolean := False) do Unprotected_Exchange_Handler (Old_Handler, New_Handler, Interrupt, Static, Restoration); --- 819,828 ---- select accept Attach_Handler ! (New_Handler : Parameterless_Handler; ! Interrupt : Interrupt_ID; ! Static : Boolean; ! Restoration : Boolean := False) do Unprotected_Exchange_Handler (Old_Handler, New_Handler, Interrupt, Static, Restoration); *************** package body System.Interrupts is *** 836,852 **** or accept Exchange_Handler (Old_Handler : out Parameterless_Handler; ! New_Handler : in Parameterless_Handler; ! Interrupt : in Interrupt_ID; ! Static : in Boolean) do Unprotected_Exchange_Handler (Old_Handler, New_Handler, Interrupt, Static); end Exchange_Handler; or accept Detach_Handler ! (Interrupt : in Interrupt_ID; ! Static : in Boolean) do Unprotected_Detach_Handler (Interrupt, Static); end Detach_Handler; --- 830,846 ---- or accept Exchange_Handler (Old_Handler : out Parameterless_Handler; ! New_Handler : Parameterless_Handler; ! Interrupt : Interrupt_ID; ! Static : Boolean) do Unprotected_Exchange_Handler (Old_Handler, New_Handler, Interrupt, Static); end Exchange_Handler; or accept Detach_Handler ! (Interrupt : Interrupt_ID; ! Static : Boolean) do Unprotected_Detach_Handler (Interrupt, Static); end Detach_Handler; *************** package body System.Interrupts is *** 870,876 **** -- it was ever ignored. Ignored (Interrupt) := False; ! User_Entry (Interrupt) := Entry_Assoc' (T => T, E => E); -- Indicate the attachment of Interrupt Entry in ATCB. -- This is need so that when an Interrupt Entry task --- 864,870 ---- -- it was ever ignored. Ignored (Interrupt) := False; ! User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E); -- Indicate the attachment of Interrupt Entry in ATCB. -- This is need so that when an Interrupt Entry task *************** package body System.Interrupts is *** 896,912 **** or accept Detach_Interrupt_Entries (T : Task_ID) do ! for I in Interrupt_ID'Range loop ! if not Is_Reserved (I) then ! if User_Entry (I).T = T then -- The interrupt should no longer be ignored if -- it was ever ignored. ! Ignored (I) := False; ! User_Entry (I) := Entry_Assoc' ! (T => Null_Task, E => Null_Task_Entry); ! IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (I)); end if; end if; end loop; --- 890,906 ---- or accept Detach_Interrupt_Entries (T : Task_ID) do ! for J in Interrupt_ID'Range loop ! if not Is_Reserved (J) then ! if User_Entry (J).T = T then -- The interrupt should no longer be ignored if -- it was ever ignored. ! Ignored (J) := False; ! User_Entry (J) := ! Entry_Assoc'(T => Null_Task, E => Null_Task_Entry); ! IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (J)); end if; end if; end loop; *************** package body System.Interrupts is *** 917,934 **** --- 911,932 ---- end Detach_Interrupt_Entries; or accept Block_Interrupt (Interrupt : Interrupt_ID) do + pragma Warnings (Off, Interrupt); raise Program_Error; end Block_Interrupt; or accept Unblock_Interrupt (Interrupt : Interrupt_ID) do + pragma Warnings (Off, Interrupt); raise Program_Error; end Unblock_Interrupt; or accept Ignore_Interrupt (Interrupt : Interrupt_ID) do + pragma Warnings (Off, Interrupt); raise Program_Error; end Ignore_Interrupt; or accept Unignore_Interrupt (Interrupt : Interrupt_ID) do + pragma Warnings (Off, Interrupt); raise Program_Error; end Unignore_Interrupt; *************** package body System.Interrupts is *** 958,964 **** Tmp_ID : Task_ID; Tmp_Entry_Index : Task_Entry_Index; Intwait_Mask : aliased IMNG.Interrupt_Mask; - Ret_Interrupt : IMNG.Interrupt_ID; begin -- By making this task independent of master, when the process --- 956,961 ---- *************** package body System.Interrupts is *** 1015,1021 **** else Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag; - Ret_Interrupt := IMOP.Interrupt_Wait (Intwait_Mask'Access); Self_ID.Common.State := Runnable; if not (Self_ID.Deferral_Level = 0 --- 1012,1017 ---- *************** package body System.Interrupts is *** 1034,1045 **** end if; Tmp_Handler.all; - POP.Write_Lock (Self_ID); if Single_Lock then POP.Lock_RTS; end if; elsif User_Entry (Interrupt).T /= Null_Task then Tmp_ID := User_Entry (Interrupt).T; Tmp_Entry_Index := User_Entry (Interrupt).E; --- 1030,1042 ---- end if; Tmp_Handler.all; if Single_Lock then POP.Lock_RTS; end if; + POP.Write_Lock (Self_ID); + elsif User_Entry (Interrupt).T /= Null_Task then Tmp_ID := User_Entry (Interrupt).T; Tmp_Entry_Index := User_Entry (Interrupt).E; *************** package body System.Interrupts is *** 1055,1065 **** System.Tasking.Rendezvous.Call_Simple (Tmp_ID, Tmp_Entry_Index, System.Null_Address); - POP.Write_Lock (Self_ID); - if Single_Lock then POP.Lock_RTS; end if; end if; end if; end if; --- 1052,1062 ---- System.Tasking.Rendezvous.Call_Simple (Tmp_ID, Tmp_Entry_Index, System.Null_Address); if Single_Lock then POP.Lock_RTS; end if; + + POP.Write_Lock (Self_ID); end if; end if; end if; *************** package body System.Interrupts is *** 1082,1088 **** ------------------------------------- function Has_Interrupt_Or_Attach_Handler ! (Object : access Dynamic_Interrupt_Protection) return Boolean is begin return True; end Has_Interrupt_Or_Attach_Handler; --- 1079,1089 ---- ------------------------------------- function Has_Interrupt_Or_Attach_Handler ! (Object : access Dynamic_Interrupt_Protection) ! return Boolean ! is ! pragma Warnings (Off, Object); ! begin return True; end Has_Interrupt_Or_Attach_Handler; *************** package body System.Interrupts is *** 1117,1122 **** --- 1118,1124 ---- (Object : access Static_Interrupt_Protection) return Boolean is + pragma Warnings (Off, Object); begin return True; end Has_Interrupt_Or_Attach_Handler; *************** package body System.Interrupts is *** 1127,1133 **** procedure Install_Handlers (Object : access Static_Interrupt_Protection; ! New_Handlers : in New_Handler_Array) is begin for N in New_Handlers'Range loop --- 1129,1136 ---- procedure Install_Handlers (Object : access Static_Interrupt_Protection; ! New_Handlers : New_Handler_Array) ! is begin for N in New_Handlers'Range loop diff -Nrc3pad gcc-3.3.3/gcc/ada/5vintman.adb gcc-3.4.0/gcc/ada/5vintman.adb *** gcc-3.3.3/gcc/ada/5vintman.adb 2002-03-14 10:58:40.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vintman.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,12 ---- -- -- -- 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- -- *************** *** 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 body System.Interrupt_Management *** 55,60 **** --- 53,59 ---- procedure Initialize_Interrupts is Status : Cond_Value_Type; + begin Sys_Crembx (Status => Status, *************** package body System.Interrupt_Management *** 74,84 **** Flags => AGN_M_WRITEONLY); pragma Assert ((Status and 1) = 1); - end Initialize_Interrupts; begin -- Unused Abort_Task_Interrupt := Interrupt_ID_0; Reserve := Reserve or Keep_Unmasked or Keep_Masked; --- 73,83 ---- Flags => AGN_M_WRITEONLY); pragma Assert ((Status and 1) = 1); end Initialize_Interrupts; begin -- Unused + Abort_Task_Interrupt := Interrupt_ID_0; Reserve := Reserve or Keep_Unmasked or Keep_Masked; *************** begin *** 86,90 **** Reserve (Interrupt_ID_0) := True; Initialize_Interrupts; - end System.Interrupt_Management; --- 85,88 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5vintman.ads gcc-3.4.0/gcc/ada/5vintman.ads *** gcc-3.3.3/gcc/ada/5vintman.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vintman.ads 2003-10-21 13:41:52.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,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. -- -- -- ------------------------------------------------------------------------------ ! -- -- This is the Alpha/VMS version of this package. -- -- This package encapsulates and centralizes information about --- 27,36 ---- -- 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 Alpha/VMS version of this package. -- -- This package encapsulates and centralizes information about diff -Nrc3pad gcc-3.3.3/gcc/ada/5vmastop.adb gcc-3.4.0/gcc/ada/5vmastop.adb *** gcc-3.3.3/gcc/ada/5vmastop.adb 2002-03-14 10:58:40.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vmastop.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 7,13 **** -- B o d y -- -- (Version for Alpha/VMS) -- -- -- - -- -- -- Copyright (C) 2001-2002 Ada Core Technologies, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- --- 7,12 ---- *************** *** 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 *** 78,122 **** for ICB_Hdr_Quad_Type'Size use 64; type Invo_Context_Blk_Type is record ! -- -- The first quadword contains: ! -- o The length of the structure in bytes (a longword field) ! -- o The frame flags (a 3 byte field of bits) ! -- o The version number (a 1 byte field) ! -- ! Hdr_Quad : ICB_Hdr_Quad_Type; ! -- ! -- The address of the procedure descriptor for the procedure. ! -- Procedure_Descriptor : Unsigned_Quadword; ! -- ! -- The current PC of a given procedure invocation. ! -- ! Program_Counter : Integer_64; ! -- ! -- The current PS of a given procedure invocation. ! -- ! Processor_Status : Integer_64; ! -- -- The register contents areas. 31 for scalars, 31 for float. ! -- ! Ireg : Unsigned_Quadword_Array (0 .. 30); ! Freg : Unsigned_Quadword_Array (0 .. 30); ! -- -- The following is an "internal" area that's reserved for use by -- the operating system. It's size may vary over time. - -- - System_Defined : Unsigned_Quadword_Array (0 .. 1); ! ----Component(s) below are defined as comments since they ! ----overlap other fields ! ---- ! ----Chfctx_Addr : Unsigned_Quadword; - -- - -- Align to octaword. - -- Filler_1 : String (1 .. 0); end record; for Invo_Context_Blk_Type use record --- 77,111 ---- for ICB_Hdr_Quad_Type'Size use 64; type Invo_Context_Blk_Type is record ! ! Hdr_Quad : ICB_Hdr_Quad_Type; -- The first quadword contains: ! -- o The length of the structure in bytes (a longword field) ! -- o The frame flags (a 3 byte field of bits) ! -- o The version number (a 1 byte field) ! Procedure_Descriptor : Unsigned_Quadword; ! -- The address of the procedure descriptor for the procedure ! ! Program_Counter : Integer_64; ! -- The current PC of a given procedure invocation ! ! Processor_Status : Integer_64; ! -- The current PS of a given procedure invocation ! ! Ireg : Unsigned_Quadword_Array (0 .. 30); ! Freg : Unsigned_Quadword_Array (0 .. 30); -- The register contents areas. 31 for scalars, 31 for float. ! ! System_Defined : Unsigned_Quadword_Array (0 .. 1); -- The following is an "internal" area that's reserved for use by -- the operating system. It's size may vary over time. ! -- Chfctx_Addr : Unsigned_Quadword; ! -- Defined as a comment since it overlaps other fields Filler_1 : String (1 .. 0); + -- Align to octaword end record; for Invo_Context_Blk_Type use record *************** package body System.Machine_State_Operat *** 128,137 **** Freg at 280 range 0 .. 1983; System_Defined at 528 range 0 .. 127; ! ----Component representation spec(s) below are defined as ! ----comments since they overlap other fields ! ---- ! ----Chfctx_Addr at 528 range 0 .. 63; Filler_1 at 544 range 0 .. -1; end record; --- 117,126 ---- Freg at 280 range 0 .. 1983; System_Defined at 528 range 0 .. 127; ! -- Component representation spec(s) below are defined as ! -- comments since they overlap other fields ! ! -- Chfctx_Addr at 528 range 0 .. 63; Filler_1 at 544 range 0 .. -1; end record; *************** package body System.Machine_State_Operat *** 166,172 **** procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is procedure Get_Invo_Context ( Result : out Unsigned_Longword; -- return value ! Invo_Handle : in Invo_Handle_Type; Invo_Context : out Invo_Context_Blk_Type); pragma Interface (External, Get_Invo_Context); --- 155,161 ---- procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is procedure Get_Invo_Context ( Result : out Unsigned_Longword; -- return value ! Invo_Handle : Invo_Handle_Type; Invo_Context : out Invo_Context_Blk_Type); pragma Interface (External, Get_Invo_Context); *************** package body System.Machine_State_Operat *** 179,190 **** procedure Goto_Unwind ( Status : out Cond_Value_Type; -- return value ! Target_Invo : in Address := Address_Zero; ! Target_PC : in Address := Address_Zero; ! New_R0 : in Unsigned_Quadword ! := Unsigned_Quadword'Null_Parameter; ! New_R1 : in Unsigned_Quadword ! := Unsigned_Quadword'Null_Parameter); pragma Interface (External, Goto_Unwind); --- 168,177 ---- procedure Goto_Unwind ( Status : out Cond_Value_Type; -- return value ! Target_Invo : Address := Address_Zero; ! Target_PC : Address := Address_Zero; ! New_R0 : Unsigned_Quadword := Unsigned_Quadword'Null_Parameter; ! New_R1 : Unsigned_Quadword := Unsigned_Quadword'Null_Parameter); pragma Interface (External, Goto_Unwind); *************** package body System.Machine_State_Operat *** 195,201 **** (Value, Reference, Reference, Reference, Reference)); ! Status : Cond_Value_Type; begin Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB); --- 182,188 ---- (Value, Reference, Reference, Reference, Reference)); ! Status : Cond_Value_Type; begin Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB); *************** package body System.Machine_State_Operat *** 210,215 **** --- 197,203 ---- function Fetch_Code (Loc : Code_Loc) return Code_Loc is begin -- The starting address is in the second longword pointed to by Loc. + return Fetch (System.Aux_DEC."+" (Loc, 8)); end Fetch_Code; *************** package body System.Machine_State_Operat *** 248,256 **** --- 236,246 ---- begin Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB); + if (Status and 1) /= 1 then return Code_Loc (System.Null_Address); end if; + return Code_Loc (ICB.Program_Counter - Asm_Call_Size); end Get_Code_Loc; *************** package body System.Machine_State_Operat *** 275,280 **** --- 265,271 ---- (M : Machine_State; Info : Subprogram_Info_Type) is + pragma Warnings (Off, Info); procedure Get_Prev_Invo_Handle ( Result : out Invo_Handle_Type; -- return value *************** package body System.Machine_State_Operat *** 336,342 **** procedure Set_Signal_Machine_State (M : Machine_State; ! Context : System.Address) is begin null; end Set_Signal_Machine_State; --- 327,337 ---- 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/5vml-tgt.adb gcc-3.4.0/gcc/ada/5vml-tgt.adb *** gcc-3.3.3/gcc/ada/5vml-tgt.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vml-tgt.adb 2004-01-05 15:20:43.000000000 +0000 *************** *** 0 **** --- 1,665 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T -- + -- (VMS Version) -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2003-2004, Free Software Foundation, Inc. -- + -- -- + -- GNAT is free software; you can redistribute it and/or modify it under -- + -- terms of the GNU General Public License as published by the Free Soft- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 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 is the VMS version of the body + + with Ada.Characters.Handling; use Ada.Characters.Handling; + with Ada.Text_IO; use Ada.Text_IO; + + with GNAT.Directory_Operations; use GNAT.Directory_Operations; + + with MLib.Fil; + with MLib.Utl; + with Namet; use Namet; + with Opt; use Opt; + with Output; use Output; + with Prj.Com; + with System; use System; + with System.Case_Util; use System.Case_Util; + + package body MLib.Tgt is + + use GNAT; + + Empty_Argument_List : aliased Argument_List := (1 .. 0 => null); + Additional_Objects : Argument_List_Access := Empty_Argument_List'Access; + -- Used to add the generated auto-init object files for auto-initializing + -- stand-alone libraries. + + Macro_Name : constant String := "macro"; + -- The name of the command to invoke the macro-assembler + + -- Options to use when invoking gcc to build the dynamic library + + No_Start_Files : aliased String := "-nostartfiles"; + + VMS_Options : Argument_List := + (No_Start_Files'Access, null); + + Gnatsym_Name : constant String := "gnatsym"; + + Gnatsym_Path : String_Access; + + Arguments : Argument_List_Access := null; + Last_Argument : Natural := 0; + + Success : Boolean := False; + + ------------------------------ + -- Target dependent section -- + ------------------------------ + + function Popen (Command, Mode : System.Address) return System.Address; + pragma Import (C, Popen); + + function Pclose (File : System.Address) return Integer; + pragma Import (C, Pclose); + + --------------------- + -- 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 "olb"; + 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 (Lib_Address); + pragma Unreferenced (Relocatable); + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Filename, DLL_Ext); + + Opts : Argument_List := Options; + Last_Opt : Natural := Opts'Last; + Opts2 : Argument_List (Options'Range); + Last_Opt2 : Natural := Opts2'First - 1; + + Inter : constant Argument_List := Interfaces; + + function Is_Interface (Obj_File : String) return Boolean; + -- For a Stand-Alone Library, returns True if Obj_File is the object + -- file name of an interface of the SAL. + -- For other libraries, always return True. + + function Option_File_Name return String; + -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt" + + function Version_String return String; + -- Returns Lib_Version if not empty, otherwise returns "1". + -- Fails gnatmake if Lib_Version is not the image of a positive number. + + ------------------ + -- Is_Interface -- + ------------------ + + function Is_Interface (Obj_File : String) return Boolean is + ALI : constant String := + Fil.Ext_To + (Filename => To_Lower (Base_Name (Obj_File)), + New_Ext => "ali"); + + begin + if Inter'Length = 0 then + return True; + + elsif ALI'Length > 2 and then + ALI (ALI'First .. ALI'First + 1) = "b$" + then + return True; + + else + for J in Inter'Range loop + if Inter (J).all = ALI then + return True; + end if; + end loop; + + return False; + end if; + end Is_Interface; + + ---------------------- + -- Option_File_Name -- + ---------------------- + + function Option_File_Name return String is + begin + if Symbol_Data.Symbol_File = No_Name then + return "symvec.opt"; + else + return Get_Name_String (Symbol_Data.Symbol_File); + end if; + end Option_File_Name; + + -------------------- + -- Version_String -- + -------------------- + + function Version_String return String is + Version : Integer := 0; + begin + if Lib_Version = "" then + return "1"; + + else + begin + Version := Integer'Value (Lib_Version); + + if Version <= 0 then + raise Constraint_Error; + end if; + + return Lib_Version; + + exception + when Constraint_Error => + Fail ("illegal version """, Lib_Version, + """ (on VMS version must be a positive number)"); + return ""; + end; + end if; + end Version_String; + + Opt_File_Name : constant String := Option_File_Name; + Version : constant String := Version_String; + For_Linker_Opt : constant String_Access := + new String'("--for-linker=" & Opt_File_Name); + + -- Start of processing for Build_Dynamic_Library + + begin + VMS_Options (VMS_Options'First + 1) := For_Linker_Opt; + + for J in Inter'Range loop + To_Lower (Inter (J).all); + end loop; + + -- "gnatsym" is necessary for building the option file + + if Gnatsym_Path = null then + Gnatsym_Path := OS_Lib.Locate_Exec_On_Path (Gnatsym_Name); + + if Gnatsym_Path = null then + Fail (Gnatsym_Name, " not found in path"); + end if; + end if; + + -- For auto-initialization of a stand-alone library, we create + -- a macro-assembly file and we invoke the macro-assembler. + + if Auto_Init then + declare + Macro_File_Name : constant String := Lib_Filename & "$init.mar"; + Macro_File : Ada.Text_IO.File_Type; + Init_Proc : String := Lib_Filename & "INIT"; + Popen_Result : System.Address; + Pclose_Result : Integer; + + Command : constant String := + Macro_Name & " " & Macro_File_Name & ASCII.NUL; + -- The command to invoke the macro-assembler on the generated + -- assembly file. + + Mode : constant String := "r" & ASCII.NUL; + -- The mode for the invocation of Popen + + begin + To_Upper (Init_Proc); + + if Verbose_Mode then + Write_Str ("Creating auto-init assembly file """); + Write_Str (Macro_File_Name); + Write_Line (""""); + end if; + + begin + Create (Macro_File, Out_File, Macro_File_Name); + + Put_Line (Macro_File, ASCII.HT & ".EXTRN LIB$INITIALIZE"); + Put_Line (Macro_File, ASCII.HT & ".EXTRN " & Init_Proc); + Put_Line + (Macro_File, + ASCII.HT & ".PSECT LIB$INITIALIZE USR,GBL,NOEXE,NOWRT,LONG"); + Put_Line (Macro_File, ASCII.HT & ".ADDRESS " & Init_Proc); + Put_Line (Macro_File, ASCII.HT & ".END"); + + Close (Macro_File); + + exception + when others => + Fail ("creation of auto-init assembly file """, + Macro_File_Name, """ failed"); + end; + + -- Invoke the macro-assembler + + if Verbose_Mode then + Write_Str ("Assembling auto-init assembly file """); + Write_Str (Macro_File_Name); + Write_Line (""""); + end if; + + Popen_Result := Popen (Command (Command'First)'Address, + Mode (Mode'First)'Address); + + if Popen_Result = Null_Address then + Fail ("assembly of auto-init assembly file """, + Macro_File_Name, """ failed"); + end if; + + -- Wait for the end of execution of the macro-assembler + + Pclose_Result := Pclose (Popen_Result); + + if Pclose_Result < 0 then + Fail ("assembly of auto init assembly file """, + Macro_File_Name, """ failed"); + end if; + + -- Add the generated object file to the list of objects to be + -- included in the library. + + Additional_Objects := + new Argument_List' + (1 => new String'(Lib_Filename & "$init.obj")); + end; + end if; + + -- Allocate the argument list and put the symbol file name, the + -- reference (if any) and the policy (if not autonomous). + + Arguments := new Argument_List (1 .. Ofiles'Length + 8); + + Last_Argument := 0; + + -- Verbosity + + if Verbose_Mode then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-v"); + end if; + + -- Version number (major ID) + + if Lib_Version /= "" then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-V"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Version); + end if; + + -- Symbol file + + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-s"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Opt_File_Name); + + -- Reference Symbol File + + if Symbol_Data.Reference /= No_Name then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-r"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := + new String'(Get_Name_String (Symbol_Data.Reference)); + end if; + + -- Policy + + case Symbol_Data.Symbol_Policy is + when Autonomous => + null; + + when Compliant => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-c"); + + when Controlled => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-C"); + end case; + + -- Add each relevant object file + + for Index in Ofiles'Range loop + if Is_Interface (Ofiles (Index).all) then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Ofiles (Index).all); + end if; + end loop; + + -- Spawn gnatsym + + Spawn (Program_Name => Gnatsym_Path.all, + Args => Arguments (1 .. Last_Argument), + Success => Success); + + if not Success then + Fail ("unable to create symbol file for library """, + Lib_Filename, """"); + end if; + + Free (Arguments); + + -- Move all the -l switches from Opts to Opts2 + + declare + Index : Natural := Opts'First; + Opt : String_Access; + + begin + while Index <= Last_Opt loop + Opt := Opts (Index); + + if Opt'Length > 2 and then + Opt (Opt'First .. Opt'First + 1) = "-l" + then + if Index < Last_Opt then + Opts (Index .. Last_Opt - 1) := + Opts (Index + 1 .. Last_Opt); + end if; + + Last_Opt := Last_Opt - 1; + + Last_Opt2 := Last_Opt2 + 1; + Opts2 (Last_Opt2) := Opt; + + else + Index := Index + 1; + end if; + end loop; + end; + + -- Invoke gcc to build the library + + Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles & Additional_Objects.all, + Options => VMS_Options, + Options_2 => Opts (Opts'First .. Last_Opt) & + Opts2 (Opts2'First .. Last_Opt2), + Driver_Name => Driver_Name); + + -- The auto-init object file need to be deleted, so that it will not + -- be included in the library as a regular object file, otherwise + -- it will be included twice when the library will be built next + -- time, which may lead to errors. + + if Auto_Init then + declare + Auto_Init_Object_File_Name : constant String := + Lib_Filename & "$init.obj"; + Disregard : Boolean; + + begin + if Verbose_Mode then + Write_Str ("deleting auto-init object file """); + Write_Str (Auto_Init_Object_File_Name); + Write_Line (""""); + end if; + + Delete_File (Auto_Init_Object_File_Name, Success => Disregard); + end; + 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 "exe"; + 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 = ".obj"; + 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 = ".olb" or else Ext = ".exe"; + end Is_Archive_Ext; + + ------------- + -- Libgnat -- + ------------- + + function Libgnat return String is + Libgnat_A : constant String := "libgnat.a"; + Libgnat_Olb : constant String := "libgnat.olb"; + + begin + Name_Len := Libgnat_A'Length; + Name_Buffer (1 .. Name_Len) := Libgnat_A; + + if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then + return Libgnat_A; + + else + return Libgnat_Olb; + end if; + end Libgnat; + + ------------------------ + -- Library_Exists_For -- + ------------------------ + + function Library_Exists_For (Project : Project_Id) return Boolean is + begin + if not Projects.Table (Project).Library then + 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 null; + end Linker_Library_Path_Option; + + ---------------- + -- Object_Ext -- + ---------------- + + function Object_Ext return String is + begin + return "obj"; + 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/5vosinte.adb gcc-3.4.0/gcc/ada/5vosinte.adb *** gcc-3.3.3/gcc/ada/5vosinte.adb 2002-03-14 10:58:40.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vosinte.adb 2003-10-21 13:41:52.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. -- -- -- ------------------------------------------------------------------------------ *************** pragma Polling (Off); *** 43,53 **** --- 42,75 ---- -- 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 + ------------------ + -- pthread_self -- + ------------------ + + function pthread_self return pthread_t is + use ASCII; + Self : pthread_t; + + begin + Asm ("call_pal 0x9e" & LF & HT & + "bis $31, $0, %0", + Outputs => pthread_t'Asm_Output ("=r", Self), + Clobber => "$0"); + return Self; + end pthread_self; + + ----------------- + -- sched_yield -- + ----------------- + function sched_yield return int is procedure sched_yield_base; pragma Import (C, sched_yield_base, "PTHREAD_YIELD_NP"); + begin sched_yield_base; return 0; diff -Nrc3pad gcc-3.3.3/gcc/ada/5vosinte.ads gcc-3.4.0/gcc/ada/5vosinte.ads *** gcc-3.3.3/gcc/ada/5vosinte.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vosinte.ads 2003-10-21 13:41:52.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-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 *** 550,556 **** pragma Import (C, pthread_exit, "PTHREAD_EXIT"); function pthread_self return pthread_t; - pragma Import (C, pthread_self, "PTHREAD_SELF"); -------------------------- -- POSIX.1c Section 17 -- --- 549,554 ---- *************** private *** 637,640 **** --- 635,640 ---- type pthread_key_t is new unsigned; + pragma Inline (pthread_self); + end System.OS_Interface; diff -Nrc3pad gcc-3.3.3/gcc/ada/5vosprim.adb gcc-3.4.0/gcc/ada/5vosprim.adb *** gcc-3.3.3/gcc/ada/5vosprim.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vosprim.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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 ---- -- -- -- 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- -- *************** *** 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_Primitives is *** 110,120 **** --------------- -- Sys_Hiber -- --------------- ! -- -- Hibernate (until woken up) ! -- -- status = returned status - -- procedure Sys_Hiber (Status : out Cond_Value_Type); -- VMS system call to hibernate the current process --- 109,118 ---- --------------- -- Sys_Hiber -- --------------- ! -- Hibernate (until woken up) ! -- status = returned status procedure Sys_Hiber (Status : out Cond_Value_Type); -- VMS system call to hibernate the current process *************** package body System.OS_Primitives is *** 174,179 **** --- 172,178 ---- ----------------- function To_Duration (T : OS_Time; Mode : Integer) return Duration is + pragma Warnings (Off, Mode); begin return Duration'Fixed_Value (T - VMS_Epoch_Offset) * 100; end To_Duration; diff -Nrc3pad gcc-3.3.3/gcc/ada/5vosprim.ads gcc-3.4.0/gcc/ada/5vosprim.ads *** gcc-3.3.3/gcc/ada/5vosprim.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vosprim.ads 2003-04-24 17:53:52.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-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 System.OS_Primitives is *** 49,61 **** -- Calendar.Time is positive. -- See Ada.Calendar.Delays for more information on VMS Time. ! Max_Sensible_Delay : constant Duration := 183 * 24 * 60 * 60.0; -- Max of half a year delay, needed to prevent exceptions for large -- delay values. It seems unlikely that any test will notice this -- restriction, except in the case of applications setting the clock at -- at run time (see s-tastim.adb). Also note that a larger value might -- cause problems (e.g overflow, or more likely OS limitation in the ! -- primitives used). function OS_Clock return OS_Time; -- Returns "absolute" time, represented as an offset --- 48,64 ---- -- Calendar.Time is positive. -- See Ada.Calendar.Delays for more information on VMS Time. ! Max_Sensible_Delay : constant Duration := ! Duration'Min (183 * 24 * 60 * 60.0, ! Duration'Last); -- Max of half a year delay, needed to prevent exceptions for large -- delay values. It seems unlikely that any test will notice this -- restriction, except in the case of applications setting the clock at -- at run time (see s-tastim.adb). Also note that a larger value might -- cause problems (e.g overflow, or more likely OS limitation in the ! -- primitives used). In the case where half a year is too long (which ! -- occurs in high integrity mode with 32-bit words, and possibly on ! -- some specific ports of GNAT), Duration'Last is used instead. function OS_Clock return OS_Time; -- Returns "absolute" time, represented as an offset diff -Nrc3pad gcc-3.3.3/gcc/ada/5vparame.ads gcc-3.4.0/gcc/ada/5vparame.ads *** gcc-3.3.3/gcc/ada/5vparame.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vparame.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1992-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- -- --- 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 := True; -- 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/5vsymbol.adb gcc-3.4.0/gcc/ada/5vsymbol.adb *** gcc-3.3.3/gcc/ada/5vsymbol.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vsymbol.adb 2003-11-20 09:53:58.000000000 +0000 *************** *** 0 **** --- 1,743 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- S Y M B O L S -- + -- -- + -- 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. -- + -- -- + -- 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 of this package + + with Ada.Exceptions; use Ada.Exceptions; + with Ada.Sequential_IO; + with Ada.Text_IO; use Ada.Text_IO; + + package body Symbols is + + Case_Sensitive : constant String := "case_sensitive="; + Symbol_Vector : constant String := "SYMBOL_VECTOR=("; + Equal_Data : constant String := "=DATA)"; + Equal_Procedure : constant String := "=PROCEDURE)"; + Gsmatch : constant String := "gsmatch=equal,"; + + Symbol_File_Name : String_Access := null; + -- Name of the symbol file + + Sym_Policy : Policy := Autonomous; + -- The symbol policy. Set by Initialize + + Major_ID : Integer := 1; + -- The Major ID. May be modified by Initialize if Library_Version is + -- specified or if it is read from the reference symbol file. + + Soft_Major_ID : Boolean := True; + -- False if library version is specified in procedure Initialize. + -- When True, Major_ID may be modified if found in the reference symbol + -- file. + + Minor_ID : Natural := 0; + -- The Minor ID. May be modified if read from the reference symbol file + + Soft_Minor_ID : Boolean := True; + -- False if symbol policy is Autonomous, if library version is specified + -- in procedure Initialize and is not the same as the major ID read from + -- the reference symbol file. When True, Minor_ID may be increased in + -- Compliant symbol policy. + + subtype Byte is Character; + -- Object files are stream of bytes, but some of these bytes, those for + -- the names of the symbols, are ASCII characters. + + package Byte_IO is new Ada.Sequential_IO (Byte); + use Byte_IO; + + type Number is mod 2**16; + -- 16 bits unsigned number for number of characters + + GSD : constant Number := 10; + -- Code for the Global Symbol Definition section + + C_SYM : constant Number := 1; + -- Code for a Symbol subsection + + V_DEF_Mask : constant Number := 2**1; + V_NORM_Mask : constant Number := 2**6; + + File : Byte_IO.File_Type; + -- Each object file is read as a stream of bytes (characters) + + B : Byte; + + Number_Of_Characters : Natural := 0; + -- The number of characters of each section + + -- The following variables are used by procedure Process when reading an + -- object file. + + Code : Number := 0; + Length : Natural := 0; + + Dummy : Number; + + Nchars : Natural := 0; + Flags : Number := 0; + + Symbol : String (1 .. 255); + LSymb : Natural; + + function Equal (Left, Right : Symbol_Data) return Boolean; + -- Test for equality of symbols + + procedure Get (N : out Number); + -- Read two bytes from the object file LSB first as unsigned 16 bit number + + procedure Get (N : out Natural); + -- Read two bytes from the object file, LSByte first, as a Natural + + + function Image (N : Integer) return String; + -- Returns the image of N, without the initial space + + ----------- + -- Equal -- + ----------- + + function Equal (Left, Right : Symbol_Data) return Boolean is + begin + return Left.Name /= null and then + Right.Name /= null and then + Left.Name.all = Right.Name.all and then + Left.Kind = Right.Kind and then + Left.Present = Right.Present; + end Equal; + + --------- + -- Get -- + --------- + + procedure Get (N : out Number) is + C : Byte; + LSByte : Number; + begin + Read (File, C); + LSByte := Byte'Pos (C); + Read (File, C); + N := LSByte + (256 * Byte'Pos (C)); + end Get; + + procedure Get (N : out Natural) is + Result : Number; + begin + Get (Result); + N := Natural (Result); + end Get; + + ----------- + -- Image -- + ----------- + + function Image (N : Integer) return String is + Result : constant String := N'Img; + begin + if Result (Result'First) = ' ' then + return Result (Result'First + 1 .. Result'Last); + + else + return Result; + end if; + end Image; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (Symbol_File : String; + Reference : String; + Symbol_Policy : Policy; + Quiet : Boolean; + Version : String; + Success : out Boolean) + is + File : Ada.Text_IO.File_Type; + Line : String (1 .. 1_000); + Last : Natural; + + begin + -- Record the symbol file name + + Symbol_File_Name := new String'(Symbol_File); + + -- Record the policy + + Sym_Policy := Symbol_Policy; + + -- Record the version (Major ID) + + if Version = "" then + Major_ID := 1; + Soft_Major_ID := True; + + else + begin + Major_ID := Integer'Value (Version); + Soft_Major_ID := False; + + if Major_ID <= 0 then + raise Constraint_Error; + end if; + + exception + when Constraint_Error => + if not Quiet then + Put_Line ("Version """ & Version & """ is illegal."); + Put_Line ("On VMS, version must be a positive number"); + end if; + + Success := False; + return; + end; + end if; + + Minor_ID := 0; + Soft_Minor_ID := Sym_Policy /= Autonomous; + + -- Empty the symbol tables + + Symbol_Table.Set_Last (Original_Symbols, 0); + Symbol_Table.Set_Last (Complete_Symbols, 0); + + -- Assume that everything will be fine + + Success := True; + + -- If policy is not autonomous, attempt to read the reference file + + if Sym_Policy /= Autonomous then + begin + Open (File, In_File, Reference); + + exception + when Ada.Text_IO.Name_Error => + return; + + when X : others => + if not Quiet then + Put_Line ("could not open """ & Reference & """"); + Put_Line (Exception_Message (X)); + end if; + + Success := False; + return; + end; + + -- Read line by line + + while not End_Of_File (File) loop + Get_Line (File, Line, Last); + + -- Ignore empty lines + + if Last = 0 then + null; + + -- Ignore lines starting with "case_sensitive=" + + elsif Last > Case_Sensitive'Length + and then Line (1 .. Case_Sensitive'Length) = Case_Sensitive + then + null; + + -- Line starting with "SYMBOL_VECTOR=(" + + elsif Last > Symbol_Vector'Length + and then Line (1 .. Symbol_Vector'Length) = Symbol_Vector + then + + -- SYMBOL_VECTOR=(=DATA) + + if Last > Symbol_Vector'Length + Equal_Data'Length and then + Line (Last - Equal_Data'Length + 1 .. Last) = Equal_Data + then + Symbol_Table.Increment_Last (Original_Symbols); + Original_Symbols.Table + (Symbol_Table.Last (Original_Symbols)) := + (Name => + new String'(Line (Symbol_Vector'Length + 1 .. + Last - Equal_Data'Length)), + Kind => Data, + Present => True); + + -- SYMBOL_VECTOR=(=PROCEDURE) + + elsif Last > Symbol_Vector'Length + Equal_Procedure'Length + and then + Line (Last - Equal_Procedure'Length + 1 .. Last) = + Equal_Procedure + then + Symbol_Table.Increment_Last (Original_Symbols); + Original_Symbols.Table + (Symbol_Table.Last (Original_Symbols)) := + (Name => + new String'(Line (Symbol_Vector'Length + 1 .. + Last - Equal_Procedure'Length)), + Kind => Proc, + Present => True); + + -- Anything else is incorrectly formatted + + else + if not Quiet then + Put_Line ("symbol file """ & Reference & + """ is incorrectly formatted:"); + Put_Line ("""" & Line (1 .. Last) & """"); + end if; + + Close (File); + Success := False; + return; + end if; + + -- Lines with "gsmatch=equal,, + + elsif Last > Gsmatch'Length + and then Line (1 .. Gsmatch'Length) = Gsmatch + then + declare + Start : Positive := Gsmatch'Length + 1; + Finish : Positive := Start; + OK : Boolean := True; + ID : Integer; + + begin + loop + if Line (Finish) not in '0' .. '9' + or else Finish >= Last - 1 + then + OK := False; + exit; + end if; + + exit when Line (Finish + 1) = ','; + + Finish := Finish + 1; + end loop; + + if OK then + ID := Integer'Value (Line (Start .. Finish)); + OK := ID /= 0; + + -- If Soft_Major_ID is True, it means that + -- Library_Version was not specified. + + if Soft_Major_ID then + Major_ID := ID; + + -- If the Major ID in the reference file is different + -- from the Library_Version, then the Minor ID will be 0 + -- because there is no point in taking the Minor ID in + -- the reference file, or incrementing it. So, we set + -- Soft_Minor_ID to False, so that we don't modify + -- the Minor_ID later. + + elsif Major_ID /= ID then + Soft_Minor_ID := False; + end if; + + Start := Finish + 2; + Finish := Start; + + loop + if Line (Finish) not in '0' .. '9' then + OK := False; + exit; + end if; + + exit when Finish = Last; + + Finish := Finish + 1; + end loop; + + -- Only set Minor_ID if Soft_Minor_ID is True (see above) + + if OK and then Soft_Minor_ID then + Minor_ID := Integer'Value (Line (Start .. Finish)); + end if; + end if; + + -- If OK is not True, that means the line is not correctly + -- formatted. + + if not OK then + if not Quiet then + Put_Line ("symbol file """ & Reference & + """ is incorrectly formatted"); + Put_Line ("""" & Line (1 .. Last) & """"); + end if; + + Close (File); + Success := False; + return; + end if; + end; + + -- Anything else is incorrectly formatted + + else + if not Quiet then + Put_Line ("unexpected line in symbol file """ & + Reference & """"); + Put_Line ("""" & Line (1 .. Last) & """"); + end if; + + Close (File); + Success := False; + return; + end if; + end loop; + + Close (File); + end if; + end Initialize; + + ------------- + -- Process -- + ------------- + + procedure Process + (Object_File : String; + Success : out Boolean) + is + begin + -- Open the object file with Byte_IO. Return with Success = False if + -- this fails. + + begin + Open (File, In_File, Object_File); + exception + when others => + Put_Line + ("*** Unable to open object file """ & Object_File & """"); + Success := False; + return; + end; + + -- Assume that the object file has a correct format + + Success := True; + + -- Get the different sections one by one from the object file + + while not End_Of_File (File) loop + + Get (Code); + Get (Number_Of_Characters); + Number_Of_Characters := Number_Of_Characters - 4; + + -- If this is not a Global Symbol Definition section, skip to the + -- next section. + + if Code /= GSD then + + for J in 1 .. Number_Of_Characters loop + Read (File, B); + end loop; + + else + + -- Skip over the next 4 bytes + + Get (Dummy); + Get (Dummy); + Number_Of_Characters := Number_Of_Characters - 4; + + -- Get each subsection in turn + + loop + Get (Code); + Get (Nchars); + Get (Dummy); + Get (Flags); + Number_Of_Characters := Number_Of_Characters - 8; + Nchars := Nchars - 8; + + -- If this is a symbol and the V_DEF flag is set, get the + -- symbol. + + if Code = C_SYM and then ((Flags and V_DEF_Mask) /= 0) then + -- First, reach the symbol length + + for J in 1 .. 25 loop + Read (File, B); + Nchars := Nchars - 1; + Number_Of_Characters := Number_Of_Characters - 1; + end loop; + + Length := Byte'Pos (B); + LSymb := 0; + + -- Get the symbol characters + + for J in 1 .. Nchars loop + Read (File, B); + Number_Of_Characters := Number_Of_Characters - 1; + if Length > 0 then + LSymb := LSymb + 1; + Symbol (LSymb) := B; + Length := Length - 1; + end if; + end loop; + + -- Create the new Symbol + + declare + S_Data : Symbol_Data; + begin + S_Data.Name := new String'(Symbol (1 .. LSymb)); + + -- The symbol kind (Data or Procedure) depends on the + -- V_NORM flag. + + if (Flags and V_NORM_Mask) = 0 then + S_Data.Kind := Data; + + else + S_Data.Kind := Proc; + end if; + + -- Put the new symbol in the table + + Symbol_Table.Increment_Last (Complete_Symbols); + Complete_Symbols.Table + (Symbol_Table.Last (Complete_Symbols)) := S_Data; + end; + + else + -- As it is not a symbol subsection, skip to the next + -- subsection. + + for J in 1 .. Nchars loop + Read (File, B); + Number_Of_Characters := Number_Of_Characters - 1; + end loop; + end if; + + -- Exit the GSD section when number of characters reaches 0 + + exit when Number_Of_Characters = 0; + end loop; + end if; + end loop; + + -- The object file has been processed, close it + + Close (File); + + exception + -- For any exception, output an error message, close the object file + -- and return with Success = False. + + when X : others => + Put_Line ("unexpected exception raised while processing """ + & Object_File & """"); + Put_Line (Exception_Information (X)); + Close (File); + Success := False; + end Process; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize + (Quiet : Boolean; + Success : out Boolean) + is + File : Ada.Text_IO.File_Type; + -- The symbol file + + S_Data : Symbol_Data; + -- A symbol + + Cur : Positive := 1; + -- Most probable index in the Complete_Symbols of the current symbol + -- in Original_Symbol. + + Found : Boolean; + + begin + -- Nothing to be done if Initialize has never been called + + if Symbol_File_Name = null then + Success := False; + + else + + -- First find if the symbols in the reference symbol file are also + -- in the object files. Note that this is not done if the policy is + -- Autonomous, because no reference symbol file has been read. + + -- Expect the first symbol in the symbol file to also be the first + -- in Complete_Symbols. + + Cur := 1; + + for Index_1 in 1 .. Symbol_Table.Last (Original_Symbols) loop + S_Data := Original_Symbols.Table (Index_1); + Found := False; + + First_Object_Loop : + for Index_2 in Cur .. Symbol_Table.Last (Complete_Symbols) loop + if Equal (S_Data, Complete_Symbols.Table (Index_2)) then + Cur := Index_2 + 1; + Complete_Symbols.Table (Index_2).Present := False; + Found := True; + exit First_Object_Loop; + end if; + end loop First_Object_Loop; + + -- If the symbol could not be found between Cur and Last, try + -- before Cur. + + if not Found then + Second_Object_Loop : + for Index_2 in 1 .. Cur - 1 loop + if Equal (S_Data, Complete_Symbols.Table (Index_2)) then + Cur := Index_2 + 1; + Complete_Symbols.Table (Index_2).Present := False; + Found := True; + exit Second_Object_Loop; + end if; + end loop Second_Object_Loop; + end if; + + -- If the symbol is not found, mark it as such in the table + + if not Found then + if (not Quiet) or else Sym_Policy = Controlled then + Put_Line ("symbol """ & S_Data.Name.all & + """ is no longer present in the object files"); + end if; + + if Sym_Policy = Controlled then + Success := False; + return; + + elsif Soft_Minor_ID then + Minor_ID := Minor_ID + 1; + Soft_Minor_ID := False; + end if; + + Original_Symbols.Table (Index_1).Present := False; + Free (Original_Symbols.Table (Index_1).Name); + + if Soft_Minor_ID then + Minor_ID := Minor_ID + 1; + Soft_Minor_ID := False; + end if; + end if; + end loop; + + -- Append additional symbols, if any, to the Original_Symbols table + + for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop + S_Data := Complete_Symbols.Table (Index); + + if S_Data.Present then + + if Sym_Policy = Controlled then + Put_Line ("symbol """ & S_Data.Name.all & + """ is not in the reference symbol file"); + Success := False; + return; + + elsif Soft_Minor_ID then + Minor_ID := Minor_ID + 1; + Soft_Minor_ID := False; + end if; + + Symbol_Table.Increment_Last (Original_Symbols); + Original_Symbols.Table (Symbol_Table.Last (Original_Symbols)) := + S_Data; + Complete_Symbols.Table (Index).Present := False; + end if; + end loop; + + -- Create the symbol file + + Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all); + + Put (File, Case_Sensitive); + Put_Line (File, "yes"); + + -- Put a line in the symbol file for each symbol in the symbol table + + for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop + if Original_Symbols.Table (Index).Present then + Put (File, Symbol_Vector); + Put (File, Original_Symbols.Table (Index).Name.all); + + if Original_Symbols.Table (Index).Kind = Data then + Put_Line (File, Equal_Data); + + else + Put_Line (File, Equal_Procedure); + end if; + + Free (Original_Symbols.Table (Index).Name); + end if; + end loop; + + Put (File, Case_Sensitive); + Put_Line (File, "NO"); + + -- Put the version IDs + + Put (File, Gsmatch); + Put (File, Image (Major_ID)); + Put (File, ','); + Put_Line (File, Image (Minor_ID)); + + -- And we are done + + Close (File); + + -- Reset both tables + + Symbol_Table.Set_Last (Original_Symbols, 0); + Symbol_Table.Set_Last (Complete_Symbols, 0); + + -- Clear the symbol file name + + Free (Symbol_File_Name); + + Success := True; + end if; + + exception + when X : others => + Put_Line ("unexpected exception raised while finalizing """ + & Symbol_File_Name.all & """"); + Put_Line (Exception_Information (X)); + Success := False; + end Finalize; + + end Symbols; diff -Nrc3pad gcc-3.3.3/gcc/ada/5vsystem.ads gcc-3.4.0/gcc/ada/5vsystem.ads *** gcc-3.3.3/gcc/ada/5vsystem.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vsystem.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 7,14 **** -- S p e c -- -- (OpenVMS DEC Threads 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 -- -- (OpenVMS DEC Threads 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 := True; - High_Integrity_Mode : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := True; 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 := True; GCC_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := True; -------------------------- -- 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 := 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 := True; 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 := 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 := False; + -------------------------- -- Underlying Priorities -- --------------------------- diff -Nrc3pad gcc-3.3.3/gcc/ada/5vtaprop.adb gcc-3.4.0/gcc/ada/5vtaprop.adb *** gcc-3.3.3/gcc/ada/5vtaprop.adb 2002-03-14 10:58:41.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vtaprop.adb 2004-01-05 15:20:43.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- -- *************** *** 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 *** 89,102 **** -- 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. --- 88,101 ---- -- 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 *** 109,114 **** --- 108,153 ---- 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 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 *** 121,143 **** -- Signal the condition variable when AST fires. procedure Timer_Sleep_AST (ID : Address) is ! Result : Interfaces.C.int; ! Self_ID : Task_ID := To_Task_ID (ID); ! begin Self_ID.Common.LL.AST_Pending := False; Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access); end Timer_Sleep_AST; ! ------------------- ! -- Stack_Guard -- ! ------------------- -- The underlying thread system sets a guard page at the -- bottom of a thread stack, so nothing is needed. -- ??? Check the comment above procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is begin null; end Stack_Guard; --- 160,184 ---- -- Signal the condition variable when AST fires. procedure Timer_Sleep_AST (ID : Address) is ! Result : Interfaces.C.int; ! Self_ID : Task_ID := To_Task_ID (ID); begin Self_ID.Common.LL.AST_Pending := False; Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access); + pragma Assert (Result = 0); end Timer_Sleep_AST; ! ----------------- ! -- Stack_Guard -- ! ----------------- -- The underlying thread system sets a guard page at the -- bottom of a thread stack, so nothing is needed. -- ??? Check the comment above procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Unreferenced (T); + pragma Unreferenced (On); begin null; end Stack_Guard; *************** package body System.Task_Primitives.Oper *** 155,179 **** -- 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 -- --------------------- -- Note: mutexes and cond_variables needed per-task basis are ! -- initialized in Initialize_TCB and the Storage_Error is ! -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) ! -- used in RTS is initialized before any status change of RTS. ! -- Therefore rasing Storage_Error in the following routines ! -- should be able to be handled safely. procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is Attributes : aliased pthread_mutexattr_t; --- 196,213 ---- -- Self -- ---------- ! function Self return Task_ID renames Specific.Self; --------------------- -- Initialize_Lock -- --------------------- -- Note: mutexes and cond_variables needed per-task basis are ! -- initialized in Initialize_TCB and the Storage_Error is ! -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) ! -- used in RTS is initialized before any status change of RTS. ! -- Therefore rasing Storage_Error in the following routines ! -- should be able to be handled safely. procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is Attributes : aliased pthread_mutexattr_t; *************** package body System.Task_Primitives.Oper *** 202,207 **** --- 236,243 ---- 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 *** 213,219 **** raise Storage_Error; end if; ! -- Don't use, see comment in s-osinte.ads about ERRORCHECK mutexes. -- Result := pthread_mutexattr_settype_np -- (Attributes'Access, PTHREAD_MUTEX_ERRORCHECK_NP); -- pragma Assert (Result = 0); --- 249,255 ---- raise Storage_Error; end if; ! -- Don't use, see comment in s-osinte.ads about ERRORCHECK mutexes??? -- Result := pthread_mutexattr_settype_np -- (Attributes'Access, PTHREAD_MUTEX_ERRORCHECK_NP); -- pragma Assert (Result = 0); *************** package body System.Task_Primitives.Oper *** 269,275 **** begin Current_Prio := Get_Priority (Self_ID); ! -- If there is no other tasks, no need to check priorities. if All_Tasks_Link /= Null_Task and then L.Prio < Interfaces.C.int (Current_Prio) --- 305,311 ---- begin Current_Prio := Get_Priority (Self_ID); ! -- If there is no other tasks, no need to check priorities if All_Tasks_Link /= Null_Task and then L.Prio < Interfaces.C.int (Current_Prio) *************** package body System.Task_Primitives.Oper *** 288,294 **** end Write_Lock; procedure Write_Lock ! (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin --- 324,331 ---- 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 *** 353,359 **** --- 390,398 ---- (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 *************** package body System.Task_Primitives.Oper *** 363,369 **** (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); if Self_ID.Deferral_Level = 0 --- 402,409 ---- (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); if Self_ID.Deferral_Level = 0 *************** package body System.Task_Primitives.Oper *** 386,395 **** --- 426,439 ---- Timedout : out Boolean; Yielded : out Boolean) is + pragma Unreferenced (Reason); + Sleep_Time : OS_Time; Result : Interfaces.C.int; Status : Cond_Value_Type; + -- The body below requires more comments ??? + begin Timedout := False; Yielded := False; *************** package body System.Task_Primitives.Oper *** 415,424 **** --- 459,470 ---- if Single_Lock then Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + pragma Assert (Result = 0); else Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); end if; Yielded := True; *************** package body System.Task_Primitives.Oper *** 454,459 **** --- 500,507 ---- Lock_RTS; end if; + -- More comments required in body below ??? + SSL.Abort_Defer.all; Write_Lock (Self_ID); *************** package body System.Task_Primitives.Oper *** 488,496 **** --- 536,546 ---- if Single_Lock then Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + pragma Assert (Result = 0); else Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); end if; Yielded := True; *************** package body System.Task_Primitives.Oper *** 510,515 **** --- 560,566 ---- if not Yielded then Result := sched_yield; + pragma Assert (Result = 0); end if; SSL.Abort_Undefer.all; *************** package body System.Task_Primitives.Oper *** 536,542 **** --- 587,596 ---- ------------ 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 *** 548,553 **** --- 602,608 ---- 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 *** 563,570 **** --- 618,628 ---- Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is + pragma Unreferenced (Loss_Of_Inheritance); + Result : Interfaces.C.int; Param : aliased struct_sched_param; + begin T.Common.Current_Priority := Prio; Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); *************** package body System.Task_Primitives.Oper *** 578,583 **** --- 636,646 ---- (T.Common.LL.Thread, SCHED_FIFO, Param'Access); else + -- SCHED_OTHER priorities are restricted to the range 8 - 15. + -- Since the translation from Underlying priorities results + -- in a range of 16 - 31, dividing by 2 gives the correct result. + + Param.sched_priority := Param.sched_priority / 2; Result := pthread_setschedparam (T.Common.LL.Thread, SCHED_OTHER, Param'Access); end if; *************** package body System.Task_Primitives.Oper *** 599,615 **** ---------------- procedure Enter_Task (Self_ID : Task_ID) is - Result : Interfaces.C.int; begin Self_ID.Common.LL.Thread := pthread_self; ! -- It is not safe for the new task accept signals until it ! -- has bound its TCB pointer to the thread with pthread_setspecific (), ! -- since the handler wrappers use the TCB pointer ! -- to restore the stack limit. ! ! Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID)); ! pragma Assert (Result = 0); Lock_RTS; --- 662,671 ---- ---------------- 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 *** 633,648 **** return new Ada_Task_Control_Block (Entry_Num); end New_ATCB; ---------------------- -- 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 if not Single_Lock then Result := pthread_mutexattr_init (Mutex_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); --- 689,725 ---- 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 + -- More comments required in body below ??? + if not Single_Lock then Result := pthread_mutexattr_init (Mutex_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); *************** package body System.Task_Primitives.Oper *** 743,750 **** -- This call may be unnecessary, not sure. ??? ! Result := pthread_attr_setinheritsched ! (Attributes'Access, PTHREAD_EXPLICIT_SCHED); pragma Assert (Result = 0); Result := pthread_create --- 820,828 ---- -- This call may be unnecessary, not sure. ??? ! Result := ! pthread_attr_setinheritsched ! (Attributes'Access, PTHREAD_EXPLICIT_SCHED); pragma Assert (Result = 0); Result := pthread_create *************** package body System.Task_Primitives.Oper *** 773,780 **** ------------------ procedure Finalize_TCB (T : Task_ID) is ! Result : Interfaces.C.int; ! Tmp : Task_ID := T; procedure Free is new Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); --- 851,859 ---- ------------------ 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 *** 796,802 **** --- 875,887 ---- end if; Free (T.Common.LL.Exc_Stack_Ptr); + 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 *** 805,811 **** procedure Exit_Task is begin ! pthread_exit (System.Null_Address); end Exit_Task; ---------------- --- 890,896 ---- procedure Exit_Task is begin ! Specific.Set (null); end Exit_Task; ---------------- *************** package body System.Task_Primitives.Oper *** 813,845 **** ---------------- procedure Abort_Task (T : Task_ID) is - begin - - -- Why is this commented out ??? - -- if T = Self and then T.Deferral_Level = 0 - -- and then T.Pending_ATC_Level < T.ATC_Nesting_Level - -- then - -- raise Standard'Abort_Signal; - -- end if; - - -- -- Interrupt Server_Tasks may be waiting on an event flag ! -- if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then Wakeup (T, Interrupt_Server_Blocked_On_Event_Flag); end if; - end Abort_Task; ---------------- -- 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; --- 898,920 ---- ---------------- procedure Abort_Task (T : Task_ID) is begin -- Interrupt Server_Tasks may be waiting on an event flag ! if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then Wakeup (T, Interrupt_Server_Blocked_On_Event_Flag); end if; end Abort_Task; ---------------- -- 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 *** 849,854 **** --- 924,931 ---- -------------------- 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 *** 886,892 **** function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin return False; end Suspend_Task; --- 963,973 ---- 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 *** 897,903 **** function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin return False; end Resume_Task; --- 978,987 ---- 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 *** 910,926 **** 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); end Initialize; - begin - declare - Result : Interfaces.C.int; - begin - Result := pthread_key_create (ATCB_Key'Access, null); - pragma Assert (Result = 0); - end; end System.Task_Primitives.Operations; --- 994,1006 ---- 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); end Initialize; end System.Task_Primitives.Operations; diff -Nrc3pad gcc-3.3.3/gcc/ada/5vtaspri.ads gcc-3.4.0/gcc/ada/5vtaspri.ads *** gcc-3.3.3/gcc/ada/5vtaspri.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vtaspri.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/5vtpopde.adb gcc-3.4.0/gcc/ada/5vtpopde.adb *** gcc-3.3.3/gcc/ada/5vtpopde.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vtpopde.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 2000-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) 2000-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,52 **** -- 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 package is for OpenVMS/Alpha with System.OS_Interface; with System.Tasking; with Unchecked_Conversion; package body System.Task_Primitives.Operations.DEC is use System.OS_Interface; use System.Tasking; use System.Aux_DEC; use type Interfaces.C.int; -- The FAB_RAB_Type specifies where the context field (the calling ! -- task) is stored. Other fields defined for FAB_RAB aren't need and -- so are ignored. type FAB_RAB_Type is record --- 27,56 ---- -- 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 package is for OpenVMS/Alpha with System.OS_Interface; + with System.Parameters; with System.Tasking; with Unchecked_Conversion; + with System.Soft_Links; package body System.Task_Primitives.Operations.DEC is use System.OS_Interface; + use System.Parameters; use System.Tasking; use System.Aux_DEC; use type Interfaces.C.int; + package SSL renames System.Soft_Links; + -- The FAB_RAB_Type specifies where the context field (the calling ! -- task) is stored. Other fields defined for FAB_RAB arent' need and -- so are ignored. type FAB_RAB_Type is record *************** package body System.Task_Primitives.Oper *** 107,113 **** function Self return Unsigned_Longword is Self_ID : Task_ID := Self; - begin Self_ID.Common.LL.AST_Pending := True; return To_Unsigned_Longword (Self); --- 111,116 ---- *************** package body System.Task_Primitives.Oper *** 132,141 **** ---------------- procedure Task_Synch is ! Synch_Self_ID : Task_ID := Self; ! begin ! Write_Lock (Synch_Self_ID); Synch_Self_ID.Common.State := AST_Server_Sleep; while Synch_Self_ID.Common.LL.AST_Pending loop --- 135,149 ---- ---------------- procedure Task_Synch is ! Synch_Self_ID : constant Task_ID := Self; begin ! if Single_Lock then ! Lock_RTS; ! else ! Write_Lock (Synch_Self_ID); ! end if; ! ! SSL.Abort_Defer.all; Synch_Self_ID.Common.State := AST_Server_Sleep; while Synch_Self_ID.Common.LL.AST_Pending loop *************** package body System.Task_Primitives.Oper *** 143,149 **** end loop; Synch_Self_ID.Common.State := Runnable; ! Unlock (Synch_Self_ID); end Task_Synch; end System.Task_Primitives.Operations.DEC; --- 151,164 ---- end loop; Synch_Self_ID.Common.State := Runnable; ! ! if Single_Lock then ! Unlock_RTS; ! else ! Unlock (Synch_Self_ID); ! end if; ! ! SSL.Abort_Undefer.all; end Task_Synch; end System.Task_Primitives.Operations.DEC; diff -Nrc3pad gcc-3.3.3/gcc/ada/5vtpopde.ads gcc-3.4.0/gcc/ada/5vtpopde.ads *** gcc-3.3.3/gcc/ada/5vtpopde.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vtpopde.ads 2003-10-21 13:41:52.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 -- ! -- . D E C -- -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 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- -- --- 2,12 ---- -- -- -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- ! -- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2000-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- -- *************** *** 29,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 package is for OpenVMS/Alpha. -- with System.Aux_DEC; --- 27,36 ---- -- 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 package is for OpenVMS/Alpha. -- with System.Aux_DEC; diff -Nrc3pad gcc-3.3.3/gcc/ada/5vtraent.adb gcc-3.4.0/gcc/ada/5vtraent.adb *** gcc-3.3.3/gcc/ada/5vtraent.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vtraent.adb 2003-10-29 10:26:12.000000000 +0000 *************** *** 0 **** --- 1,68 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M . T R A C E B A C K _ E N T R I E S -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 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 body System.Traceback_Entries is + + ------------ + -- PC_For -- + ------------ + + function PC_For (TB_Entry : Traceback_Entry) return System.Address is + begin + return TB_Entry.PC; + end PC_For; + + ------------ + -- PV_For -- + ------------ + + function PV_For (TB_Entry : Traceback_Entry) return System.Address is + begin + return TB_Entry.PV; + end PV_For; + + ------------------ + -- TB_Entry_For -- + ------------------ + + function TB_Entry_For (PC : System.Address) return Traceback_Entry is + begin + return (PC => PC, PV => System.Null_Address); + end TB_Entry_For; + + end System.Traceback_Entries; + diff -Nrc3pad gcc-3.3.3/gcc/ada/5vtraent.ads gcc-3.4.0/gcc/ada/5vtraent.ads *** gcc-3.3.3/gcc/ada/5vtraent.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vtraent.ads 2003-10-29 10:26:12.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M . T R A C E B A C K _ E N T R I E S -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 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. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the Alpha/OpenVMS version of this package + + package System.Traceback_Entries is + + type Traceback_Entry is record + PC : System.Address; + PV : System.Address; + end record; + + pragma Suppress_Initialization (Traceback_Entry); + + Null_TB_Entry : constant Traceback_Entry := + (PC => System.Null_Address, + PV => System.Null_Address); + + function PC_For (TB_Entry : Traceback_Entry) return System.Address; + function PV_For (TB_Entry : Traceback_Entry) return System.Address; + + function TB_Entry_For (PC : System.Address) return Traceback_Entry; + + end System.Traceback_Entries; + diff -Nrc3pad gcc-3.3.3/gcc/ada/5vvaflop.adb gcc-3.4.0/gcc/ada/5vvaflop.adb *** gcc-3.3.3/gcc/ada/5vvaflop.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5vvaflop.adb 2003-04-24 17:53:52.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1997-2000 Free Software Foundation, Inc. -- -- (Version for Alpha OpenVMS) -- -- -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5wgloloc.adb gcc-3.4.0/gcc/ada/5wgloloc.adb *** gcc-3.3.3/gcc/ada/5wgloloc.adb 2002-03-14 10:58:41.000000000 +0000 --- gcc-3.4.0/gcc/ada/5wgloloc.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 27,33 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 26,33 ---- -- 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/5wintman.adb gcc-3.4.0/gcc/ada/5wintman.adb *** gcc-3.3.3/gcc/ada/5wintman.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5wintman.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- 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. -- -- -- ------------------------------------------------------------------------------ *************** package body System.Interrupt_Management *** 64,70 **** end Initialize_Interrupts; begin ! -- "Reserve" all the interrupts, except those that are explicitly defined for J in Interrupt_ID'Range loop Reserve (J) := True; --- 63,69 ---- end Initialize_Interrupts; begin ! -- "Reserve" all the interrupts, except those that are explicitely defined for J in Interrupt_ID'Range loop Reserve (J) := True; diff -Nrc3pad gcc-3.3.3/gcc/ada/5wmemory.adb gcc-3.4.0/gcc/ada/5wmemory.adb *** gcc-3.3.3/gcc/ada/5wmemory.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5wmemory.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 4,17 **** -- -- -- S Y S T E M . M E M O R Y -- -- -- ! -- S p e c -- ! -- -- ! -- -- ! -- Copyright (C) 2001 Free Software Foundation, Inc. -- -- -- ! -- This specification is derived from the Ada Reference Manual for use with -- ! -- GNAT. The copyright notice above, and the license provisions that follow -- ! -- apply solely to the contents of the part following the private keyword. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 4,12 ---- -- -- -- S Y S T E M . M E M O R Y -- -- -- ! -- 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- -- *************** package body System.Memory is *** 192,198 **** return System.Address is Result : System.Address; ! Actual_Size : size_t := Size; Old_Size : size_t; begin --- 187,193 ---- return System.Address is Result : System.Address; ! Actual_Size : constant size_t := Size; Old_Size : size_t; begin diff -Nrc3pad gcc-3.3.3/gcc/ada/5wml-tgt.adb gcc-3.4.0/gcc/ada/5wml-tgt.adb *** gcc-3.3.3/gcc/ada/5wml-tgt.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5wml-tgt.adb 2003-11-20 09:53:58.000000000 +0000 *************** *** 0 **** --- 1,356 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T -- + -- (Windows Version) -- + -- -- + -- 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. -- + -- -- + -- 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 Windows version of the body. + + with Namet; use Namet; + with Opt; + with Output; use Output; + with Prj.Com; + + with GNAT.OS_Lib; use GNAT.OS_Lib; + + with MDLL; + with MDLL.Utl; + with MLib.Fil; + + package body MLib.Tgt is + + --------------------- + -- 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 (Ofiles); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Driver_Name); + pragma Unreferenced (Lib_Version); + pragma Unreferenced (Auto_Init); + + Imp_File : constant String := + "lib" & MLib.Fil.Ext_To (Lib_Filename, Archive_Ext); + -- Name of the import library + + DLL_File : constant String := MLib.Fil.Ext_To (Lib_Filename, DLL_Ext); + -- Name of the DLL file + + Lib_File : constant String := Lib_Dir & Directory_Separator & DLL_File; + -- Full path of the DLL file + + Success : Boolean; + + begin + if Opt.Verbose_Mode then + if Relocatable then + Write_Str ("building relocatable shared library "); + else + Write_Str ("building non-relocatable shared library "); + end if; + + Write_Line (Lib_File); + end if; + + MDLL.Verbose := Opt.Verbose_Mode; + MDLL.Quiet := not MDLL.Verbose; + + MDLL.Utl.Locate; + + MDLL.Build_Dynamic_Library + (Foreign, Afiles, + MDLL.Null_Argument_List, MDLL.Null_Argument_List, Options, + Lib_Filename, Lib_Filename & ".def", + Lib_Address, True, Relocatable); + + -- Move the DLL and import library in the lib directory + + Copy_File (DLL_File, Lib_Dir, Success, Mode => Overwrite); + + if not Success then + Fail ("could not copy DLL to library dir"); + end if; + + Copy_File (Imp_File, Lib_Dir, Success, Mode => Overwrite); + + if not Success then + Fail ("could not copy import library to library dir"); + end if; + + -- Delete files + + Delete_File (DLL_File, Success); + + if not Success then + Fail ("could not delete DLL from build dir"); + end if; + + Delete_File (Imp_File, Success); + + if not Success then + Fail ("could not delete import library from build dir"); + end if; + end Build_Dynamic_Library; + + ------------------------- + -- Default_DLL_Address -- + ------------------------- + + function Default_DLL_Address return String is + begin + return "0x11000000"; + end Default_DLL_Address; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "dll"; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return ""; + 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 + + -- Static libraries are named : lib.a + + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + MLib.Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + -- Shared libraries are named : .dll + + return Is_Regular_File + (Lib_Dir & Directory_Separator & + MLib.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 + if Projects.Table (Project).Library_Kind = Static then + + -- Static libraries are named : lib.a + + Name_Len := 3; + Name_Buffer (1 .. Name_Len) := "lib"; + + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + -- Shared libraries are named : .dll + + Name_Len := 0; + 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 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 ""; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return False; + 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/5wosinte.ads gcc-3.4.0/gcc/ada/5wosinte.ads *** gcc-3.3.3/gcc/ada/5wosinte.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5wosinte.ads 2003-12-11 16:21:39.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- -- *************** with Interfaces.C.Strings; *** 47,52 **** --- 46,53 ---- package System.OS_Interface is pragma Preelaborate; + pragma Linker_Options ("-mthreads"); + subtype int is Interfaces.C.int; subtype long is Interfaces.C.long; *************** pragma Preelaborate; *** 63,69 **** -- (See Operations.Clock) type LARGE_INTEGER is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0; - for LARGE_INTEGER'Alignment use 4; subtype PSZ is Interfaces.C.Strings.chars_ptr; subtype PCHAR is Interfaces.C.Strings.chars_ptr; --- 64,69 ---- *************** pragma Preelaborate; *** 185,190 **** --- 185,193 ---- type Thread_Body is access function (arg : System.Address) return System.Address; + procedure SwitchToThread; + pragma Import (Stdcall, SwitchToThread, "SwitchToThread"); + ----------------------- -- Critical sections -- ----------------------- *************** pragma Preelaborate; *** 400,405 **** --- 403,413 ---- dwPriorityClass : DWORD) return BOOL; pragma Import (Stdcall, SetPriorityClass, "SetPriorityClass"); + procedure SetThreadPriorityBoost + (hThread : HANDLE; + DisablePriorityBoost : BOOL); + pragma Import (Stdcall, SetThreadPriorityBoost, "SetThreadPriorityBoost"); + Normal_Priority_Class : constant := 16#00000020#; Idle_Priority_Class : constant := 16#00000040#; High_Priority_Class : constant := 16#00000080#; diff -Nrc3pad gcc-3.3.3/gcc/ada/5wosprim.adb gcc-3.4.0/gcc/ada/5wosprim.adb *** gcc-3.3.3/gcc/ada/5wosprim.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5wosprim.adb 2004-01-05 15:20:43.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-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,72 **** -- 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 NT version of this package with Ada.Exceptions; ! with System.OS_Interface; package body System.OS_Primitives is ! use System.OS_Interface; ! --------------------------------------- -- Data for the high resolution clock -- ! --------------------------------------- ! Tick_Frequency : aliased LARGE_INTEGER; -- Holds frequency of high-performance counter used by Clock -- Windows NT uses a 1_193_182 Hz counter on PCs. ! Base_Ticks : aliased LARGE_INTEGER; -- Holds the Tick count for the base time. ! Base_Clock : Duration; -- Holds the current clock for the standard clock's base time ! Base_Monotonic_Clock : Duration; -- Holds the current clock for monotonic clock's base time ! Base_Time : aliased Long_Long_Integer; -- Holds the base time used to check for system time change, used with -- the standard clock. procedure Get_Base_Time; ! -- Retrieve the base time. This base time will be used by clock to ! -- compute the current time by adding to it a fraction of the -- performance counter. This is for the implementation of a ! -- high-resolution clock. ----------- -- Clock -- --- 27,129 ---- -- 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 NT version of this package with Ada.Exceptions; ! with Interfaces.C; package body System.OS_Primitives is ! --------------------------- ! -- Win32 API Definitions -- ! --------------------------- ! -- These definitions are copied from System.OS_Interface because we do not ! -- want to depend on gnarl here. ! ! type DWORD is new Interfaces.C.unsigned_long; ! ! type LARGE_INTEGER is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0; ! ! type BOOL is new Boolean; ! for BOOL'Size use Interfaces.C.unsigned_long'Size; ! ! procedure GetSystemTimeAsFileTime (lpFileTime : access Long_Long_Integer); ! pragma Import (Stdcall, GetSystemTimeAsFileTime, "GetSystemTimeAsFileTime"); ! ! function QueryPerformanceCounter ! (lpPerformanceCount : access LARGE_INTEGER) return BOOL; ! pragma Import ! (Stdcall, QueryPerformanceCounter, "QueryPerformanceCounter"); ! ! function QueryPerformanceFrequency ! (lpFrequency : access LARGE_INTEGER) return BOOL; ! pragma Import ! (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency"); ! ! procedure Sleep (dwMilliseconds : DWORD); ! pragma Import (Stdcall, Sleep, External_Name => "Sleep"); ! ! ---------------------------------------- -- Data for the high resolution clock -- ! ---------------------------------------- ! -- Declare some pointers to access multi-word data above. This is needed ! -- to workaround a limitation in the GNU/Linker auto-import feature used ! -- to build the GNAT runtime DLLs. In fact the Clock and Monotonic_Clock ! -- routines are inlined and they are using some multi-word variables. ! -- GNU/Linker will fail to auto-import those variables when building ! -- libgnarl.dll. The indirection level introduced here has no measurable ! -- penalties. ! -- ! -- Note that access variables below must not be declared as constant ! -- otherwise the compiler optimization will remove this indirect access. ! ! type DA is access all Duration; ! -- Use to have indirect access to multi-word variables ! ! type LIA is access all LARGE_INTEGER; ! -- Use to have indirect access to multi-word variables ! ! type LLIA is access all Long_Long_Integer; ! -- Use to have indirect access to multi-word variables ! ! Tick_Frequency : aliased LARGE_INTEGER; ! TFA : constant LIA := Tick_Frequency'Access; -- Holds frequency of high-performance counter used by Clock -- Windows NT uses a 1_193_182 Hz counter on PCs. ! Base_Ticks : aliased LARGE_INTEGER; ! BTA : constant LIA := Base_Ticks'Access; -- Holds the Tick count for the base time. ! Base_Monotonic_Ticks : aliased LARGE_INTEGER; ! BMTA : constant LIA := Base_Monotonic_Ticks'Access; ! -- Holds the Tick count for the base monotonic time ! ! Base_Clock : aliased Duration; ! BCA : constant DA := Base_Clock'Access; -- Holds the current clock for the standard clock's base time ! Base_Monotonic_Clock : aliased Duration; ! BMCA : constant DA := Base_Monotonic_Clock'Access; -- Holds the current clock for monotonic clock's base time ! Base_Time : aliased Long_Long_Integer; ! BTiA : constant LLIA := Base_Time'Access; -- Holds the base time used to check for system time change, used with -- the standard clock. procedure Get_Base_Time; ! -- Retrieve the base time and base ticks. These values will be used by ! -- clock to compute the current time by adding to it a fraction of the -- performance counter. This is for the implementation of a ! -- high-resolution clock. Note that this routine does not change the base ! -- monotonic values used by the monotonic clock. ----------- -- Clock -- *************** package body System.OS_Primitives is *** 79,86 **** -- microsecs to complete. function Clock return Duration is ! Max_Shift : constant Duration := 2.0; ! Hundreds_Nano_In_Sec : constant := 1E7; Current_Ticks : aliased LARGE_INTEGER; Elap_Secs_Tick : Duration; Elap_Secs_Sys : Duration; --- 136,143 ---- -- microsecs to complete. function Clock return Duration is ! Max_Shift : constant Duration := 2.0; ! Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7; Current_Ticks : aliased LARGE_INTEGER; Elap_Secs_Tick : Duration; Elap_Secs_Sys : Duration; *************** package body System.OS_Primitives is *** 94,119 **** GetSystemTimeAsFileTime (Now'Access); Elap_Secs_Sys := ! Duration (abs (Now - Base_Time) / Hundreds_Nano_In_Sec); Elap_Secs_Tick := ! Duration (Long_Long_Float (Current_Ticks - Base_Ticks) / ! Long_Long_Float (Tick_Frequency)); -- If we have a shift of more than Max_Shift seconds we resynchonize the -- Clock. This is probably due to a manual Clock adjustment, an DST ! -- adjustment or an NNTP synchronisation. And we want to adjust the -- time for this system (non-monotonic) clock. if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then Get_Base_Time; Elap_Secs_Tick := ! Duration (Long_Long_Float (Current_Ticks - Base_Ticks) / ! Long_Long_Float (Tick_Frequency)); end if; ! return Base_Clock + Elap_Secs_Tick; end Clock; ------------------- --- 151,177 ---- GetSystemTimeAsFileTime (Now'Access); Elap_Secs_Sys := ! Duration (Long_Long_Float (abs (Now - BTiA.all)) / ! Hundreds_Nano_In_Sec); Elap_Secs_Tick := ! Duration (Long_Long_Float (Current_Ticks - BTA.all) / ! Long_Long_Float (TFA.all)); -- If we have a shift of more than Max_Shift seconds we resynchonize the -- Clock. This is probably due to a manual Clock adjustment, an DST ! -- adjustment or an NTP synchronisation. And we want to adjust the -- time for this system (non-monotonic) clock. if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then Get_Base_Time; Elap_Secs_Tick := ! Duration (Long_Long_Float (Current_Ticks - BTA.all) / ! Long_Long_Float (TFA.all)); end if; ! return BCA.all + Elap_Secs_Tick; end Clock; ------------------- *************** package body System.OS_Primitives is *** 121,128 **** ------------------- procedure Get_Base_Time is - use System.OS_Interface; - -- The resolution for GetSystemTime is 1 millisecond. -- The time to get both base times should take less than 1 millisecond. --- 179,184 ---- *************** package body System.OS_Primitives is *** 175,184 **** end if; Elap_Secs_Tick := ! Duration (Long_Long_Float (Current_Ticks - Base_Ticks) / ! Long_Long_Float (Tick_Frequency)); ! return Base_Monotonic_Clock + Elap_Secs_Tick; end Monotonic_Clock; ----------------- --- 231,240 ---- end if; Elap_Secs_Tick := ! Duration (Long_Long_Float (Current_Ticks - BMTA.all) / ! Long_Long_Float (TFA.all)); ! return BMCA.all + Elap_Secs_Tick; end Monotonic_Clock; ----------------- *************** begin *** 222,226 **** --- 278,286 ---- Get_Base_Time; + -- Keep base clock and ticks for the monotonic clock. These values should + -- never be changed to ensure proper behavior of the monotonic clock. + Base_Monotonic_Clock := Base_Clock; + Base_Monotonic_Ticks := Base_Ticks; end System.OS_Primitives; diff -Nrc3pad gcc-3.3.3/gcc/ada/5wsystem.ads gcc-3.4.0/gcc/ada/5wsystem.ads *** gcc-3.3.3/gcc/ada/5wsystem.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5wsystem.ads 2003-12-01 09:39:57.000000000 +0000 *************** *** 7,14 **** -- S p e c -- -- (NT 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 -- -- (NT 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,140 **** 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 := True; --------------------------- -- Underlying Priorities -- --- 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 := 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 := False; --------------------------- -- Underlying Priorities -- diff -Nrc3pad gcc-3.3.3/gcc/ada/5wtaprop.adb gcc-3.4.0/gcc/ada/5wtaprop.adb *** gcc-3.3.3/gcc/ada/5wtaprop.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5wtaprop.adb 2004-01-05 15:20:43.000000000 +0000 *************** *** 6,13 **** -- -- -- 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- -- --- 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- -- *************** *** 28,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 NT (native) version of this package. -- This package contains all the GNULL primitives that interface directly -- with the underlying OS. --- 27,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. -- -- -- ------------------------------------------------------------------------------ ! -- This is a NT (native) version of this package -- This package contains all the GNULL primitives that interface directly -- with the underlying OS. *************** package body System.Task_Primitives.Oper *** 96,104 **** package SSL renames System.Soft_Links; ! ------------------ ! -- Local Data -- ! ------------------ Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. --- 95,103 ---- package SSL renames System.Soft_Links; ! ---------------- ! -- Local Data -- ! ---------------- Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. *************** package body System.Task_Primitives.Oper *** 117,160 **** FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; -- Indicates whether FIFO_Within_Priorities is set. ! --------------------------------- ! -- Foreign Threads Detection -- ! --------------------------------- ! ! -- 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 run-time 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 - - --------------------------------- - -- 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. - ------------------------------------ -- The thread local storage index -- ------------------------------------ --- 116,124 ---- 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). ------------------------------------ -- The thread local storage index -- ------------------------------------ *************** package body System.Task_Primitives.Oper *** 164,274 **** -- To ensure that this variable won't be local to this package, since -- in some cases, inlining forces this variable to be global anyway. ! ---------------------------------- ! -- Utility Conversion Functions -- ! ---------------------------------- ! ! function To_Task_Id is new Unchecked_Conversion (System.Address, Task_ID); ! ! function To_Address is new Unchecked_Conversion (Task_ID, System.Address); ! ! ------------------- ! -- New_Fake_ATCB -- ! ------------------- ! ! function New_Fake_ATCB return Task_ID is ! Self_ID : Task_ID; ! P, Q : Fake_ATCB_Ptr; ! Succeeded : Boolean; ! Res : BOOL; ! ! 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 := GetCurrentThread; ! Res := TlsSetValue (TlsIndex, To_Address (Self_ID)); ! pragma Assert (Res = True); ! -- 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); ! -- Must not unlock until Next_ATCB is again allocated. ! Unlock_RTS; ! return Self_ID; ! end New_Fake_ATCB; ---------------------------------- -- Condition Variable Functions -- --- 128,182 ---- -- To ensure that this variable won't be local to this package, since -- in some cases, inlining forces this variable to be global anyway. ! -------------------- ! -- Local Packages -- ! -------------------- ! package Specific is ! 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. ! end Specific; ! package body Specific is ! function Is_Valid_Task return Boolean is ! begin ! return TlsGetValue (TlsIndex) /= System.Null_Address; ! end Is_Valid_Task; ! procedure Set (Self_Id : Task_ID) is ! Succeeded : BOOL; ! begin ! Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id)); ! pragma Assert (Succeeded = True); ! end Set; ! end 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; ! ---------------------------------- ! -- Utility Conversion Functions -- ! ---------------------------------- ! function To_Task_Id is new Unchecked_Conversion (System.Address, Task_ID); ! function To_Address is new Unchecked_Conversion (Task_ID, System.Address); ---------------------------------- -- Condition Variable Functions -- *************** package body System.Task_Primitives.Oper *** 297,303 **** -- Do timed wait on condition variable Cond using lock L. The duration -- of the timed wait is given by Rel_Time. When the condition is -- signalled, Timed_Out shows whether or not a time out occurred. ! -- Status shows whether Cond_Timed_Wait completed successfully. --------------------- -- Initialize_Cond -- --- 205,212 ---- -- Do timed wait on condition variable Cond using lock L. The duration -- of the timed wait is given by Rel_Time. When the condition is -- signalled, Timed_Out shows whether or not a time out occurred. ! -- Status is only valid if Timed_Out is False, in which case it ! -- shows whether Cond_Timed_Wait completed successfully. --------------------- -- Initialize_Cond -- *************** package body System.Task_Primitives.Oper *** 321,327 **** procedure Finalize_Cond (Cond : access Condition_Variable) is Result : BOOL; - begin Result := CloseHandle (HANDLE (Cond.all)); pragma Assert (Result = True); --- 230,235 ---- *************** package body System.Task_Primitives.Oper *** 333,339 **** procedure Cond_Signal (Cond : access Condition_Variable) is Result : BOOL; - begin Result := SetEvent (HANDLE (Cond.all)); pragma Assert (Result = True); --- 241,246 ---- *************** package body System.Task_Primitives.Oper *** 389,398 **** Timed_Out : out Boolean; Status : out Integer) is ! Time_Out : DWORD; ! Result : BOOL; ! Int_Rel_Time : DWORD; Wait_Result : DWORD; begin --- 296,307 ---- Timed_Out : out Boolean; Status : out Integer) is ! Time_Out_Max : constant DWORD := 16#FFFF0000#; ! -- NT 4 cannot handle timeout values that are too large, ! -- e.g. DWORD'Last - 1 ! Time_Out : DWORD; ! Result : BOOL; Wait_Result : DWORD; begin *************** package body System.Task_Primitives.Oper *** 407,416 **** if Rel_Time <= 0.0 then Timed_Out := True; else ! Int_Rel_Time := DWORD (Rel_Time); ! Time_Out := Int_Rel_Time * 1000 + ! DWORD ((Rel_Time - Duration (Int_Rel_Time)) * 1000.0); Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out); if Wait_Result = WAIT_TIMEOUT then --- 316,330 ---- if Rel_Time <= 0.0 then Timed_Out := True; + Wait_Result := 0; + else ! if Rel_Time >= Duration (Time_Out_Max) / 1000 then ! Time_Out := Time_Out_Max; ! else ! Time_Out := DWORD (Rel_Time * 1000); ! end if; ! Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out); if Wait_Result = WAIT_TIMEOUT then *************** package body System.Task_Primitives.Oper *** 442,447 **** --- 356,364 ---- -- ??? Check the comment above procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Warnings (Off, T); + pragma Warnings (Off, On); + begin null; end Stack_Guard; *************** package body System.Task_Primitives.Oper *** 460,475 **** ---------- function Self return Task_ID is ! Self_Id : Task_ID; begin - Self_Id := To_Task_Id (TlsGetValue (TlsIndex)); - if Self_Id = null then ! return New_Fake_ATCB; end if; - - return Self_Id; end Self; --------------------- --- 377,390 ---- ---------- function Self return Task_ID is ! Self_Id : constant Task_ID := To_Task_Id (TlsGetValue (TlsIndex)); begin if Self_Id = null then ! return Register_Foreign_Thread (GetCurrentThread); ! else ! return Self_Id; end if; end Self; --------------------- *************** package body System.Task_Primitives.Oper *** 477,483 **** --------------------- -- 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 -- the RTS is initialized before any status change of RTS. -- Therefore raising Storage_Error in the following routines --- 392,398 ---- --------------------- -- Note: mutexes and cond_variables needed per-task basis are ! -- initialized in Intialize_TCB and the Storage_Error is handled. -- Other mutexes (such as RTS_Lock, Memory_Lock...) used in -- the RTS is initialized before any status change of RTS. -- Therefore raising Storage_Error in the following routines *************** package body System.Task_Primitives.Oper *** 485,491 **** procedure Initialize_Lock (Prio : System.Any_Priority; ! L : access Lock) is begin InitializeCriticalSection (L.Mutex'Access); L.Owner_Priority := 0; --- 400,407 ---- procedure Initialize_Lock (Prio : System.Any_Priority; ! L : access Lock) ! is begin InitializeCriticalSection (L.Mutex'Access); L.Owner_Priority := 0; *************** package body System.Task_Primitives.Oper *** 493,498 **** --- 409,416 ---- end Initialize_Lock; procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Unreferenced (Level); + begin InitializeCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); end Initialize_Lock; *************** package body System.Task_Primitives.Oper *** 530,536 **** end Write_Lock; procedure Write_Lock ! (L : access RTS_Lock; Global_Lock : Boolean := False) is begin if not Single_Lock or else Global_Lock then EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); --- 448,456 ---- end Write_Lock; procedure Write_Lock ! (L : access RTS_Lock; ! Global_Lock : Boolean := False) ! is begin if not Single_Lock or else Global_Lock then EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); *************** package body System.Task_Primitives.Oper *** 584,590 **** procedure Sleep (Self_ID : Task_ID; ! Reason : System.Tasking.Task_States) is begin pragma Assert (Self_ID = Self); --- 504,513 ---- procedure Sleep (Self_ID : Task_ID; ! Reason : System.Tasking.Task_States) ! is ! pragma Unreferenced (Reason); ! begin pragma Assert (Self_ID = Self); *************** package body System.Task_Primitives.Oper *** 618,624 **** Timedout : out Boolean; Yielded : out Boolean) is ! Check_Time : constant Duration := Monotonic_Clock; Rel_Time : Duration; Abs_Time : Duration; Result : Integer; --- 541,548 ---- Timedout : out Boolean; Yielded : out Boolean) is ! pragma Unreferenced (Reason); ! Check_Time : Duration := Monotonic_Clock; Rel_Time : Duration; Abs_Time : Duration; Result : Integer; *************** package body System.Task_Primitives.Oper *** 650,664 **** Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result); end if; ! exit when Abs_Time <= Monotonic_Clock; if not Local_Timedout then ! -- somebody may have called Wakeup for us Timedout := False; exit; end if; ! Rel_Time := Abs_Time - Monotonic_Clock; end loop; end if; end Timed_Sleep; --- 574,591 ---- Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result); end if; ! Check_Time := Monotonic_Clock; ! exit when Abs_Time <= Check_Time; if not Local_Timedout then ! ! -- Somebody may have called Wakeup for us ! Timedout := False; exit; end if; ! Rel_Time := Abs_Time - Check_Time; end loop; end if; end Timed_Sleep; *************** package body System.Task_Primitives.Oper *** 672,678 **** Time : Duration; Mode : ST.Delay_Modes) is ! Check_Time : constant Duration := Monotonic_Clock; Rel_Time : Duration; Abs_Time : Duration; Result : Integer; --- 599,605 ---- Time : Duration; Mode : ST.Delay_Modes) is ! Check_Time : Duration := Monotonic_Clock; Rel_Time : Duration; Abs_Time : Duration; Result : Integer; *************** package body System.Task_Primitives.Oper *** 719,727 **** Self_ID.Common.LL.L'Access, Rel_Time, Timedout, Result); end if; ! exit when Abs_Time <= Monotonic_Clock; ! Rel_Time := Abs_Time - Monotonic_Clock; end loop; Self_ID.Common.State := Runnable; --- 646,655 ---- Self_ID.Common.LL.L'Access, Rel_Time, Timedout, Result); end if; ! Check_Time := Monotonic_Clock; ! exit when Abs_Time <= Check_Time; ! Rel_Time := Abs_Time - Check_Time; end loop; Self_ID.Common.State := Runnable; *************** package body System.Task_Primitives.Oper *** 742,747 **** --- 670,677 ---- ------------ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + begin Cond_Signal (T.Common.LL.CV'Access); end Wakeup; *************** package body System.Task_Primitives.Oper *** 772,779 **** -- scheduling. procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is Res : BOOL; --- 702,709 ---- -- scheduling. procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is Res : BOOL; *************** package body System.Task_Primitives.Oper *** 784,803 **** (T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio))); pragma Assert (Res = True); - -- ??? Work around a bug in NT 4.0 SP3 scheduler - -- It looks like when a task with Thread_Priority_Idle (using RT class) - -- never reaches its time slice (e.g by doing multiple and simple RV, - -- see CXD8002), the scheduler never gives higher priority task a - -- chance to run. - -- Note that this works fine on NT 4.0 SP1 - - if Time_Slice_Val = 0 - and then Underlying_Priorities (Prio) = Thread_Priority_Idle - and then Loss_Of_Inheritance - then - Sleep (20); - end if; - if FIFO_Within_Priorities then -- Annex D requirement [RM D.2.2 par. 9]: --- 714,719 ---- *************** package body System.Task_Primitives.Oper *** 861,871 **** pragma Import (C, Init_Float, "__gnat_init_float"); -- Properly initializes the FPU for x86 systems. - Succeeded : BOOL; - begin ! Succeeded := TlsSetValue (TlsIndex, To_Address (Self_ID)); ! pragma Assert (Succeeded = True); Init_Float; Self_ID.Common.LL.Thread_Id := GetCurrentThreadId; --- 777,784 ---- pragma Import (C, Init_Float, "__gnat_init_float"); -- Properly initializes the FPU for x86 systems. begin ! Specific.Set (Self_ID); Init_Float; Self_ID.Common.LL.Thread_Id := GetCurrentThreadId; *************** package body System.Task_Primitives.Oper *** 892,903 **** --- 805,840 ---- 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 (GetCurrentThread); + end if; + end Register_Foreign_Thread; + -------------------- -- Initialize_TCB -- -------------------- procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is begin + -- Initialize thread ID to 0, this is needed to detect threads that + -- are not yet activated. + + Self_ID.Common.LL.Thread := 0; + Initialize_Cond (Self_ID.Common.LL.CV'Access); if not Single_Lock then *************** package body System.Task_Primitives.Oper *** 965,970 **** --- 902,915 ---- Set_Priority (T, Priority); + if Time_Slice_Val = 0 or else FIFO_Within_Priorities then + -- Here we need Annex E semantics so we disable the NT priority + -- boost. A priority boost is temporarily given by the system to a + -- thread when it is taken out of a wait state. + + SetThreadPriorityBoost (hTask, DisablePriorityBoost => True); + end if; + -- Step 4: Now, start it for good: Result := ResumeThread (hTask); *************** package body System.Task_Primitives.Oper *** 981,986 **** --- 926,932 ---- Self_ID : Task_ID := T; Result : DWORD; Succeeded : BOOL; + Is_Self : constant Boolean := T = Self; procedure Free is new Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); *************** package body System.Task_Primitives.Oper *** 996,1010 **** Known_Tasks (T.Known_Tasks_Index) := null; end if; ! -- Wait for the thread to terminate then close it. this is needed ! -- to release system ressources. ! Result := WaitForSingleObject (T.Common.LL.Thread, Wait_Infinite); ! pragma Assert (Result /= WAIT_FAILED); ! Succeeded := CloseHandle (T.Common.LL.Thread); ! pragma Assert (Succeeded = True); Free (Self_ID); end Finalize_TCB; --------------- --- 942,964 ---- Known_Tasks (T.Known_Tasks_Index) := null; end if; ! if Self_ID.Common.LL.Thread /= 0 then ! -- This task has been activated. Wait for the thread to terminate ! -- then close it. this is needed to release system ressources. ! ! Result := WaitForSingleObject (T.Common.LL.Thread, Wait_Infinite); ! pragma Assert (Result /= WAIT_FAILED); ! Succeeded := CloseHandle (T.Common.LL.Thread); ! pragma Assert (Succeeded = True); ! end if; Free (Self_ID); + + if Is_Self then + Succeeded := TlsSetValue (TlsIndex, System.Null_Address); + pragma Assert (Succeeded = True); + end if; end Finalize_TCB; --------------- *************** package body System.Task_Primitives.Oper *** 1013,1019 **** procedure Exit_Task is begin ! ExitThread (0); end Exit_Task; ---------------- --- 967,973 ---- procedure Exit_Task is begin ! Specific.Set (null); end Exit_Task; ---------------- *************** package body System.Task_Primitives.Oper *** 1021,1026 **** --- 975,981 ---- ---------------- procedure Abort_Task (T : Task_ID) is + pragma Unreferenced (T); begin null; end Abort_Task; *************** package body System.Task_Primitives.Oper *** 1057,1069 **** ---------------- procedure Initialize (Environment_Task : Task_ID) is ! Res : BOOL; begin Environment_Task_ID := Environment_Task; if Time_Slice_Val = 0 or else FIFO_Within_Priorities then ! Res := OS_Interface.SetPriorityClass ! (GetCurrentProcess, Realtime_Priority_Class); end if; TlsIndex := TlsAlloc; --- 1012,1037 ---- ---------------- procedure Initialize (Environment_Task : Task_ID) is ! Discard : BOOL; ! pragma Unreferenced (Discard); ! begin Environment_Task_ID := Environment_Task; if Time_Slice_Val = 0 or else FIFO_Within_Priorities then ! ! -- Here we need Annex E semantics, switch the current process to the ! -- High_Priority_Class. ! ! Discard := ! OS_Interface.SetPriorityClass ! (GetCurrentProcess, High_Priority_Class); ! ! -- ??? In theory it should be possible to use the priority class ! -- Realtime_Prioriry_Class but we suspect a bug in the NT scheduler ! -- which prevents (in some obscure cases) a thread to get on top of ! -- the running queue by another thread of lower priority. For ! -- example cxd8002 ACATS test freeze. end if; TlsIndex := TlsAlloc; *************** package body System.Task_Primitives.Oper *** 1074,1083 **** Environment_Task.Common.LL.Thread := GetCurrentThread; Enter_Task (Environment_Task); - - -- Create a free ATCB for use on the Fake_ATCB_List - - Next_Fake_ATCB := new Fake_ATCB; end Initialize; --------------------- --- 1042,1047 ---- *************** package body System.Task_Primitives.Oper *** 1104,1109 **** --- 1068,1075 ---- -- (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 *** 1113,1118 **** --- 1079,1086 ---- -------------------- 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 *** 1123,1129 **** function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin if T.Common.LL.Thread /= Thread_Self then return SuspendThread (T.Common.LL.Thread) = NO_ERROR; --- 1091,1099 ---- function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) ! return Boolean ! is begin if T.Common.LL.Thread /= Thread_Self then return SuspendThread (T.Common.LL.Thread) = NO_ERROR; *************** package body System.Task_Primitives.Oper *** 1138,1144 **** function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin if T.Common.LL.Thread /= Thread_Self then return ResumeThread (T.Common.LL.Thread) = NO_ERROR; --- 1108,1116 ---- function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) ! return Boolean ! is begin if T.Common.LL.Thread /= Thread_Self then return ResumeThread (T.Common.LL.Thread) = NO_ERROR; diff -Nrc3pad gcc-3.3.3/gcc/ada/5wtaspri.ads gcc-3.4.0/gcc/ada/5wtaspri.ads *** gcc-3.3.3/gcc/ada/5wtaspri.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5wtaspri.ads 2003-10-21 13:41:52.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-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. -- -- -- ------------------------------------------------------------------------------ *************** private *** 85,93 **** -- make sure is that they are updated in atomic fashion. Thread_Id : aliased System.OS_Interface.DWORD; ! -- 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. CV : aliased Condition_Variable; -- Condition Variable used to implement Sleep/Wakeup --- 84,91 ---- -- make sure is that they are updated in atomic fashion. Thread_Id : aliased System.OS_Interface.DWORD; ! -- The purpose of this field is to provide a better tasking support ! -- in gdb. CV : aliased Condition_Variable; -- Condition Variable used to implement Sleep/Wakeup diff -Nrc3pad gcc-3.3.3/gcc/ada/5xparame.ads gcc-3.4.0/gcc/ada/5xparame.ads *** gcc-3.3.3/gcc/ada/5xparame.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5xparame.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 0 **** --- 1,203 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- S Y S T E M . P A R A M E T E R S -- + -- -- + -- 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- -- + -- 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 OpenVMS version for restricted tasking. + + -- Blank line intentional so that it lines up exactly with default. + + -- This package defines some system dependent parameters for GNAT. These + -- are values that are referenced by the runtime library and are therefore + -- relevant to the target machine. + + -- The parameters whose value is defined in the spec are not generally + -- expected to be changed. If they are changed, it will be necessary to + -- recompile the run-time library. + + -- The parameters which are defined by functions can be changed by modifying + -- the body of System.Parameters in file s-parame.adb. A change to this body + -- requires only rebinding and relinking of the application. + + -- Note: do not introduce any pragma Inline statements into this unit, since + -- otherwise the relinking and rebinding capability would be deactivated. + + package System.Parameters is + pragma Pure (Parameters); + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Ratio is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Ratio : constant Ratio := Dynamic; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- 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 := True; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := 32; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this is not true + -- of all targets. For example, in OpenVMS long /= Long_Integer. + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are ommitted only for outer level onjects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- 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 -- + ---------------------- + + Single_Lock : constant Boolean := True; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := True; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + ---------------------- + -- Dynamic Priority -- + ---------------------- + + Dynamic_Priority_Support : constant Boolean := False; + -- This constant indicates whether dynamic changes of task priorities + -- are allowed (True means normal RM mode in which such changes are + -- allowed). In particular, if this is False, then we do not need to + -- poll for pending base priority changes at every abort completion + -- 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 -- + -------------------- + + Runtime_Traces : constant Boolean := False; + -- This constant indicates whether the runtime outputs traces to a + -- predefined output or not (True means that traces are output). + -- See System.Traces for more details. + + end System.Parameters; diff -Nrc3pad gcc-3.3.3/gcc/ada/5xsystem.ads gcc-3.4.0/gcc/ada/5xsystem.ads *** gcc-3.3.3/gcc/ada/5xsystem.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5xsystem.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 0 **** --- 1,236 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M -- + -- -- + -- S p e c -- + -- (OpenVMS GCC_ZCX DEC Threads Version) -- + -- -- + -- Copyright (C) 2002-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 := 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 := True; + 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 := False; + + -------------------------- + -- Underlying Priorities -- + --------------------------- + + -- Important note: this section of the file must come AFTER the + -- definition of the system implementation parameters to ensure + -- that the value of these parameters is available for analysis + -- of the declarations here (using Rtsfind at compile time). + + -- The underlying priorities table provides a generalized mechanism + -- for mapping from Ada priorities to system priorities. In some + -- cases a 1-1 mapping is not the convenient or optimal choice. + + -- For DEC Threads OpenVMS, we use the full range of 31 priorities + -- in the Ada model, but map them by compression onto the more limited + -- range of priorities available in OpenVMS. + + -- To replace the default values of the Underlying_Priorities mapping, + -- copy this source file into your build directory, edit the file to + -- reflect your desired behavior, and recompile with the command: + + -- $ gcc -c -O3 -gnatpgn system.ads + + -- then recompile the run-time parts that depend on this package: + + -- $ gnatmake -a -gnatn -O3 + + -- then force rebuilding your application if you need different options: + + -- $ gnatmake -f + + type Priorities_Mapping is array (Any_Priority) of Integer; + pragma Suppress_Initialization (Priorities_Mapping); + -- Suppress initialization in case gnat.adc specifies Normalize_Scalars + + Underlying_Priorities : constant Priorities_Mapping := + + (Priority'First => 16, + + 1 => 17, + 2 => 18, + 3 => 18, + 4 => 18, + 5 => 18, + 6 => 19, + 7 => 19, + 8 => 19, + 9 => 20, + 10 => 20, + 11 => 21, + 12 => 21, + 13 => 22, + 14 => 23, + + Default_Priority => 24, + + 16 => 25, + 17 => 25, + 18 => 25, + 19 => 26, + 20 => 26, + 21 => 26, + 22 => 27, + 23 => 27, + 24 => 27, + 25 => 28, + 26 => 28, + 27 => 29, + 28 => 29, + 29 => 30, + + Priority'Last => 30, + + Interrupt_Priority => 31); + + ---------------------------- + -- Special VMS Interfaces -- + ---------------------------- + + procedure Lib_Stop (I : in Integer); + pragma Interface (C, Lib_Stop); + pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); + -- Interface to VMS condition handling. Used by RTSfind and pragma + -- {Import,Export}_Exception. Put here because this is the only + -- VMS specific package that doesn't drag in tasking. + + end System; diff -Nrc3pad gcc-3.3.3/gcc/ada/5xvxwork.ads gcc-3.4.0/gcc/ada/5xvxwork.ads *** gcc-3.3.3/gcc/ada/5xvxwork.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5xvxwork.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 0 **** --- 1,54 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . V X W O R K S -- + -- -- + -- 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- -- + -- 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 Xscale VxWorks version of this package. + + package System.VxWorks is + pragma Preelaborate (System.VxWorks); + + -- Floating point context record. Xscale version + + -- There is no floating point unit on Xscale. The record definition + -- below matches what arch/arm/fppArmLib.h says. + + type FP_CONTEXT is record + Dummy : Integer; + end record; + + for FP_CONTEXT'Alignment use 4; + pragma Convention (C, FP_CONTEXT); + + Num_HW_Interrupts : constant := 256; + -- Number of entries in hardware interrupt vector table. + + end System.VxWorks; diff -Nrc3pad gcc-3.3.3/gcc/ada/5yparame.ads gcc-3.4.0/gcc/ada/5yparame.ads *** gcc-3.3.3/gcc/ada/5yparame.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5yparame.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 0 **** --- 1,203 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- S Y S T E M . P A R A M E T E R S -- + -- -- + -- 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- -- + -- 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 default VxWorks AE 653 version of the package.` + + -- This package defines some system dependent parameters for GNAT. These + -- are values that are referenced by the runtime library and are therefore + -- relevant to the target machine. + + -- The parameters whose value is defined in the spec are not generally + -- expected to be changed. If they are changed, it will be necessary to + -- recompile the run-time library. + + -- The parameters which are defined by functions can be changed by modifying + -- the body of System.Parameters in file s-parame.adb. A change to this body + -- requires only rebinding and relinking of the application. + + -- Note: do not introduce any pragma Inline statements into this unit, since + -- otherwise the relinking and rebinding capability would be deactivated. + + package System.Parameters is + pragma Pure (Parameters); + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Ratio is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Ratio : constant Ratio := 50; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Default_Env_Stack_Size : constant Size_Type := 14_336; + -- 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. + -- This value is chosen as the VxWorks default stack size is 20kB, + -- and a little more than 4kB is necessary for the run time. + + Stack_Grows_Down : constant Boolean := True; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := Long_Integer'Size; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this is not true + -- of all targets. For example, in OpenVMS long /= Long_Integer. + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are ommitted only for outer level onjects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- 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 -- + ---------------------- + + Single_Lock : constant Boolean := False; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := False; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + ---------------------- + -- Dynamic Priority -- + ---------------------- + + Dynamic_Priority_Support : constant Boolean := True; + -- This constant indicates whether dynamic changes of task priorities + -- are allowed (True means normal RM mode in which such changes are + -- allowed). In particular, if this is False, then we do not need to + -- poll for pending base priority changes at every abort completion + -- 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 -- + -------------------- + + Runtime_Traces : constant Boolean := False; + -- This constant indicates whether the runtime outputs traces to a + -- predefined output or not (True means that traces are output). + -- See System.Traces for more details. + + end System.Parameters; diff -Nrc3pad gcc-3.3.3/gcc/ada/5ysystem.ads gcc-3.4.0/gcc/ada/5ysystem.ads *** gcc-3.3.3/gcc/ada/5ysystem.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5ysystem.ads 2003-10-21 13:41:52.000000000 +0000 *************** *** 5,14 **** -- S Y S T E M -- -- -- -- S p e c -- ! -- (VXWORKS Version PPC) -- ! -- -- -- -- ! -- 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 -- ! -- (VxWorks 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 -- *************** 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 := True; 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 := 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/5zinit.adb gcc-3.4.0/gcc/ada/5zinit.adb *** gcc-3.3.3/gcc/ada/5zinit.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5zinit.adb 2004-01-05 15:20:43.000000000 +0000 *************** *** 0 **** --- 1,319 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . I N I T -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2003-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- -- + -- 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 Level A cert version of this package for AE653 + + with Interfaces.C; + -- Used for int and other types + + with Ada.Exceptions; + -- Used for Raise_Exception + + package body System.Init is + + use Ada.Exceptions; + use Interfaces.C; + + -------------------------- + -- Signal Definitions -- + -------------------------- + + NSIG : constant := 32; + -- Number of signals on the target OS + + type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1); + + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGFPE : constant := 8; -- floating point exception + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + + type sigset_t is new long; + + SIG_SETMASK : constant := 3; + SA_ONSTACK : constant := 16#0004#; + + 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; + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + 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"); + + ------------------------------- + -- Binder Generated Values -- + ------------------------------- + + Gl_Main_Priority : Integer := -1; + pragma Export (C, Gl_Main_Priority, "__gl_main_priority"); + + Gl_Time_Slice_Val : Integer := -1; + pragma Export (C, Gl_Time_Slice_Val, "__gl_time_slice_val"); + + Gl_Wc_Encoding : Character := 'n'; + pragma Export (C, Gl_Wc_Encoding, "__gl_wc_encoding"); + + Gl_Locking_Policy : Character := ' '; + pragma Export (C, Gl_Locking_Policy, "__gl_locking_policy"); + + Gl_Queuing_Policy : Character := ' '; + pragma Export (C, Gl_Queuing_Policy, "__gl_queuing_policy"); + + Gl_Task_Dispatching_Policy : Character := ' '; + pragma Export (C, Gl_Task_Dispatching_Policy, + "__gl_task_dispatching_policy"); + + Gl_Restrictions : Address := Null_Address; + pragma Export (C, Gl_Restrictions, "__gl_restrictions"); + + Gl_Interrupt_States : Address := Null_Address; + pragma Export (C, Gl_Interrupt_States, "__gl_interrupt_states"); + + Gl_Num_Interrupt_States : Integer := 0; + pragma Export (C, Gl_Num_Interrupt_States, "__gl_num_interrupt_states"); + + Gl_Unreserve_All_Interrupts : Integer := 0; + pragma Export (C, Gl_Unreserve_All_Interrupts, + "__gl_unreserve_all_interrupts"); + + Gl_Exception_Tracebacks : Integer := 0; + pragma Export (C, Gl_Exception_Tracebacks, "__gl_exception_tracebacks"); + + Gl_Zero_Cost_Exceptions : Integer := 0; + pragma Export (C, Gl_Zero_Cost_Exceptions, "__gl_zero_cost_exceptions"); + + Already_Called : Boolean := False; + + Handler_Installed : Integer := 0; + pragma Export (C, Handler_Installed, "__gnat_handler_installed"); + -- Indication of whether synchronous signal handlers have already been + -- installed by a previous call to Install_Handler. + + ------------------------ + -- Local procedures -- + ------------------------ + + procedure GNAT_Error_Handler (Sig : Signal); + -- Common procedure that is executed when a SIGFPE, SIGILL, + -- SIGSEGV, or SIGBUS is captured. + + ------------------------ + -- GNAT_Error_Handler -- + ------------------------ + + procedure GNAT_Error_Handler (Sig : Signal) is + Mask : aliased sigset_t; + + Result : int; + pragma Unreferenced (Result); + + begin + -- VxWorks will always mask out the signal during the signal + -- handler and will reenable it on a longjmp. GNAT does not + -- generate a longjmp to return from a signal handler so the + -- signal will still be masked unless we unmask it. + + Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access); + Result := sigdelset (Mask'Access, Sig); + Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null); + + case Sig is + when SIGFPE => + Raise_Exception (Constraint_Error'Identity, "SIGFPE"); + when SIGILL => + Raise_Exception (Constraint_Error'Identity, "SIGILL"); + when SIGSEGV => + Raise_Exception + (Program_Error'Identity, + "erroneous memory access"); + when SIGBUS => + Raise_Exception + (Storage_Error'Identity, + "stack overflow or SIGBUS"); + when others => + Raise_Exception (Program_Error'Identity, "unhandled signal"); + end case; + end GNAT_Error_Handler; + + ----------------- + -- Set_Globals -- + ----------------- + + -- This routine is called from the binder generated main program. It + -- copies the values for global quantities computed by the binder + -- into the following global locations. The reason that we go through + -- this copy, rather than just define the global locations in the + -- binder generated file, is that they are referenced from the + -- runtime, which may be in a shared library, and the binder file is + -- not in the shared library. Global references across library + -- boundaries like this are not handled correctly in all systems. + + procedure Set_Globals + (Main_Priority : Integer; + Time_Slice_Value : Integer; + WC_Encoding : Character; + Locking_Policy : Character; + Queuing_Policy : Character; + Task_Dispatching_Policy : Character; + Restrictions : System.Address; + Interrupt_States : System.Address; + Num_Interrupt_States : Integer; + Unreserve_All_Interrupts : Integer; + Exception_Tracebacks : Integer; + Zero_Cost_Exceptions : Integer) + is + begin + -- If this procedure has been already called once, check that the + -- arguments in this call are consistent with the ones in the + -- previous calls. Otherwise, raise a Program_Error exception. + + -- We do not check for consistency of the wide character encoding + -- method. This default affects only Wide_Text_IO where no + -- explicit coding method is given, and there is no particular + -- reason to let this default be affected by the source + -- representation of a library in any case. + + -- We do not check either for the consistency of exception tracebacks, + -- because exception tracebacks are not normally set in Stand-Alone + -- libraries. If a library or the main program set the exception + -- tracebacks, then they are never reset afterwards (see below). + + -- The value of main_priority is meaningful only when we are + -- invoked from the main program elaboration routine of an Ada + -- application. Checking the consistency of this parameter should + -- therefore not be done. Since it is assured that the main + -- program elaboration will always invoke this procedure before + -- any library elaboration routine, only the value of + -- main_priority during the first call should be taken into + -- account and all the subsequent ones should be ignored. Note + -- that the case where the main program is not written in Ada is + -- also properly handled, since the default value will then be + -- used for this parameter. + + -- For identical reasons, the consistency of time_slice_val should + -- not be checked. + + if Already_Called then + if (Gl_Locking_Policy /= Locking_Policy) or else + (Gl_Queuing_Policy /= Queuing_Policy) or else + (Gl_Task_Dispatching_Policy /= Task_Dispatching_Policy) or else + (Gl_Unreserve_All_Interrupts /= Unreserve_All_Interrupts) or else + (Gl_Exception_Tracebacks /= Exception_Tracebacks) or else + (Gl_Zero_Cost_Exceptions /= Zero_Cost_Exceptions) + then + raise Program_Error; + end if; + + -- If either a library or the main program set the exception + -- traceback flag, it is never reset later. + + if Gl_Exception_Tracebacks /= 0 then + Gl_Exception_Tracebacks := Exception_Tracebacks; + end if; + + else + Already_Called := True; + + Gl_Main_Priority := Main_Priority; + Gl_Time_Slice_Val := Time_Slice_Value; + Gl_Wc_Encoding := WC_Encoding; + Gl_Locking_Policy := Locking_Policy; + Gl_Queuing_Policy := Queuing_Policy; + Gl_Task_Dispatching_Policy := Task_Dispatching_Policy; + Gl_Restrictions := Restrictions; + Gl_Interrupt_States := Interrupt_States; + Gl_Num_Interrupt_States := Num_Interrupt_States; + Gl_Unreserve_All_Interrupts := Unreserve_All_Interrupts; + Gl_Exception_Tracebacks := Exception_Tracebacks; + Gl_Zero_Cost_Exceptions := Zero_Cost_Exceptions; + end if; + end Set_Globals; + + --------------------- + -- Install_Handler -- + --------------------- + + procedure Install_Handler is + Mask : aliased sigset_t; + Signal_Action : aliased struct_sigaction; + + Result : Interfaces.C.int; + pragma Unreferenced (Result); + + begin + -- Set up signal handler to map synchronous signals to appropriate + -- exceptions. Make sure that the handler isn't interrupted by + -- another signal that might cause a scheduling event! + + Signal_Action.sa_handler := GNAT_Error_Handler'Address; + Signal_Action.sa_flags := SA_ONSTACK; + Result := sigemptyset (Mask'Access); + Signal_Action.sa_mask := Mask; + + Result := sigaction + (Signal (SIGFPE), Signal_Action'Unchecked_Access, null); + + Result := sigaction + (Signal (SIGILL), Signal_Action'Unchecked_Access, null); + + Result := sigaction + (Signal (SIGSEGV), Signal_Action'Unchecked_Access, null); + + Result := sigaction + (Signal (SIGBUS), Signal_Action'Unchecked_Access, null); + + Handler_Installed := 1; + end Install_Handler; + + end System.Init; diff -Nrc3pad gcc-3.3.3/gcc/ada/5zinterr.adb gcc-3.4.0/gcc/ada/5zinterr.adb *** gcc-3.3.3/gcc/ada/5zinterr.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5zinterr.adb 2004-01-05 15:20:43.000000000 +0000 *************** *** 6,13 **** -- -- -- 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- -- --- 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- -- *************** *** 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. -- -- -- ------------------------------------------------------------------------------ *************** with Ada.Task_Identification; *** 78,83 **** --- 77,85 ---- with Ada.Exceptions; -- used for Raise_Exception + with System.Interrupt_Management; + -- used for Reserve + with System.Task_Primitives.Operations; -- used for Write_Lock -- Unlock *************** package body System.Interrupts is *** 110,116 **** use Tasking; use Ada.Exceptions; - package PRI renames System.Task_Primitives; package POP renames System.Task_Primitives.Operations; function To_Ada is new Unchecked_Conversion --- 112,117 ---- *************** package body System.Interrupts is *** 421,432 **** -------------------------------- -- Restore default handlers for interrupt servers. -- This is called by the Interrupt_Manager task when it receives the abort -- signal during program finalization. procedure Finalize_Interrupt_Servers is begin ! if HW_Interrupt'Last >= 0 then for Int in HW_Interrupt loop if Server_ID (Interrupt_ID (Int)) /= null and then --- 422,436 ---- -------------------------------- -- Restore default handlers for interrupt servers. + -- This is called by the Interrupt_Manager task when it receives the abort -- signal during program finalization. procedure Finalize_Interrupt_Servers is + HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0; + begin ! if HW_Interrupts then for Int in HW_Interrupt loop if Server_ID (Interrupt_ID (Int)) /= null and then *************** package body System.Interrupts is *** 448,460 **** ------------------------------------- function Has_Interrupt_Or_Attach_Handler ! (Object : access Dynamic_Interrupt_Protection) return Boolean is begin return True; end Has_Interrupt_Or_Attach_Handler; function Has_Interrupt_Or_Attach_Handler ! (Object : access Static_Interrupt_Protection) return Boolean is begin return True; end Has_Interrupt_Or_Attach_Handler; --- 452,472 ---- ------------------------------------- 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; 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 *** 518,528 **** is use Interfaces.VxWorks; ! Vec : constant Interrupt_Vector := ! INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt)); Old_Handler : constant VOIDFUNCPTR := ! intVecGet (INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt))); Stat : Interfaces.VxWorks.STATUS; begin -- Only install umbrella handler when no Ada handler has already been --- 530,545 ---- is use Interfaces.VxWorks; ! Vec : constant Interrupt_Vector := ! INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt)); ! Old_Handler : constant VOIDFUNCPTR := ! intVecGet ! (INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt))); ! Stat : Interfaces.VxWorks.STATUS; + pragma Unreferenced (Stat); + -- ??? shouldn't we test Stat at least in a pragma Assert? begin -- Only install umbrella handler when no Ada handler has already been *************** package body System.Interrupts is *** 532,538 **** if Default_Handler (Interrupt) = null then Stat := ! intConnect (Vec, VOIDFUNCPTR (Handler), System.Address (Interrupt)); Default_Handler (Interrupt) := Old_Handler; end if; end Install_Umbrella_Handler; --- 549,555 ---- if Default_Handler (Interrupt) = null then Stat := ! intConnect (Vec, Handler, System.Address (Interrupt)); Default_Handler (Interrupt) := Old_Handler; end if; end Install_Umbrella_Handler; *************** package body System.Interrupts is *** 602,608 **** Ptr := Registered_Handler_Head; ! while (Ptr /= null) loop if Ptr.H = Fat.Handler_Addr then return True; end if; --- 619,625 ---- Ptr := Registered_Handler_Head; ! while Ptr /= null loop if Ptr.H = Fat.Handler_Addr then return True; end if; *************** package body System.Interrupts is *** 618,625 **** ----------------- function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is begin ! return False; end Is_Reserved; ---------------------- --- 635,643 ---- ----------------- function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is + use System.Interrupt_Management; begin ! return Reserve (System.Interrupt_Management.Interrupt_ID (Interrupt)); end Is_Reserved; ---------------------- *************** package body System.Interrupts is *** 643,650 **** -- server task deletes its semaphore and terminates. procedure Notify_Interrupt (Param : System.Address) is ! Interrupt : Interrupt_ID := Interrupt_ID (Param); Discard_Result : STATUS; begin Discard_Result := semGive (Semaphore_ID_Map (Interrupt)); --- 661,670 ---- -- server task deletes its semaphore and terminates. procedure Notify_Interrupt (Param : System.Address) is ! Interrupt : constant Interrupt_ID := Interrupt_ID (Param); ! Discard_Result : STATUS; + pragma Unreferenced (Discard_Result); begin Discard_Result := semGive (Semaphore_ID_Map (Interrupt)); *************** package body System.Interrupts is *** 738,748 **** ----------------------- task body Interrupt_Manager is - --------------------- - -- Local Variables -- - --------------------- - - Self_Id : constant Task_ID := POP.Self; -------------------- -- Local Routines -- --- 758,763 ---- *************** package body System.Interrupts is *** 992,998 **** "A binding for this interrupt is already present"); end if; ! User_Entry (Interrupt) := Entry_Assoc' (T => T, E => E); -- Indicate the attachment of interrupt entry in the ATCB. -- This is needed so when an interrupt entry task terminates --- 1007,1013 ---- "A binding for this interrupt is already present"); end if; ! User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E); -- Indicate the attachment of interrupt entry in the ATCB. -- This is needed so when an interrupt entry task terminates *************** package body System.Interrupts is *** 1023,1030 **** for Int in Interrupt_ID'Range loop if not Is_Reserved (Int) then if User_Entry (Int).T = T then ! User_Entry (Int) := Entry_Assoc' ! (T => Null_Task, E => Null_Task_Entry); Unbind_Handler (Int); end if; end if; --- 1038,1046 ---- for Int in Interrupt_ID'Range loop if not Is_Reserved (Int) then if User_Entry (Int).T = T then ! User_Entry (Int) := ! Entry_Assoc' ! (T => Null_Task, E => Null_Task_Entry); Unbind_Handler (Int); end if; end if; diff -Nrc3pad gcc-3.3.3/gcc/ada/5zintman.adb gcc-3.4.0/gcc/ada/5zintman.adb *** gcc-3.3.3/gcc/ada/5zintman.adb 2002-10-23 08:27:55.000000000 +0000 --- gcc-3.4.0/gcc/ada/5zintman.adb 2004-01-05 15:20:43.000000000 +0000 *************** *** 6,13 **** -- -- -- 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- -- --- 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.Interrupt_Management *** 59,85 **** use System.OS_Interface; use type Interfaces.C.int; ! type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID; ! Exception_Interrupts : constant Interrupt_List (1 .. 4) := ! (SIGFPE, SIGILL, SIGSEGV, SIGBUS); ! -- Keep these variables global so that they are initialized only once. Exception_Action : aliased struct_sigaction; ! ---------------------- ! -- Notify_Exception -- ! ---------------------- procedure Notify_Exception (signo : Signal); -- Identify the Ada exception to be raised using -- the information when the system received a synchronous signal. procedure Notify_Exception (signo : Signal) is Mask : aliased sigset_t; - Result : int; My_Id : t_id; begin Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access); Result := sigdelset (Mask'Access, signo); --- 58,96 ---- use System.OS_Interface; use type Interfaces.C.int; ! type Signal_List is array (Signal_ID range <>) of Signal_ID; ! Exception_Signals : constant Signal_List (1 .. 4) := ! (SIGFPE, SIGILL, SIGSEGV, SIGBUS); ! -- Keep these variables global so that they are initialized only once ! -- What are "these variables" ???, I see only one Exception_Action : aliased struct_sigaction; ! procedure Map_And_Raise_Exception (signo : Signal); ! pragma Import (C, Map_And_Raise_Exception, "__gnat_map_signal"); ! -- Map signal to Ada exception and raise it. Different versions ! -- of VxWorks need different mappings. ! ! ----------------------- ! -- Local Subprograms -- ! ----------------------- procedure Notify_Exception (signo : Signal); -- Identify the Ada exception to be raised using -- the information when the system received a synchronous signal. + ---------------------- + -- Notify_Exception -- + ---------------------- + procedure Notify_Exception (signo : Signal) is Mask : aliased sigset_t; My_Id : t_id; + Result : int; + pragma Unreferenced (Result); + begin Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access); Result := sigdelset (Mask'Access, signo); *************** package body System.Interrupt_Management *** 88,112 **** -- VxWorks will suspend the task when it gets a hardware -- exception. We take the liberty of resuming the task -- for the application. My_Id := taskIdSelf; if taskIsSuspended (My_Id) /= 0 then Result := taskResume (My_Id); end if; ! case signo is ! when SIGFPE => ! raise Constraint_Error; ! when SIGILL => ! raise Constraint_Error; ! when SIGSEGV => ! raise Program_Error; ! when SIGBUS => ! raise Program_Error; ! when others => ! -- Unexpected signal ! raise Program_Error; ! end case; end Notify_Exception; --------------------------- --- 99,112 ---- -- VxWorks will suspend the task when it gets a hardware -- exception. We take the liberty of resuming the task -- for the application. + My_Id := taskIdSelf; if taskIsSuspended (My_Id) /= 0 then Result := taskResume (My_Id); end if; ! Map_And_Raise_Exception (signo); end Notify_Exception; --------------------------- *************** package body System.Interrupt_Management *** 121,130 **** old_act : aliased struct_sigaction; begin ! for J in Exception_Interrupts'Range loop Result := sigaction ! (Signal (Exception_Interrupts (J)), Exception_Action'Access, old_act'Unchecked_Access); pragma Assert (Result = 0); end loop; --- 121,130 ---- old_act : aliased struct_sigaction; begin ! for J in Exception_Signals'Range loop Result := sigaction ! (Signal (Exception_Signals (J)), Exception_Action'Access, old_act'Unchecked_Access); pragma Assert (Result = 0); end loop; *************** begin *** 134,154 **** declare mask : aliased sigset_t; Result : int; begin ! Abort_Task_Interrupt := SIGABRT; -- Change this if you want to use another signal for task abort. -- SIGTERM might be a good one. Exception_Action.sa_handler := Notify_Exception'Address; Exception_Action.sa_flags := SA_ONSTACK; Result := sigemptyset (mask'Access); pragma Assert (Result = 0); ! for J in Exception_Interrupts'Range loop ! Result := sigaddset (mask'Access, Signal (Exception_Interrupts (J))); pragma Assert (Result = 0); end loop; Exception_Action.sa_mask := mask; end; end System.Interrupt_Management; --- 134,194 ---- declare mask : aliased sigset_t; Result : int; + + 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: + + 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 ! -- Initialize signal handling ! -- Change this if you want to use another signal for task abort. -- SIGTERM might be a good one. + Abort_Task_Signal := SIGABRT; + Exception_Action.sa_handler := Notify_Exception'Address; Exception_Action.sa_flags := SA_ONSTACK; Result := sigemptyset (mask'Access); pragma Assert (Result = 0); ! for J in Exception_Signals'Range loop ! Result := sigaddset (mask'Access, Signal (Exception_Signals (J))); pragma Assert (Result = 0); end loop; Exception_Action.sa_mask := mask; + + -- Initialize hardware interrupt handling + + pragma Assert (Reserve = (Interrupt_ID'Range => False)); + + -- Check all interrupts for state that requires keeping them reserved + + for J in Interrupt_ID'Range loop + if State (J) = Default or else State (J) = Runtime then + Reserve (J) := True; + end if; + end loop; + + -- Add exception signals to the set of unmasked signals + + for J in Exception_Signals'Range loop + Keep_Unmasked (Exception_Signals (J)) := True; + end loop; + + -- The abort signal must also be unmasked + + Keep_Unmasked (Abort_Task_Signal) := True; end; end System.Interrupt_Management; diff -Nrc3pad gcc-3.3.3/gcc/ada/5zintman.ads gcc-3.4.0/gcc/ada/5zintman.ads *** gcc-3.3.3/gcc/ada/5zintman.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5zintman.ads 2003-11-24 14:27:57.000000000 +0000 *************** *** 0 **** --- 1,123 ---- + ------------------------------------------------------------------------------ + -- -- + -- 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 -- + -- -- + -- 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- -- + -- 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 VxWorks version of this package. + + -- This package encapsulates and centralizes information about all + -- uses of interrupts (or signals), including the target-dependent + -- mapping of interrupts (or signals) to exceptions. + + -- Unlike the original design, System.Interrupt_Management can only + -- be used for tasking systems. + + -- PLEASE DO NOT remove the Elaborate_Body pragma from this package. + -- Elaboration of this package should happen early, as most other + -- initializations depend on it. Forcing immediate elaboration of + -- the body also helps to enforce the design assumption that this + -- is a second-level package, just one level above System.OS_Interface + -- with no cross-dependencies. + + -- PLEASE DO NOT put any subprogram declarations with arguments of + -- type Interrupt_ID into the visible part of this package. The type + -- Interrupt_ID is used to derive the type in Ada.Interrupts, and + -- adding more operations to that type would be illegal according + -- to the Ada Reference Manual. This is the reason why the signals + -- sets are implemeneted using visible arrays rather than functions. + + with System.OS_Interface; + -- used for sigset_t + + with Interfaces.C; + -- used for int + + package System.Interrupt_Management is + + pragma Elaborate_Body; + + type Interrupt_Mask is limited private; + + type Interrupt_ID is new Interfaces.C.int + range 0 .. System.OS_Interface.Max_Interrupt; + + type Interrupt_Set is array (Interrupt_ID) of Boolean; + + subtype Signal_ID is Interrupt_ID + range 0 .. Interfaces.C."-" (System.OS_Interface.NSIG, 1); + + type Signal_Set is array (Signal_ID) of Boolean; + + -- The following objects serve as constants, but are initialized + -- in the body to aid portability. This permits us to use more + -- portable names for interrupts, where distinct names may map to + -- the same interrupt ID value. + -- + -- For example, suppose SIGRARE is a signal that is not defined on + -- all systems, but is always reserved when it is defined. If we + -- have the convention that ID zero is not used for any "real" + -- signals, and SIGRARE = 0 when SIGRARE is not one of the locally + -- supported signals, we can write + -- Reserved (SIGRARE) := true; + -- and the initialization code will be portable. + + Abort_Task_Signal : Signal_ID; + -- The signal that is used to implement task abortion if + -- an interrupt is used for that purpose. This is one of the + -- reserved signals. + + Keep_Unmasked : Signal_Set := (others => False); + -- Keep_Unmasked (I) is true iff the signal I is one that must + -- that must be kept unmasked at all times, except (perhaps) for + -- short critical sections. This includes signals that are + -- mapped to exceptions, but may also include interrupts + -- (e.g. timer) that need to be kept unmasked for other + -- reasons. Where signal masking is per-task, the signal should be + -- unmasked in ALL TASKS. + + Reserve : Interrupt_Set := (others => False); + -- Reserve (I) is true iff the interrupt I is one that cannot be + -- permitted to be attached to a user handler. The possible reasons + -- are many. For example, it may be mapped to an exception used to + -- implement task abortion, or used to implement time delays. + + procedure Initialize_Interrupts; + -- On systems where there is no signal inheritance between tasks (e.g + -- VxWorks, GNU/LinuxThreads), this procedure is used to initialize + -- interrupts handling in each task. Otherwise this function should + -- only be called by initialize in this package body. + + private + type Interrupt_Mask is new System.OS_Interface.sigset_t; + -- In some implementation Interrupt_Mask can be represented + -- as a linked list. + + end System.Interrupt_Management; diff -Nrc3pad gcc-3.3.3/gcc/ada/5zml-tgt.adb gcc-3.4.0/gcc/ada/5zml-tgt.adb *** gcc-3.3.3/gcc/ada/5zml-tgt.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5zml-tgt.adb 2004-01-05 15:20:43.000000000 +0000 *************** *** 0 **** --- 1,326 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- M L I B . T G T -- + -- (VxWorks Version) -- + -- -- + -- 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. -- + -- -- + -- 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 libraries. + + -- This is the VxWorks version of the body + + with MLib.Fil; + with Namet; use Namet; + with Prj.Com; + with Sdefault; + + package body MLib.Tgt is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Get_Target_Suffix return String; + -- Returns the required suffix for some utilities + -- (such as ar and ranlib) that depend on the real target. + + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return "ar" & Get_Target_Suffix; + 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" & Get_Target_Suffix; + 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 (Ofiles); + pragma Unreferenced (Foreign); + pragma Unreferenced (Afiles); + pragma Unreferenced (Options); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Lib_Filename); + pragma Unreferenced (Lib_Dir); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Driver_Name); + pragma Unreferenced (Lib_Address); + pragma Unreferenced (Lib_Version); + pragma Unreferenced (Relocatable); + pragma Unreferenced (Auto_Init); + + begin + null; + 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 ""; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return ""; + end Dynamic_Option; + + ----------------------------- + -- Get_Target_Suffix -- + ----------------------------- + + function Get_Target_Suffix return String is + Target_Name : constant String_Ptr := Sdefault.Target_Name; + Index : Positive := Target_Name'First; + + begin + while Index < Target_Name'Last + and then Target_Name (Index + 1) /= '-' + loop + Index := Index + 1; + end loop; + + if Target_Name (Target_Name'First .. Index) = "m68k" then + return "68k"; + elsif Target_Name (Target_Name'First .. Index) = "mips" then + return "mips"; + elsif Target_Name (Target_Name'First .. Index) = "powerpc" then + return "ppc"; + elsif Target_Name (Target_Name'First .. Index) = "sparc" then + return "sparc"; + elsif Target_Name (Target_Name'First .. Index) = "sparc64" then + return "sparc64"; + elsif Target_Name (Target_Name'First .. Index) = "xscale" then + return "arm"; + else + return ""; + end if; + end Get_Target_Suffix; + + ------------------- + -- 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; -- To avoid warning; + + 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,-R,"); + 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 False; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Static_Only; + end Support_For_Libraries; + + end MLib.Tgt; diff -Nrc3pad gcc-3.3.3/gcc/ada/5zosinte.adb gcc-3.4.0/gcc/ada/5zosinte.adb *** gcc-3.3.3/gcc/ada/5zosinte.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5zosinte.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1997-2002 Free Software Foundation -- -- -- -- 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 body System.OS_Interface is *** 101,108 **** F := F + 1.0; end if; ! return timespec' (ts_sec => S, ! ts_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; ------------------------- --- 100,107 ---- F := F + 1.0; end if; ! return timespec'(ts_sec => S, ! ts_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; ------------------------- diff -Nrc3pad gcc-3.3.3/gcc/ada/5zosinte.ads gcc-3.4.0/gcc/ada/5zosinte.ads *** gcc-3.3.3/gcc/ada/5zosinte.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5zosinte.ads 2003-10-21 13:41:52.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-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 *** 215,220 **** --- 214,228 ---- -- VxWorks specific API -- -------------------------- + subtype STATUS is int; + -- Equivalent of the C type STATUS + + OK : constant STATUS := 0; + ERROR : constant STATUS := Interfaces.C.int (-1); + + function taskIdVerify (tid : t_id) return STATUS; + pragma Import (C, taskIdVerify, "taskIdVerify"); + function taskIdSelf return t_id; pragma Import (C, taskIdSelf, "taskIdSelf"); *************** package System.OS_Interface is *** 228,234 **** pragma Import (C, taskIsSuspended, "taskIsSuspended"); function taskVarAdd ! (tid : t_id; pVar : System.Address) return int; pragma Import (C, taskVarAdd, "taskVarAdd"); function taskVarDelete --- 236,242 ---- pragma Import (C, taskIsSuspended, "taskIsSuspended"); function taskVarAdd ! (tid : t_id; pVar : access System.Address) return int; pragma Import (C, taskVarAdd, "taskVarAdd"); function taskVarDelete *************** package System.OS_Interface is *** 288,299 **** (tid : t_id; newPriority : int) return int; pragma Import (C, taskPrioritySet, "taskPrioritySet"); - subtype STATUS is int; - -- Equivalent of the C type STATUS - - OK : constant STATUS := 0; - ERROR : constant STATUS := Interfaces.C.int (-1); - -- Semaphore creation flags. SEM_Q_FIFO : constant := 0; --- 296,301 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/5zosprim.adb gcc-3.4.0/gcc/ada/5zosprim.adb *** gcc-3.3.3/gcc/ada/5zosprim.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5zosprim.adb 2003-10-21 13:41:52.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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 ---- -- -- -- 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- -- *************** *** 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. -- -- -- ------------------------------------------------------------------------------ *************** with Interfaces.C; *** 46,51 **** --- 45,51 ---- package body System.OS_Primitives is use System.OS_Interface; + use type Interfaces.C.int; -------------------------- -- Internal functions -- *************** package body System.OS_Primitives is *** 60,66 **** --- 60,71 ---- Ticks : Long_Long_Integer; Rate_Duration : Duration; Ticks_Duration : Duration; + begin + if D < 0.0 then + return -1; + end if; + -- Ensure that the duration can be converted to ticks -- at the current clock tick rate without overflowing. *************** package body System.OS_Primitives is *** 69,76 **** if D > (Duration'Last / Rate_Duration) then Ticks := Long_Long_Integer (int'Last); else - -- We always want to round up to the nearest clock tick. - Ticks_Duration := D * Rate_Duration; Ticks := Long_Long_Integer (Ticks_Duration); --- 74,79 ---- *************** package body System.OS_Primitives is *** 95,100 **** --- 98,104 ---- Result : int; use type Interfaces.C.int; + begin Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); pragma Assert (Result = 0); *************** package body System.OS_Primitives is *** 115,124 **** (Time : Duration; Mode : Integer) is - Result : int; Rel_Time : Duration; Abs_Time : Duration; Check_Time : Duration := Clock; begin if Mode = Relative then --- 119,131 ---- (Time : Duration; Mode : Integer) is Rel_Time : Duration; Abs_Time : Duration; Check_Time : Duration := Clock; + Ticks : int; + + Result : int; + pragma Unreferenced (Result); begin if Mode = Relative then *************** package body System.OS_Primitives is *** 131,137 **** if Rel_Time > 0.0 then loop ! Result := taskDelay (To_Clock_Ticks (Rel_Time)); Check_Time := Clock; exit when Abs_Time <= Check_Time; --- 138,154 ---- if Rel_Time > 0.0 then loop ! Ticks := To_Clock_Ticks (Rel_Time); ! ! if Mode = Relative and then Ticks < int'Last then ! -- The first tick will delay anytime between 0 and ! -- 1 / sysClkRateGet seconds, so we need to add one to ! -- be on the safe side. ! ! Ticks := Ticks + 1; ! end if; ! ! Result := taskDelay (Ticks); Check_Time := Clock; exit when Abs_Time <= Check_Time; diff -Nrc3pad gcc-3.3.3/gcc/ada/5zparame.ads gcc-3.4.0/gcc/ada/5zparame.ads *** gcc-3.3.3/gcc/ada/5zparame.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5zparame.ads 2003-10-21 13:41:53.000000000 +0000 *************** *** 0 **** --- 1,203 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- S Y S T E M . P A R A M E T E R S -- + -- -- + -- 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- -- + -- 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 default VxWorks version of the package.` + + -- This package defines some system dependent parameters for GNAT. These + -- are values that are referenced by the runtime library and are therefore + -- relevant to the target machine. + + -- The parameters whose value is defined in the spec are not generally + -- expected to be changed. If they are changed, it will be necessary to + -- recompile the run-time library. + + -- The parameters which are defined by functions can be changed by modifying + -- the body of System.Parameters in file s-parame.adb. A change to this body + -- requires only rebinding and relinking of the application. + + -- Note: do not introduce any pragma Inline statements into this unit, since + -- otherwise the relinking and rebinding capability would be deactivated. + + package System.Parameters is + pragma Pure (Parameters); + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Ratio is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Ratio : constant Ratio := Dynamic; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Default_Env_Stack_Size : constant Size_Type := 14_336; + -- 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. + -- This value is chosen as the VxWorks default stack size is 20kB, + -- and a little more than 4kB is necessary for the run time. + + Stack_Grows_Down : constant Boolean := True; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := Long_Integer'Size; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this is not true + -- of all targets. For example, in OpenVMS long /= Long_Integer. + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are ommitted only for outer level onjects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- 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 -- + ---------------------- + + Single_Lock : constant Boolean := False; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := False; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + ---------------------- + -- Dynamic Priority -- + ---------------------- + + Dynamic_Priority_Support : constant Boolean := True; + -- This constant indicates whether dynamic changes of task priorities + -- are allowed (True means normal RM mode in which such changes are + -- allowed). In particular, if this is False, then we do not need to + -- poll for pending base priority changes at every abort completion + -- 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 -- + -------------------- + + Runtime_Traces : constant Boolean := False; + -- This constant indicates whether the runtime outputs traces to a + -- predefined output or not (True means that traces are output). + -- See System.Traces for more details. + + end System.Parameters; diff -Nrc3pad gcc-3.3.3/gcc/ada/5zsystem.ads gcc-3.4.0/gcc/ada/5zsystem.ads *** gcc-3.3.3/gcc/ada/5zsystem.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/5zsystem.ads 2003-10-21 13:41:53.000000000 +0000 *************** *** 5,14 **** -- S Y S T E M -- -- -- -- S p e c -- ! -- (VXWORKS Version Alpha) -- ! -- -- -- -- ! -- 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 -- ! -- (VxWorks Version Alpha) -- -- -- ! -- 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 := 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 := True; 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 := 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/5ztaprop.adb gcc-3.4.0/gcc/ada/5ztaprop.adb *** gcc-3.3.3/gcc/ada/5ztaprop.adb 2002-10-23 08:27:55.000000000 +0000 --- gcc-3.4.0/gcc/ada/5ztaprop.adb 2004-01-05 15:20:43.000000000 +0000 *************** *** 6,13 **** -- -- -- 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- -- --- 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- -- *************** with System.Tasking.Debug; *** 46,53 **** with System.Interrupt_Management; -- used for Keep_Unmasked ! -- Abort_Task_Interrupt ! -- Interrupt_ID -- Initialize_Interrupts with System.Soft_Links; --- 45,52 ---- with System.Interrupt_Management; -- used for Keep_Unmasked ! -- Abort_Task_Signal ! -- Signal_ID -- Initialize_Interrupts with System.Soft_Links; *************** with System.Tasking; *** 69,77 **** -- Task_ID -- ATCB components and types - with System.Task_Info; - -- used for Task_Image - with Interfaces.C; with Unchecked_Conversion; --- 68,73 ---- *************** package body System.Task_Primitives.Oper *** 81,87 **** use System.Tasking.Debug; use System.Tasking; - use System.Task_Info; use System.OS_Interface; use System.Parameters; use type Interfaces.C.int; --- 77,82 ---- *************** package body System.Task_Primitives.Oper *** 99,113 **** -- The followings are logically constants, but need to be initialized -- at run time. - Current_Task : aliased Task_ID; - pragma Export (Ada, Current_Task); - -- Task specific value used to store the Ada Task_ID. - 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. --- 94,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 System.Address := System.Null_Address; + -- Key used to find the Ada Task_ID associated with a thread + + ATCB_Key_Addr : System.Address := ATCB_Key'Address; + pragma Export (Ada, ATCB_Key_Addr, "__gnat_ATCB_key_addr"); + -- Exported to support the temporary AE653 task registration + -- implementation. This mechanism is used to minimize impact on other + -- targets. + Environment_Task_ID : Task_ID; -- A variable to hold Task_ID for the environment task. *************** package body System.Task_Primitives.Oper *** 130,140 **** --- 130,180 ---- Mutex_Protocol : Priority_Type; + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads). + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + 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 -- ----------------------- procedure Abort_Handler (signo : Signal); + -- Handler for the abort (SIGABRT) signal to handle asynchronous abortion. + + procedure Install_Signal_Handlers; + -- Install the default signal handlers for the current task function To_Address is new Unchecked_Conversion (Task_ID, System.Address); *************** package body System.Task_Primitives.Oper *** 143,153 **** --- 183,202 ---- ------------------- procedure Abort_Handler (signo : Signal) is + pragma Unreferenced (signo); + Self_ID : constant Task_ID := Self; Result : 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 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 *** 169,176 **** ----------------- procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is begin ! -- Nothing needed. null; end Stack_Guard; --- 218,229 ---- ----------------- procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Unreferenced (T); + pragma Unreferenced (On); + begin ! -- Nothing needed (why not???) ! null; end Stack_Guard; *************** package body System.Task_Primitives.Oper *** 187,210 **** -- Self -- ---------- ! function Self return Task_ID is ! begin ! pragma Assert (Current_Task /= null); ! return Current_Task; ! end Self; ----------------------------- -- Install_Signal_Handlers -- ----------------------------- - procedure Install_Signal_Handlers; - -- Install the default signal handlers for the current task. - procedure Install_Signal_Handlers is ! act : aliased struct_sigaction; ! old_act : aliased struct_sigaction; ! Tmp_Set : aliased sigset_t; ! Result : int; begin act.sa_flags := 0; --- 240,256 ---- -- Self -- ---------- ! function Self return Task_ID renames Specific.Self; ----------------------------- -- Install_Signal_Handlers -- ----------------------------- procedure Install_Signal_Handlers is ! act : aliased struct_sigaction; ! old_act : aliased struct_sigaction; ! Tmp_Set : aliased sigset_t; ! Result : int; begin act.sa_flags := 0; *************** package body System.Task_Primitives.Oper *** 216,222 **** Result := sigaction ! (Signal (Interrupt_Management.Abort_Task_Interrupt), act'Unchecked_Access, old_act'Unchecked_Access); pragma Assert (Result = 0); --- 262,268 ---- Result := sigaction ! (Signal (Interrupt_Management.Abort_Task_Signal), act'Unchecked_Access, old_act'Unchecked_Access); pragma Assert (Result = 0); *************** package body System.Task_Primitives.Oper *** 237,242 **** --- 283,290 ---- end Initialize_Lock; procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Unreferenced (Level); + begin L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); L.Prio_Ceiling := int (System.Any_Priority'Last); *************** package body System.Task_Primitives.Oper *** 250,255 **** --- 298,304 ---- procedure Finalize_Lock (L : access Lock) is Result : int; + begin Result := semDelete (L.Mutex); pragma Assert (Result = 0); *************** package body System.Task_Primitives.Oper *** 257,262 **** --- 306,312 ---- procedure Finalize_Lock (L : access RTS_Lock) is Result : int; + begin Result := semDelete (L.Mutex); pragma Assert (Result = 0); *************** package body System.Task_Primitives.Oper *** 268,273 **** --- 318,324 ---- procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is Result : int; + begin if L.Protocol = Prio_Protect and then int (Self.Common.Current_Priority) > L.Prio_Ceiling *************** package body System.Task_Primitives.Oper *** 283,291 **** end Write_Lock; procedure Write_Lock ! (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : int; begin if not Single_Lock or else Global_Lock then Result := semTake (L.Mutex, WAIT_FOREVER); --- 334,344 ---- end Write_Lock; procedure Write_Lock ! (L : access RTS_Lock; ! Global_Lock : Boolean := False) is Result : int; + begin if not Single_Lock or else Global_Lock then Result := semTake (L.Mutex, WAIT_FOREVER); *************** package body System.Task_Primitives.Oper *** 295,300 **** --- 348,354 ---- procedure Write_Lock (T : Task_ID) is Result : int; + begin if not Single_Lock then Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER); *************** package body System.Task_Primitives.Oper *** 317,322 **** --- 371,377 ---- procedure Unlock (L : access Lock) is Result : int; + begin Result := semGive (L.Mutex); pragma Assert (Result = 0); *************** package body System.Task_Primitives.Oper *** 324,329 **** --- 379,385 ---- procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : int; + begin if not Single_Lock or else Global_Lock then Result := semGive (L.Mutex); *************** package body System.Task_Primitives.Oper *** 333,338 **** --- 389,395 ---- procedure Unlock (T : Task_ID) is Result : int; + begin if not Single_Lock then Result := semGive (T.Common.LL.L.Mutex); *************** package body System.Task_Primitives.Oper *** 345,360 **** ----------- procedure Sleep (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is Result : int; begin pragma Assert (Self_ID = Self); - -- Disable task scheduling. - - Result := taskLock; - -- Release the mutex before sleeping. - if Single_Lock then Result := semGive (Single_RTS_Lock.Mutex); else --- 402,415 ---- ----------- procedure Sleep (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : int; + begin pragma Assert (Self_ID = Self); -- Release the mutex before sleeping. if Single_Lock then Result := semGive (Single_RTS_Lock.Mutex); else *************** package body System.Task_Primitives.Oper *** 363,386 **** pragma Assert (Result = 0); - -- Indicate that there is another thread waiting on the CV. - - Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting + 1; - -- Perform a blocking operation to take the CV semaphore. -- Note that a blocking operation in VxWorks will reenable -- task scheduling. When we are no longer blocked and control -- is returned, task scheduling will again be disabled. ! Result := semTake (Self_ID.Common.LL.CV.Sem, WAIT_FOREVER); ! ! if Result /= 0 then ! Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting - 1; ! pragma Assert (False); ! end if; -- Take the mutex back. - if Single_Lock then Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); else --- 418,432 ---- pragma Assert (Result = 0); -- Perform a blocking operation to take the CV semaphore. -- Note that a blocking operation in VxWorks will reenable -- task scheduling. When we are no longer blocked and control -- is returned, task scheduling will again be disabled. ! Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER); ! pragma Assert (Result = 0); -- Take the mutex back. if Single_Lock then Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); else *************** package body System.Task_Primitives.Oper *** 388,397 **** end if; pragma Assert (Result = 0); - - -- Reenable task scheduling. - - Result := taskUnlock; end Sleep; ----------------- --- 434,439 ---- *************** package body System.Task_Primitives.Oper *** 410,487 **** Timedout : out Boolean; Yielded : out Boolean) is ! Ticks : int; ! Result : int; begin ! Timedout := True; ! Yielded := True; if Mode = Relative then -- Systematically add one since the first tick will delay -- *at most* 1 / Rate_Duration seconds, so we need to add one to -- be on the safe side. ! Ticks := To_Clock_Ticks (Time) + 1; else ! Ticks := To_Clock_Ticks (Time - Monotonic_Clock); end if; if Ticks > 0 then ! -- Disable task scheduling. ! ! Result := taskLock; ! -- Release the mutex before sleeping. ! if Single_Lock then ! Result := semGive (Single_RTS_Lock.Mutex); ! else ! Result := semGive (Self_ID.Common.LL.L.Mutex); ! end if; ! pragma Assert (Result = 0); ! -- Indicate that there is another thread waiting on the CV. ! Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting + 1; ! -- Perform a blocking operation to take the CV semaphore. ! -- Note that a blocking operation in VxWorks will reenable ! -- task scheduling. When we are no longer blocked and control ! -- is returned, task scheduling will again be disabled. ! Result := semTake (Self_ID.Common.LL.CV.Sem, Ticks); ! if Result = 0 then ! -- Somebody may have called Wakeup for us ! Timedout := False; ! else ! Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting - 1; ! if errno /= S_objLib_OBJ_TIMEOUT then ! Timedout := False; ! end if; ! end if; ! -- Take the mutex back. if Single_Lock then Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); else Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); end if; - - pragma Assert (Result = 0); - - -- Reenable task scheduling. - - Result := taskUnlock; - - else - taskDelay (0); end if; end Timed_Sleep; --- 452,556 ---- Timedout : out Boolean; Yielded : out Boolean) is ! pragma Unreferenced (Reason); ! ! Orig : constant Duration := Monotonic_Clock; ! Absolute : Duration; ! Ticks : int; ! Result : int; ! Wakeup : Boolean := False; begin ! Timedout := False; ! Yielded := True; if Mode = Relative then + Absolute := Orig + Time; + -- Systematically add one since the first tick will delay -- *at most* 1 / Rate_Duration seconds, so we need to add one to -- be on the safe side. ! Ticks := To_Clock_Ticks (Time); ! ! if Ticks > 0 and then Ticks < int'Last then ! Ticks := Ticks + 1; ! end if; ! else ! Absolute := Time; ! Ticks := To_Clock_Ticks (Time - Monotonic_Clock); end if; if Ticks > 0 then ! loop ! -- Release the mutex before sleeping. ! if Single_Lock then ! Result := semGive (Single_RTS_Lock.Mutex); ! else ! Result := semGive (Self_ID.Common.LL.L.Mutex); ! end if; ! pragma Assert (Result = 0); ! -- Perform a blocking operation to take the CV semaphore. ! -- Note that a blocking operation in VxWorks will reenable ! -- task scheduling. When we are no longer blocked and control ! -- is returned, task scheduling will again be disabled. ! Result := semTake (Self_ID.Common.LL.CV, Ticks); ! if Result = 0 then ! -- Somebody may have called Wakeup for us ! Wakeup := True; ! else ! if errno /= S_objLib_OBJ_TIMEOUT then ! Wakeup := True; ! else ! -- If Ticks = int'last, it was most probably truncated ! -- so let's make another round after recomputing Ticks ! -- from the the absolute time. ! if Ticks /= int'Last then ! Timedout := True; ! else ! Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); ! if Ticks < 0 then ! Timedout := True; ! end if; ! end if; ! end if; ! end if; ! -- Take the mutex back. ! if Single_Lock then ! Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); ! else ! Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); ! end if; ! pragma Assert (Result = 0); ! exit when Timedout or Wakeup; ! end loop; ! else ! Timedout := True; + -- Should never hold a lock while yielding. if Single_Lock then + Result := semGive (Single_RTS_Lock.Mutex); + taskDelay (0); Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); + else + Result := semGive (Self_ID.Common.LL.L.Mutex); + taskDelay (0); Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); end if; end if; end Timed_Sleep; *************** package body System.Task_Primitives.Oper *** 502,576 **** Ticks : int; Timedout : Boolean; Result : int; begin SSL.Abort_Defer.all; - if Single_Lock then - Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); - else - Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); - end if; - - pragma Assert (Result = 0); - if Mode = Relative then Absolute := Orig + Time; ! Ticks := To_Clock_Ticks (Time); - if Ticks > 0 then -- The first tick will delay anytime between 0 and -- 1 / sysClkRateGet seconds, so we need to add one to -- be on the safe side. Ticks := Ticks + 1; end if; else Absolute := Time; Ticks := To_Clock_Ticks (Time - Orig); end if; if Ticks > 0 then Self_ID.Common.State := Delay_Sleep; loop if Self_ID.Pending_Priority_Change then Self_ID.Pending_Priority_Change := False; ! Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; Set_Priority (Self_ID, Self_ID.Common.Base_Priority); end if; ! exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; ! Timedout := False; ! Result := taskLock; if Single_Lock then Result := semGive (Single_RTS_Lock.Mutex); else Result := semGive (Self_ID.Common.LL.L.Mutex); end if; - pragma Assert (Result = 0); ! -- Indicate that there is another thread waiting on the CV. ! ! Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting + 1; ! Result := semTake (Self_ID.Common.LL.CV.Sem, Ticks); if Result /= 0 then ! Self_ID.Common.LL.CV.Waiting := ! Self_ID.Common.LL.CV.Waiting - 1; ! if errno = S_objLib_OBJ_TIMEOUT then Timedout := True; else Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); end if; end if; if Single_Lock then Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); else --- 571,653 ---- Ticks : int; Timedout : Boolean; Result : int; + Aborted : Boolean := False; begin SSL.Abort_Defer.all; if Mode = Relative then Absolute := Orig + Time; + Ticks := To_Clock_Ticks (Time); ! if Ticks > 0 and then Ticks < int'Last then -- The first tick will delay anytime between 0 and -- 1 / sysClkRateGet seconds, so we need to add one to -- be on the safe side. Ticks := Ticks + 1; end if; + else Absolute := Time; Ticks := To_Clock_Ticks (Time - Orig); end if; if Ticks > 0 then + -- Modifying State and Pending_Priority_Change, locking the TCB. + if Single_Lock then + Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); + else + Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); + end if; + + pragma Assert (Result = 0); + Self_ID.Common.State := Delay_Sleep; + Timedout := False; 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; ! Aborted := Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; ! -- Release the TCB before sleeping if Single_Lock then Result := semGive (Single_RTS_Lock.Mutex); else Result := semGive (Self_ID.Common.LL.L.Mutex); end if; pragma Assert (Result = 0); ! exit when Aborted; ! Result := semTake (Self_ID.Common.LL.CV, Ticks); if Result /= 0 then ! -- If Ticks = int'last, it was most probably truncated ! -- so let's make another round after recomputing Ticks ! -- from the the absolute time. ! if errno = S_objLib_OBJ_TIMEOUT and then Ticks /= int'Last then Timedout := True; else Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); + + if Ticks < 0 then + Timedout := True; + end if; end if; end if; + -- Take back the lock after having slept, to protect further + -- access to Self_ID + if Single_Lock then Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); else *************** package body System.Task_Primitives.Oper *** 579,603 **** pragma Assert (Result = 0); - -- Reenable task scheduling. - - Result := taskUnlock; - exit when Timedout; end loop; Self_ID.Common.State := Runnable; - else - taskDelay (0); - end if; ! if Single_Lock then ! Result := semGive (Single_RTS_Lock.Mutex); else ! Result := semGive (Self_ID.Common.LL.L.Mutex); end if; - pragma Assert (Result = 0); SSL.Abort_Undefer.all; end Timed_Delay; --- 656,676 ---- pragma Assert (Result = 0); exit when Timedout; end loop; Self_ID.Common.State := Runnable; ! if Single_Lock then ! Result := semGive (Single_RTS_Lock.Mutex); ! else ! Result := semGive (Self_ID.Common.LL.L.Mutex); ! end if; ! else ! taskDelay (0); end if; SSL.Abort_Undefer.all; end Timed_Delay; *************** package body System.Task_Primitives.Oper *** 621,627 **** function RT_Resolution return Duration is begin ! return 10#1.0#E-6; end RT_Resolution; ------------ --- 694,700 ---- function RT_Resolution return Duration is begin ! return 1.0 / Duration (sysClkRateGet); end RT_Resolution; ------------ *************** package body System.Task_Primitives.Oper *** 629,658 **** ------------ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is ! Result : int; ! begin ! -- Disable task scheduling. ! ! Result := taskLock; ! ! -- Iff someone is currently waiting on the condition variable ! -- then release the semaphore; we don't want to leave the ! -- semaphore in the full state because the next guy to do ! -- a condition wait operation would not block. ! ! if T.Common.LL.CV.Waiting > 0 then ! Result := semGive (T.Common.LL.CV.Sem); ! ! -- One less thread waiting on the CV. ! ! T.Common.LL.CV.Waiting := T.Common.LL.CV.Waiting - 1; ! ! pragma Assert (Result = 0); ! end if; ! -- Reenable task scheduling. ! Result := taskUnlock; end Wakeup; ----------- --- 702,714 ---- ------------ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is ! pragma Unreferenced (Reason); ! Result : int; ! begin ! Result := semGive (T.Common.LL.CV); ! pragma Assert (Result = 0); end Wakeup; ----------- *************** package body System.Task_Primitives.Oper *** 660,666 **** --- 716,724 ---- ----------- procedure Yield (Do_Yield : Boolean := True) is + pragma Unreferenced (Do_Yield); Result : int; + pragma Unreferenced (Result); begin Result := taskDelay (0); end Yield; *************** package body System.Task_Primitives.Oper *** 674,698 **** Prio_Array : Prio_Array_Type; -- Global array containing the id of the currently running task for ! -- each priority. ! -- ! -- Note: we assume that we are on a single processor with run-til-blocked ! -- scheduling. procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is Array_Item : Integer; Result : int; begin ! Result := taskPrioritySet ! (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio))); pragma Assert (Result = 0); if FIFO_Within_Priorities then -- Annex D requirement [RM D.2.2 par. 9]: -- If the task drops its priority due to the loss of inherited -- priority, it is added at the head of the ready queue for its --- 732,756 ---- Prio_Array : Prio_Array_Type; -- Global array containing the id of the currently running task for ! -- each priority. Note that we assume that we are on a single processor ! -- with run-till-blocked scheduling. procedure Set_Priority ! (T : Task_ID; ! Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is Array_Item : Integer; Result : int; begin ! Result := ! taskPrioritySet ! (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio))); pragma Assert (Result = 0); if FIFO_Within_Priorities then + -- Annex D requirement [RM D.2.2 par. 9]: -- If the task drops its priority due to the loss of inherited -- priority, it is added at the head of the ready queue for its *************** package body System.Task_Primitives.Oper *** 705,713 **** Prio_Array (T.Common.Base_Priority) := Array_Item; loop ! -- Let some processes a chance to arrive ! Yield; -- Then wait for our turn to proceed --- 763,771 ---- Prio_Array (T.Common.Base_Priority) := Array_Item; loop ! -- Give some processes a chance to arrive ! taskDelay (0); -- Then wait for our turn to proceed *************** package body System.Task_Primitives.Oper *** 737,752 **** ---------------- procedure Enter_Task (Self_ID : Task_ID) is - Result : int; - procedure Init_Float; pragma Import (C, Init_Float, "__gnat_init_float"); -- Properly initializes the FPU for PPC/MIPS systems. begin Self_ID.Common.LL.Thread := taskIdSelf; ! Result := taskVarAdd (0, Current_Task'Address); ! Current_Task := Self_ID; Init_Float; -- Install the signal handlers. --- 795,808 ---- ---------------- procedure Enter_Task (Self_ID : Task_ID) is procedure Init_Float; pragma Import (C, Init_Float, "__gnat_init_float"); -- Properly initializes the FPU for PPC/MIPS systems. begin Self_ID.Common.LL.Thread := taskIdSelf; ! Specific.Set (Self_ID); ! Init_Float; -- Install the signal handlers. *************** package body System.Task_Primitives.Oper *** 777,793 **** return new Ada_Task_Control_Block (Entry_Num); end New_ATCB; -------------------- -- Initialize_TCB -- -------------------- procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is begin ! Self_ID.Common.LL.CV.Sem := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY); ! Self_ID.Common.LL.CV.Waiting := 0; Self_ID.Common.LL.Thread := 0; ! if Self_ID.Common.LL.CV.Sem = 0 then Succeeded := False; else Succeeded := True; --- 833,867 ---- 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 (taskIdSelf); + end if; + end Register_Foreign_Thread; + -------------------- -- Initialize_TCB -- -------------------- procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is begin ! Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY); Self_ID.Common.LL.Thread := 0; ! if Self_ID.Common.LL.CV = 0 then Succeeded := False; else Succeeded := True; *************** package body System.Task_Primitives.Oper *** 809,818 **** Priority : System.Any_Priority; Succeeded : out Boolean) is - use type System.Task_Info.Task_Image_Type; - Adjusted_Stack_Size : size_t; - begin if Stack_Size = Unspecified_Size then Adjusted_Stack_Size := size_t (Default_Stack_Size); --- 883,889 ---- *************** package body System.Task_Primitives.Oper *** 839,844 **** --- 910,916 ---- -- -- XXX - we should come back and visit this so we can -- set the task name to something appropriate. + Adjusted_Stack_Size := Adjusted_Stack_Size + 2048; -- Since the initial signal mask of a thread is inherited from the *************** package body System.Task_Primitives.Oper *** 846,852 **** -- do not need to manipulate caller's signal mask at this point. -- All tasks in RTS will have All_Tasks_Mask initially. ! if T.Common.Task_Image = null then T.Common.LL.Thread := taskSpawn (System.Null_Address, To_VxWorks_Priority (int (Priority)), --- 918,924 ---- -- do not need to manipulate caller's signal mask at this point. -- All tasks in RTS will have All_Tasks_Mask initially. ! if T.Common.Task_Image_Len = 0 then T.Common.LL.Thread := taskSpawn (System.Null_Address, To_VxWorks_Priority (int (Priority)), *************** package body System.Task_Primitives.Oper *** 856,864 **** To_Address (T)); else declare ! Name : aliased String (1 .. T.Common.Task_Image'Length + 1); begin ! Name (1 .. Name'Last - 1) := T.Common.Task_Image.all; Name (Name'Last) := ASCII.NUL; T.Common.LL.Thread := taskSpawn --- 928,937 ---- To_Address (T)); else declare ! Name : aliased String (1 .. T.Common.Task_Image_Len + 1); begin ! Name (1 .. Name'Last - 1) := ! T.Common.Task_Image (1 .. T.Common.Task_Image_Len); Name (Name'Last) := ASCII.NUL; T.Common.LL.Thread := taskSpawn *************** package body System.Task_Primitives.Oper *** 886,906 **** ------------------ procedure Finalize_TCB (T : Task_ID) is ! Result : int; ! Tmp : Task_ID := T; procedure Free is new Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); begin ! if Single_Lock then Result := semDelete (T.Common.LL.L.Mutex); pragma Assert (Result = 0); end if; T.Common.LL.Thread := 0; ! Result := semDelete (T.Common.LL.CV.Sem); pragma Assert (Result = 0); if T.Known_Tasks_Index /= -1 then --- 959,980 ---- ------------------ procedure Finalize_TCB (T : Task_ID) is ! Result : 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 := semDelete (T.Common.LL.L.Mutex); pragma Assert (Result = 0); end if; T.Common.LL.Thread := 0; ! Result := semDelete (T.Common.LL.CV); pragma Assert (Result = 0); if T.Known_Tasks_Index /= -1 then *************** package body System.Task_Primitives.Oper *** 908,913 **** --- 982,992 ---- end if; Free (Tmp); + + if Is_Self then + Result := taskVarDelete (taskIdSelf, ATCB_Key'Access); + pragma Assert (Result /= ERROR); + end if; end Finalize_TCB; --------------- *************** package body System.Task_Primitives.Oper *** 916,923 **** procedure Exit_Task is begin ! Task_Termination_Hook; ! taskDelete (0); end Exit_Task; ---------------- --- 995,1001 ---- procedure Exit_Task is begin ! Specific.Set (null); end Exit_Task; ---------------- *************** package body System.Task_Primitives.Oper *** 926,934 **** procedure Abort_Task (T : Task_ID) is Result : int; begin Result := kill (T.Common.LL.Thread, ! Signal (Interrupt_Management.Abort_Task_Interrupt)); pragma Assert (Result = 0); end Abort_Task; --- 1004,1013 ---- procedure Abort_Task (T : Task_ID) is Result : int; + begin Result := kill (T.Common.LL.Thread, ! Signal (Interrupt_Management.Abort_Task_Signal)); pragma Assert (Result = 0); end Abort_Task; *************** package body System.Task_Primitives.Oper *** 936,945 **** -- Check_Exit -- ---------------- ! -- Dummy versions. The only currently working version is for solaris ! -- (native). function Check_Exit (Self_ID : ST.Task_ID) return Boolean is begin return True; end Check_Exit; --- 1015,1025 ---- -- 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 *** 949,954 **** --- 1029,1036 ---- -------------------- 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 *** 986,992 **** function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin if T.Common.LL.Thread /= 0 and then T.Common.LL.Thread /= Thread_Self --- 1068,1076 ---- function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) ! return Boolean ! is begin if T.Common.LL.Thread /= 0 and then T.Common.LL.Thread /= Thread_Self *************** package body System.Task_Primitives.Oper *** 1003,1009 **** function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin if T.Common.LL.Thread /= 0 and then T.Common.LL.Thread /= Thread_Self --- 1087,1095 ---- function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) ! return Boolean ! is begin if T.Common.LL.Thread /= 0 and then T.Common.LL.Thread /= Thread_Self *************** package body System.Task_Primitives.Oper *** 1019,1037 **** ---------------- procedure Initialize (Environment_Task : Task_ID) is - 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); - end Initialize; - - begin - declare Result : int; begin if Locking_Policy = 'C' then Mutex_Protocol := Prio_Protect; --- 1105,1112 ---- ---------------- procedure Initialize (Environment_Task : Task_ID) is Result : int; + begin if Locking_Policy = 'C' then Mutex_Protocol := Prio_Protect; *************** begin *** 1049,1053 **** Result := sigemptyset (Unblocked_Signal_Mask'Access); pragma Assert (Result = 0); ! end; end System.Task_Primitives.Operations; --- 1124,1144 ---- Result := sigemptyset (Unblocked_Signal_Mask'Access); pragma Assert (Result = 0); ! ! for J in Interrupt_Management.Signal_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; ! ! 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); ! end Initialize; ! end System.Task_Primitives.Operations; diff -Nrc3pad gcc-3.3.3/gcc/ada/5ztaspri.ads gcc-3.4.0/gcc/ada/5ztaspri.ads *** gcc-3.3.3/gcc/ada/5ztaspri.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5ztaspri.ads 2003-10-21 13:41:53.000000000 +0000 *************** *** 0 **** --- 1,95 ---- + ------------------------------------------------------------------------------ + -- -- + -- 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) 2001-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 VxWorks 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 System.OS_Interface; + + 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 Priority_Type is (Prio_None, Prio_Protect, Prio_Inherit); + + type Lock is record + Mutex : System.OS_Interface.SEM_ID; + Protocol : Priority_Type; + Prio_Ceiling : System.OS_Interface.int; + -- priority ceiling of lock + end record; + + type RTS_Lock is new Lock; + + type Private_Data is record + Thread : aliased System.OS_Interface.t_id := 0; + 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.SEM_ID; + + 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/5ztfsetr.adb gcc-3.4.0/gcc/ada/5ztfsetr.adb *** gcc-3.3.3/gcc/ada/5ztfsetr.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5ztfsetr.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 0 **** --- 1,107 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . T R A C E S . S E N D -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 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. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This version is for VxWorks targets. + + -- Trace information is sent to WindView using the wvEvent function. + + -- Note that wvEvent is from the VxWorks API. + + -- When adding a new event, just give an Id to then event, and then modify + -- the WindView events database. + + -- Refer to WindView User's Guide for more details on how to add new events + -- to the events database. + + ---------------- + -- Send_Trace -- + ---------------- + + -- This procedure formats the string, maps the event Id to an Id + -- recognized by WindView, and send the event using wvEvent + + separate (System.Traces.Format) + procedure Send_Trace (Id : Trace_T; Info : String) is + + procedure Wv_Event + (Id : Integer; + Buffer : System.Address; + Size : Integer); + pragma Import (C, Wv_Event, "wvEvent"); + + Info_Trace : String_Trace; + Id_Event : Integer; + + begin + Info_Trace := Format_Trace (Info); + + case Id is + when M_Accept_Complete => Id_Event := 30000; + when M_Select_Else => Id_Event := 30001; + when M_RDV_Complete => Id_Event := 30002; + when M_Call_Complete => Id_Event := 30003; + when M_Delay => Id_Event := 30004; + when E_Kill => Id_Event := 30005; + when E_Missed => Id_Event := 30006; + when E_Timeout => Id_Event := 30007; + + when W_Call => Id_Event := 30010; + when W_Accept => Id_Event := 30011; + when W_Select => Id_Event := 30012; + when W_Completion => Id_Event := 30013; + when W_Delay => Id_Event := 30014; + when WT_Select => Id_Event := 30015; + when WT_Call => Id_Event := 30016; + when WT_Completion => Id_Event := 30017; + when WU_Delay => Id_Event := 30018; + + when PO_Call => Id_Event := 30020; + when POT_Call => Id_Event := 30021; + when PO_Run => Id_Event := 30022; + when PO_Lock => Id_Event := 30023; + when PO_Unlock => Id_Event := 30024; + when PO_Done => Id_Event := 30025; + + when T_Create => Id_Event := 30030; + when T_Activate => Id_Event := 30031; + when T_Abort => Id_Event := 30032; + when T_Terminate => Id_Event := 30033; + + -- Unrecognized events are given the special Id_Event value 29999 + + when others => Id_Event := 29999; + + end case; + + Wv_Event (Id_Event, Info_Trace'Address, Max_Size); + end Send_Trace; diff -Nrc3pad gcc-3.3.3/gcc/ada/5ztpopsp.adb gcc-3.4.0/gcc/ada/5ztpopsp.adb *** gcc-3.3.3/gcc/ada/5ztpopsp.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/5ztpopsp.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- + -- -- + -- 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 a VxWorks version of this package where foreign threads are + -- recognized. + + separate (System.Task_Primitives.Operations) + package body Specific is + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + begin + return taskVarGet (taskIdSelf, ATCB_Key'Access) /= ERROR; + end Is_Valid_Task; + + --------- + -- Set -- + --------- + + procedure Set (Self_Id : Task_ID) is + Result : STATUS; + + begin + if taskVarGet (0, ATCB_Key'Access) = ERROR then + Result := taskVarAdd (0, ATCB_Key'Access); + pragma Assert (Result = OK); + end if; + + ATCB_Key := To_Address (Self_Id); + end Set; + + ---------- + -- Self -- + ---------- + + function Self return Task_ID is + begin + return To_Task_Id (ATCB_Key); + end Self; + + end Specific; diff -Nrc3pad gcc-3.3.3/gcc/ada/6vcpp.adb gcc-3.4.0/gcc/ada/6vcpp.adb *** gcc-3.3.3/gcc/ada/6vcpp.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/6vcpp.adb 2004-01-05 15:20:43.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 2000-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-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- -- *************** *** 32,38 **** -- -- ------------------------------------------------------------------------------ ! -- This is the OpenVMS/Alpha DEC C++ (cxx) version of this package. with Ada.Tags; use Ada.Tags; with System; use System; --- 31,37 ---- -- -- ------------------------------------------------------------------------------ ! -- This is the OpenVMS/Alpha DEC C++ (cxx) version of this package with Ada.Tags; use Ada.Tags; with System; use System; *************** package body Interfaces.CPP is *** 103,114 **** function Displaced_This (Current_This : System.Address; Vptr : Vtable_Ptr; ! Position : Positive) ! return System.Address is begin return Current_This; ! -- + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1); end Displaced_This; ----------------------- --- 102,115 ---- function Displaced_This (Current_This : System.Address; Vptr : Vtable_Ptr; ! Position : Positive) return System.Address is + pragma Warnings (Off, Vptr); + pragma Warnings (Off, Position); begin return Current_This; ! -- + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1); ! -- why is above line commented out ??? end Displaced_This; ----------------------- *************** package body Interfaces.CPP is *** 117,124 **** function CPP_CW_Membership (Obj_Tag : Vtable_Ptr; ! Typ_Tag : Vtable_Ptr) ! return Boolean is Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth; begin --- 118,124 ---- function CPP_CW_Membership (Obj_Tag : Vtable_Ptr; ! Typ_Tag : Vtable_Ptr) return Boolean is Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth; begin *************** package body Interfaces.CPP is *** 152,165 **** return T.TSD.Idepth; end CPP_Get_Inheritance_Depth; ! ------------------------- -- CPP_Get_Prim_Op_Address -- ! ------------------------- function CPP_Get_Prim_Op_Address (T : Vtable_Ptr; ! Position : Positive) ! return Address is begin return T.Prims_Ptr (Position).Pfn; end CPP_Get_Prim_Op_Address; --- 152,175 ---- return T.TSD.Idepth; end CPP_Get_Inheritance_Depth; ! ----------------------- ! -- CPP_Get_RC_Offset -- ! ----------------------- ! ! function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is ! pragma Warnings (Off, T); ! begin ! return 0; ! end CPP_Get_RC_Offset; ! ! ----------------------------- -- CPP_Get_Prim_Op_Address -- ! ----------------------------- function CPP_Get_Prim_Op_Address (T : Vtable_Ptr; ! Position : Positive) return Address ! is begin return T.Prims_Ptr (Position).Pfn; end CPP_Get_Prim_Op_Address; *************** package body Interfaces.CPP is *** 169,174 **** --- 179,185 ---- ------------------------------- function CPP_Get_Remotely_Callable (T : Vtable_Ptr) return Boolean is + pragma Warnings (Off, T); begin return True; end CPP_Get_Remotely_Callable; *************** package body Interfaces.CPP is *** 187,200 **** -------------------- procedure CPP_Inherit_DT ! (Old_T : Vtable_Ptr; ! New_T : Vtable_Ptr; Entry_Count : Natural) is begin if Old_T /= null then ! New_T.Prims_Ptr (1 .. Entry_Count) ! := Old_T.Prims_Ptr (1 .. Entry_Count); end if; end CPP_Inherit_DT; --- 198,211 ---- -------------------- procedure CPP_Inherit_DT ! (Old_T : Vtable_Ptr; ! New_T : Vtable_Ptr; Entry_Count : Natural) is begin if Old_T /= null then ! New_T.Prims_Ptr (1 .. Entry_Count) := ! Old_T.Prims_Ptr (1 .. Entry_Count); end if; end CPP_Inherit_DT; *************** package body Interfaces.CPP is *** 206,213 **** (Old_TSD : Address; New_Tag : Vtable_Ptr) is ! TSD : constant Type_Specific_Data_Ptr ! := To_Type_Specific_Data_Ptr (Old_TSD); New_TSD : Type_Specific_Data renames New_Tag.TSD.all; --- 217,224 ---- (Old_TSD : Address; New_Tag : Vtable_Ptr) is ! TSD : constant Type_Specific_Data_Ptr := ! To_Type_Specific_Data_Ptr (Old_TSD); New_TSD : Type_Specific_Data renames New_Tag.TSD.all; *************** package body Interfaces.CPP is *** 266,276 **** --- 277,300 ---- T.Prims_Ptr (Position).Pfn := Value; end CPP_Set_Prim_Op_Address; + ----------------------- + -- CPP_Set_RC_Offset -- + ----------------------- + + procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is + pragma Warnings (Off, T); + pragma Warnings (Off, Value); + begin + null; + end CPP_Set_RC_Offset; + ------------------------------- -- CPP_Set_Remotely_Callable -- ------------------------------- procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean) is + pragma Warnings (Off, T); + pragma Warnings (Off, Value); begin null; end CPP_Set_Remotely_Callable; *************** package body Interfaces.CPP is *** 289,296 **** ------------------- function Expanded_Name (T : Vtable_Ptr) return String is ! Result : Cstring_Ptr := T.TSD.Expanded_Name; ! begin return Result (1 .. Length (Result)); end Expanded_Name; --- 313,319 ---- ------------------- function Expanded_Name (T : Vtable_Ptr) return String is ! Result : constant Cstring_Ptr := T.TSD.Expanded_Name; begin return Result (1 .. Length (Result)); end Expanded_Name; *************** package body Interfaces.CPP is *** 300,307 **** ------------------ function External_Tag (T : Vtable_Ptr) return String is ! Result : Cstring_Ptr := T.TSD.External_Tag; ! begin return Result (1 .. Length (Result)); end External_Tag; --- 323,329 ---- ------------------ function External_Tag (T : Vtable_Ptr) return String is ! Result : constant Cstring_Ptr := T.TSD.External_Tag; begin return Result (1 .. Length (Result)); end External_Tag; *************** package body Interfaces.CPP is *** 321,333 **** return Len - 1; end Length; - procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is - begin - null; - end CPP_Set_RC_Offset; - - function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is - begin - return 0; - end CPP_Get_RC_Offset; end Interfaces.CPP; --- 343,346 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/6vcstrea.adb gcc-3.4.0/gcc/ada/6vcstrea.adb *** gcc-3.3.3/gcc/ada/6vcstrea.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/6vcstrea.adb 2004-01-05 15:20:43.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1996-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-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- -- *************** *** 37,42 **** --- 36,51 ---- with Unchecked_Conversion; package body Interfaces.C_Streams is + use type System.CRTL.size_t; + + -- Substantial rewriting is needed here. These functions are far too + -- long to be inlined. They should be rewritten to be small helper + -- functions that are inlined, and then call the real routines.??? + + -- Alternatively, provide a separate spec for VMS, in which case we + -- could reduce the amount of junk bodies in the other cases by + -- interfacing directly in the spec.??? + ------------ -- fread -- ------------ *************** package body Interfaces.C_Streams is *** 45,75 **** (buffer : voids; size : size_t; count : size_t; ! stream : FILEs) ! return size_t is Get_Count : size_t := 0; type Buffer_Type is array (size_t range 1 .. count, size_t range 1 .. size) of Character; type Buffer_Access is access Buffer_Type; function To_BA is new Unchecked_Conversion (voids, Buffer_Access); ! BA : Buffer_Access := To_BA (buffer); Ch : int; - begin -- This Fread goes with the Fwrite below. -- The C library fread sometimes can't read fputc generated files. for C in 1 .. count loop for S in 1 .. size loop Ch := fgetc (stream); if Ch = EOF then ! return 0; end if; BA.all (C, S) := Character'Val (Ch); end loop; Get_Count := Get_Count + 1; end loop; return Get_Count; end fread; --- 54,89 ---- (buffer : voids; size : size_t; count : size_t; ! stream : FILEs) return size_t is Get_Count : size_t := 0; + type Buffer_Type is array (size_t range 1 .. count, size_t range 1 .. size) of Character; type Buffer_Access is access Buffer_Type; function To_BA is new Unchecked_Conversion (voids, Buffer_Access); ! ! BA : constant Buffer_Access := To_BA (buffer); Ch : int; + begin -- This Fread goes with the Fwrite below. -- The C library fread sometimes can't read fputc generated files. for C in 1 .. count loop for S in 1 .. size loop Ch := fgetc (stream); + if Ch = EOF then ! return Get_Count; end if; + BA.all (C, S) := Character'Val (Ch); end loop; + Get_Count := Get_Count + 1; end loop; + return Get_Count; end fread; *************** package body Interfaces.C_Streams is *** 82,112 **** index : size_t; size : size_t; count : size_t; ! stream : FILEs) ! return size_t is Get_Count : size_t := 0; type Buffer_Type is array (size_t range 1 .. count, size_t range 1 .. size) of Character; type Buffer_Access is access Buffer_Type; function To_BA is new Unchecked_Conversion (voids, Buffer_Access); ! BA : Buffer_Access := To_BA (buffer); Ch : int; - begin -- This Fread goes with the Fwrite below. -- The C library fread sometimes can't read fputc generated files. for C in 1 + index .. count + index loop for S in 1 .. size loop Ch := fgetc (stream); if Ch = EOF then ! return 0; end if; BA.all (C, S) := Character'Val (Ch); end loop; Get_Count := Get_Count + 1; end loop; return Get_Count; end fread; --- 96,131 ---- index : size_t; size : size_t; count : size_t; ! stream : FILEs) return size_t is Get_Count : size_t := 0; + type Buffer_Type is array (size_t range 1 .. count, size_t range 1 .. size) of Character; type Buffer_Access is access Buffer_Type; function To_BA is new Unchecked_Conversion (voids, Buffer_Access); ! ! BA : constant Buffer_Access := To_BA (buffer); Ch : int; + begin -- This Fread goes with the Fwrite below. -- The C library fread sometimes can't read fputc generated files. for C in 1 + index .. count + index loop for S in 1 .. size loop Ch := fgetc (stream); + if Ch = EOF then ! return Get_Count; end if; + BA.all (C, S) := Character'Val (Ch); end loop; + Get_Count := Get_Count + 1; end loop; + return Get_Count; end fread; *************** package body Interfaces.C_Streams is *** 118,134 **** (buffer : voids; size : size_t; count : size_t; ! stream : FILEs) ! return size_t is Put_Count : size_t := 0; type Buffer_Type is array (size_t range 1 .. count, size_t range 1 .. size) of Character; type Buffer_Access is access Buffer_Type; function To_BA is new Unchecked_Conversion (voids, Buffer_Access); - BA : Buffer_Access := To_BA (buffer); - begin -- Fwrite on VMS has the undesirable effect of always generating at -- least one record of output per call, regardless of buffering. To -- get around this, we do multiple fputc calls instead. --- 137,154 ---- (buffer : voids; size : size_t; count : size_t; ! stream : FILEs) return size_t is Put_Count : size_t := 0; + type Buffer_Type is array (size_t range 1 .. count, size_t range 1 .. size) of Character; type Buffer_Access is access Buffer_Type; function To_BA is new Unchecked_Conversion (voids, Buffer_Access); + BA : constant Buffer_Access := To_BA (buffer); + + begin -- Fwrite on VMS has the undesirable effect of always generating at -- least one record of output per call, regardless of buffering. To -- get around this, we do multiple fputc calls instead. *************** package body Interfaces.C_Streams is *** 136,146 **** for C in 1 .. count loop for S in 1 .. size loop if fputc (Character'Pos (BA.all (C, S)), stream) = EOF then ! exit; end if; end loop; Put_Count := Put_Count + 1; end loop; return Put_Count; end fwrite; --- 156,168 ---- for C in 1 .. count loop for S in 1 .. size loop if fputc (Character'Pos (BA.all (C, S)), stream) = EOF then ! return Put_Count; end if; end loop; + Put_Count := Put_Count + 1; end loop; + return Put_Count; end fwrite; *************** package body Interfaces.C_Streams is *** 152,182 **** (stream : FILEs; buffer : chars; mode : int; ! size : size_t) ! return int is - function C_setvbuf - (stream : FILEs; - buffer : chars; - mode : int; - size : size_t) - return int; - pragma Import (C, C_setvbuf, "setvbuf"); - use type System.Address; - begin -- In order for the above fwrite hack to work, we must always buffer -- stdout and stderr. Is_regular_file on VMS cannot detect when -- these are redirected to a file, so checking for that condition ! -- doesn't help. if mode = IONBF and then (stream = stdout or else stream = stderr) then ! return C_setvbuf (stream, buffer, IOLBF, size); else ! return C_setvbuf (stream, buffer, mode, size); end if; end setvbuf; --- 174,197 ---- (stream : FILEs; buffer : chars; mode : int; ! size : size_t) return int is use type System.Address; + begin -- In order for the above fwrite hack to work, we must always buffer -- stdout and stderr. Is_regular_file on VMS cannot detect when -- these are redirected to a file, so checking for that condition ! -- doesnt help. if mode = IONBF and then (stream = stdout or else stream = stderr) then ! return System.CRTL.setvbuf ! (stream, buffer, IOLBF, System.CRTL.size_t (size)); else ! return System.CRTL.setvbuf ! (stream, buffer, mode, System.CRTL.size_t (size)); end if; end setvbuf; diff -Nrc3pad gcc-3.3.3/gcc/ada/6vinterf.ads gcc-3.4.0/gcc/ada/6vinterf.ads *** gcc-3.3.3/gcc/ada/6vinterf.ads 2002-03-14 10:58:43.000000000 +0000 --- gcc-3.4.0/gcc/ada/6vinterf.ads 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,22 **** -- -- -- 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. -- -- -- ------------------------------------------------------------------------------ -- This is the OpenVMS version of this package which adds Float_Representation ! -- pragmas to the IEEE floating point types to enusre they remain IEEE in ! -- thse presence of a VAX_Float Float_Representatin configuration pragma. -- It assumes integer sizes of 8, 16, 32 and 64 are available, and that IEEE -- floating-point formats are available. --- 6,43 ---- -- -- -- S p e c -- -- -- + -- Copyright (C) 2002-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 implementation dependent sections of this file. -- ! -- -- ! -- 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 OpenVMS version of this package which adds Float_Representation ! -- pragmas to the IEEE floating point types to ensure they remain IEEE in ! -- the presence of a configuration pragma Float_Representation (Vax_Float). -- It assumes integer sizes of 8, 16, 32 and 64 are available, and that IEEE -- floating-point formats are available. diff -Nrc3pad gcc-3.3.3/gcc/ada/7sinmaop.adb gcc-3.4.0/gcc/ada/7sinmaop.adb *** gcc-3.3.3/gcc/ada/7sinmaop.adb 2002-03-14 10:58:43.000000000 +0000 --- gcc-3.4.0/gcc/ada/7sinmaop.adb 2003-11-24 14:27:57.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. -- -- -- ------------------------------------------------------------------------------ *************** begin *** 326,336 **** Storage_Elements.To_Address (Storage_Elements.Integer_Address (SIG_IGN)); ! for I in Interrupt_ID loop ! if Keep_Unmasked (I) then ! Result := sigaddset (mask'Access, Signal (I)); pragma Assert (Result = 0); ! Result := sigdelset (allmask'Access, Signal (I)); pragma Assert (Result = 0); end if; end loop; --- 325,340 ---- Storage_Elements.To_Address (Storage_Elements.Integer_Address (SIG_IGN)); ! for J in Interrupt_ID loop ! ! -- We need to check whether J is in Keep_Unmasked because ! -- the index type of the Keep_Unmasked array is not always ! -- Interrupt_ID; it may be a subtype of Interrupt_ID. ! ! if J in Keep_Unmasked'Range and then Keep_Unmasked (J) then ! Result := sigaddset (mask'Access, Signal (J)); pragma Assert (Result = 0); ! Result := sigdelset (allmask'Access, Signal (J)); pragma Assert (Result = 0); end if; end loop; diff -Nrc3pad gcc-3.3.3/gcc/ada/7sintman.adb gcc-3.4.0/gcc/ada/7sintman.adb *** gcc-3.3.3/gcc/ada/7sintman.adb 2002-03-14 10:58:43.000000000 +0000 --- gcc-3.4.0/gcc/ada/7sintman.adb 2003-12-08 10:33:14.000000000 +0000 *************** *** 6,13 **** -- -- -- 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- -- --- 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,41 **** -- 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 default version of this package ! ! -- 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. --- 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 POSIX 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. *************** *** 52,67 **** -- signal handling, create a new s-intman.adb that will fit your needs. -- This file assumes that: ! -- -- SIGFPE, SIGILL, SIGSEGV and SIGBUS exist. They are mapped as follows: -- SIGPFE => Constraint_Error -- SIGILL => Program_Error -- SIGSEGV => Storage_Error -- SIGBUS => Storage_Error ! -- -- SIGINT exists and will be kept unmasked unless the pragma -- Unreserve_All_Interrupts is specified anywhere in the application. ! -- -- System.OS_Interface contains the following: -- SIGADAABORT: the signal that will be used to abort tasks. -- Unmasked: the OS specific set of signals that should be unmasked in --- 48,63 ---- -- signal handling, create a new s-intman.adb that will fit your needs. -- This file assumes that: ! -- SIGFPE, SIGILL, SIGSEGV and SIGBUS exist. They are mapped as follows: -- SIGPFE => Constraint_Error -- SIGILL => Program_Error -- SIGSEGV => Storage_Error -- SIGBUS => Storage_Error ! -- SIGINT exists and will be kept unmasked unless the pragma -- Unreserve_All_Interrupts is specified anywhere in the application. ! -- System.OS_Interface contains the following: -- SIGADAABORT: the signal that will be used to abort tasks. -- Unmasked: the OS specific set of signals that should be unmasked in *************** package body System.Interrupt_Management *** 110,116 **** begin -- With the __builtin_longjmp, the signal mask is not restored, so we ! -- need to restore it explicitly. Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null); pragma Assert (Result = 0); --- 106,112 ---- begin -- With the __builtin_longjmp, the signal mask is not restored, so we ! -- need to restore it explicitely. Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null); pragma Assert (Result = 0); *************** begin *** 152,158 **** declare act : aliased struct_sigaction; old_act : aliased struct_sigaction; ! Result : Interfaces.C.int; begin -- Need to call pthread_init very early because it is doing signal --- 148,169 ---- declare act : aliased struct_sigaction; old_act : aliased struct_sigaction; ! Result : System.OS_Interface.int; ! ! 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 -- Need to call pthread_init very early because it is doing signal *************** begin *** 164,170 **** 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 --- 175,190 ---- act.sa_handler := Notify_Exception'Address; ! act.sa_flags := SA_SIGINFO; ! ! -- Setting SA_SIGINFO asks the kernel to pass more than just the signal ! -- number argument to the handler when it is called. The set of extra ! -- parameters typically includes a pointer to a structure describing ! -- the interrupted context. Although the Notify_Exception handler does ! -- not use this information, it is actually required for the GCC/ZCX ! -- exception propagation scheme because on some targets (at least ! -- alpha-tru64), the structure contents are not even filled when this ! -- flag is not set. -- 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 *************** begin *** 175,225 **** -- 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 the same reason explained above, we can't mask these ! -- signals because otherwise we won't be able to catch more than ! -- one signal. act.sa_mask := Signal_Mask; ! Keep_Unmasked (Abort_Task_Interrupt) := True; ! -- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but at ! -- the same time, disable the ability of handling this signal via ! -- package 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; ! 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; 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; -- 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 --- 195,280 ---- -- 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 explicitely -- the mask in the exception handler. Result := sigemptyset (Signal_Mask'Access); pragma Assert (Result = 0); ! -- Add signals that map to Ada exceptions to the mask. ! for J in Exception_Interrupts'Range loop ! if State (Exception_Interrupts (J)) /= Default then ! Result := ! sigaddset (Signal_Mask'Access, Signal (Exception_Interrupts (J))); ! pragma Assert (Result = 0); ! end if; ! end loop; act.sa_mask := Signal_Mask; ! 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; ! if State (Exception_Interrupts (J)) /= Default then ! Result := ! sigaction ! (Signal (Exception_Interrupts (J)), act'Unchecked_Access, ! old_act'Unchecked_Access); ! pragma Assert (Result = 0); ! end if; ! 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 is not in "User" ! -- state. Check for Unreserve_All_Interrupts last ! ! if State (SIGINT) /= User then Keep_Unmasked (SIGINT) := True; + Reserve (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 the set of signals that must always be unmasked for this target + for J in Unmasked'Range loop Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True; + Reserve (Interrupt_ID (Unmasked (J))) := True; end loop; ! -- Add target-specific reserved signals for J in Reserved'Range loop Reserve (Interrupt_ID (Reserved (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 non-existent signals (see s-intnam.ads). Therefore, -- Signal 0 should not be used in all signal related operations hence diff -Nrc3pad gcc-3.3.3/gcc/ada/7sosinte.adb gcc-3.4.0/gcc/ada/7sosinte.adb *** gcc-3.3.3/gcc/ada/7sosinte.adb 2002-03-14 10:58:44.000000000 +0000 --- gcc-3.4.0/gcc/ada/7sosinte.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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 ---- -- -- -- 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 *** 79,86 **** F := F + 1.0; end if; ! return timespec' (tv_sec => S, ! tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; ---------------- --- 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; ---------------- *************** package body System.OS_Interface is *** 103,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; ------------- --- 102,111 ---- 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; ------------- diff -Nrc3pad gcc-3.3.3/gcc/ada/7sosprim.adb gcc-3.4.0/gcc/ada/7sosprim.adb *** gcc-3.3.3/gcc/ada/7sosprim.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/7sosprim.adb 2003-11-10 15:54:35.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-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_Primitives is *** 48,58 **** pragma Convention (C, struct_timezone); type struct_timezone_ptr is access all struct_timezone; ! type time_t is new Integer; type struct_timeval is record tv_sec : time_t; ! tv_usec : Integer; end record; pragma Convention (C, struct_timeval); --- 47,57 ---- pragma Convention (C, struct_timezone); type struct_timezone_ptr is access all struct_timezone; ! type time_t is new Long_Integer; type struct_timeval is record tv_sec : time_t; ! tv_usec : Long_Integer; end record; pragma Convention (C, struct_timeval); *************** package body System.OS_Primitives is *** 76,82 **** --- 75,83 ---- function Clock return Duration is TV : aliased struct_timeval; + Result : Integer; + pragma Unreferenced (Result); begin Result := gettimeofday (TV'Access, null); *************** package body System.OS_Primitives is *** 111,118 **** F := F + 1.0; end if; ! return timespec' (tv_sec => S, ! tv_nsec => Long_Integer (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; ----------------- --- 112,120 ---- F := F + 1.0; end if; ! return ! timespec'(tv_sec => S, ! tv_nsec => Long_Integer (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; ----------------- *************** package body System.OS_Primitives is *** 125,134 **** is Request : aliased timespec; Remaind : aliased timespec; - Result : Integer; Rel_Time : Duration; Abs_Time : Duration; Check_Time : Duration := Clock; begin if Mode = Relative then Rel_Time := Time; --- 127,139 ---- is Request : aliased timespec; Remaind : aliased timespec; Rel_Time : Duration; Abs_Time : Duration; Check_Time : Duration := Clock; + + Result : Integer; + pragma Unreferenced (Result); + begin if Mode = Relative then Rel_Time := Time; diff -Nrc3pad gcc-3.3.3/gcc/ada/7staprop.adb gcc-3.4.0/gcc/ada/7staprop.adb *** gcc-3.3.3/gcc/ada/7staprop.adb 2002-10-23 08:27:55.000000000 +0000 --- gcc-3.4.0/gcc/ada/7staprop.adb 2004-01-05 15:20:43.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- -- *************** *** 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.Task_Primitives.Oper *** 111,116 **** --- 110,118 ---- -- 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 *** 139,153 **** FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; -- Indicates whether FIFO_Within_Priorities is set. ! ----------------------- ! -- 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 -- --- 141,148 ---- 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 body System.Task_Primitives.Oper *** 159,164 **** --- 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 *** 172,177 **** --- 171,196 ---- 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. + -- See also comment before body, below. + + function To_Address is new Unchecked_Conversion (Task_ID, System.Address); + ------------------- -- Abort_Handler -- ------------------- *************** package body System.Task_Primitives.Oper *** 196,232 **** -- 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). ! ! -- The following procedure would be needed if we can't lonjmp out of ! -- a signal handler (See below) ! ! -- procedure Raise_Abort_Signal is ! -- begin ! -- raise Standard'Abort_Signal; ! -- end if; ! ! procedure Abort_Handler ! (Sig : Signal) is T : Task_ID := Self; Result : Interfaces.C.int; Old_Set : aliased sigset_t; begin ! -- Assuming it is safe to longjmp out of a signal handler, the ! -- following code can be used: if T.Deferral_Level = 0 and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then --- 215,234 ---- -- systems do not restore the signal mask on longjmp(), leaving the -- abort signal masked. ! procedure Abort_Handler (Sig : Signal) is ! pragma Warnings (Off, 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 *************** package body System.Task_Primitives.Oper *** 242,256 **** raise Standard'Abort_Signal; end if; - - -- Otherwise, something like this is required: - -- if not Abort_Is_Deferred.all then - -- -- Overwrite the return PC address with the address of the - -- -- special raise routine, and "return" to that routine's - -- -- starting address. - -- Context.PC := Raise_Abort_Signal'Address; - -- return; - -- end if; end Abort_Handler; ----------------- --- 244,249 ---- *************** package body System.Task_Primitives.Oper *** 265,270 **** --- 258,264 ---- begin if Stack_Base_Available then + -- Compute the guard page address Guard_Page_Address := *************** package body System.Task_Primitives.Oper *** 300,306 **** --------------------- -- 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 --- 294,300 ---- --------------------- -- Note: mutexes and cond_variables needed per-task basis are ! -- initialized in Intialize_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 *************** package body System.Task_Primitives.Oper *** 348,355 **** end Initialize_Lock; procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is Attributes : aliased pthread_mutexattr_t; ! Result : Interfaces.C.int; begin Result := pthread_mutexattr_init (Attributes'Access); --- 342,351 ---- end Initialize_Lock; procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Warnings (Off, Level); + Attributes : aliased pthread_mutexattr_t; ! Result : Interfaces.C.int; begin Result := pthread_mutexattr_init (Attributes'Access); *************** package body System.Task_Primitives.Oper *** 392,397 **** --- 388,394 ---- procedure Finalize_Lock (L : access Lock) is Result : Interfaces.C.int; + begin Result := pthread_mutex_destroy (L); pragma Assert (Result = 0); *************** package body System.Task_Primitives.Oper *** 399,404 **** --- 396,402 ---- procedure Finalize_Lock (L : access RTS_Lock) is Result : Interfaces.C.int; + begin Result := pthread_mutex_destroy (L); pragma Assert (Result = 0); *************** package body System.Task_Primitives.Oper *** 410,415 **** --- 408,414 ---- 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 *** 420,428 **** 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); --- 419,429 ---- 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 *** 432,437 **** --- 433,439 ---- 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 *** 454,459 **** --- 456,462 ---- 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 *** 461,466 **** --- 464,470 ---- 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 *** 470,475 **** --- 474,480 ---- 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 *** 485,491 **** --- 490,499 ---- (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is + pragma Warnings (Off, Reason); + Result : Interfaces.C.int; + begin if Single_Lock then Result := pthread_cond_wait *************** package body System.Task_Primitives.Oper *** 516,521 **** --- 524,531 ---- Timedout : out Boolean; Yielded : out Boolean) is + pragma Warnings (Off, Reason); + Check_Time : constant Duration := Monotonic_Clock; Rel_Time : Duration; Abs_Time : Duration; *************** package body System.Task_Primitives.Oper *** 700,706 **** --- 710,719 ---- ------------ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is + pragma Warnings (Off, 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 *** 712,717 **** --- 725,731 ---- 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 *** 727,732 **** --- 741,748 ---- Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is + pragma Warnings (Off, Loss_Of_Inheritance); + Result : Interfaces.C.int; Param : aliased struct_sched_param; *************** package body System.Task_Primitives.Oper *** 792,800 **** return new Ada_Task_Control_Block (Entry_Num); end New_ATCB; ! ---------------------- ! -- Initialize_TCB -- ! ---------------------- procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is Mutex_Attr : aliased pthread_mutexattr_t; --- 808,835 ---- 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; *************** package body System.Task_Primitives.Oper *** 813,825 **** pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then ! Result := pthread_mutexattr_setprotocol ! (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT); ! pragma Assert (Result = 0); ! Result := pthread_mutexattr_setprioceiling ! (Mutex_Attr'Access, Interfaces.C.int (System.Any_Priority'Last)); ! pragma Assert (Result = 0); Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); --- 848,868 ---- pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then ! if Locking_Policy = 'C' then ! Result := pthread_mutexattr_setprotocol ! (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT); ! pragma Assert (Result = 0); ! Result := pthread_mutexattr_setprioceiling ! (Mutex_Attr'Access, ! Interfaces.C.int (System.Any_Priority'Last)); ! pragma Assert (Result = 0); ! ! elsif Locking_Policy = 'I' then ! Result := pthread_mutexattr_setprotocol ! (Mutex_Attr'Access, PTHREAD_PRIO_INHERIT); ! pragma Assert (Result = 0); ! end if; Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); *************** package body System.Task_Primitives.Oper *** 954,959 **** --- 997,1003 ---- 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 *** 972,977 **** --- 1016,1027 ---- 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 *** 980,986 **** procedure Exit_Task is begin ! pthread_exit (System.Null_Address); end Exit_Task; ---------------- --- 1030,1039 ---- procedure Exit_Task is begin ! -- Mark this task as unknown, so that if Self is called, it won't ! -- return a dangling pointer. ! ! Specific.Set (null); end Exit_Task; ---------------- *************** package body System.Task_Primitives.Oper *** 1000,1009 **** -- 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; --- 1053,1063 ---- -- Check_Exit -- ---------------- ! -- Dummy version function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + pragma Warnings (Off, Self_ID); + begin return True; end Check_Exit; *************** package body System.Task_Primitives.Oper *** 1013,1018 **** --- 1067,1074 ---- -------------------- function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + pragma Warnings (Off, Self_ID); + begin return True; end Check_No_Locks; *************** package body System.Task_Primitives.Oper *** 1050,1056 **** function Suspend_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin return False; end Suspend_Task; --- 1106,1117 ---- 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 *** 1061,1067 **** function Resume_Task (T : ST.Task_ID; ! Thread_Self : Thread_Id) return Boolean is begin return False; end Resume_Task; --- 1122,1133 ---- 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 *** 1076,1081 **** --- 1142,1161 ---- 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 *** 1089,1108 **** -- 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 --- 1169,1191 ---- -- 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 diff -Nrc3pad gcc-3.3.3/gcc/ada/7staspri.ads gcc-3.4.0/gcc/ada/7staspri.ads *** gcc-3.3.3/gcc/ada/7staspri.ads 2002-03-14 10:58:44.000000000 +0000 --- gcc-3.4.0/gcc/ada/7staspri.ads 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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 ---- -- -- -- 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/7stfsetr.adb gcc-3.4.0/gcc/ada/7stfsetr.adb *** gcc-3.3.3/gcc/ada/7stfsetr.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/7stfsetr.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 0 **** --- 1,313 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . T R A C E S . S E N D -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2001-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. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This version is for all targets, provided that System.IO.Put_Line is + -- functional. It prints debug information to Standard Output + + with System.IO; use System.IO; + with GNAT.Regpat; use GNAT.Regpat; + + ---------------- + -- Send_Trace -- + ---------------- + + -- Prints debug information both in a human readable form + -- and in the form they are sent from upper layers. + + separate (System.Traces.Format) + procedure Send_Trace (Id : Trace_T; Info : String) is + + type Param_Type is + (Name_Param, + Caller_Param, + Entry_Param, + Timeout_Param, + Acceptor_Param, + Parent_Param, + Number_Param); + -- Type of parameter found in the message + + Info_Trace : String_Trace := Format_Trace (Info); + + function Get_Param + (Input : String_Trace; + Param : Param_Type; + How_Many : Integer) + return String; + -- Extract a parameter from the given input string + + --------------- + -- Get_Param -- + --------------- + + function Get_Param + (Input : String_Trace; + Param : Param_Type; + How_Many : Integer) + return String + is + pragma Unreferenced (How_Many); + + Matches : Match_Array (1 .. 2); + begin + -- We need comments here ??? + + case Param is + when Name_Param => + Match ("/N:([\w]+)", Input, Matches); + + when Caller_Param => + Match ("/C:([\w]+)", Input, Matches); + + when Entry_Param => + Match ("/E:([\s]*) +([0-9 ,]+)", Input, Matches); + + when Timeout_Param => + Match ("/T:([\s]*) +([0-9]+.[0-9]+)", Input, Matches); + + when Acceptor_Param => + Match ("/A:([\w]+)", Input, Matches); + + when Parent_Param => + Match ("/P:([\w]+)", Input, Matches); + + when Number_Param => + Match ("/#:([\s]*) +([0-9]+)", Input, Matches); + end case; + + if Matches (1).First < Input'First then + return ""; + end if; + + case Param is + when Timeout_Param | Entry_Param | Number_Param => + return Input (Matches (2).First .. Matches (2).Last); + + when others => + return Input (Matches (1).First .. Matches (1).Last); + end case; + end Get_Param; + + -- Start of processing for Send_Trace + + begin + New_Line; + Put_Line ("- Trace Debug Info ----------------"); + Put ("Caught event Id : "); + + case Id is + when M_Accept_Complete => Put ("M_Accept_Complete"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " completes accept on entry " + & Get_Param (Info_Trace, Entry_Param, 1) & " with " + & Get_Param (Info_Trace, Caller_Param, 1)); + + when M_Select_Else => Put ("M_Select_Else"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " selects else statement"); + + when M_RDV_Complete => Put ("M_RDV_Complete"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " completes rendezvous with " + & Get_Param (Info_Trace, Caller_Param, 1)); + + when M_Call_Complete => Put ("M_Call_Complete"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " completes call"); + + when M_Delay => Put ("M_Delay"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " completes delay " + & Get_Param (Info_Trace, Timeout_Param, 1)); + + when E_Missed => Put ("E_Missed"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " got an invalid acceptor " + & Get_Param (Info_Trace, Acceptor_Param, 1)); + + when E_Timeout => Put ("E_Timeout"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " ends select due to timeout "); + + when E_Kill => Put ("E_Kill"); + New_Line; + Put_Line ("Asynchronous Transfer of Control on task " + & Get_Param (Info_Trace, Name_Param, 1)); + + when W_Delay => Put ("W_Delay"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " sleeping " + & Get_Param (Info_Trace, Timeout_Param, 1) + & " seconds"); + + when WU_Delay => Put ("WU_Delay"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " sleeping until " + & Get_Param (Info_Trace, Timeout_Param, 1)); + + when W_Call => Put ("W_Call"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " calling entry " + & Get_Param (Info_Trace, Entry_Param, 1) + & " of " & Get_Param (Info_Trace, Acceptor_Param, 1)); + + when W_Accept => Put ("W_Accept"); + New_Line; + Put ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " waiting on " + & Get_Param (Info_Trace, Number_Param, 1) + & " accept(s)" + & ", " & Get_Param (Info_Trace, Entry_Param, 1)); + New_Line; + + when W_Select => Put ("W_Select"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " waiting on " + & Get_Param (Info_Trace, Number_Param, 1) + & " select(s)" + & ", " & Get_Param (Info_Trace, Entry_Param, 1)); + New_Line; + + when W_Completion => Put ("W_Completion"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " waiting for completion "); + + when WT_Select => Put ("WT_Select"); + New_Line; + Put ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " waiting " & Get_Param (Info_Trace, Timeout_Param, 1) + & " seconds on " + & Get_Param (Info_Trace, Number_Param, 1) + & " select(s)"); + + if Get_Param (Info_Trace, Number_Param, 1) /= "" then + Put (", " & Get_Param (Info_Trace, Entry_Param, 1)); + end if; + + New_Line; + + when WT_Call => Put ("WT_Call"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " calling entry " + & Get_Param (Info_Trace, Entry_Param, 1) + & " of " & Get_Param (Info_Trace, Acceptor_Param, 1) + & " with timeout " + & Get_Param (Info_Trace, Timeout_Param, 1)); + + when WT_Completion => Put ("WT_Completion"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " waiting " + & Get_Param (Info_Trace, Timeout_Param, 1) + & " for call completion"); + + when PO_Call => Put ("PO_Call"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " calling protected entry " + & Get_Param (Info_Trace, Entry_Param, 1)); + + when POT_Call => Put ("POT_Call"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " calling protected entry " + & Get_Param (Info_Trace, Entry_Param, 1) + & " with timeout " + & Get_Param (Info_Trace, Timeout_Param, 1)); + + when PO_Run => Put ("PO_Run"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " running entry " + & Get_Param (Info_Trace, Entry_Param, 1) + & " for " + & Get_Param (Info_Trace, Caller_Param, 1)); + + when PO_Done => Put ("PO_Done"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " finished call from " + & Get_Param (Info_Trace, Caller_Param, 1)); + + when PO_Lock => Put ("PO_Lock"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " took lock"); + + when PO_Unlock => Put ("PO_Unlock"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " released lock"); + + when T_Create => Put ("T_Create"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " created"); + + when T_Activate => Put ("T_Activate"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " activated"); + + when T_Abort => Put ("T_Abort"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " aborted by " + & Get_Param (Info_Trace, Parent_Param, 1)); + + when T_Terminate => Put ("T_Terminate"); + New_Line; + Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1) + & " terminated"); + + when others + => Put ("Invalid Id"); + end case; + + Put_Line (" --> " & Info_Trace); + Put_Line ("-----------------------------------"); + New_Line; + end Send_Trace; diff -Nrc3pad gcc-3.3.3/gcc/ada/7stpopsp.adb gcc-3.4.0/gcc/ada/7stpopsp.adb *** gcc-3.3.3/gcc/ada/7stpopsp.adb 2002-03-14 10:58:44.000000000 +0000 --- gcc-3.4.0/gcc/ada/7stpopsp.adb 2004-01-05 15:20:43.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) 1992-2003, 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- -- *************** *** 27,73 **** -- 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 FSU-like version of this package. 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 - ---------------- -- 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); 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); --- 26,68 ---- -- 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 POSIX-like 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 := 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 *** 78,89 **** ---------- 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; end Specific; --- 73,81 ---- ---------- function Self return Task_ID is begin ! return To_Task_Id (pthread_getspecific (ATCB_Key)); end Self; end Specific; diff -Nrc3pad gcc-3.3.3/gcc/ada/7straceb.adb gcc-3.4.0/gcc/ada/7straceb.adb *** gcc-3.3.3/gcc/ada/7straceb.adb 2002-03-14 10:58:44.000000000 +0000 --- gcc-3.4.0/gcc/ada/7straceb.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1999-2000 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) 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- -- *************** *** 28,34 **** -- 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). -- -- -- ------------------------------------------------------------------------------ --- 27,33 ---- -- 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 *** 49,84 **** (Traceback : System.Address; Max_Len : Natural; Len : out Natural; ! Exclude_Min, ! Exclude_Max : System.Address := System.Null_Address) is type Tracebacks_Array is array (1 .. Max_Len) of Code_Loc; pragma Suppress_Initialization (Tracebacks_Array); M : Machine_State; Code : Code_Loc; ! J : Natural := 1; Trace : Tracebacks_Array; for Trace'Address use Traceback; begin M := Allocate_Machine_State; Set_Machine_State (M); loop Code := Get_Code_Loc (M); ! exit when Code = Null_Address or else J = Max_Len + 1; if Code < Exclude_Min or else Code > Exclude_Max then ! Trace (J) := Code; ! J := J + 1; end if; Pop_Frame (M, System.Null_Address); end loop; - Len := J - 1; Free_Machine_State (M); end Call_Chain; --- 48,98 ---- (Traceback : System.Address; 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 Code_Loc; pragma Suppress_Initialization (Tracebacks_Array); M : Machine_State; Code : Code_Loc; ! Trace : Tracebacks_Array; for Trace'Address use Traceback; + N_Skips : Natural := 0; + begin M := Allocate_Machine_State; Set_Machine_State (M); + -- Skip the requested number of frames + loop Code := Get_Code_Loc (M); + exit when Code = Null_Address or else N_Skips = Skip_Frames; ! Pop_Frame (M, System.Null_Address); ! N_Skips := N_Skips + 1; ! end loop; ! ! -- Now, record the frames outside the exclusion bounds, updating ! -- the Len output value along the way. ! ! Len := 0; ! loop ! Code := Get_Code_Loc (M); ! exit when Code = Null_Address or else Len = Max_Len; if Code < Exclude_Min or else Code > Exclude_Max then ! Len := Len + 1; ! Trace (Len) := Code; end if; Pop_Frame (M, System.Null_Address); end loop; Free_Machine_State (M); end Call_Chain; diff -Nrc3pad gcc-3.3.3/gcc/ada/7straces.adb gcc-3.4.0/gcc/ada/7straces.adb *** gcc-3.3.3/gcc/ada/7straces.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/7straces.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . T R A C E S -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 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. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + with System.Soft_Links; + with System.Parameters; + with System.Traces.Format; + + package body System.Traces is + + package SSL renames System.Soft_Links; + use System.Traces.Format; + + ---------------------- + -- Send_Trace_Info -- + ---------------------- + + procedure Send_Trace_Info (Id : Trace_T) is + Task_S : String := SSL.Task_Name.all; + Trace_S : String (1 .. 3 + Task_S'Length); + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. Trace_S'Last) := Task_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info (Id : Trace_T; Timeout : Duration) is + Task_S : String := SSL.Task_Name.all; + Timeout_S : String := Duration'Image (Timeout); + Trace_S : String (1 .. 6 + Task_S'Length + Timeout_S'Length); + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + Task_S'Length) := Task_S; + Trace_S (4 + Task_S'Length .. 6 + Task_S'Length) := "/T:"; + Trace_S (7 + Task_S'Length .. Trace_S'Last) := Timeout_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + end System.Traces; diff -Nrc3pad gcc-3.3.3/gcc/ada/7strafor.adb gcc-3.4.0/gcc/ada/7strafor.adb *** gcc-3.3.3/gcc/ada/7strafor.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/7strafor.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 0 **** --- 1,113 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . T R A C E S . F O R M A T -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 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. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + with System.Parameters; + + package body System.Traces.Format is + + procedure Send_Trace (Id : Trace_T; Info : String) is separate; + + ------------------ + -- Format_Trace -- + ------------------ + + function Format_Trace (Source : in String) return String_Trace is + Length : Integer := Source'Length; + Result : String_Trace := (others => ' '); + + begin + -- If run-time tracing active, then fill the string + + if Parameters.Runtime_Traces then + if Max_Size - Length > 0 then + Result (1 .. Length) := Source (1 .. Length); + Result (Length + 1 .. Max_Size) := (others => ' '); + Result (Length + 1) := ASCII.NUL; + else + Result (1 .. Max_Size - 1) := Source (1 .. Max_Size - 1); + Result (Max_Size) := ASCII.NUL; + end if; + end if; + + return Result; + end Format_Trace; + + ------------ + -- Append -- + ------------ + + function Append + (Source : String_Trace; + Annex : String) + return String_Trace + is + Result : String_Trace := (others => ' '); + Source_Length : Integer := 1; + Annex_Length : Integer := Annex'Length; + + begin + if Parameters.Runtime_Traces then + + -- First we determine the size used, without the spaces at the + -- end, if a String_Trace is present. Look at + -- System.Traces.Tasking for examples. + + while Source (Source_Length) /= ASCII.NUL loop + Source_Length := Source_Length + 1; + end loop; + + -- Then we fill the string. + + if Source_Length - 1 + Annex_Length <= Max_Size then + Result (1 .. Source_Length - 1) := + Source (1 .. Source_Length - 1); + + Result (Source_Length .. Source_Length - 1 + Annex_Length) := + Annex (1 .. Annex_Length); + + Result (Source_Length + Annex_Length) := ASCII.NUL; + + Result (Source_Length + Annex_Length + 1 .. Max_Size) := + (others => ' '); + else + Result (1 .. Source_Length - 1) := Source (1 .. Source_Length - 1); + Result (Source_Length .. Max_Size - 1) := + Annex (1 .. Max_Size - Source_Length); + Result (Max_Size) := ASCII.NUL; + end if; + end if; + + return Result; + end Append; + + end System.Traces.Format; diff -Nrc3pad gcc-3.3.3/gcc/ada/7strafor.ads gcc-3.4.0/gcc/ada/7strafor.ads *** gcc-3.3.3/gcc/ada/7strafor.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/7strafor.ads 2003-10-21 13:41:53.000000000 +0000 *************** *** 0 **** --- 1,62 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . T R A C E S . F O R M A T -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 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. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package implements functions to format run-time traces + + package System.Traces.Format is + + Max_Size : constant Integer := 128; + -- Event messages' maximum size. + + subtype String_Trace is String (1 .. Max_Size); + -- Specific type in which trace information is stored. An ASCII.NUL + -- character ends the string so that it is compatible with C strings + -- which is useful on some targets (eg. VxWorks) + + -- These private functions handles String_Trace formatting + + function Format_Trace (Source : String) return String_Trace; + -- Put a String in a String_Trace, truncates the string if necessary. + -- Similar to Head( .. ) found in Ada.Strings.Bounded + + function Append + (Source : String_Trace; + Annex : String) + return String_Trace; + pragma Inline (Append); + -- Concatenates two string, similar to & operator from Ada.String.Unbounded + + procedure Send_Trace (Id : Trace_T; Info : String); + -- This function (which is a subunit) send messages to external programs + + end System.Traces.Format; diff -Nrc3pad gcc-3.3.3/gcc/ada/7stratas.adb gcc-3.4.0/gcc/ada/7stratas.adb *** gcc-3.3.3/gcc/ada/7stratas.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/7stratas.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 0 **** --- 1,367 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- + -- -- + -- S Y S T E M . T R A C E S . T A S K I N G -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2001-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. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + with System.Tasking; use System.Tasking; + with System.Soft_Links; + with System.Parameters; + with System.Traces.Format; use System.Traces.Format; + with System.Traces; use System.Traces; + + package body System.Traces.Tasking is + + use System.Tasking; + use System.Traces; + use System.Traces.Format; + + package SSL renames System.Soft_Links; + + function Extract_Accepts (Task_Name : Task_ID) return String_Trace; + -- This function is used to extract data joined with + -- W_Select, WT_Select, W_Accept events + + --------------------- + -- Send_Trace_Info -- + --------------------- + + procedure Send_Trace_Info (Id : Trace_T; Task_Name2 : Task_ID) is + Task_S : constant String := SSL.Task_Name.all; + Task2_S : constant String := + Task_Name2.Common.Task_Image + (1 .. Task_Name2.Common.Task_Image_Len); + Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length); + + L0 : Integer := Task_S'Length; + L1 : Integer := Task2_S'Length; + + begin + if Parameters.Runtime_Traces then + case Id is + when M_RDV_Complete | PO_Done => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/C:"; + Trace_S (7 + L0 .. Trace_S'Last) := Task2_S; + Send_Trace (Id, Trace_S); + + when E_Missed => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/A:"; + Trace_S (7 + L0 .. Trace_S'Last) := Task2_S; + Send_Trace (Id, Trace_S); + + when E_Kill => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L1) := Task2_S; + Trace_S (4 + L1 .. Trace_S'Last) := (others => ' '); + Send_Trace (Id, Trace_S); + + when T_Create => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L1) := Task2_S; + Trace_S (4 + L1 .. Trace_S'Last) := (others => ' '); + Send_Trace (Id, Trace_S); + + when others => + null; + -- should raise an exception ??? + end case; + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name2 : Task_ID; + Entry_Number : Entry_Index) + is + Task_S : constant String := SSL.Task_Name.all; + Task2_S : constant String := + Task_Name2.Common.Task_Image + (1 .. Task_Name2.Common.Task_Image_Len); + Entry_S : String := Integer'Image (Integer (Entry_Number)); + Trace_S : String (1 .. 9 + Task_S'Length + + Task2_S'Length + Entry_S'Length); + + L0 : Integer := Task_S'Length; + L1 : Integer := Task_S'Length + Entry_S'Length; + L2 : Integer := Task_S'Length + Task2_S'Length; + + begin + if Parameters.Runtime_Traces then + case Id is + when M_Accept_Complete => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/E:"; + Trace_S (7 + L0 .. 6 + L1) := Entry_S; + Trace_S (7 + L1 .. 9 + L1) := "/C:"; + Trace_S (10 + L1 .. Trace_S'Last) := Task2_S; + Send_Trace (Id, Trace_S); + + when W_Call => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/A:"; + Trace_S (7 + L0 .. 6 + L2) := Task2_S; + Trace_S (7 + L2 .. 9 + L2) := "/C:"; + Trace_S (10 + L2 .. Trace_S'Last) := Entry_S; + Send_Trace (Id, Trace_S); + + when others => + null; + -- should raise an exception ??? + end case; + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : Task_ID; + Task_Name2 : Task_ID; + Entry_Number : Entry_Index) + is + Task_S : constant String := + Task_Name.Common.Task_Image + (1 .. Task_Name.Common.Task_Image_Len); + Task2_S : constant String := + Task_Name2.Common.Task_Image + (1 .. Task_Name2.Common.Task_Image_Len); + Entry_S : String := Integer'Image (Integer (Entry_Number)); + Trace_S : String (1 .. 9 + Task_S'Length + + Task2_S'Length + Entry_S'Length); + + L0 : Integer := Task_S'Length; + L1 : Integer := Task_S'Length + Entry_S'Length; + + begin + if Parameters.Runtime_Traces then + case Id is + when PO_Run => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/E:"; + Trace_S (7 + L0 .. 6 + L1) := Entry_S; + Trace_S (7 + L1 .. 9 + L1) := "/C:"; + Trace_S (10 + L1 .. Trace_S'Last) := Task2_S; + Send_Trace (Id, Trace_S); + + when others => + null; + -- should raise an exception ??? + end case; + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info (Id : Trace_T; Entry_Number : Entry_Index) is + Task_S : String := SSL.Task_Name.all; + Entry_S : String := Integer'Image (Integer (Entry_Number)); + Trace_S : String (1 .. 6 + Task_S'Length + Entry_S'Length); + + L0 : Integer := Task_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/E:"; + Trace_S (7 + L0 .. Trace_S'Last) := Entry_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : Task_ID; + Task_Name2 : Task_ID) + is + Task_S : constant String := + Task_Name.Common.Task_Image + (1 .. Task_Name.Common.Task_Image_Len); + Task2_S : constant String := + Task_Name2.Common.Task_Image + (1 .. Task_Name2.Common.Task_Image_Len); + Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length); + + L0 : Integer := Task2_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task2_S; + Trace_S (4 + L0 .. 6 + L0) := "/P:"; + Trace_S (7 + L0 .. Trace_S'Last) := Task_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Acceptor : Task_ID; + Entry_Number : Entry_Index; + Timeout : Duration) + is + Task_S : constant String := SSL.Task_Name.all; + Acceptor_S : constant String := + Acceptor.Common.Task_Image + (1 .. Acceptor.Common.Task_Image_Len); + Entry_S : String := Integer'Image (Integer (Entry_Number)); + Timeout_S : String := Duration'Image (Timeout); + Trace_S : String (1 .. 12 + Task_S'Length + Acceptor_S'Length + + Entry_S'Length + Timeout_S'Length); + + L0 : Integer := Task_S'Length; + L1 : Integer := Task_S'Length + Acceptor_S'Length; + L2 : Integer := Task_S'Length + Acceptor_S'Length + Entry_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/A:"; + Trace_S (7 + L0 .. 6 + L1) := Acceptor_S; + Trace_S (7 + L1 .. 9 + L1) := "/E:"; + Trace_S (10 + L1 .. 9 + L2) := Entry_S; + Trace_S (10 + L2 .. 12 + L2) := "/T:"; + Trace_S (13 + L2 .. Trace_S'Last) := Timeout_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Entry_Number : Entry_Index; + Timeout : Duration) + is + Task_S : String := SSL.Task_Name.all; + Entry_S : String := Integer'Image (Integer (Entry_Number)); + Timeout_S : String := Duration'Image (Timeout); + Trace_S : String (1 .. 9 + Task_S'Length + + Entry_S'Length + Timeout_S'Length); + + L0 : Integer := Task_S'Length; + L1 : Integer := Task_S'Length + Entry_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/E:"; + Trace_S (7 + L0 .. 6 + L1) := Entry_S; + Trace_S (7 + L1 .. 9 + L1) := "/T:"; + Trace_S (10 + L1 .. Trace_S'Last) := Timeout_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : Task_ID; + Number : Integer) + is + Task_S : String := SSL.Task_Name.all; + Number_S : String := Integer'Image (Number); + Accepts_S : String := Extract_Accepts (Task_Name); + Trace_S : String (1 .. 9 + Task_S'Length + + Number_S'Length + Accepts_S'Length); + + L0 : Integer := Task_S'Length; + L1 : Integer := Task_S'Length + Number_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/#:"; + Trace_S (7 + L0 .. 6 + L1) := Number_S; + Trace_S (7 + L1 .. 9 + L1) := "/E:"; + Trace_S (10 + L1 .. Trace_S'Last) := Accepts_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : Task_ID; + Number : Integer; + Timeout : Duration) + is + Task_S : String := SSL.Task_Name.all; + Timeout_S : String := Duration'Image (Timeout); + Number_S : String := Integer'Image (Number); + Accepts_S : String := Extract_Accepts (Task_Name); + Trace_S : String (1 .. 12 + Task_S'Length + Timeout_S'Length + + Number_S'Length + Accepts_S'Length); + + L0 : Integer := Task_S'Length; + L1 : Integer := Task_S'Length + Timeout_S'Length; + L2 : Integer := Task_S'Length + Timeout_S'Length + Number_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/T:"; + Trace_S (7 + L0 .. 6 + L1) := Timeout_S; + Trace_S (7 + L1 .. 9 + L1) := "/#:"; + Trace_S (10 + L1 .. 9 + L2) := Number_S; + Trace_S (10 + L2 .. 12 + L2) := "/E:"; + Trace_S (13 + L2 .. Trace_S'Last) := Accepts_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + --------------------- + -- Extract_Accepts -- + --------------------- + + -- This function returns a string in which all opened + -- Accepts or Selects are given, separated by semi-colons. + + function Extract_Accepts (Task_Name : Task_ID) return String_Trace is + Info_Annex : String_Trace := (ASCII.NUL, others => ' '); + + begin + for J in Task_Name.Open_Accepts'First .. + Task_Name.Open_Accepts'Last - 1 + loop + Info_Annex := Append (Info_Annex, Integer'Image + (Integer (Task_Name.Open_Accepts (J).S)) & ","); + end loop; + + Info_Annex := Append (Info_Annex, + Integer'Image (Integer + (Task_Name.Open_Accepts + (Task_Name.Open_Accepts'Last).S))); + return Info_Annex; + end Extract_Accepts; + end System.Traces.Tasking; diff -Nrc3pad gcc-3.3.3/gcc/ada/86numaux.adb gcc-3.4.0/gcc/ada/86numaux.adb *** gcc-3.3.3/gcc/ada/86numaux.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/86numaux.adb 2003-04-24 17:53:52.000000000 +0000 *************** *** 7,13 **** -- B o d y -- -- (Machine Version for x86) -- -- -- - -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- --- 7,12 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/86numaux.ads gcc-3.4.0/gcc/ada/86numaux.ads *** gcc-3.3.3/gcc/ada/86numaux.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/86numaux.ads 2003-04-24 17:53:52.000000000 +0000 *************** *** 7,13 **** -- S p e c -- -- (Machine Version for x86) -- -- -- - -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- --- 7,12 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/9drpc.adb gcc-3.4.0/gcc/ada/9drpc.adb *** gcc-3.3.3/gcc/ada/9drpc.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/9drpc.adb 2003-10-21 13:41:53.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 ---- *************** package body System.RPC is *** 1010,1016 **** Partition_ID'Image (Partition)); Garbage_Collector.Allocate (Anonymous); ! -- We subtracted the size of the header from the size of the -- global message in order to provide immediatly Params size Anonymous.Element.Start --- 1009,1015 ---- Partition_ID'Image (Partition)); Garbage_Collector.Allocate (Anonymous); ! -- We substracted the size of the header from the size of the -- global message in order to provide immediatly Params size Anonymous.Element.Start diff -Nrc3pad gcc-3.3.3/gcc/ada/a-astaco.adb gcc-3.4.0/gcc/ada/a-astaco.adb *** gcc-3.3.3/gcc/ada/a-astaco.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-astaco.adb 2003-04-24 17:53:52.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992,1993,1994,1995 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/a-astaco.ads gcc-3.4.0/gcc/ada/a-astaco.ads *** gcc-3.3.3/gcc/ada/a-astaco.ads 2002-03-14 10:58:45.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-astaco.ads 2003-04-24 17:53:52.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-caldel.adb gcc-3.4.0/gcc/ada/a-caldel.adb *** gcc-3.3.3/gcc/ada/a-caldel.adb 2002-03-14 10:58:45.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-caldel.adb 2003-10-21 13:41:53.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. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/a-caldel.ads gcc-3.4.0/gcc/ada/a-caldel.ads *** gcc-3.3.3/gcc/ada/a-caldel.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-caldel.ads 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1998, 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/a-calend.adb gcc-3.4.0/gcc/ada/a-calend.adb *** gcc-3.3.3/gcc/ada/a-calend.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-calend.adb 2003-04-24 17:53:52.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/a-calend.ads gcc-3.4.0/gcc/ada/a-calend.ads *** gcc-3.3.3/gcc/ada/a-calend.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-calend.ads 2003-04-24 17:53:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-chahan.adb gcc-3.4.0/gcc/ada/a-chahan.adb *** gcc-3.3.3/gcc/ada/a-chahan.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-chahan.adb 2003-04-24 17:53:52.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/a-chahan.ads gcc-3.4.0/gcc/ada/a-chahan.ads *** gcc-3.3.3/gcc/ada/a-chahan.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-chahan.ads 2003-04-24 17:53:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-charac.ads gcc-3.4.0/gcc/ada/a-charac.ads *** gcc-3.3.3/gcc/ada/a-charac.ads 2002-03-14 10:58:46.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-charac.ads 2003-10-21 13:41:53.000000000 +0000 *************** *** 1,4 **** ! ----------------------------------------------------------------------------- -- -- -- GNAT RUNTIME COMPONENTS -- -- -- --- 1,4 ---- ! ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- *************** *** 14,20 **** -- -- ------------------------------------------------------------------------------ - package Ada.Characters is pragma Pure (Characters); --- 13,18 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-chlat1.ads gcc-3.4.0/gcc/ada/a-chlat1.ads *** gcc-3.3.3/gcc/ada/a-chlat1.ads 2002-03-14 10:58:46.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-chlat1.ads 2003-04-24 17:53:52.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-chlat9.ads gcc-3.4.0/gcc/ada/a-chlat9.ads *** gcc-3.3.3/gcc/ada/a-chlat9.ads 2002-10-28 16:19:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-chlat9.ads 2003-04-24 17:53:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 2002 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/a-colien.adb gcc-3.4.0/gcc/ada/a-colien.adb *** gcc-3.3.3/gcc/ada/a-colien.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-colien.adb 2003-04-24 17:53:52.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1996-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/a-colien.ads gcc-3.4.0/gcc/ada/a-colien.ads *** gcc-3.3.3/gcc/ada/a-colien.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-colien.ads 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1996-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) 1996-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- -- *************** *** 32,37 **** --- 31,42 ---- -- -- ------------------------------------------------------------------------------ + -- Note: Services offered by this package are guaranteed to be platform + -- independent as long as no call to GNAT.OS_Lib.Setenv or to C putenv + -- routine is done. On some platforms the services below will report new + -- environment variables (e.g. Windows) on some others it will not + -- (e.g. GNU/Linux and Solaris). + package Ada.Command_Line.Environment is function Environment_Count return Natural; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-colire.adb gcc-3.4.0/gcc/ada/a-colire.adb *** gcc-3.3.3/gcc/ada/a-colire.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-colire.adb 2003-04-24 17:53:52.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 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/a-colire.ads gcc-3.4.0/gcc/ada/a-colire.ads *** gcc-3.3.3/gcc/ada/a-colire.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-colire.ads 2003-04-24 17:53:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 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/a-comlin.adb gcc-3.4.0/gcc/ada/a-comlin.adb *** gcc-3.3.3/gcc/ada/a-comlin.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-comlin.adb 2003-10-21 13:41:53.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-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,38 **** -- -- ------------------------------------------------------------------------------ ! with System; package body Ada.Command_Line is function Arg_Count return Natural; --- 31,38 ---- -- -- ------------------------------------------------------------------------------ ! with System; use System; ! package body Ada.Command_Line is function Arg_Count return Natural; *************** package body Ada.Command_Line is *** 44,49 **** --- 44,58 ---- function Len_Arg (Arg_Num : Integer) return Integer; pragma Import (C, Len_Arg, "__gnat_len_arg"); + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Initialized return Boolean; + -- Checks to ensure that gnat_argc and gnat_argv have been properly + -- initialized. Returns false if not, or if argv / argc are + -- unsupported on the target (e.g. VxWorks). + -------------- -- Argument -- -------------- *************** package body Ada.Command_Line is *** 77,82 **** --- 86,96 ---- function Argument_Count return Natural is begin + if not Initialized then + -- RM A.15 (11) + return 0; + end if; + if Remove_Args = null then return Arg_Count - 1; else *************** package body Ada.Command_Line is *** 84,99 **** end if; end Argument_Count; ------------------ -- Command_Name -- ------------------ function Command_Name return String is - Arg : aliased String (1 .. Len_Arg (0)); - begin ! Fill_Arg (Arg'Address, 0); ! return Arg; end Command_Name; end Ada.Command_Line; --- 98,132 ---- end if; end Argument_Count; + ----------------- + -- Initialized -- + ----------------- + + function Initialized return Boolean is + gnat_argv : System.Address; + pragma Import (C, gnat_argv, "gnat_argv"); + + begin + return gnat_argv /= System.Null_Address; + end Initialized; + ------------------ -- Command_Name -- ------------------ function Command_Name return String is begin ! if not Initialized then ! return ""; ! end if; ! ! declare ! Arg : aliased String (1 .. Len_Arg (0)); ! ! begin ! Fill_Arg (Arg'Address, 0); ! return Arg; ! end; end Command_Name; end Ada.Command_Line; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-comlin.ads gcc-3.4.0/gcc/ada/a-comlin.ads *** gcc-3.3.3/gcc/ada/a-comlin.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-comlin.ads 2003-04-24 17:53:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-2002 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/a-cwila1.ads gcc-3.4.0/gcc/ada/a-cwila1.ads *** gcc-3.3.3/gcc/ada/a-cwila1.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-cwila1.ads 2003-04-24 17:53:52.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-2000 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/a-cwila9.ads gcc-3.4.0/gcc/ada/a-cwila9.ads *** gcc-3.3.3/gcc/ada/a-cwila9.ads 2002-10-28 16:19:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-cwila9.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-2002 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/ada.ads gcc-3.4.0/gcc/ada/ada.ads *** gcc-3.3.3/gcc/ada/ada.ads 2002-03-14 10:59:01.000000000 +0000 --- gcc-3.4.0/gcc/ada/ada.ads 2003-04-24 17:53:57.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/adadecode.c gcc-3.4.0/gcc/ada/adadecode.c *** gcc-3.3.3/gcc/ada/adadecode.c 2002-10-23 08:04:17.000000000 +0000 --- gcc-3.4.0/gcc/ada/adadecode.c 2003-11-24 16:38:39.000000000 +0000 *************** *** 2,13 **** * * * GNAT COMPILER COMPONENTS * * * ! * G N A T D E C O * ! * * * * * C Implementation File * * * ! * Copyright (C) 2001-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- * --- 2,12 ---- * * * GNAT COMPILER COMPONENTS * * * ! * A D A D E C O D E * * * * C Implementation File * * * ! * 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- * *************** *** 36,50 **** #include "system.h" #else #include #define PARMS(ARGS) ARGS #endif - #include "ctype.h" #include "adadecode.h" ! static void add_verbose PARAMS ((const char *, char *)); ! static int has_prefix PARAMS ((char *, const char *)); ! static int has_suffix PARAMS ((char *, const char *)); /* Set to nonzero if we have written any verbose info. */ static int verbose_info; --- 35,54 ---- #include "system.h" #else #include + #include + #define ISDIGIT(c) isdigit(c) #define PARMS(ARGS) ARGS #endif #include "adadecode.h" ! static void add_verbose (const char *, char *); ! static int has_prefix (const char *, const char *); ! static int has_suffix (const char *, const char *); ! ! /* This is a safe version of strcpy that can be used with overlapped ! pointers. Does nothing if s2 <= s1. */ ! static void ostrcpy (char *s1, char *s2); /* Set to nonzero if we have written any verbose info. */ static int verbose_info; *************** static int verbose_info; *** 52,60 **** /* Add TEXT to end of ADA_NAME, putting a leading " (" or ", ", depending on VERBOSE_INFO. */ ! static void add_verbose (text, ada_name) ! const char *text; ! char *ada_name; { strcat (ada_name, verbose_info ? ", " : " ("); strcat (ada_name, text); --- 56,62 ---- /* Add TEXT to end of ADA_NAME, putting a leading " (" or ", ", depending on VERBOSE_INFO. */ ! static void add_verbose (const char *text, char *ada_name) { strcat (ada_name, verbose_info ? ", " : " ("); strcat (ada_name, text); *************** static void add_verbose (text, ada_name) *** 65,73 **** /* Returns 1 if NAME starts with PREFIX. */ static int ! has_prefix (name, prefix) ! char *name; ! const char *prefix; { return strncmp (name, prefix, strlen (prefix)) == 0; } --- 67,73 ---- /* Returns 1 if NAME starts with PREFIX. */ static int ! has_prefix (const char *name, const char *prefix) { return strncmp (name, prefix, strlen (prefix)) == 0; } *************** has_prefix (name, prefix) *** 75,83 **** /* Returns 1 if NAME ends with SUFFIX. */ static int ! has_suffix (name, suffix) ! char *name; ! const char *suffix; { int nlen = strlen (name); int slen = strlen (suffix); --- 75,81 ---- /* Returns 1 if NAME ends with SUFFIX. */ static int ! has_suffix (const char *name, const char *suffix) { int nlen = strlen (name); int slen = strlen (suffix); *************** has_suffix (name, suffix) *** 85,90 **** --- 83,100 ---- return nlen > slen && strncmp (name + nlen - slen, suffix, slen) == 0; } + /* Safe overlapped pointers version of strcpy. */ + + static void + ostrcpy (char *s1, char *s2) + { + if (s2 > s1) + { + while (*s2) *s1++ = *s2++; + *s1 = '\0'; + } + } + /* This function will return the Ada name from the encoded form. The Ada coding is done in exp_dbug.ads and this is the inverse function. see exp_dbug.ads for full encoding rules, a short description is added *************** has_suffix (name, suffix) *** 132,141 **** x__Oexpon "**" */ void ! __gnat_decode (coded_name, ada_name, verbose) ! const char *coded_name; ! char *ada_name; ! int verbose; { int lib_subprog = 0; int overloaded = 0; --- 142,148 ---- x__Oexpon "**" */ void ! __gnat_decode (const char *coded_name, char *ada_name, int verbose) { int lib_subprog = 0; int overloaded = 0; *************** __gnat_decode (coded_name, ada_name, ver *** 143,158 **** int in_task = 0; int body_nested = 0; - /* Copy the coded name into the ada name string, the rest of the code will - just replace or add characters into the ada_name. */ - strcpy (ada_name, coded_name); - /* Check for library level subprogram. */ ! if (has_prefix (ada_name, "_ada_")) { ! strcpy (ada_name, ada_name + 5); lib_subprog = 1; } /* Check for task body. */ if (has_suffix (ada_name, "TKB")) --- 150,163 ---- int in_task = 0; int body_nested = 0; /* Check for library level subprogram. */ ! if (has_prefix (coded_name, "_ada_")) { ! strcpy (ada_name, coded_name + 5); lib_subprog = 1; } + else + strcpy (ada_name, coded_name); /* Check for task body. */ if (has_suffix (ada_name, "TKB")) *************** __gnat_decode (coded_name, ada_name, ver *** 192,198 **** while ((tktoken = (char *) strstr (ada_name, "TK__")) != NULL) { ! strcpy (tktoken, tktoken + 2); in_task = 1; } } --- 197,203 ---- while ((tktoken = (char *) strstr (ada_name, "TK__")) != NULL) { ! ostrcpy (tktoken, tktoken + 2); in_task = 1; } } *************** __gnat_decode (coded_name, ada_name, ver *** 203,209 **** int n_digits = 0; if (len > 1) ! while (isdigit ((int) ada_name[(int) len - 1 - n_digits])) n_digits++; /* Check if we have $ or __ before digits. */ --- 208,214 ---- int n_digits = 0; if (len > 1) ! while (ISDIGIT ((int) ada_name[(int) len - 1 - n_digits])) n_digits++; /* Check if we have $ or __ before digits. */ *************** __gnat_decode (coded_name, ada_name, ver *** 230,236 **** if (ada_name[k] == '_' && ada_name[k+1] == '_') { ada_name[k] = '.'; ! strcpy (ada_name + k + 1, ada_name + k + 2); len = len - 1; } k++; --- 235,241 ---- if (ada_name[k] == '_' && ada_name[k+1] == '_') { ada_name[k] = '.'; ! ostrcpy (ada_name + k + 1, ada_name + k + 2); len = len - 1; } k++; *************** __gnat_decode (coded_name, ada_name, ver *** 260,266 **** if (codedlen > oplen) /* We shrink the space. */ ! strcpy (optoken, optoken + codedlen - oplen); else if (oplen > codedlen) { /* We need more space. */ --- 265,271 ---- if (codedlen > oplen) /* We shrink the space. */ ! ostrcpy (optoken, optoken + codedlen - oplen); else if (oplen > codedlen) { /* We need more space. */ *************** __gnat_decode (coded_name, ada_name, ver *** 286,292 **** } /* If verbose mode is on, we add some information to the Ada name. */ ! if (verbose) { if (overloaded) add_verbose ("overloaded", ada_name); --- 291,297 ---- } /* If verbose mode is on, we add some information to the Ada name. */ ! if (verbose) { if (overloaded) add_verbose ("overloaded", ada_name); *************** __gnat_decode (coded_name, ada_name, ver *** 309,316 **** } char * ! ada_demangle (coded_name) ! const char *coded_name; { char ada_name[2048]; --- 314,320 ---- } char * ! ada_demangle (const char *coded_name) { char ada_name[2048]; diff -Nrc3pad gcc-3.3.3/gcc/ada/adadecode.h gcc-3.4.0/gcc/ada/adadecode.h *** gcc-3.3.3/gcc/ada/adadecode.h 2002-10-23 08:04:17.000000000 +0000 --- gcc-3.4.0/gcc/ada/adadecode.h 2003-10-24 13:02:42.000000000 +0000 *************** *** 2,13 **** * * * GNAT COMPILER COMPONENTS * * * ! * G N A T D E C O * ! * * * * * C Header File * * * ! * Copyright (C) 2001-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- * --- 2,12 ---- * * * GNAT COMPILER COMPONENTS * * * ! * A D A D E C O D E * * * * C Header File * * * ! * 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- * *************** *** 43,51 **** verbose information). VERBOSE is nonzero if more information about the entity is to be added at the end of the Ada name and surrounded by ( and ). */ ! extern void __gnat_decode PARAMS ((const char *, char *, int)); /* ada_demangle is added for COMPATIBILITY ONLY. It has the name of the function used in the binutils and GDB. Always consider using __gnat_decode instead of ada_demangle. Caller must free the pointer returned. */ ! extern char *ada_demangle PARAMS ((const char *)); --- 42,50 ---- verbose information). VERBOSE is nonzero if more information about the entity is to be added at the end of the Ada name and surrounded by ( and ). */ ! extern void __gnat_decode (const char *, char *, int); /* ada_demangle is added for COMPATIBILITY ONLY. It has the name of the function used in the binutils and GDB. Always consider using __gnat_decode instead of ada_demangle. Caller must free the pointer returned. */ ! extern char *ada_demangle (const char *); diff -Nrc3pad gcc-3.3.3/gcc/ada/adafinal.c gcc-3.4.0/gcc/ada/adafinal.c *** gcc-3.3.3/gcc/ada/adafinal.c 2003-01-29 22:37:55.000000000 +0000 --- gcc-3.4.0/gcc/ada/adafinal.c 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,56 **** - /**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * A D A F I N A L * - * * - * * - * C Implementation File * - * * - * Copyright (C) 1992-2001 Free Software Foundation, Inc. * - * * - * GNAT is free software; you can redistribute it and/or modify it under * - * terms of the GNU General Public License as published by the Free Soft- * - * ware Foundation; either version 2, or (at your option) any later ver- * - * sion. GNAT is distributed in the hope that it will be useful, but WITH- * - * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * - * for more details. You should have received a copy of the GNU General * - * Public License distributed with GNAT; see file COPYING. If not, write * - * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, * - * MA 02111-1307, USA. * - * * - * As a special exception, if you link this file with other files to * - * produce an executable, this file does not by itself cause the resulting * - * executable to be covered by the GNU General Public License. This except- * - * ion 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. * - * * - ****************************************************************************/ - - #ifdef __alpha_vxworks - #include "vxWorks.h" - #endif - - #ifdef IN_RTS - #include "tconfig.h" - #include "tsystem.h" - #else - #include "config.h" - #include "system.h" - #endif - - #include "raise.h" - - /* This routine is called at the extreme end of execution of an Ada program - (the call is generated by the binder). The standard routine does nothing - at all, the intention is that this be replaced by system specific code - where finalization is required. */ - - void - __gnat_finalize () - { - } --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/ada.h gcc-3.4.0/gcc/ada/ada.h *** gcc-3.3.3/gcc/ada/ada.h 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/ada.h 2003-04-24 17:53:57.000000000 +0000 *************** *** 6,13 **** * * * C Header File * * * ! * * ! * Copyright (C) 1992-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- * --- 6,12 ---- * * * C Header File * * * ! * 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- * *************** *** 75,81 **** SUBTYPE macro defined above. */ #define IN(VALUE,SUBTYPE) \ ! (((VALUE) >= (SUBTYPE) CAT (SUBTYPE,__First)) && \ ! ((VALUE) <= (SUBTYPE) CAT (SUBTYPE,__Last))) #endif --- 74,80 ---- SUBTYPE macro defined above. */ #define IN(VALUE,SUBTYPE) \ ! (((VALUE) >= (SUBTYPE) CAT (SUBTYPE,__First)) \ ! && ((VALUE) <= (SUBTYPE) CAT (SUBTYPE,__Last))) #endif diff -Nrc3pad gcc-3.3.3/gcc/ada/adaint.c gcc-3.4.0/gcc/ada/adaint.c *** gcc-3.3.3/gcc/ada/adaint.c 2002-11-18 14:39:46.000000000 +0000 --- gcc-3.4.0/gcc/ada/adaint.c 2004-01-13 11:51:31.000000000 +0000 *************** *** 4,13 **** * * * A D A I N T * * * - * * * C Implementation File * * * ! * Copyright (C) 1992-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- * --- 4,12 ---- * * * A D A I N T * * * * C Implementation File * * * ! * 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- * *************** *** 51,62 **** --- 50,69 ---- #endif /* VxWorks */ + #ifdef VMS + #define _POSIX_EXIT 1 + #endif + #ifdef IN_RTS #include "tconfig.h" #include "tsystem.h" + #include #include #include + #ifdef VMS + #include + #endif /* We don't have libiberty, so use malloc. */ #define xmalloc(S) malloc (S) *************** *** 65,71 **** --- 72,95 ---- #include "config.h" #include "system.h" #endif + + #ifdef __MINGW32__ + #include "mingw32.h" + #include + #include + #else + #ifndef VMS + #include + #endif + #endif + + #ifdef __MINGW32__ + #if OLD_MINGW + #include + #endif + #else #include + #endif #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32) #elif defined (VMS) *************** struct dsc$descriptor_fib *** 98,104 **** /* I/O Status Block. */ struct IOSB ! { unsigned short status, count; unsigned long devdep; }; --- 122,128 ---- /* I/O Status Block. */ struct IOSB ! { unsigned short status, count; unsigned long devdep; }; *************** const int __gnat_vmsp = 1; *** 213,246 **** const int __gnat_vmsp = 0; #endif - /* This variable is used to export the maximum length of a path name to - Ada code. */ - #ifdef __EMX__ ! int __gnat_max_path_len = _MAX_PATH; #elif defined (VMS) ! int __gnat_max_path_len = 4096; /* PATH_MAX */ #elif defined (__vxworks) || defined (__OPENNT) ! int __gnat_max_path_len = PATH_MAX; #else #include ! int __gnat_max_path_len = MAXPATHLEN; #endif /* The following macro HAVE_READDIR_R should be defined if the system provides the routine readdir_r. */ #undef HAVE_READDIR_R void ! __gnat_to_gm_time (p_time, p_year, p_month, p_day, p_hours, p_mins, p_secs) ! int *p_time, *p_year, *p_month, *p_day, *p_hours, *p_mins, *p_secs; { struct tm *res; ! time_t time = *p_time; #ifdef _WIN32 /* On Windows systems, the time is sometimes rounded up to the nearest --- 237,292 ---- const int __gnat_vmsp = 0; #endif #ifdef __EMX__ ! #define GNAT_MAX_PATH_LEN MAX_PATH #elif defined (VMS) ! #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */ #elif defined (__vxworks) || defined (__OPENNT) ! #define GNAT_MAX_PATH_LEN PATH_MAX ! ! #else ! ! #if defined (__MINGW32__) ! #include "mingw32.h" ! ! #if OLD_MINGW ! #include ! #endif #else #include ! #endif ! ! #define GNAT_MAX_PATH_LEN MAXPATHLEN #endif + /* The __gnat_max_path_len variable is used to export the maximum + length of a path name to Ada code. max_path_len is also provided + for compatibility with older GNAT versions, please do not use + it. */ + + int __gnat_max_path_len = GNAT_MAX_PATH_LEN; + int max_path_len = GNAT_MAX_PATH_LEN; + /* The following macro HAVE_READDIR_R should be defined if the system provides the routine readdir_r. */ #undef HAVE_READDIR_R void ! __gnat_to_gm_time ! (OS_Time *p_time, ! int *p_year, ! int *p_month, ! int *p_day, ! int *p_hours, ! int *p_mins, ! int *p_secs) { struct tm *res; ! time_t time = (time_t) *p_time; #ifdef _WIN32 /* On Windows systems, the time is sometimes rounded up to the nearest *************** __gnat_to_gm_time (p_time, p_year, p_mon *** 249,255 **** --- 295,305 ---- time++; #endif + #ifdef VMS + res = localtime (&time); + #else res = gmtime (&time); + #endif if (res) { *************** __gnat_to_gm_time (p_time, p_year, p_mon *** 269,279 **** of characters of its content in BUF. Otherwise, return -1. For Windows, OS/2 and vxworks, always return -1. */ ! int ! __gnat_readlink (path, buf, bufsiz) ! char *path; ! char *buf; ! size_t bufsiz; { #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__) return -1; --- 319,328 ---- of characters of its content in BUF. Otherwise, return -1. For Windows, OS/2 and vxworks, always return -1. */ ! int ! __gnat_readlink (char *path ATTRIBUTE_UNUSED, ! char *buf ATTRIBUTE_UNUSED, ! size_t bufsiz ATTRIBUTE_UNUSED) { #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__) return -1; *************** __gnat_readlink (path, buf, bufsiz) *** 291,299 **** Interix and VMS, always return -1. */ int ! __gnat_symlink (oldpath, newpath) ! char *oldpath; ! char *newpath; { #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__) return -1; --- 340,347 ---- Interix and VMS, always return -1. */ int ! __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED, ! char *newpath ATTRIBUTE_UNUSED) { #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__) return -1; *************** __gnat_symlink (oldpath, newpath) *** 313,321 **** /* Version that does not use link. */ int ! __gnat_try_lock (dir, file) ! char *dir; ! char *file; { char full_path[256]; int fd; --- 361,367 ---- /* Version that does not use link. */ int ! __gnat_try_lock (char *dir, char *file) { char full_path[256]; int fd; *************** __gnat_try_lock (dir, file) *** 335,343 **** line problem ??? */ int ! __gnat_try_lock (dir, file) ! char *dir; ! char *file; { char full_path[256]; int fd; --- 381,387 ---- line problem ??? */ int ! __gnat_try_lock (char *dir, char *file) { char full_path[256]; int fd; *************** __gnat_try_lock (dir, file) *** 354,364 **** #else /* Version using link(), more secure over NFS. */ int ! __gnat_try_lock (dir, file) ! char *dir; ! char *file; { char full_path[256]; char temp_file[256]; --- 398,407 ---- #else /* Version using link(), more secure over NFS. */ + /* See TN 6913-016 for discussion ??? */ int ! __gnat_try_lock (char *dir, char *file) { char full_path[256]; char temp_file[256]; *************** __gnat_try_lock (dir, file) *** 366,372 **** int fd; sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file); ! sprintf (temp_file, "%s-%d-%d", dir, getpid(), getppid ()); /* Create the temporary file and write the process number. */ fd = open (temp_file, O_CREAT | O_WRONLY, 0600); --- 409,415 ---- int fd; sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file); ! sprintf (temp_file, "%s-%ld-%ld", dir, (long) getpid(), (long) getppid ()); /* Create the temporary file and write the process number. */ fd = open (temp_file, O_CREAT | O_WRONLY, 0600); *************** __gnat_try_lock (dir, file) *** 389,395 **** /* Return the maximum file name length. */ int ! __gnat_get_maximum_file_name_length () { #if defined (MSDOS) return 8; --- 432,438 ---- /* Return the maximum file name length. */ int ! __gnat_get_maximum_file_name_length (void) { #if defined (MSDOS) return 8; *************** __gnat_get_maximum_file_name_length () *** 406,412 **** /* Return nonzero if file names are case sensitive. */ int ! __gnat_get_file_names_case_sensitive () { #if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined (WINNT) return 0; --- 449,455 ---- /* Return nonzero if file names are case sensitive. */ int ! __gnat_get_file_names_case_sensitive (void) { #if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined (WINNT) return 0; *************** __gnat_get_file_names_case_sensitive () *** 416,422 **** } char ! __gnat_get_default_identifier_character_set () { #if defined (__EMX__) || defined (MSDOS) return 'p'; --- 459,465 ---- } char ! __gnat_get_default_identifier_character_set (void) { #if defined (__EMX__) || defined (MSDOS) return 'p'; *************** __gnat_get_default_identifier_character_ *** 428,436 **** /* Return the current working directory. */ void ! __gnat_get_current_dir (dir, length) ! char *dir; ! int *length; { #ifdef VMS /* Force Unix style, which is what GNAT uses internally. */ --- 471,477 ---- /* Return the current working directory. */ void ! __gnat_get_current_dir (char *dir, int *length) { #ifdef VMS /* Force Unix style, which is what GNAT uses internally. */ *************** __gnat_get_current_dir (dir, length) *** 441,457 **** *length = strlen (dir); ! dir[*length] = DIR_SEPARATOR; ! ++*length; dir[*length] = '\0'; } /* Return the suffix for object files. */ void ! __gnat_get_object_suffix_ptr (len, value) ! int *len; ! const char **value; { *value = HOST_OBJECT_SUFFIX; --- 482,499 ---- *length = strlen (dir); ! if (dir [*length - 1] != DIR_SEPARATOR) ! { ! dir [*length] = DIR_SEPARATOR; ! ++(*length); ! } dir[*length] = '\0'; } /* Return the suffix for object files. */ void ! __gnat_get_object_suffix_ptr (int *len, const char **value) { *value = HOST_OBJECT_SUFFIX; *************** __gnat_get_object_suffix_ptr (len, value *** 466,474 **** /* Return the suffix for executable files. */ void ! __gnat_get_executable_suffix_ptr (len, value) ! int *len; ! const char **value; { *value = HOST_EXECUTABLE_SUFFIX; if (!*value) --- 508,514 ---- /* Return the suffix for executable files. */ void ! __gnat_get_executable_suffix_ptr (int *len, const char **value) { *value = HOST_EXECUTABLE_SUFFIX; if (!*value) *************** __gnat_get_executable_suffix_ptr (len, v *** 483,491 **** executable extension. */ void ! __gnat_get_debuggable_suffix_ptr (len, value) ! int *len; ! const char **value; { #ifndef MSDOS *value = HOST_EXECUTABLE_SUFFIX; --- 523,529 ---- executable extension. */ void ! __gnat_get_debuggable_suffix_ptr (int *len, const char **value) { #ifndef MSDOS *value = HOST_EXECUTABLE_SUFFIX; *************** __gnat_get_debuggable_suffix_ptr (len, v *** 503,511 **** } int ! __gnat_open_read (path, fmode) ! char *path; ! int fmode; { int fd; int o_fmode = O_BINARY; --- 541,547 ---- } int ! __gnat_open_read (char *path, int fmode) { int fd; int o_fmode = O_BINARY; *************** __gnat_open_read (path, fmode) *** 526,541 **** return fd < 0 ? -1 : fd; } ! #if defined (__EMX__) #define PERM (S_IREAD | S_IWRITE) #else #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH) #endif int ! __gnat_open_rw (path, fmode) ! char *path; ! int fmode; { int fd; int o_fmode = O_BINARY; --- 562,584 ---- return fd < 0 ? -1 : fd; } ! #if defined (__EMX__) || defined (__MINGW32__) #define PERM (S_IREAD | S_IWRITE) + #elif defined (VMS) + /* Excerpt from DECC C RTL Reference Manual: + To create files with OpenVMS RMS default protections using the UNIX + system-call functions umask, mkdir, creat, and open, call mkdir, creat, + and open with a file-protection mode argument of 0777 in a program + that never specifically calls umask. These default protections include + correctly establishing protections based on ACLs, previous versions of + files, and so on. */ + #define PERM 0777 #else #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH) #endif int ! __gnat_open_rw (char *path, int fmode) { int fd; int o_fmode = O_BINARY; *************** __gnat_open_rw (path, fmode) *** 554,562 **** } int ! __gnat_open_create (path, fmode) ! char *path; ! int fmode; { int fd; int o_fmode = O_BINARY; --- 597,603 ---- } int ! __gnat_open_create (char *path, int fmode) { int fd; int o_fmode = O_BINARY; *************** __gnat_open_create (path, fmode) *** 575,583 **** } int ! __gnat_open_append (path, fmode) ! char *path; ! int fmode; { int fd; int o_fmode = O_BINARY; --- 616,622 ---- } int ! __gnat_open_append (char *path, int fmode) { int fd; int o_fmode = O_BINARY; *************** __gnat_open_append (path, fmode) *** 598,606 **** /* Open a new file. Return error (-1) if the file already exists. */ int ! __gnat_open_new (path, fmode) ! char *path; ! int fmode; { int fd; int o_fmode = O_BINARY; --- 637,643 ---- /* Open a new file. Return error (-1) if the file already exists. */ int ! __gnat_open_new (char *path, int fmode) { int fd; int o_fmode = O_BINARY; *************** __gnat_open_new (path, fmode) *** 623,638 **** processes, however they really slow down output. Used in gnatchop. */ int ! __gnat_open_new_temp (path, fmode) ! char *path; ! int fmode; { int fd; int o_fmode = O_BINARY; strcpy (path, "GNAT-XXXXXX"); ! #if defined (linux) && !defined (__vxworks) return mkstemp (path); #elif defined (__Lynx__) mktemp (path); --- 660,673 ---- processes, however they really slow down output. Used in gnatchop. */ int ! __gnat_open_new_temp (char *path, int fmode) { int fd; int o_fmode = O_BINARY; strcpy (path, "GNAT-XXXXXX"); ! #if (defined (__FreeBSD__) || defined (linux)) && !defined (__vxworks) return mkstemp (path); #elif defined (__Lynx__) mktemp (path); *************** __gnat_open_new_temp (path, fmode) *** 658,665 **** /* Return the number of bytes in the specified file. */ long ! __gnat_file_length (fd) ! int fd; { int ret; struct stat statbuf; --- 693,699 ---- /* Return the number of bytes in the specified file. */ long ! __gnat_file_length (int fd) { int ret; struct stat statbuf; *************** __gnat_file_length (fd) *** 675,682 **** TMP_FILENAME. */ void ! __gnat_tmp_name (tmp_filename) ! char *tmp_filename; { #ifdef __MINGW32__ { --- 709,715 ---- TMP_FILENAME. */ void ! __gnat_tmp_name (char *tmp_filename) { #ifdef __MINGW32__ { *************** __gnat_tmp_name (tmp_filename) *** 689,698 **** pname = (char *) tempnam ("c:\\temp", "gnat-"); /* If pname start with a back slash and not path information it means that the filename is valid for the current working directory. */ ! if (pname[0] == '\\') { strcpy (tmp_filename, ".\\"); strcat (tmp_filename, pname+1); --- 722,737 ---- pname = (char *) tempnam ("c:\\temp", "gnat-"); + /* if pname is NULL, the file was not created properly, the disk is full + or there is no more free temporary files */ + + if (pname == NULL) + *tmp_filename = '\0'; + /* If pname start with a back slash and not path information it means that the filename is valid for the current working directory. */ ! else if (pname[0] == '\\') { strcpy (tmp_filename, ".\\"); strcat (tmp_filename, pname+1); *************** __gnat_tmp_name (tmp_filename) *** 703,715 **** free (pname); } ! #elif defined (linux) char *tmpdir = getenv ("TMPDIR"); ! if (tmpdir == NULL) strcpy (tmp_filename, "/tmp/gnat-XXXXXX"); else ! sprintf (tmp_filename, "%.200s/gnat-XXXXXX", tmpdir); close (mkstemp(tmp_filename)); #else --- 742,757 ---- free (pname); } ! #elif defined (linux) || defined (__FreeBSD__) ! #define MAX_SAFE_PATH 1000 char *tmpdir = getenv ("TMPDIR"); ! /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid ! a buffer overflow. */ ! if (tmpdir == NULL || strlen (tmpdir) > MAX_SAFE_PATH) strcpy (tmp_filename, "/tmp/gnat-XXXXXX"); else ! sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir); close (mkstemp(tmp_filename)); #else *************** __gnat_tmp_name (tmp_filename) *** 721,729 **** in the buffer. */ char * ! __gnat_readdir (dirp, buffer) ! DIR *dirp; ! char* buffer; { /* If possible, try to use the thread-safe version. */ #ifdef HAVE_READDIR_R --- 763,769 ---- in the buffer. */ char * ! __gnat_readdir (DIR *dirp, char *buffer) { /* If possible, try to use the thread-safe version. */ #ifdef HAVE_READDIR_R *************** __gnat_readdir (dirp, buffer) *** 749,755 **** /* Returns 1 if readdir is thread safe, 0 otherwise. */ int ! __gnat_readdir_is_thread_safe () { #ifdef HAVE_READDIR_R return 1; --- 789,795 ---- /* Returns 1 if readdir is thread safe, 0 otherwise. */ int ! __gnat_readdir_is_thread_safe (void) { #ifdef HAVE_READDIR_R return 1; *************** __gnat_readdir_is_thread_safe () *** 759,764 **** --- 799,806 ---- } #ifdef _WIN32 + /* Number of seconds between and . */ + static const unsigned long long w32_epoch_offset = 11644473600ULL; /* Returns the file modification timestamp using Win32 routines which are immune against daylight saving time change. It is in fact not possible to *************** __gnat_readdir_is_thread_safe () *** 766,805 **** stat structure. */ static time_t ! win32_filetime (h) ! HANDLE h; { ! BOOL res; ! FILETIME t_create; ! FILETIME t_access; ! FILETIME t_write; ! unsigned long long timestamp; ! ! /* Number of seconds between and . */ ! unsigned long long offset = 11644473600; /* GetFileTime returns FILETIME data which are the number of 100 nanosecs since . This function must return the number of seconds since . */ ! res = GetFileTime (h, &t_create, &t_access, &t_write); ! ! timestamp = (((long long) t_write.dwHighDateTime << 32) ! + t_write.dwLowDateTime); ! ! timestamp = timestamp / 10000000 - offset; ! ! return (time_t) timestamp; } #endif /* Return a GNAT time stamp given a file name. */ time_t ! __gnat_file_time_name (name) ! char *name; { - struct stat statbuf; #if defined (__EMX__) || defined (MSDOS) int fd = open (name, O_RDONLY | O_BINARY); --- 808,837 ---- stat structure. */ static time_t ! win32_filetime (HANDLE h) { ! union ! { ! FILETIME ft_time; ! unsigned long long ull_time; ! } t_write; /* GetFileTime returns FILETIME data which are the number of 100 nanosecs since . This function must return the number of seconds since . */ ! if (GetFileTime (h, NULL, NULL, &t_write.ft_time)) ! return (time_t) (t_write.ull_time / 10000000ULL ! - w32_epoch_offset); ! return (time_t) 0; } #endif /* Return a GNAT time stamp given a file name. */ time_t ! __gnat_file_time_name (char *name) { #if defined (__EMX__) || defined (MSDOS) int fd = open (name, O_RDONLY | O_BINARY); *************** __gnat_file_time_name (name) *** 808,820 **** return ret; #elif defined (_WIN32) HANDLE h = CreateFile (name, GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0); ! time_t ret = win32_filetime (h); ! CloseHandle (h); return ret; #else ! (void) __gnat_stat (name, &statbuf); #ifdef VMS /* VMS has file versioning. */ --- 840,857 ---- return ret; #elif defined (_WIN32) + time_t ret = 0; HANDLE h = CreateFile (name, GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0); ! ! if (h != INVALID_HANDLE_VALUE) ! { ! ret = win32_filetime (h); ! CloseHandle (h); ! } return ret; #else ! struct stat statbuf; (void) __gnat_stat (name, &statbuf); #ifdef VMS /* VMS has file versioning. */ *************** __gnat_file_time_name (name) *** 828,835 **** /* Return a GNAT time stamp given a file descriptor. */ time_t ! __gnat_file_time_fd (fd) ! int fd; { /* The following workaround code is due to the fact that under EMX and DJGPP fstat attempts to convert time values to GMT rather than keep the --- 865,871 ---- /* Return a GNAT time stamp given a file descriptor. */ time_t ! __gnat_file_time_fd (int fd) { /* The following workaround code is due to the fact that under EMX and DJGPP fstat attempts to convert time values to GMT rather than keep the *************** __gnat_file_time_fd (fd) *** 920,934 **** /* Set the file time stamp. */ void ! __gnat_set_file_time_name (name, time_stamp) ! char *name; ! time_t time_stamp; { ! #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32) \ ! || defined (__vxworks) /* Code to implement __gnat_set_file_time_name for these systems. */ #elif defined (VMS) struct FAB fab; struct NAM nam; --- 956,988 ---- /* Set the file time stamp. */ void ! __gnat_set_file_time_name (char *name, time_t time_stamp) { ! #if defined (__EMX__) || defined (MSDOS) || defined (__vxworks) /* Code to implement __gnat_set_file_time_name for these systems. */ + #elif defined (_WIN32) + union + { + FILETIME ft_time; + unsigned long long ull_time; + } t_write; + + HANDLE h = CreateFile (name, GENERIC_WRITE, FILE_SHARE_WRITE, NULL, + OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, + NULL); + if (h == INVALID_HANDLE_VALUE) + return; + /* Add number of seconds between and */ + t_write.ull_time = ((unsigned long long)time_stamp + w32_epoch_offset); + /* Convert to 100 nanosecond units */ + t_write.ull_time *= 10000000ULL; + + SetFileTime(h, NULL, NULL, &t_write.ft_time); + CloseHandle (h); + return; + #elif defined (VMS) struct FAB fab; struct NAM nam; *************** __gnat_set_file_time_name (name, time_st *** 1051,1068 **** { time_t t; - struct tm *ts; - - ts = localtime (&time_stamp); /* Set creation time to requested time. */ ! unix_time_to_vms (time_stamp + ts->tm_gmtoff, newtime); t = time ((time_t) 0); - ts = localtime (&t); /* Set revision time to now in local time. */ ! unix_time_to_vms (t + ts->tm_gmtoff, revtime); } /* Reopen the file, modify the times and then close. */ --- 1105,1118 ---- { time_t t; /* Set creation time to requested time. */ ! unix_time_to_vms (time_stamp, newtime); t = time ((time_t) 0); /* Set revision time to now in local time. */ ! unix_time_to_vms (t, revtime); } /* Reopen the file, modify the times and then close. */ *************** __gnat_set_file_time_name (name, time_st *** 1105,1114 **** } void ! __gnat_get_env_value_ptr (name, len, value) ! char *name; ! int *len; ! char **value; { *value = getenv (name); if (!*value) --- 1155,1161 ---- } void ! __gnat_get_env_value_ptr (char *name, int *len, char **value) { *value = getenv (name); if (!*value) *************** __gnat_get_env_value_ptr (name, len, val *** 1123,1129 **** #ifdef VMS ! static char *to_host_path_spec PARAMS ((char *)); struct descriptor_s { --- 1170,1176 ---- #ifdef VMS ! static char *to_host_path_spec (char *); struct descriptor_s { *************** typedef struct _ile3 *** 1141,1149 **** #endif void ! __gnat_set_env_value (name, value) ! char *name; ! char *value; { #ifdef MSDOS --- 1188,1194 ---- #endif void ! __gnat_set_env_value (char *name, char *value) { #ifdef MSDOS *************** __gnat_set_env_value (name, value) *** 1151,1168 **** struct descriptor_s name_desc; /* Put in JOB table for now, so that the project stuff at least works. */ struct descriptor_s table_desc = {7, 0, "LNM$JOB"}; ! char *host_pathspec = to_host_path_spec (value); char *copy_pathspec; int num_dirs_in_pathspec = 1; char *ptr; ! ! if (*host_pathspec == 0) ! return; name_desc.len = strlen (name); name_desc.mbz = 0; name_desc.adr = name; ptr = host_pathspec; while (*ptr++) if (*ptr == ',') --- 1196,1220 ---- struct descriptor_s name_desc; /* Put in JOB table for now, so that the project stuff at least works. */ struct descriptor_s table_desc = {7, 0, "LNM$JOB"}; ! char *host_pathspec = value; char *copy_pathspec; int num_dirs_in_pathspec = 1; char *ptr; ! long status; name_desc.len = strlen (name); name_desc.mbz = 0; name_desc.adr = name; + if (*host_pathspec == 0) + /* deassign */ + { + status = LIB$DELETE_LOGICAL (&name_desc, &table_desc); + /* no need to check status; if the logical name is not + defined, that's fine. */ + return; + } + ptr = host_pathspec; while (*ptr++) if (*ptr == ',') *************** __gnat_set_env_value (name, value) *** 1225,1231 **** key. */ char * ! __gnat_get_libraries_from_registry () { char *result = (char *) ""; --- 1277,1283 ---- key. */ char * ! __gnat_get_libraries_from_registry (void) { char *result = (char *) ""; *************** __gnat_get_libraries_from_registry () *** 1280,1295 **** } int ! __gnat_stat (name, statbuf) ! char *name; ! struct stat *statbuf; { #ifdef _WIN32 /* Under Windows the directory name for the stat function must not be terminated by a directory separator except if just after a drive name. */ int name_len = strlen (name); char last_char = name[name_len - 1]; ! char win32_name[4096]; strcpy (win32_name, name); --- 1332,1348 ---- } int ! __gnat_stat (char *name, struct stat *statbuf) { #ifdef _WIN32 /* Under Windows the directory name for the stat function must not be terminated by a directory separator except if just after a drive name. */ int name_len = strlen (name); char last_char = name[name_len - 1]; ! char win32_name[GNAT_MAX_PATH_LEN + 2]; ! ! if (name_len > GNAT_MAX_PATH_LEN) ! return -1; strcpy (win32_name, name); *************** __gnat_stat (name, statbuf) *** 1311,1338 **** } int ! __gnat_file_exists (name) ! char *name; { struct stat statbuf; return !__gnat_stat (name, &statbuf); } ! int ! __gnat_is_absolute_path (name) ! char *name; { return (*name == '/' || *name == DIR_SEPARATOR #if defined (__EMX__) || defined (MSDOS) || defined (WINNT) ! || strlen (name) > 1 && isalpha (name[0]) && name[1] == ':' #endif ); } int ! __gnat_is_regular_file (name) ! char *name; { int ret; struct stat statbuf; --- 1364,1388 ---- } int ! __gnat_file_exists (char *name) { struct stat statbuf; return !__gnat_stat (name, &statbuf); } ! int ! __gnat_is_absolute_path (char *name) { return (*name == '/' || *name == DIR_SEPARATOR #if defined (__EMX__) || defined (MSDOS) || defined (WINNT) ! || (strlen (name) > 1 && isalpha (name[0]) && name[1] == ':') #endif ); } int ! __gnat_is_regular_file (char *name) { int ret; struct stat statbuf; *************** __gnat_is_regular_file (name) *** 1342,1349 **** } int ! __gnat_is_directory (name) ! char *name; { int ret; struct stat statbuf; --- 1392,1398 ---- } int ! __gnat_is_directory (char *name) { int ret; struct stat statbuf; *************** __gnat_is_directory (name) *** 1353,1360 **** } int ! __gnat_is_writable_file (name) ! char *name; { int ret; int mode; --- 1402,1420 ---- } int ! __gnat_is_readable_file (char *name) ! { ! int ret; ! int mode; ! struct stat statbuf; ! ! ret = __gnat_stat (name, &statbuf); ! mode = statbuf.st_mode & S_IRUSR; ! return (!ret && mode); ! } ! ! int ! __gnat_is_writable_file (char *name) { int ret; int mode; *************** __gnat_is_writable_file (name) *** 1365,1374 **** return (!ret && mode); } #ifdef VMS /* Defined in VMS header files. */ #define fork() (decc$$alloc_vfork_blocks() >= 0 ? \ ! LIB$GET_CURRENT_INVO_CONTEXT (decc$$get_vfork_jmpbuf()) : -1) #endif #if defined (sun) && defined (__SVR4) --- 1425,1485 ---- return (!ret && mode); } + void + __gnat_set_writable (char *name) + { + #ifndef __vxworks + struct stat statbuf; + + if (stat (name, &statbuf) == 0) + { + statbuf.st_mode = statbuf.st_mode | S_IWUSR; + chmod (name, statbuf.st_mode); + } + #endif + } + + void + __gnat_set_readonly (char *name) + { + #ifndef __vxworks + struct stat statbuf; + + if (stat (name, &statbuf) == 0) + { + statbuf.st_mode = statbuf.st_mode & 07577; + chmod (name, statbuf.st_mode); + } + #endif + } + + int + __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED) + { + #if defined (__vxworks) + return 0; + + #elif defined (_AIX) || defined (unix) + int ret; + struct stat statbuf; + + ret = lstat (name, &statbuf); + return (!ret && S_ISLNK (statbuf.st_mode)); + + #else + return 0; + #endif + } + #ifdef VMS /* Defined in VMS header files. */ + #if defined (__ALPHA) #define fork() (decc$$alloc_vfork_blocks() >= 0 ? \ ! LIB$GET_CURRENT_INVO_CONTEXT (decc$$get_vfork_jmpbuf()) : -1) ! #elif defined (__IA64) ! #define fork() (decc$$alloc_vfork_blocks() >= 0 ? \ ! LIB$I64_GET_CURR_INVO_CONTEXT(decc$$get_vfork_jmpbuf()) : -1) ! #endif #endif #if defined (sun) && defined (__SVR4) *************** __gnat_is_writable_file (name) *** 1379,1393 **** #endif int ! __gnat_portable_spawn (args) ! char *args[]; { int status = 0; ! int finished; ! int pid; #if defined (MSDOS) || defined (_WIN32) ! status = spawnvp (P_WAIT, args[0], args); if (status < 0) return -1; else --- 1490,1503 ---- #endif int ! __gnat_portable_spawn (char *args[]) { int status = 0; ! int finished ATTRIBUTE_UNUSED; ! int pid ATTRIBUTE_UNUSED; #if defined (MSDOS) || defined (_WIN32) ! status = spawnvp (P_WAIT, args[0],(const char* const*)args); if (status < 0) return -1; else *************** __gnat_portable_spawn (args) *** 1440,1458 **** static CRITICAL_SECTION plist_cs; void ! __gnat_plist_init () { InitializeCriticalSection (&plist_cs); } static void ! plist_enter () { EnterCriticalSection (&plist_cs); } static void ! plist_leave () { LeaveCriticalSection (&plist_cs); } --- 1550,1568 ---- static CRITICAL_SECTION plist_cs; void ! __gnat_plist_init (void) { InitializeCriticalSection (&plist_cs); } static void ! plist_enter (void) { EnterCriticalSection (&plist_cs); } static void ! plist_leave (void) { LeaveCriticalSection (&plist_cs); } *************** static Process_List *PLIST = NULL; *** 1468,1475 **** static int plist_length = 0; static void ! add_handle (h) ! HANDLE h; { Process_List *pl; --- 1578,1584 ---- static int plist_length = 0; static void ! add_handle (HANDLE h) { Process_List *pl; *************** add_handle (h) *** 1487,1496 **** plist_leave(); } ! void remove_handle (h) ! HANDLE h; { ! Process_List *pl, *prev; plist_enter(); --- 1596,1606 ---- plist_leave(); } ! static void ! remove_handle (HANDLE h) { ! Process_List *pl; ! Process_List *prev = NULL; plist_enter(); *************** void remove_handle (h) *** 1521,1529 **** } static int ! win32_no_block_spawn (command, args) ! char *command; ! char *args[]; { BOOL result; STARTUPINFO SI; --- 1631,1637 ---- } static int ! win32_no_block_spawn (char *command, char *args[]) { BOOL result; STARTUPINFO SI; *************** win32_no_block_spawn (command, args) *** 1586,1593 **** } static int ! win32_wait (status) ! int *status; { DWORD exitcode; HANDLE *hl; --- 1694,1700 ---- } static int ! win32_wait (int *status) { DWORD exitcode; HANDLE *hl; *************** win32_wait (status) *** 1634,1641 **** #endif int ! __gnat_portable_no_block_spawn (args) ! char *args[]; { int pid = 0; --- 1741,1747 ---- #endif int ! __gnat_portable_no_block_spawn (char *args[]) { int pid = 0; *************** __gnat_portable_no_block_spawn (args) *** 1669,1675 **** if (execv (args[0], args) != 0) #if defined (VMS) return -1; /* execv is in parent context on VMS. */ ! #else _exit (1); #endif } --- 1775,1781 ---- if (execv (args[0], args) != 0) #if defined (VMS) return -1; /* execv is in parent context on VMS. */ ! #else _exit (1); #endif } *************** __gnat_portable_no_block_spawn (args) *** 1680,1687 **** } int ! __gnat_portable_wait (process_status) ! int *process_status; { int status = 0; int pid = 0; --- 1786,1792 ---- } int ! __gnat_portable_wait (int *process_status) { int status = 0; int pid = 0; *************** __gnat_portable_wait (process_status) *** 1707,1714 **** } int ! __gnat_waitpid (pid) ! int pid; { int status = 0; --- 1812,1818 ---- } int ! __gnat_waitpid (int pid) { int status = 0; *************** __gnat_waitpid (pid) *** 1725,1764 **** } void ! __gnat_os_exit (status) ! int status; { - #ifdef VMS - /* Exit without changing 0 to 1. */ - __posix_exit (status); - #else exit (status); - #endif } /* Locate a regular file, give a Path value. */ char * ! __gnat_locate_regular_file (file_name, path_val) ! char *file_name; ! char *path_val; { char *ptr; /* Handle absolute pathnames. */ for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++) ; ! if (*ptr != 0 ! #if defined (__EMX__) || defined (MSDOS) || defined (WINNT) ! || isalpha (file_name[0]) && file_name[1] == ':' ! #endif ! ) { if (__gnat_is_regular_file (file_name)) return xstrdup (file_name); - - return 0; } if (path_val == 0) --- 1829,1865 ---- } void ! __gnat_os_exit (int status) { exit (status); } /* Locate a regular file, give a Path value. */ char * ! __gnat_locate_regular_file (char *file_name, char *path_val) { char *ptr; + int absolute = __gnat_is_absolute_path (file_name); /* Handle absolute pathnames. */ + if (absolute) + { + if (__gnat_is_regular_file (file_name)) + return xstrdup (file_name); + + return 0; + } + + /* If file_name include directory separator(s), try it first as + a path name relative to the current directory */ for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++) ; ! if (*ptr != 0) { if (__gnat_is_regular_file (file_name)) return xstrdup (file_name); } if (path_val == 0) *************** __gnat_locate_regular_file (file_name, p *** 1798,1806 **** instead. */ char * ! __gnat_locate_exec (exec_name, path_val) ! char *exec_name; ! char *path_val; { if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX)) { --- 1899,1905 ---- instead. */ char * ! __gnat_locate_exec (char *exec_name, char *path_val) { if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX)) { *************** __gnat_locate_exec (exec_name, path_val) *** 1818,1834 **** /* Locate an executable using the Systems default PATH. */ char * ! __gnat_locate_exec_on_path (exec_name) ! char *exec_name; { #ifdef VMS char *path_val = "/VAXC$PATH"; #else char *path_val = getenv ("PATH"); #endif ! char *apath_val = alloca (strlen (path_val) + 1); strcpy (apath_val, path_val); return __gnat_locate_exec (exec_name, apath_val); } --- 1917,1947 ---- /* Locate an executable using the Systems default PATH. */ char * ! __gnat_locate_exec_on_path (char *exec_name) { + char *apath_val; #ifdef VMS char *path_val = "/VAXC$PATH"; #else char *path_val = getenv ("PATH"); #endif ! #ifdef _WIN32 ! /* In Win32 systems we expand the PATH as for XP environment ! variables are not automatically expanded. */ ! int len = strlen (path_val) * 3; ! char *expanded_path_val = alloca (len + 1); ! ! DWORD res = ExpandEnvironmentStrings (path_val, expanded_path_val, len); + if (res != 0) + { + path_val = expanded_path_val; + } + #endif + + apath_val = alloca (strlen (path_val) + 1); strcpy (apath_val, path_val); + return __gnat_locate_exec (exec_name, apath_val); } *************** __gnat_locate_exec_on_path (exec_name) *** 1837,1868 **** /* These functions are used to translate to and from VMS and Unix syntax file, directory and path specifications. */ #define MAXNAMES 256 #define NEW_CANONICAL_FILELIST_INCREMENT 64 ! static char new_canonical_dirspec[255]; ! static char new_canonical_filespec[255]; ! static char new_canonical_pathspec[MAXNAMES*255]; static unsigned new_canonical_filelist_index; static unsigned new_canonical_filelist_in_use; static unsigned new_canonical_filelist_allocated; static char **new_canonical_filelist; ! static char new_host_pathspec[MAXNAMES*255]; ! static char new_host_dirspec[255]; ! static char new_host_filespec[255]; /* Routine is called repeatedly by decc$from_vms via ! __gnat_to_canonical_file_list_init until it returns 0 or the expansion runs ! out. */ static int ! wildcard_translate_unix (name) ! char *name; { char *ver; ! char buff[256]; ! strcpy (buff, name); ver = strrchr (buff, '.'); /* Chop off the version. */ --- 1950,1982 ---- /* These functions are used to translate to and from VMS and Unix syntax file, directory and path specifications. */ + #define MAXPATH 256 #define MAXNAMES 256 #define NEW_CANONICAL_FILELIST_INCREMENT 64 ! static char new_canonical_dirspec [MAXPATH]; ! static char new_canonical_filespec [MAXPATH]; ! static char new_canonical_pathspec [MAXNAMES*MAXPATH]; static unsigned new_canonical_filelist_index; static unsigned new_canonical_filelist_in_use; static unsigned new_canonical_filelist_allocated; static char **new_canonical_filelist; ! static char new_host_pathspec [MAXNAMES*MAXPATH]; ! static char new_host_dirspec [MAXPATH]; ! static char new_host_filespec [MAXPATH]; /* Routine is called repeatedly by decc$from_vms via ! __gnat_to_canonical_file_list_init until it returns 0 or the expansion ! runs out. */ static int ! wildcard_translate_unix (char *name) { char *ver; ! char buff [MAXPATH]; ! strncpy (buff, name, MAXPATH); ! buff [MAXPATH - 1] = (char) 0; ver = strrchr (buff, '.'); /* Chop off the version. */ *************** wildcard_translate_unix (name) *** 1888,1906 **** one at a time (_next). If onlydirs set, only expand directory files. */ int ! __gnat_to_canonical_file_list_init (filespec, onlydirs) ! char *filespec; ! int onlydirs; { int len; ! char buff[256]; len = strlen (filespec); ! strcpy (buff, filespec); ! /* Only look for directories. */ ! if (onlydirs && !strstr (&buff[len - 5], "*.dir")) ! strcat (buff, "*.dir"); decc$from_vms (buff, wildcard_translate_unix, 1); --- 2002,2020 ---- one at a time (_next). If onlydirs set, only expand directory files. */ int ! __gnat_to_canonical_file_list_init (char *filespec, int onlydirs) { int len; ! char buff [MAXPATH]; len = strlen (filespec); ! strncpy (buff, filespec, MAXPATH); ! /* Only look for directories */ ! if (onlydirs && !strstr (&buff [len-5], "*.dir")) ! strncat (buff, "*.dir", MAXPATH); ! ! buff [MAXPATH - 1] = (char) 0; decc$from_vms (buff, wildcard_translate_unix, 1); *************** __gnat_to_canonical_file_list_free () *** 1953,1961 **** slashes, in case it's a logical name. */ char * ! __gnat_to_canonical_dir_spec (dirspec, prefixflag) ! char *dirspec; ! int prefixflag; { int len; --- 2067,2073 ---- slashes, in case it's a logical name. */ char * ! __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag) { int len; *************** __gnat_to_canonical_dir_spec (dirspec, p *** 1965,1980 **** char *dirspec1; if (strchr (dirspec, ']') || strchr (dirspec, ':')) ! strcpy (new_canonical_dirspec, (char *) decc$translate_vms (dirspec)); else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0) ! strcpy (new_canonical_dirspec, (char *) decc$translate_vms (dirspec1)); else ! strcpy (new_canonical_dirspec, dirspec); } len = strlen (new_canonical_dirspec); ! if (prefixflag && new_canonical_dirspec[len - 1] != '/') ! strcat (new_canonical_dirspec, "/"); return new_canonical_dirspec; --- 2077,2104 ---- char *dirspec1; if (strchr (dirspec, ']') || strchr (dirspec, ':')) ! { ! strncpy (new_canonical_dirspec, ! (char *) decc$translate_vms (dirspec), ! MAXPATH); ! } else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0) ! { ! strncpy (new_canonical_dirspec, ! (char *) decc$translate_vms (dirspec1), ! MAXPATH); ! } else ! { ! strncpy (new_canonical_dirspec, dirspec, MAXPATH); ! } } len = strlen (new_canonical_dirspec); ! if (prefixflag && new_canonical_dirspec [len-1] != '/') ! strncat (new_canonical_dirspec, "/", MAXPATH); ! ! new_canonical_dirspec [MAXPATH - 1] = (char) 0; return new_canonical_dirspec; *************** __gnat_to_canonical_dir_spec (dirspec, p *** 1984,1997 **** If no indicators of VMS syntax found, return input string. */ char * ! __gnat_to_canonical_file_spec (filespec) ! char *filespec; { ! strcpy (new_canonical_filespec, ""); if (strchr (filespec, ']') || strchr (filespec, ':')) ! strcpy (new_canonical_filespec, (char *) decc$translate_vms (filespec)); else ! strcpy (new_canonical_filespec, filespec); return new_canonical_filespec; } --- 2108,2129 ---- If no indicators of VMS syntax found, return input string. */ char * ! __gnat_to_canonical_file_spec (char *filespec) { ! strncpy (new_canonical_filespec, "", MAXPATH); ! if (strchr (filespec, ']') || strchr (filespec, ':')) ! { ! strncpy (new_canonical_filespec, ! (char *) decc$translate_vms (filespec), ! MAXPATH); ! } else ! { ! strncpy (new_canonical_filespec, filespec, MAXPATH); ! } ! ! new_canonical_filespec [MAXPATH - 1] = (char) 0; return new_canonical_filespec; } *************** __gnat_to_canonical_file_spec (filespec) *** 2000,2009 **** If no indicators of VMS syntax found, return input string. */ char * ! __gnat_to_canonical_path_spec (pathspec) ! char *pathspec; { ! char *curr, *next, buff[256]; if (pathspec == 0) return pathspec; --- 2132,2140 ---- If no indicators of VMS syntax found, return input string. */ char * ! __gnat_to_canonical_path_spec (char *pathspec) { ! char *curr, *next, buff [MAXPATH]; if (pathspec == 0) return pathspec; *************** __gnat_to_canonical_path_spec (pathspec) *** 2035,2071 **** char *next_dir; next_dir = __gnat_to_canonical_file_list_next (); ! strcat (new_canonical_pathspec, next_dir); /* Don't append the separator after the last expansion. */ if (i+1 < dirs) ! strcat (new_canonical_pathspec, ":"); } __gnat_to_canonical_file_list_free (); } else ! strcat (new_canonical_pathspec, ! __gnat_to_canonical_dir_spec (buff, 0)); if (*next == 0) break; ! strcat (new_canonical_pathspec, ":"); curr = next + 1; } return new_canonical_pathspec; } ! static char filename_buff[256]; static int ! translate_unix (name, type) ! char *name; ! int type; { ! strcpy (filename_buff, name); return 0; } --- 2166,2203 ---- char *next_dir; next_dir = __gnat_to_canonical_file_list_next (); ! strncat (new_canonical_pathspec, next_dir, MAXPATH); /* Don't append the separator after the last expansion. */ if (i+1 < dirs) ! strncat (new_canonical_pathspec, ":", MAXPATH); } __gnat_to_canonical_file_list_free (); } else ! strncat (new_canonical_pathspec, ! __gnat_to_canonical_dir_spec (buff, 0), MAXPATH); if (*next == 0) break; ! strncat (new_canonical_pathspec, ":", MAXPATH); curr = next + 1; } + new_canonical_pathspec [MAXPATH - 1] = (char) 0; + return new_canonical_pathspec; } ! static char filename_buff [MAXPATH]; static int ! translate_unix (char *name, int type) { ! strncpy (filename_buff, name, MAXPATH); ! filename_buff [MAXPATH - 1] = (char) 0; return 0; } *************** translate_unix (name, type) *** 2073,2082 **** directories. */ static char * ! to_host_path_spec (pathspec) ! char *pathspec; { ! char *curr, *next, buff[256]; if (pathspec == 0) return pathspec; --- 2205,2213 ---- directories. */ static char * ! to_host_path_spec (char *pathspec) { ! char *curr, *next, buff [MAXPATH]; if (pathspec == 0) return pathspec; *************** to_host_path_spec (pathspec) *** 2097,2109 **** strncpy (buff, curr, next - curr); buff[next - curr] = 0; ! strcat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0)); if (*next == 0) break; ! strcat (new_host_pathspec, ","); curr = next + 1; } return new_host_pathspec; } --- 2228,2242 ---- strncpy (buff, curr, next - curr); buff[next - curr] = 0; ! strncat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0), MAXPATH); if (*next == 0) break; ! strncat (new_host_pathspec, ",", MAXPATH); curr = next + 1; } + new_host_pathspec [MAXPATH - 1] = (char) 0; + return new_host_pathspec; } *************** to_host_path_spec (pathspec) *** 2113,2125 **** string. */ char * ! __gnat_to_host_dir_spec (dirspec, prefixflag) ! char *dirspec; ! int prefixflag ATTRIBUTE_UNUSED; { int len = strlen (dirspec); ! strcpy (new_host_dirspec, dirspec); if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':')) return new_host_dirspec; --- 2246,2257 ---- string. */ char * ! __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED) { int len = strlen (dirspec); ! strncpy (new_host_dirspec, dirspec, MAXPATH); ! new_host_dirspec [MAXPATH - 1] = (char) 0; if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':')) return new_host_dirspec; *************** __gnat_to_host_dir_spec (dirspec, prefix *** 2131,2158 **** } decc$to_vms (new_host_dirspec, translate_unix, 1, 2); ! strcpy (new_host_dirspec, filename_buff); return new_host_dirspec; - } /* Translate a Unix syntax file specification into VMS syntax. If indicators of VMS syntax found, return input string. */ char * ! __gnat_to_host_file_spec (filespec) ! char *filespec; { ! strcpy (new_host_filespec, ""); if (strchr (filespec, ']') || strchr (filespec, ':')) ! strcpy (new_host_filespec, filespec); else { decc$to_vms (filespec, translate_unix, 1, 1); ! strcpy (new_host_filespec, filename_buff); } return new_host_filespec; } --- 2263,2293 ---- } decc$to_vms (new_host_dirspec, translate_unix, 1, 2); ! strncpy (new_host_dirspec, filename_buff, MAXPATH); ! new_host_dirspec [MAXPATH - 1] = (char) 0; return new_host_dirspec; } /* Translate a Unix syntax file specification into VMS syntax. If indicators of VMS syntax found, return input string. */ char * ! __gnat_to_host_file_spec (char *filespec) { ! strncpy (new_host_filespec, "", MAXPATH); if (strchr (filespec, ']') || strchr (filespec, ':')) ! { ! strncpy (new_host_filespec, filespec, MAXPATH); ! } else { decc$to_vms (filespec, translate_unix, 1, 1); ! strncpy (new_host_filespec, filename_buff, MAXPATH); } + new_host_filespec [MAXPATH - 1] = (char) 0; + return new_host_filespec; } *************** __gnat_adjust_os_resource_limits () *** 2162,2229 **** SYS$ADJWSL (131072, 0); } ! #else /* Dummy functions for Osint import for non-VMS systems. */ int ! __gnat_to_canonical_file_list_init (dirspec, onlydirs) ! char *dirspec ATTRIBUTE_UNUSED; ! int onlydirs ATTRIBUTE_UNUSED; { return 0; } char * ! __gnat_to_canonical_file_list_next () { return (char *) ""; } void ! __gnat_to_canonical_file_list_free () { } char * ! __gnat_to_canonical_dir_spec (dirspec, prefixflag) ! char *dirspec; ! int prefixflag ATTRIBUTE_UNUSED; { return dirspec; } char * ! __gnat_to_canonical_file_spec (filespec) ! char *filespec; { return filespec; } char * ! __gnat_to_canonical_path_spec (pathspec) ! char *pathspec; { return pathspec; } char * ! __gnat_to_host_dir_spec (dirspec, prefixflag) ! char *dirspec; ! int prefixflag ATTRIBUTE_UNUSED; { return dirspec; } char * ! __gnat_to_host_file_spec (filespec) ! char *filespec; { return filespec; } void ! __gnat_adjust_os_resource_limits () { } --- 2297,2356 ---- SYS$ADJWSL (131072, 0); } ! #else /* VMS */ /* Dummy functions for Osint import for non-VMS systems. */ int ! __gnat_to_canonical_file_list_init ! (char *dirspec ATTRIBUTE_UNUSED, int onlydirs ATTRIBUTE_UNUSED) { return 0; } char * ! __gnat_to_canonical_file_list_next (void) { return (char *) ""; } void ! __gnat_to_canonical_file_list_free (void) { } char * ! __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED) { return dirspec; } char * ! __gnat_to_canonical_file_spec (char *filespec) { return filespec; } char * ! __gnat_to_canonical_path_spec (char *pathspec) { return pathspec; } char * ! __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED) { return dirspec; } char * ! __gnat_to_host_file_spec (char *filespec) { return filespec; } void ! __gnat_adjust_os_resource_limits (void) { } *************** void __dummy () {} *** 2238,2244 **** #endif #if defined (__mips_vxworks) ! int _flush_cache() { CACHE_USER_FLUSH (0, ENTIRE_CACHE); } --- 2365,2372 ---- #endif #if defined (__mips_vxworks) ! int ! _flush_cache() { CACHE_USER_FLUSH (0, ENTIRE_CACHE); } *************** int _flush_cache() *** 2246,2266 **** #if defined (CROSS_COMPILE) \ || (! (defined (sparc) && defined (sun) && defined (__SVR4)) \ ! && ! defined (linux) \ && ! defined (hpux) \ && ! (defined (__alpha__) && defined (__osf__)) \ && ! defined (__MINGW32__)) /* Dummy function to satisfy g-trasym.o. Currently Solaris sparc, HP/UX, ! GNU/Linux, Tru64 & Windows provide a non-dummy version of this procedure in ! libaddr2line.a. */ void ! convert_addresses (addrs, n_addr, buf, len) ! void *addrs ATTRIBUTE_UNUSED; ! int n_addr ATTRIBUTE_UNUSED; ! void *buf ATTRIBUTE_UNUSED; ! int *len; { *len = 0; } --- 2374,2394 ---- #if defined (CROSS_COMPILE) \ || (! (defined (sparc) && defined (sun) && defined (__SVR4)) \ ! && ! (defined (linux) && defined (i386)) \ && ! defined (hpux) \ + && ! defined (_AIX) \ && ! (defined (__alpha__) && defined (__osf__)) \ && ! defined (__MINGW32__)) /* Dummy function to satisfy g-trasym.o. Currently Solaris sparc, HP/UX, ! GNU/Linux x86, Tru64 & Windows provide a non-dummy version of this ! procedure in libaddr2line.a. */ void ! convert_addresses (void *addrs ATTRIBUTE_UNUSED, ! int n_addr ATTRIBUTE_UNUSED, ! void *buf ATTRIBUTE_UNUSED, ! int *len ATTRIBUTE_UNUSED) { *len = 0; } *************** int __gnat_argument_needs_quote = 1; *** 2271,2273 **** --- 2399,2497 ---- #else int __gnat_argument_needs_quote = 0; #endif + + /* This option is used to enable/disable object files handling from the + binder file by the GNAT Project module. For example, this is disabled on + Windows as it is already done by the mdll module. */ + #if defined (_WIN32) + int __gnat_prj_add_obj_files = 0; + #else + int __gnat_prj_add_obj_files = 1; + #endif + + /* char used as prefix/suffix for environment variables */ + #if defined (_WIN32) + char __gnat_environment_char = '%'; + #else + char __gnat_environment_char = '$'; + #endif + + /* This functions copy the file attributes from a source file to a + destination file. + + mode = 0 : In this mode copy only the file time stamps (last access and + last modification time stamps). + + mode = 1 : In this mode, time stamps and read/write/execute attributes are + copied. + + Returns 0 if operation was successful and -1 in case of error. */ + + int + __gnat_copy_attribs (char *from, char *to, int mode) + { + #if defined (VMS) || defined (__vxworks) + return -1; + #else + struct stat fbuf; + struct utimbuf tbuf; + + if (stat (from, &fbuf) == -1) + { + return -1; + } + + tbuf.actime = fbuf.st_atime; + tbuf.modtime = fbuf.st_mtime; + + if (utime (to, &tbuf) == -1) + { + return -1; + } + + if (mode == 1) + { + if (chmod (to, fbuf.st_mode) == -1) + { + return -1; + } + } + + return 0; + #endif + } + + /* This function is installed in libgcc.a. */ + extern void __gnat_install_locks (void (*) (void), void (*) (void)); + + /* This function offers a hook for libgnarl to set the + locking subprograms for libgcc_eh. + This is only needed on OpenVMS, since other platforms use standard + --enable-threads=posix option, or similar. */ + + void + __gnatlib_install_locks (void (*lock) (void) ATTRIBUTE_UNUSED, + void (*unlock) (void) ATTRIBUTE_UNUSED) + { + #if defined (IN_RTS) && defined (VMS) + __gnat_install_locks (lock, unlock); + /* There is a bootstrap path issue if adaint is build with this + symbol unresolved for the stage1 compiler. Since the compiler + does not use tasking, we simply make __gnatlib_install_locks + a no-op in this case. */ + #endif + } + + int + __gnat_lseek (int fd, long offset, int whence) + { + return (int) lseek (fd, offset, whence); + } + + /* This function returns the version of GCC being used. Here it's GCC 3. */ + int + get_gcc_version (void) + { + return 3; + } + diff -Nrc3pad gcc-3.3.3/gcc/ada/adaint.h gcc-3.4.0/gcc/ada/adaint.h *** gcc-3.3.3/gcc/ada/adaint.h 2003-01-29 17:40:47.000000000 +0000 --- gcc-3.4.0/gcc/ada/adaint.h 2003-12-03 11:47:52.000000000 +0000 *************** *** 4,13 **** * * * A D A I N T * * * - * * * C Header File * * * ! * Copyright (C) 1992-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- * --- 4,12 ---- * * * A D A I N T * * * * C Header File * * * ! * 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- * *************** *** 31,144 **** * * ****************************************************************************/ - #if defined(__rtems__) #include - #endif - #include ! extern int __gnat_max_path_len; ! extern void __gnat_to_gm_time PARAMS ((int *, int *, ! int *, int *, ! int *, int *, ! int *)); ! extern int __gnat_get_maximum_file_name_length PARAMS ((void)); ! extern int __gnat_get_switches_case_sensitive PARAMS ((void)); ! extern int __gnat_get_file_names_case_sensitive PARAMS ((void)); ! extern char __gnat_get_default_identifier_character_set PARAMS ((void)); ! extern void __gnat_get_current_dir PARAMS ((char *, int *)); ! extern void __gnat_get_object_suffix_ptr PARAMS ((int *, ! const char **)); ! extern void __gnat_get_executable_suffix_ptr PARAMS ((int *, ! const char **)); ! extern void __gnat_get_debuggable_suffix_ptr PARAMS ((int *, ! const char **)); ! extern int __gnat_readlink PARAMS ((char *, char *, ! size_t)); ! extern int __gnat_symlink PARAMS ((char *, char *)); ! extern int __gnat_try_lock PARAMS ((char *, char *)); ! extern int __gnat_open_new PARAMS ((char *, int)); ! extern int __gnat_open_new_temp PARAMS ((char *, int)); ! extern int __gnat_mkdir PARAMS ((char *)); ! extern int __gnat_stat PARAMS ((char *, ! struct stat *)); ! extern int __gnat_open_read PARAMS ((char *, int)); ! extern int __gnat_open_rw PARAMS ((char *, int)); ! extern int __gnat_open_create PARAMS ((char *, int)); ! extern int __gnat_open_append PARAMS ((char *, int)); ! extern long __gnat_file_length PARAMS ((int)); ! extern void __gnat_tmp_name PARAMS ((char *)); ! extern char *__gnat_readdir PARAMS ((DIR *, char *)); ! extern int __gnat_readdir_is_thread_safe PARAMS ((void)); ! extern time_t __gnat_file_time_name PARAMS ((char *)); ! extern time_t __gnat_file_time_fd PARAMS ((int)); ! extern void __gnat_set_file_time_name PARAMS ((char *, time_t)); ! extern void __gnat_get_env_value_ptr PARAMS ((char *, int *, ! char **)); ! extern int __gnat_file_exists PARAMS ((char *)); ! extern int __gnat_is_regular_file PARAMS ((char *)); ! extern int __gnat_is_absolute_path PARAMS ((char *)); ! extern int __gnat_is_directory PARAMS ((char *)); ! extern int __gnat_is_writable_file PARAMS ((char *)); ! extern int __gnat_portable_spawn PARAMS ((char *[])); ! extern int __gnat_portable_no_block_spawn PARAMS ((char *[])); ! extern int __gnat_portable_wait PARAMS ((int *)); ! extern int __gnat_waitpid PARAMS ((int)); ! extern char *__gnat_locate_exec PARAMS ((char *, char *)); ! extern char *__gnat_locate_exec_on_path PARAMS ((char *)); ! extern char *__gnat_locate_regular_file PARAMS ((char *, char *)); ! extern void __gnat_maybe_glob_args PARAMS ((int *, char ***)); ! extern void __gnat_os_exit PARAMS ((int)); ! extern void __gnat_set_env_value PARAMS ((char *, char *)); ! extern char *__gnat_get_libraries_from_registry PARAMS ((void)); ! extern int __gnat_to_canonical_file_list_init PARAMS ((char *, int)); ! extern char *__gnat_to_canonical_file_list_next PARAMS ((void)); ! extern void __gnat_to_canonical_file_list_free PARAMS ((void)); ! extern char *__gnat_to_canonical_dir_spec PARAMS ((char *, int)); ! extern char *__gnat_to_canonical_file_spec PARAMS ((char *)); ! extern char *__gnat_to_host_dir_spec PARAMS ((char *, int)); ! extern char *__gnat_to_host_file_spec PARAMS ((char *)); ! extern char *__gnat_to_canonical_path_spec PARAMS ((char *)); ! extern void __gnat_adjust_os_resource_limits PARAMS ((void)); ! extern int __gnat_feof PARAMS ((FILE *)); ! extern int __gnat_ferror PARAMS ((FILE *)); ! extern int __gnat_fileno PARAMS ((FILE *)); ! extern int __gnat_is_regular_file_fd PARAMS ((int)); ! extern FILE *__gnat_constant_stderr PARAMS ((void)); ! extern FILE *__gnat_constant_stdin PARAMS ((void)); ! extern FILE *__gnat_constant_stdout PARAMS ((void)); ! extern char *__gnat_full_name PARAMS ((char *, char *)); ! extern int __gnat_arg_count PARAMS ((void)); ! extern int __gnat_len_arg PARAMS ((int)); ! extern void __gnat_fill_arg PARAMS ((char *, int)); ! extern int __gnat_env_count PARAMS ((void)); ! extern int __gnat_len_env PARAMS ((int)); ! extern void __gnat_fill_env PARAMS ((char *, int)); /* Routines for interface to scanf and printf functions for integer values */ ! extern int get_int PARAMS ((void)); ! extern void put_int PARAMS ((int)); ! extern void put_int_stderr PARAMS ((int)); ! extern int get_char PARAMS ((void)); ! extern void put_char PARAMS ((int)); ! extern void put_char_stderr PARAMS ((int)); ! extern char *mktemp PARAMS ((char *)); ! extern void __gnat_set_exit_status PARAMS ((int)); ! extern int __gnat_expect_fork PARAMS ((void)); ! extern void __gnat_expect_portable_execvp PARAMS ((char *, char *[])); ! extern int __gnat_pipe PARAMS ((int *)); ! extern int __gnat_expect_poll PARAMS ((int *, int, int, ! int *)); ! extern void __gnat_set_binary_mode PARAMS ((int)); ! extern void __gnat_set_text_mode PARAMS ((int)); ! extern char *__gnat_ttyname PARAMS ((int)); #ifdef IN_RTS /* Portable definition of strdup, which is not available on all systems. */ #define xstrdup(S) strcpy ((char *) malloc (strlen (S) + 1), S) #endif --- 30,160 ---- * * ****************************************************************************/ #include #include ! typedef long OS_Time; /* Type corresponding to GNAT.OS_Lib.OS_Time */ ! extern int __gnat_max_path_len; ! extern void __gnat_to_gm_time (OS_Time *, int *, ! int *, int *, ! int *, int *, ! int *); ! extern int __gnat_get_maximum_file_name_length (void); ! extern int __gnat_get_switches_case_sensitive (void); ! extern int __gnat_get_file_names_case_sensitive (void); ! extern char __gnat_get_default_identifier_character_set (void); ! extern void __gnat_get_current_dir (char *, int *); ! extern void __gnat_get_object_suffix_ptr (int *, ! const char **); ! extern void __gnat_get_executable_suffix_ptr (int *, ! const char **); ! extern void __gnat_get_debuggable_suffix_ptr (int *, ! const char **); ! extern int __gnat_readlink (char *, char *, ! size_t); ! extern int __gnat_symlink (char *, char *); ! extern int __gnat_try_lock (char *, char *); ! extern int __gnat_open_new (char *, int); ! extern int __gnat_open_new_temp (char *, int); ! extern int __gnat_mkdir (char *); ! extern int __gnat_stat (char *, ! struct stat *); ! extern int __gnat_open_read (char *, int); ! extern int __gnat_open_rw (char *, int); ! extern int __gnat_open_create (char *, int); ! extern int __gnat_open_append (char *, int); ! extern long __gnat_file_length (int); ! extern void __gnat_tmp_name (char *); ! extern char *__gnat_readdir (DIR *, char *); ! extern int __gnat_readdir_is_thread_safe (void); ! extern time_t __gnat_file_time_name (char *); ! extern time_t __gnat_file_time_fd (int); ! extern void __gnat_set_file_time_name (char *, time_t); ! extern void __gnat_get_env_value_ptr (char *, int *, ! char **); ! extern int __gnat_file_exists (char *); ! extern int __gnat_is_regular_file (char *); ! extern int __gnat_is_absolute_path (char *); ! extern int __gnat_is_directory (char *); ! extern int __gnat_is_writable_file (char *); ! extern int __gnat_is_readable_file (char *name); ! extern void __gnat_set_readonly (char *name); ! extern void __gnat_set_writable (char *name); ! extern int __gnat_is_symbolic_link (char *name); ! extern int __gnat_portable_spawn (char *[]); ! extern int __gnat_portable_no_block_spawn (char *[]); ! extern int __gnat_portable_wait (int *); ! extern int __gnat_waitpid (int); ! extern char *__gnat_locate_exec (char *, char *); ! extern char *__gnat_locate_exec_on_path (char *); ! extern char *__gnat_locate_regular_file (char *, char *); ! extern void __gnat_maybe_glob_args (int *, char ***); ! extern void __gnat_os_exit (int); ! extern void __gnat_set_env_value (char *, char *); ! extern char *__gnat_get_libraries_from_registry (void); ! extern int __gnat_to_canonical_file_list_init (char *, int); ! extern char *__gnat_to_canonical_file_list_next (void); ! extern void __gnat_to_canonical_file_list_free (void); ! extern char *__gnat_to_canonical_dir_spec (char *, int); ! extern char *__gnat_to_canonical_file_spec (char *); ! extern char *__gnat_to_host_dir_spec (char *, int); ! extern char *__gnat_to_host_file_spec (char *); ! extern char *__gnat_to_canonical_path_spec (char *); ! extern void __gnat_adjust_os_resource_limits (void); ! extern void convert_addresses (void *, int, ! void *, int *); ! extern int __gnat_copy_attribs (char *, char *, int); ! extern int __gnat_feof (FILE *); ! extern int __gnat_ferror (FILE *); ! extern int __gnat_fileno (FILE *); ! extern int __gnat_is_regular_file_fd (int); ! extern FILE *__gnat_constant_stderr (void); ! extern FILE *__gnat_constant_stdin (void); ! extern FILE *__gnat_constant_stdout (void); ! extern char *__gnat_full_name (char *, char *); ! extern int __gnat_arg_count (void); ! extern int __gnat_len_arg (int); ! extern void __gnat_fill_arg (char *, int); ! extern int __gnat_env_count (void); ! extern int __gnat_len_env (int); ! extern void __gnat_fill_env (char *, int); /* Routines for interface to scanf and printf functions for integer values */ ! extern int get_int (void); ! extern void put_int (int); ! extern void put_int_stderr (int); ! extern int get_char (void); ! extern void put_char (int); ! extern void put_char_stderr (int); ! extern char *mktemp (char *); ! extern void __gnat_set_exit_status (int); ! extern int __gnat_expect_fork (void); ! extern void __gnat_expect_portable_execvp (char *, char *[]); ! extern int __gnat_pipe (int *); ! extern int __gnat_expect_poll (int *, int, int, int *); ! extern void __gnat_set_binary_mode (int); ! extern void __gnat_set_text_mode (int); ! extern char *__gnat_ttyname (int); ! extern int __gnat_lseek (int, long, int); ! ! #ifdef __MINGW32__ ! extern void __gnat_plist_init (void); ! #endif #ifdef IN_RTS /* Portable definition of strdup, which is not available on all systems. */ #define xstrdup(S) strcpy ((char *) malloc (strlen (S) + 1), S) #endif + + /* This function returns the version of GCC being used. Here it's GCC 3. */ + extern int get_gcc_version (void); + + /* This function offers a hook for libgnarl to set the + locking subprograms for libgcc_eh. */ + extern void __gnatlib_install_locks (void (*) (void), + void (*) (void)); diff -Nrc3pad gcc-3.3.3/gcc/ada/ada-tree.def gcc-3.4.0/gcc/ada/ada-tree.def *** gcc-3.3.3/gcc/ada/ada-tree.def 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/ada-tree.def 2003-11-18 10:00:42.000000000 +0000 *************** *** 6,13 **** * * * Specification * * * ! * * ! * 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 ---- * * * Specification * * * ! * 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- * *************** DEFTREECODE (TRANSFORM_EXPR, "transform_ *** 38,44 **** by operand 0 at the alignment given by operand 1 and return the address of the resulting memory. */ ! DEFTREECODE (ALLOCATE_EXPR, "allocate_expr", 's', 2) /* A type that is an unconstrained array itself. This node is never passed to GCC. TREE_TYPE is the type of the fat pointer and TYPE_OBJECT_RECORD_TYPE --- 37,43 ---- by operand 0 at the alignment given by operand 1 and return the address of the resulting memory. */ ! DEFTREECODE (ALLOCATE_EXPR, "allocate_expr", '2', 2) /* A type that is an unconstrained array itself. This node is never passed to GCC. TREE_TYPE is the type of the fat pointer and TYPE_OBJECT_RECORD_TYPE *************** DEFTREECODE (GNAT_NOP_EXPR, "gnat_nop_ex *** 77,80 **** ??? This should be redone at some point. */ ! DEFTREECODE (GNAT_LOOP_ID, "gnat_loop_id", 'x', 1) --- 76,87 ---- ??? This should be redone at some point. */ ! DEFTREECODE (GNAT_LOOP_ID, "gnat_loop_id", 'x', 0) ! ! /* Here are the tree codes for the statement types known to Ada. These ! must be at the end of this file to allow IS_STMT to work. ! ! We start with an expression statement, whose only operand is an ! expression, EXPR_STMT_EXPR, Execution of the statement means evaluation of ! the expression (such as a MODIFY_EXPR) and discarding its result. */ ! DEFTREECODE (EXPR_STMT, "expr_stmt_expr", 's', 1) diff -Nrc3pad gcc-3.3.3/gcc/ada/ada-tree.h gcc-3.4.0/gcc/ada/ada-tree.h *** gcc-3.3.3/gcc/ada/ada-tree.h 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/ada-tree.h 2003-11-17 14:58:14.000000000 +0000 *************** *** 6,13 **** * * * C Header File * * * ! * * ! * 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 ---- * * * C Header File * * * ! * 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- * *************** struct tree_loop_id GTY(()) *** 43,49 **** /* The language-specific tree. */ union lang_tree_node ! GTY((desc ("TREE_CODE (&%h.generic) == GNAT_LOOP_ID"))) { union tree_node GTY ((tag ("0"), desc ("tree_node_structure (&%h)"))) --- 42,49 ---- /* The language-specific tree. */ union lang_tree_node ! GTY((desc ("TREE_CODE (&%h.generic) == GNAT_LOOP_ID"), ! chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)"))) { union tree_node GTY ((tag ("0"), desc ("tree_node_structure (&%h)"))) *************** struct lang_type GTY(()) *** 72,81 **** #define TYPE_FAT_POINTER_P(NODE) \ (TREE_CODE (NODE) == RECORD_TYPE && TYPE_IS_FAT_POINTER_P (NODE)) ! /* For integral types, nonzero if this is a packed array type. Such ! types should not be extended to a larger size. */ #define TYPE_PACKED_ARRAY_TYPE_P(NODE) TYPE_LANG_FLAG_0 (NODE) /* For INTEGER_TYPE, nonzero if this is a modular type with a modulus that is not equal to two to the power of its mode's size. */ #define TYPE_MODULAR_P(NODE) TYPE_LANG_FLAG_1 (INTEGER_TYPE_CHECK (NODE)) --- 72,85 ---- #define TYPE_FAT_POINTER_P(NODE) \ (TREE_CODE (NODE) == RECORD_TYPE && TYPE_IS_FAT_POINTER_P (NODE)) ! /* For integral types and array types, nonzero if this is a packed array type. ! Such types should not be extended to a larger size. */ #define TYPE_PACKED_ARRAY_TYPE_P(NODE) TYPE_LANG_FLAG_0 (NODE) + #define TYPE_IS_PACKED_ARRAY_TYPE_P(NODE) \ + ((TREE_CODE (NODE) == INTEGER_TYPE || TREE_CODE (NODE) == ARRAY_TYPE) \ + && TYPE_PACKED_ARRAY_TYPE_P (NODE)) + /* For INTEGER_TYPE, nonzero if this is a modular type with a modulus that is not equal to two to the power of its mode's size. */ #define TYPE_MODULAR_P(NODE) TYPE_LANG_FLAG_1 (INTEGER_TYPE_CHECK (NODE)) *************** struct lang_type GTY(()) *** 174,187 **** #define TYPE_INDEX_TYPE(NODE) \ (&TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))->t.generic) #define SET_TYPE_INDEX_TYPE(NODE, X) \ ! (TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) = (struct lang_type *)(X)) /* For an INTEGER_TYPE with TYPE_VAX_FLOATING_POINT_P, stores the Digits_Value. */ ! #define TYPE_DIGITS_VALUE(NODE) \ ! ((long) TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))) #define SET_TYPE_DIGITS_VALUE(NODE, X) \ ! (TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) = (struct lang_type *)(X)) /* For INTEGER_TYPE, stores the RM_Size of the type. */ #define TYPE_RM_SIZE_INT(NODE) TYPE_VALUES (INTEGER_TYPE_CHECK (NODE)) --- 178,191 ---- #define TYPE_INDEX_TYPE(NODE) \ (&TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))->t.generic) #define SET_TYPE_INDEX_TYPE(NODE, X) \ ! (TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) = (struct lang_type *) (X)) /* For an INTEGER_TYPE with TYPE_VAX_FLOATING_POINT_P, stores the Digits_Value. */ ! #define TYPE_DIGITS_VALUE(NODE) \ ! (&TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))->t.generic) #define SET_TYPE_DIGITS_VALUE(NODE, X) \ ! (TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) = (struct lang_type *) (X)) /* For INTEGER_TYPE, stores the RM_Size of the type. */ #define TYPE_RM_SIZE_INT(NODE) TYPE_VALUES (INTEGER_TYPE_CHECK (NODE)) *************** struct lang_type GTY(()) *** 233,239 **** /* Nonzero if this decl is a PARM_DECL for an Ada array being passed to a foreign convention subprogram. */ ! #define DECL_BY_COMPONENT_PTR_P(NODE) DECL_LANG_FLAG_2 (NODE) /* Nonzero in a FIELD_DECL that is a dummy built for some internal reason. */ #define DECL_INTERNAL_P(NODE) DECL_LANG_FLAG_3 (FIELD_DECL_CHECK (NODE)) --- 237,243 ---- /* Nonzero if this decl is a PARM_DECL for an Ada array being passed to a foreign convention subprogram. */ ! #define DECL_BY_COMPONENT_PTR_P(NODE) DECL_LANG_FLAG_2 (PARM_DECL_CHECK (NODE)) /* Nonzero in a FIELD_DECL that is a dummy built for some internal reason. */ #define DECL_INTERNAL_P(NODE) DECL_LANG_FLAG_3 (FIELD_DECL_CHECK (NODE)) *************** struct lang_type GTY(()) *** 271,277 **** discriminant number. */ #define DECL_DISCRIMINANT_NUMBER(NODE) DECL_INITIAL (FIELD_DECL_CHECK (NODE)) ! /* This is a horrible kludge to store the loop_id of a loop into a tree ! node. We need to find some other place to store it! */ #define TREE_LOOP_ID(NODE) \ ! (((union lang_tree_node *)TREE_CHECK (NODE, GNAT_LOOP_ID))->loop_id.loop_id) --- 275,291 ---- discriminant number. */ #define DECL_DISCRIMINANT_NUMBER(NODE) DECL_INITIAL (FIELD_DECL_CHECK (NODE)) ! /* This is the loop id for a GNAT_LOOP_ID node. */ #define TREE_LOOP_ID(NODE) \ ! ((union lang_tree_node *) TREE_CHECK (NODE, GNAT_LOOP_ID))->loop_id.loop_id ! ! /* Define fields and macros for statements. ! ! Start by defining which tree codes are used for statements. */ ! #define IS_STMT(NODE) (TREE_CODE_CLASS (TREE_CODE (NODE)) == 's') ! ! /* We store the Sloc in statement nodes. */ ! #define TREE_SLOC(NODE) TREE_COMPLEXITY (STMT_CHECK (NODE)) ! ! /* There is just one field in an EXPR_STMT: the expression. */ ! #define EXPR_STMT_EXPR(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXPR_STMT, 0) diff -Nrc3pad gcc-3.3.3/gcc/ada/a-decima.adb gcc-3.4.0/gcc/ada/a-decima.adb *** gcc-3.3.3/gcc/ada/a-decima.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-decima.adb 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992,1993,1994 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/a-decima.ads gcc-3.4.0/gcc/ada/a-decima.ads *** gcc-3.3.3/gcc/ada/a-decima.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-decima.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-diocst.adb gcc-3.4.0/gcc/ada/a-diocst.adb *** gcc-3.3.3/gcc/ada/a-diocst.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-diocst.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-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.Direct_IO.C_Streams is *** 64,80 **** procedure Open (File : in out File_Type; ! Mode : in File_Mode; ! C_Stream : in FILEs; ! Form : in String := "") is ! File_Control_Block : DIO.Direct_AFCB; begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => File_Control_Block, Mode => To_FCB (Mode), ! Name => "", Form => Form, Amethod => 'D', Creat => False, --- 63,83 ---- procedure Open (File : in out File_Type; ! Mode : File_Mode; ! C_Stream : FILEs; ! Form : String := ""; ! Name : String := "") is ! Dummy_File_Control_Block : DIO.Direct_AFCB; ! pragma Warnings (Off, Dummy_File_Control_Block); ! -- Yes, we know this is never assigned a value, only the tag ! -- is used for dispatching purposes, so that's expected. begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => Dummy_File_Control_Block, Mode => To_FCB (Mode), ! Name => Name, Form => Form, Amethod => 'D', Creat => False, diff -Nrc3pad gcc-3.3.3/gcc/ada/a-diocst.ads gcc-3.4.0/gcc/ada/a-diocst.ads *** gcc-3.3.3/gcc/ada/a-diocst.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-diocst.ads 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1992,1993,1994,1995 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-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 Ada.Direct_IO.C_Streams is *** 48,56 **** procedure Open (File : in out File_Type; ! Mode : in File_Mode; ! C_Stream : in ICS.FILEs; ! Form : in String := ""); -- Create new file from existing stream end Ada.Direct_IO.C_Streams; --- 47,56 ---- procedure Open (File : in out File_Type; ! Mode : File_Mode; ! C_Stream : ICS.FILEs; ! Form : String := ""; ! Name : String := ""); -- Create new file from existing stream end Ada.Direct_IO.C_Streams; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-direio.adb gcc-3.4.0/gcc/ada/a-direio.adb *** gcc-3.3.3/gcc/ada/a-direio.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-direio.adb 2003-12-15 11:51:00.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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- -- --- 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- -- *************** *** 39,44 **** --- 38,44 ---- with Interfaces.C_Streams; use Interfaces.C_Streams; with System; use System; + with System.CRTL; with System.File_Control_Block; with System.File_IO; with System.Direct_IO; *************** use type System.Direct_IO.Count; *** 49,55 **** package body Ada.Direct_IO is ! Zeroes : System.Storage_Elements.Storage_Array := (1 .. System.Storage_Elements.Storage_Offset (Bytes) => 0); -- Buffer used to fill out partial records. --- 49,55 ---- package body Ada.Direct_IO is ! Zeroes : constant System.Storage_Elements.Storage_Array := (1 .. System.Storage_Elements.Storage_Offset (Bytes) => 0); -- Buffer used to fill out partial records. *************** package body Ada.Direct_IO is *** 61,72 **** subtype AP is FCB.AFCB_Ptr; subtype FP is DIO.File_Type; - subtype DCount is DIO.Count; subtype DPCount is DIO.Positive_Count; function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode); function To_DIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode); ----------- -- Close -- ----------- --- 61,73 ---- subtype AP is FCB.AFCB_Ptr; subtype FP is DIO.File_Type; subtype DPCount is DIO.Positive_Count; function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode); function To_DIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode); + use type System.CRTL.size_t; + ----------- -- Close -- ----------- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-direio.ads gcc-3.4.0/gcc/ada/a-direio.ads *** gcc-3.3.3/gcc/ada/a-direio.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-direio.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1999 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/a-dynpri.adb gcc-3.4.0/gcc/ada/a-dynpri.adb *** gcc-3.3.3/gcc/ada/a-dynpri.adb 2002-10-28 16:19:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-dynpri.adb 2003-04-24 17:53:53.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 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-dynpri.ads gcc-3.4.0/gcc/ada/a-dynpri.ads *** gcc-3.3.3/gcc/ada/a-dynpri.ads 2002-03-14 10:58:48.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-dynpri.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-einuoc.adb gcc-3.4.0/gcc/ada/a-einuoc.adb *** gcc-3.3.3/gcc/ada/a-einuoc.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-einuoc.adb 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 2000 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/a-einuoc.ads gcc-3.4.0/gcc/ada/a-einuoc.ads *** gcc-3.3.3/gcc/ada/a-einuoc.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-einuoc.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 2000 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/a-elchha.adb gcc-3.4.0/gcc/ada/a-elchha.adb *** gcc-3.3.3/gcc/ada/a-elchha.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-elchha.adb 2003-12-17 13:37:03.000000000 +0000 *************** *** 0 **** --- 1,165 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- A D A . E X C E P T I O N S . L A S T _ C H A N C E _ H A N D L E R -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 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. -- + -- -- + ------------------------------------------------------------------------------ + + -- Default version for most targets + + procedure Ada.Exceptions.Last_Chance_Handler + (Except : Exception_Occurrence) + is + procedure Unhandled_Terminate; + pragma No_Return (Unhandled_Terminate); + pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate"); + -- Perform system dependent shutdown code + + function Tailored_Exception_Information + (X : Exception_Occurrence) return String; + -- Exception information to be output in the case of automatic tracing + -- requested through GNAT.Exception_Traces. + -- + -- This is the same as Exception_Information if no backtrace decorator + -- is currently in place. Otherwise, this is Exception_Information with + -- the call chain raw addresses replaced by the result of a call to the + -- current decorator provided with the call chain addresses. + + pragma Import + (Ada, Tailored_Exception_Information, + "__gnat_tailored_exception_information"); + + procedure Tailored_Exception_Information + (X : Exception_Occurrence; + Buff : in out String; + Last : in out Integer); + -- Procedural version of the above function. Instead of returning the + -- result, this one is put in Buff (Buff'first .. Buff'first + Last) + + procedure To_Stderr (S : String); + pragma Import (Ada, To_Stderr, "__gnat_to_stderr"); + -- Little routine to output string to stderr + + Nline : constant String := String'(1 => ASCII.LF); + -- Convenient shortcut + + Msg : constant String := Except.Msg (1 .. Except.Msg_Length); + + Max_Static_Exc_Info : constant := 1024; + -- This should be enough for most exception information cases + -- even though tailoring introduces some uncertainty. The + -- name+message should not exceed 320 chars, so that leaves at + -- least 35 backtrace slots (each slot needs 19 chars for + -- representing a 64 bit address). + + subtype Exc_Info_Type is String (1 .. Max_Static_Exc_Info); + type Str_Ptr is access Exc_Info_Type; + Exc_Info : Str_Ptr; + Exc_Info_Last : Natural := 0; + -- Buffer that is allocated to store the tailored exception + -- information while Adafinal is run. This buffer is allocated + -- on the heap only when it is needed. It is better to allocate + -- on the heap than on the stack since stack overflows are more + -- common than heap overflows. + + procedure Tailored_Exception_Information + (X : Exception_Occurrence; + Buff : in out String; + Last : in out Integer) + is + Info : constant String := Tailored_Exception_Information (X); + begin + Last := Info'Last; + Buff (1 .. Last) := Info; + end Tailored_Exception_Information; + + begin + -- First allocate & store the exception info in a buffer when + -- we know it will be needed. This needs to be done before + -- Adafinal because it implicitly uses the secondary stack. + + if Except.Id.Full_Name.all (1) /= '_' + and then Except.Num_Tracebacks /= 0 + then + Exc_Info := new Exc_Info_Type; + if Exc_Info /= null then + Tailored_Exception_Information + (Except, Exc_Info.all, Exc_Info_Last); + end if; + end if; + + -- Let's shutdown the runtime now. The rest of the procedure + -- needs to be careful not to use anything that would require + -- runtime support. In particular, functions returning strings + -- are banned since the sec stack is no longer functional. + System.Standard_Library.Adafinal; + + -- Check for special case of raising _ABORT_SIGNAL, which is not + -- really an exception at all. We recognize this by the fact that + -- it is the only exception whose name starts with underscore. + + if Except.Id.Full_Name.all (1) = '_' then + To_Stderr (Nline); + To_Stderr ("Execution terminated by abort of environment task"); + To_Stderr (Nline); + + -- If no tracebacks, we print the unhandled exception in the old style + -- (i.e. the style used before ZCX was implemented). We do this to + -- retain compatibility. + + elsif Except.Num_Tracebacks = 0 then + To_Stderr (Nline); + To_Stderr ("raised "); + To_Stderr (Except.Id.Full_Name.all (1 .. Except.Id.Name_Length - 1)); + + if Msg'Length /= 0 then + To_Stderr (" : "); + To_Stderr (Msg); + end if; + + To_Stderr (Nline); + + -- Traceback exists + + else + -- Note we can have this whole information output twice if + -- this occurrence gets reraised up to here. + + To_Stderr (Nline); + To_Stderr ("Execution terminated by unhandled exception"); + To_Stderr (Nline); + To_Stderr (Exc_Info (1 .. Exc_Info_Last)); + end if; + + Unhandled_Terminate; + end Ada.Exceptions.Last_Chance_Handler; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-elchha.ads gcc-3.4.0/gcc/ada/a-elchha.ads *** gcc-3.3.3/gcc/ada/a-elchha.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-elchha.ads 2003-12-05 10:24:04.000000000 +0000 *************** *** 0 **** --- 1,46 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- A D A . E X C E P T I O N S . L A S T _ C H A N C E _ H A N D L E R -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 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. -- + -- -- + ------------------------------------------------------------------------------ + + -- Last chance handler. Unhandled exceptions are passed to this + -- routine. + + procedure Ada.Exceptions.Last_Chance_Handler + (Except : Exception_Occurrence); + pragma Export (C, + Last_Chance_Handler, + "__gnat_last_chance_handler"); + pragma No_Return (Last_Chance_Handler); diff -Nrc3pad gcc-3.3.3/gcc/ada/a-excach.adb gcc-3.4.0/gcc/ada/a-excach.adb *** gcc-3.3.3/gcc/ada/a-excach.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-excach.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- ADA.EXCEPTIONS.CALL_CHAIN -- + -- -- + -- 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- -- + -- 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. -- + -- -- + ------------------------------------------------------------------------------ + + with System.Traceback; + + separate (Ada.Exceptions) + procedure Call_Chain (Excep : EOA) is + + Exception_Tracebacks : Integer; + pragma Import (C, Exception_Tracebacks, "__gl_exception_tracebacks"); + -- Boolean indicating whether tracebacks should be stored in exception + -- occurrences. + + begin + + if Exception_Tracebacks /= 0 and Excep.Num_Tracebacks = 0 then + + -- If Exception_Tracebacks = 0 then the program was not + -- compiled for storing tracebacks in exception occurrences + -- (-bargs -E switch) so that we do not generate them. + -- + -- If Excep.Num_Tracebacks /= 0 then this is a reraise, no need + -- to store a new (wrong) chain. + + -- We ask System.Traceback.Call_Chain to skip 3 frames to ensure that + -- itself, ourselves and our caller are not part of the result. Our + -- caller is always an exception propagation actor that we don't want + -- to see, and it may be part of a separate subunit which pulls it + -- outside the AAA/ZZZ range. + + System.Traceback.Call_Chain + (Traceback => Excep.Tracebacks'Address, + Max_Len => Max_Tracebacks, + Len => Excep.Num_Tracebacks, + Exclude_Min => Code_Address_For_AAA, + Exclude_Max => Code_Address_For_ZZZ, + Skip_Frames => 3); + + end if; + + end Call_Chain; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-except.adb gcc-3.4.0/gcc/ada/a-except.adb *** gcc-3.3.3/gcc/ada/a-except.adb 2003-03-04 20:11:23.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-except.adb 2003-12-01 13:29:27.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1992-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- -- --- 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- -- *************** pragma Polling (Off); *** 36,55 **** -- We must turn polling off for this unit, because otherwise we get -- elaboration circularities with System.Exception_Tables. ! with Ada.Unchecked_Deallocation; ! ! with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; with System; use System; - with System.Exception_Table; use System.Exception_Table; - with System.Exceptions; use System.Exceptions; with System.Standard_Library; use System.Standard_Library; - with System.Storage_Elements; use System.Storage_Elements; with System.Soft_Links; use System.Soft_Links; with System.Machine_State_Operations; use System.Machine_State_Operations; - with System.Traceback; - - with Unchecked_Conversion; package body Ada.Exceptions is --- 35,48 ---- -- We must turn polling off for this unit, because otherwise we get -- elaboration circularities with System.Exception_Tables. ! pragma Warnings (Off); ! -- Since several constructs give warnings in 3.14a1, including unreferenced ! -- variables and pragma Unreferenced itself. with System; use System; with System.Standard_Library; use System.Standard_Library; with System.Soft_Links; use System.Soft_Links; with System.Machine_State_Operations; use System.Machine_State_Operations; package body Ada.Exceptions is *************** package body Ada.Exceptions is *** 62,273 **** -- we are in big trouble. If an exceptional situation does occur, better -- that it not be raised, since raising it can cause confusing chaos. - type Subprogram_Descriptor_List_Ptr is - access all Subprogram_Descriptor_List; - - Subprogram_Descriptors : Subprogram_Descriptor_List_Ptr; - -- This location is initialized by Register_Exceptions to point to a - -- list of pointers to procedure descriptors, sorted into ascending - -- order of PC addresses. - -- - -- Note that SDP_Table_Build is called *before* this unit (or any - -- other unit) is elaborated. That's important, because exceptions can - -- and do occur during elaboration of units, and must be handled during - -- elaboration. This means that we are counting on the fact that the - -- initialization of Subprogram_Descriptors to null is done by the - -- load process and NOT by an explicit assignment during elaboration. - - Num_Subprogram_Descriptors : Natural; - -- Number of subprogram descriptors, the useful descriptors are stored - -- in Subprogram_Descriptors (1 .. Num_Subprogram_Descriptors). There - -- can be unused entries at the end of the array due to elimination of - -- duplicated entries (which can arise from use of pragma Import). - - Exception_Tracebacks : Integer; - pragma Import (C, Exception_Tracebacks, "__gl_exception_tracebacks"); - -- Boolean indicating whether tracebacks should be stored in exception - -- occurrences. - Zero_Cost_Exceptions : Integer; pragma Import (C, Zero_Cost_Exceptions, "__gl_zero_cost_exceptions"); -- Boolean indicating if we are handling exceptions using a zero cost -- mechanism. -- - -- ??? We currently have two alternatives for this scheme : one using - -- front-end tables and one using back-end tables. The former is known to - -- only work for GNAT3 and the latter is known to only work for GNAT5. - -- Both are present in this implementation and it would be good to have - -- separate bodies at some point. - -- -- Note that although we currently do not support it, the GCC3 back-end -- tables are also potentially useable for setjmp/longjmp processing. ! Nline : constant String := String' (1 => ASCII.LF); ! -- Convenient shortcut ! ------------------------------------------------ ! -- Entities to interface with the GCC runtime -- ! ------------------------------------------------ ! -- These come from "C++ ABI for Itanium : Exception handling", which is ! -- the reference for GCC. They are used only when we are relying on ! -- back-end tables for exception propagation, which in turn is currenly ! -- only the case for Zero_Cost_Exceptions in GNAT5. ! -- Return codes from the GCC runtime functions used to propagate ! -- an exception. ! type Unwind_Reason_Code is ! (URC_NO_REASON, ! URC_FOREIGN_EXCEPTION_CAUGHT, ! URC_PHASE2_ERROR, ! URC_PHASE1_ERROR, ! URC_NORMAL_STOP, ! URC_END_OF_STACK, ! URC_HANDLER_FOUND, ! URC_INSTALL_CONTEXT, ! URC_CONTINUE_UNWIND); ! -- ??? pragma Unreferenced is unknown until 3.15, so we need to disable ! -- warnings around it to fix the bootstrap path. ! pragma Warnings (Off); ! pragma Unreferenced ! (URC_NO_REASON, ! URC_FOREIGN_EXCEPTION_CAUGHT, ! URC_PHASE2_ERROR, ! URC_PHASE1_ERROR, ! URC_NORMAL_STOP, ! URC_END_OF_STACK, ! URC_HANDLER_FOUND, ! URC_INSTALL_CONTEXT, ! URC_CONTINUE_UNWIND); ! pragma Warnings (On); ! pragma Convention (C, Unwind_Reason_Code); ! -- Mandatory common header for any exception object handled by the ! -- GCC unwinding runtime. ! subtype Exception_Class is String (1 .. 8); ! GNAT_Exception_Class : constant Exception_Class ! := "GNU" & ASCII.NUL & "Ada" & ASCII.NUL; ! type Unwind_Exception is record ! Class : Exception_Class := GNAT_Exception_Class; ! Cleanup : System.Address := System.Null_Address; ! Private1 : Integer; ! Private2 : Integer; ! end record; ! pragma Convention (C, Unwind_Exception); ! for Unwind_Exception'Alignment use Standard'Maximum_Alignment; ! -- A GNAT exception object to be dealt with by the personality routine ! -- called by the GCC unwinding runtime. This structure shall match the ! -- one in raise.c and is currently experimental as it might be merged ! -- with the GNAT runtime definition some day. ! type GNAT_GCC_Exception is record ! Header : Unwind_Exception; ! -- Exception header first, as required by the ABI. ! Id : Exception_Id; ! -- Usual Exception identifier ! Handled_By_Others : Boolean; ! -- Is this exception handled by "when others" ? ! Has_Cleanup : Boolean; ! -- Did we see any at-end handler while walking up the stack ! -- searching for a handler ? This is used to determine if we ! -- start the propagation again after having tried once without ! -- finding a true handler for the exception. ! Select_Cleanups : Boolean; ! -- Do we consider at-end handlers as legitimate handlers for the ! -- exception ? This is used to control the propagation process ! -- as described in Raise_Current_Excep. ! end record; ! pragma Convention (C, GNAT_GCC_Exception); ! -- GCC runtime functions used ! function Unwind_RaiseException ! (E : access GNAT_GCC_Exception) ! return Unwind_Reason_Code; ! pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException"); ! ----------------------- ! -- Local Subprograms -- ! ----------------------- ! -- Note: the exported subprograms in this package body are called directly ! -- from C clients using the given external name, even though they are not ! -- technically visible in the Ada sense. ! procedure AAA; ! -- Mark start of procedures in this unit ! procedure ZZZ; ! -- Mark end of procedures in this package ! function Address_Image (A : System.Address) return String; ! -- Returns at string of the form 0xhhhhhhhhh for 32-bit addresses ! -- or 0xhhhhhhhhhhhhhhhh for 64-bit addresses. Hex characters are ! -- in lower case. ! procedure Call_Chain (Excep : EOA); ! -- Store up to Max_Tracebacks in Excep, corresponding to the current ! -- call chain. ! procedure Free ! is new Ada.Unchecked_Deallocation ! (Subprogram_Descriptor_List, Subprogram_Descriptor_List_Ptr); ! procedure Process_Raise_Exception ! (E : Exception_Id; ! From_Signal_Handler : Boolean); ! pragma Inline (Process_Raise_Exception); ! pragma No_Return (Process_Raise_Exception); ! -- This is the lowest level raise routine. It raises the exception ! -- referenced by Current_Excep.all in the TSD, without deferring abort ! -- (the caller must ensure that abort is deferred on entry). ! -- ! -- This is actually the common implementation for Raise_Current_Excep and ! -- Raise_From_Signal_Handler, with a couple of operations inhibited when ! -- called from the latter. The origin of the call is indicated by the ! -- From_Signal_Handler argument. ! -- ! -- The Inline pragma is there for efficiency reasons. ! procedure Propagate_Exception_With_FE_Support (Mstate : Machine_State); ! pragma No_Return (Propagate_Exception_With_FE_Support); ! -- This procedure propagates the exception represented by the occurrence ! -- referenced by Current_Excep in the TSD for the current task. M is the ! -- initial machine state, representing the site of the exception raise ! -- operation. ! -- ! -- The procedure searches the front end exception tables for an applicable ! -- handler, calling Pop_Frame as needed. If and when it locates an ! -- applicable handler, Enter_Handler is called to actually enter this ! -- handler. If the search is unable to locate an applicable handler, ! -- execution is terminated by calling Unhandled_Exception_Terminate. ! procedure Propagate_Exception_With_GCC_Support (Mstate : Machine_State); ! pragma No_Return (Propagate_Exception_With_GCC_Support); ! -- This procedure propagates the exception represented by the occurrence ! -- referenced by Current_Excep in the TSD for the current task. M is the ! -- initial machine state, representing the site of the exception raise ! -- operation. It is currently not used and is there for the purpose of ! -- interface consistency against Propagate_Exception_With_FE_Support. ! -- ! -- The procedure builds an object suitable for the libgcc processing and ! -- calls Unwind_RaiseException to actually throw, taking care of handling ! -- the two phase scheme it implements. procedure Raise_Current_Excep (E : Exception_Id); pragma No_Return (Raise_Current_Excep); --- 55,309 ---- -- we are in big trouble. If an exceptional situation does occur, better -- that it not be raised, since raising it can cause confusing chaos. Zero_Cost_Exceptions : Integer; pragma Import (C, Zero_Cost_Exceptions, "__gl_zero_cost_exceptions"); -- Boolean indicating if we are handling exceptions using a zero cost -- mechanism. -- -- Note that although we currently do not support it, the GCC3 back-end -- tables are also potentially useable for setjmp/longjmp processing. ! ----------------------- ! -- Local Subprograms -- ! ----------------------- ! -- Note: the exported subprograms in this package body are called directly ! -- from C clients using the given external name, even though they are not ! -- technically visible in the Ada sense. ! procedure AAA; ! procedure ZZZ; ! -- Mark start and end of procedures in this package ! -- ! -- The AAA and ZZZ procedures are used to provide exclusion bounds in ! -- calls to Call_Chain at exception raise points from this unit. The ! -- purpose is to arrange for the exception tracebacks not to include ! -- frames from routines involved in the raise process, as these are ! -- meaningless from the user's standpoint. ! -- ! -- For these bounds to be meaningful, we need to ensure that the object ! -- code for the routines involved in processing a raise is located after ! -- the object code for AAA and before the object code for ZZZ. This will ! -- indeed be the case as long as the following rules are respected: ! -- ! -- 1) The bodies of the subprograms involved in processing a raise ! -- are located after the body of AAA and before the body of ZZZ. ! -- ! -- 2) No pragma Inline applies to any of these subprograms, as this ! -- could delay the corresponding assembly output until the end of ! -- the unit. ! Code_Address_For_AAA, Code_Address_For_ZZZ : System.Address; ! -- Used to represent addresses really inside the code range for AAA and ! -- ZZZ, initialized to the address of a label inside the corresponding ! -- procedure. This is initialization takes place inside the procedures ! -- themselves, which are called as part of the elaboration code. ! -- ! -- We are doing this instead of merely using Proc'Address because on some ! -- platforms the latter does not yield the address we want, but the ! -- address of a stub or of a descriptor instead. This is the case at least ! -- on Alpha-VMS and PA-HPUX. ! procedure Call_Chain (Excep : EOA); ! -- Store up to Max_Tracebacks in Excep, corresponding to the current ! -- call chain. ! procedure Process_Raise_Exception ! (E : Exception_Id; ! From_Signal_Handler : Boolean); ! pragma No_Return (Process_Raise_Exception); ! -- This is the lowest level raise routine. It raises the exception ! -- referenced by Current_Excep.all in the TSD, without deferring abort ! -- (the caller must ensure that abort is deferred on entry). ! -- ! -- This is the common implementation for Raise_Current_Excep and ! -- Raise_From_Signal_Handler. The origin of the call is indicated by the ! -- From_Signal_Handler argument. ! package Exception_Data is ! ---------------------------------- ! -- Exception messages routines -- ! ---------------------------------- ! procedure Set_Exception_C_Msg ! (Id : Exception_Id; ! Msg1 : Big_String_Ptr; ! Line : Integer := 0; ! Msg2 : Big_String_Ptr := null); ! -- This routine is called to setup the exception referenced by the ! -- Current_Excep field in the TSD to contain the indicated Id value ! -- and message. Msg1 is a null terminated string which is generated ! -- as the exception message. If line is non-zero, then a colon and ! -- the decimal representation of this integer is appended to the ! -- message. When Msg2 is non-null, a space and this additional null ! -- terminated string is added to the message. ! procedure Set_Exception_Msg ! (Id : Exception_Id; ! Message : String); ! -- This routine is called to setup the exception referenced by the ! -- Current_Excep field in the TSD to contain the indicated Id value ! -- and message. Message is a string which is generated as the ! -- exception message. ! -------------------------------------- ! -- Exception information subprogram -- ! -------------------------------------- ! function Exception_Information (X : Exception_Occurrence) return String; ! -- The format of the exception information is as follows: ! -- ! -- exception name (as in Exception_Name) ! -- message (or a null line if no message) ! -- PID=nnnn ! -- 0xyyyyyyyy 0xyyyyyyyy ... ! -- ! -- The lines are separated by a ASCII.LF character ! -- The nnnn is the partition Id given as decimal digits. ! -- The 0x... line represents traceback program counter locations, ! -- in order with the first one being the exception location. ! --------------------------------------- ! -- Exception backtracing subprograms -- ! --------------------------------------- ! -- What is automatically output when exception tracing is on basically ! -- corresponds to the usual exception information, but with the call ! -- chain backtrace possibly tailored by a backtrace decorator. Modifying ! -- Exception_Information itself is not a good idea because the decorated ! -- output is completely out of control and would break all our code ! -- related to the streaming of exceptions. ! -- ! -- We then provide an alternative function to Exception_Information to ! -- compute the possibly tailored output, which is equivalent if no ! -- decorator is currently set. ! function Tailored_Exception_Information ! (X : Exception_Occurrence) ! return String; ! -- Exception information to be output in the case of automatic tracing ! -- requested through GNAT.Exception_Traces. ! -- ! -- This is the same as Exception_Information if no backtrace decorator ! -- is currently in place. Otherwise, this is Exception_Information with ! -- the call chain raw addresses replaced by the result of a call to the ! -- current decorator provided with the call chain addresses. ! pragma Export ! (Ada, Tailored_Exception_Information, ! "__gnat_tailored_exception_information"); ! -- This function is used within this package but also from within ! -- System.Tasking.Stages. ! -- ! -- The output of Exception_Information and ! -- Tailored_Exception_Information share a common part which was ! -- formerly built using local procedures within ! -- Exception_Information. These procedures have been extracted ! -- from their original place to be available to ! -- Tailored_Exception_Information also. ! -- ! -- Each of these procedures appends some input to an ! -- information string currently being built. The Ptr argument ! -- represents the last position in this string at which a ! -- character has been written. ! procedure Tailored_Exception_Information ! (X : Exception_Occurrence; ! Buff : in out String; ! Last : in out Integer); ! -- Procedural version of the above function. Instead of returning the ! -- result, this one is put in Buff (Buff'first .. Buff'first + Last) ! -- And what happens on overflow ??? ! end Exception_Data; ! package Exception_Traces is ! use Exception_Data; ! -- Imports Tailored_Exception_Information ! ---------------------------------------------- ! -- Run-Time Exception Notification Routines -- ! ---------------------------------------------- ! -- These subprograms provide a common run-time interface to trigger the ! -- actions required when an exception is about to be propagated (e.g. ! -- user specified actions or output of exception information). They are ! -- exported to be usable by the Ada exception handling personality ! -- routine when the GCC 3 mechanism is used. ! procedure Notify_Handled_Exception; ! pragma Export (C, Notify_Handled_Exception, ! "__gnat_notify_handled_exception"); ! -- This routine is called for a handled occurrence is about to be ! -- propagated. ! procedure Notify_Unhandled_Exception; ! pragma Export (C, Notify_Unhandled_Exception, ! "__gnat_notify_unhandled_exception"); ! -- This routine is called when an unhandled occurrence is about to be ! -- propagated. ! procedure Unhandled_Exception_Terminate; ! pragma No_Return (Unhandled_Exception_Terminate); ! -- This procedure is called to terminate execution following an ! -- unhandled exception. The exception information, including ! -- traceback if available is output, and execution is then ! -- terminated. Note that at the point where this routine is ! -- called, the stack has typically been destroyed. ! end Exception_Traces; ! package Exception_Propagation is ! use Exception_Traces; ! -- Imports Notify_Unhandled_Exception and ! -- Unhandled_Exception_Terminate ! ------------------------------------ ! -- Exception propagation routines -- ! ------------------------------------ ! procedure Setup_Exception ! (Excep : EOA; ! Current : EOA; ! Reraised : Boolean := False); ! -- Perform the necessary operations to prepare the propagation of Excep ! -- in a task where Current is the current occurrence. Excep is assumed ! -- to be a valid (non null) pointer. ! -- ! -- This should be called before any (re-)setting of the current ! -- occurrence. Any such (re-)setting shall take care *not* to clobber ! -- the Private_Data component. ! -- ! -- Having Current provided as an argument (instead of retrieving it via ! -- Get_Current_Excep internally) is required to allow one task to setup ! -- an exception for another task, which is used by Transfer_Occurrence. ! procedure Propagate_Exception (From_Signal_Handler : Boolean); ! pragma No_Return (Propagate_Exception); ! -- This procedure propagates the exception represented by the occurrence ! -- referenced by Current_Excep in the TSD for the current task. ! end Exception_Propagation; ! package Stream_Attributes is ! ! -------------------------------- ! -- Stream attributes routines -- ! -------------------------------- ! ! function EId_To_String (X : Exception_Id) return String; ! function String_To_EId (S : String) return Exception_Id; ! -- Functions for implementing Exception_Id stream attributes ! ! function EO_To_String (X : Exception_Occurrence) return String; ! function String_To_EO (S : String) return Exception_Occurrence; ! -- Functions for implementing Exception_Occurrence stream ! -- attributes ! ! end Stream_Attributes; procedure Raise_Current_Excep (E : Exception_Id); pragma No_Return (Raise_Current_Excep); *************** package body Ada.Exceptions is *** 281,287 **** procedure Raise_Exception_No_Defer (E : Exception_Id; Message : String := ""); ! pragma Export (Ada, Raise_Exception_No_Defer, "ada__exceptions__raise_exception_no_defer"); pragma No_Return (Raise_Exception_No_Defer); -- Similar to Raise_Exception, but with no abort deferral --- 317,324 ---- procedure Raise_Exception_No_Defer (E : Exception_Id; Message : String := ""); ! pragma Export ! (Ada, Raise_Exception_No_Defer, "ada__exceptions__raise_exception_no_defer"); pragma No_Return (Raise_Exception_No_Defer); -- Similar to Raise_Exception, but with no abort deferral *************** package body Ada.Exceptions is *** 294,317 **** -- exception occurrence referenced by the Current_Excep in the TSD. -- Abort is deferred before the raise call. ! procedure Raise_With_Location ! (E : Exception_Id; ! F : Big_String_Ptr; ! L : Integer); ! pragma No_Return (Raise_With_Location); ! -- Raise an exception with given exception id value. A filename and line ! -- number is associated with the raise and is stored in the exception ! -- occurrence. procedure Raise_With_Location_And_Msg (E : Exception_Id; F : Big_String_Ptr; L : Integer; ! M : Big_String_Ptr); pragma No_Return (Raise_With_Location_And_Msg); -- Raise an exception with given exception id value. A filename and line -- number is associated with the raise and is stored in the exception ! -- occurrence and in addition a string message M is appended to this. procedure Raise_Constraint_Error (File : Big_String_Ptr; --- 331,360 ---- -- exception occurrence referenced by the Current_Excep in the TSD. -- Abort is deferred before the raise call. ! procedure Raise_With_Msg (E : Exception_Id; Setup : Boolean); ! pragma No_Return (Raise_With_Msg); ! -- Similar to above, with an extra parameter to indicate wether ! -- Setup_Exception has been called already. ! ! procedure Raise_After_Setup (E : Exception_Id); ! pragma No_Return (Raise_After_Setup); ! pragma Export (C, Raise_After_Setup, "__gnat_raise_after_setup"); ! -- Wrapper to Raise_With_Msg and Setup set to True. ! -- ! -- This is called by System.Tasking.Entry_Calls.Check_Exception when an ! -- exception has occured during an entry call. The exception to propagate ! -- has been setup and initialized via Transfer_Occurrence in this case. procedure Raise_With_Location_And_Msg (E : Exception_Id; F : Big_String_Ptr; L : Integer; ! M : Big_String_Ptr := null); pragma No_Return (Raise_With_Location_And_Msg); -- Raise an exception with given exception id value. A filename and line -- number is associated with the raise and is stored in the exception ! -- occurrence and in addition a string message M is appended to ! -- this (if M is not null). procedure Raise_Constraint_Error (File : Big_String_Ptr; *************** package body Ada.Exceptions is *** 377,390 **** -- | | | | | -- +--+ +--+ +---+ | +---+ -- | | | | | ! -- R_E_No_Defer(i) R_W_Msg(i) R_W_Loc R_W_C_Msg ! -- | | | | | | ! -- +------------+ | +-----------+ +--+ +--+ | ! -- | | | | | | ! -- | | | Set_E_C_Msg(i) | ! -- | | | | ! -- | | | +--------------------------+ ! -- | | | | -- Raise_Current_Excep procedure Reraise; --- 420,431 ---- -- | | | | | -- +--+ +--+ +---+ | +---+ -- | | | | | ! -- R_E_No_Defer(i) R_W_Msg(i) R_W_Loc ! -- | | | | ! -- +------------+ | +-----------+ +--+ ! -- | | | | ! -- | | | Set_E_C_Msg(i) ! -- | | | -- Raise_Current_Excep procedure Reraise; *************** package body Ada.Exceptions is *** 394,460 **** -- the TSD (all fields of this exception occurrence are set). Abort -- is deferred before the reraise operation. ! function SDP_Table_Sort_Lt (Op1, Op2 : Natural) return Boolean; ! -- Used in call to sort SDP table (SDP_Table_Build), compares two elements ! ! procedure SDP_Table_Sort_Move (From : Natural; To : Natural); ! -- Used in call to sort SDP table (SDP_Table_Build), moves one element ! ! procedure Set_Exception_C_Msg ! (Id : Exception_Id; ! Msg1 : Big_String_Ptr; ! Line : Integer := 0; ! Msg2 : Big_String_Ptr := null); ! -- This routine is called to setup the exception referenced by the ! -- Current_Excep field in the TSD to contain the indicated Id value ! -- and message. Msg1 is a null terminated string which is generated ! -- as the exception message. If line is non-zero, then a colon and ! -- the decimal representation of this integer is appended to the ! -- message. When Msg2 is non-null, a space and this additional null ! -- terminated string is added to the message. ! ! procedure To_Stderr (S : String); ! pragma Export (Ada, To_Stderr, "__gnat_to_stderr"); ! -- Little routine to output string to stderr that is also used ! -- in the tasking run time. ! ! procedure Unhandled_Exception_Terminate; ! pragma No_Return (Unhandled_Exception_Terminate); ! -- This procedure is called to terminate execution following an unhandled ! -- exception. The exception information, including traceback if available ! -- is output, and execution is then terminated. Note that at the point ! -- where this routine is called, the stack has typically been destroyed ! ! --------------------------------- ! -- Debugger Interface Routines -- ! --------------------------------- ! -- The routines here are null routines that normally have no effect. ! -- they are provided for the debugger to place breakpoints on their ! -- entry points to get control on an exception. ! procedure Notify_Exception ! (Id : Exception_Id; ! Handler : Code_Loc; ! Is_Others : Boolean); ! pragma Export (C, Notify_Exception, "__gnat_notify_exception"); ! -- This routine is called whenever an exception is signalled. The Id ! -- parameter is the Exception_Id of the exception being raised. The ! -- second parameter Handler is Null_Loc if the exception is unhandled, ! -- and is otherwise the entry point of the handler that will handle ! -- the exception. Is_Others is True if the handler is an others handler ! -- and False otherwise. In the unhandled exception case, if possible ! -- (and certainly if zero cost exception handling is active), the ! -- stack is still intact when this procedure is called. Note that this ! -- routine is entered before any finalization handlers are entered if ! -- the exception is unhandled by a "real" exception handler. ! procedure Unhandled_Exception; ! pragma Export (C, Unhandled_Exception, "__gnat_unhandled_exception"); ! -- This routine is called in addition to Notify_Exception in the ! -- unhandled exception case. The fact that there are two routines ! -- which are somewhat redundant is historical. Notify_Exception ! -- certainly is complete enough, but GDB still uses this routine. ----------------------------- -- Run-Time Check Routines -- --- 435,466 ---- -- the TSD (all fields of this exception occurrence are set). Abort -- is deferred before the reraise operation. ! -- Save_Occurrence variations: As the management of the private data ! -- attached to occurrences is delicate, wether or not pointers to such ! -- data has to be copied in various situations is better made explicit. ! -- The following procedures provide an internal interface to help making ! -- this explicit. ! procedure Save_Occurrence_And_Private ! (Target : out Exception_Occurrence; ! Source : Exception_Occurrence); ! -- Copy all the components of Source to Target as well as the ! -- Private_Data pointer. ! procedure Save_Occurrence_No_Private ! (Target : out Exception_Occurrence; ! Source : Exception_Occurrence); ! -- Copy all the components of Source to Target, except the ! -- Private_Data pointer. ! procedure Transfer_Occurrence ! (Target : Exception_Occurrence_Access; ! Source : Exception_Occurrence); ! pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); ! -- Called from System.Tasking.RendezVous.Exceptional_Complete_RendezVous ! -- to setup Target from Source as an exception to be propagated in the ! -- caller task. Target is expected to be a pointer to the fixed TSD ! -- occurrence for this task. ----------------------------- -- Run-Time Check Routines -- *************** package body Ada.Exceptions is *** 552,561 **** Rmsg_14 : constant String := "all guards closed" & NUL; Rmsg_15 : constant String := "duplicated entry address" & NUL; Rmsg_16 : constant String := "explicit raise" & NUL; ! Rmsg_17 : constant String := "finalize raised exception" & NUL; ! Rmsg_18 : constant String := "invalid data" & NUL; ! Rmsg_19 : constant String := "misaligned address value" & NUL; ! Rmsg_20 : constant String := "missing return" & NUL; Rmsg_21 : constant String := "potentially blocking operation" & NUL; Rmsg_22 : constant String := "stubbed subprogram called" & NUL; Rmsg_23 : constant String := "unchecked union restriction" & NUL; --- 558,567 ---- Rmsg_14 : constant String := "all guards closed" & NUL; Rmsg_15 : constant String := "duplicated entry address" & NUL; Rmsg_16 : constant String := "explicit raise" & NUL; ! Rmsg_17 : constant String := "finalize/adjust raised exception" & NUL; ! Rmsg_18 : constant String := "misaligned address value" & NUL; ! Rmsg_19 : constant String := "missing return" & NUL; ! Rmsg_20 : constant String := "overlaid controlled object" & NUL; Rmsg_21 : constant String := "potentially blocking operation" & NUL; Rmsg_22 : constant String := "stubbed subprogram called" & NUL; Rmsg_23 : constant String := "unchecked union restriction" & NUL; *************** package body Ada.Exceptions is *** 565,866 **** Rmsg_27 : constant String := "object too large" & NUL; Rmsg_28 : constant String := "restriction violation" & NUL; - -------------------------------------- - -- Calls to Run-Time Check Routines -- - -------------------------------------- - - procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_00'Address)); - end Rcheck_00; - - procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_01'Address)); - end Rcheck_01; - - procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_02'Address)); - end Rcheck_02; - - procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_03'Address)); - end Rcheck_03; - - procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_04'Address)); - end Rcheck_04; - - procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_05'Address)); - end Rcheck_05; - - procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_06'Address)); - end Rcheck_06; - - procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_07'Address)); - end Rcheck_07; - - procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_08'Address)); - end Rcheck_08; - - procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_09'Address)); - end Rcheck_09; - - procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_10'Address)); - end Rcheck_10; - - procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_11'Address)); - end Rcheck_11; - - procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_12'Address)); - end Rcheck_12; - - procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_13'Address)); - end Rcheck_13; - - procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_14'Address)); - end Rcheck_14; - - procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_15'Address)); - end Rcheck_15; - - procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_16'Address)); - end Rcheck_16; - - procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_17'Address)); - end Rcheck_17; - - procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_18'Address)); - end Rcheck_18; - - procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_19'Address)); - end Rcheck_19; - - procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_20'Address)); - end Rcheck_20; - - procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_21'Address)); - end Rcheck_21; - - procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_22'Address)); - end Rcheck_22; - - procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_23'Address)); - end Rcheck_23; - - procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_24'Address)); - end Rcheck_24; - - procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_25'Address)); - end Rcheck_25; - - procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_26'Address)); - end Rcheck_26; - - procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_27'Address)); - end Rcheck_27; - - procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_28'Address)); - end Rcheck_28; - - --------------------------------------- - -- Exception backtracing subprograms -- - --------------------------------------- - - -- What is automatically output when exception tracing is on basically - -- corresponds to the usual exception information, but with the call - -- chain backtrace possibly tailored by a backtrace decorator. Modifying - -- Exception_Information itself is not a good idea because the decorated - -- output is completely out of control and would break all our code - -- related to the streaming of exceptions. - -- - -- We then provide an alternative function to Exception_Information to - -- compute the possibly tailored output, which is equivalent if no - -- decorator is currently set : - - function Tailored_Exception_Information - (X : Exception_Occurrence) - return String; - -- Exception information to be output in the case of automatic tracing - -- requested through GNAT.Exception_Traces. - -- - -- This is the same as Exception_Information if no backtrace decorator - -- is currently in place. Otherwise, this is Exception_Information with - -- the call chain raw addresses replaced by the result of a call to the - -- current decorator provided with the call chain addresses. - - pragma Export - (Ada, Tailored_Exception_Information, - "__gnat_tailored_exception_information"); - -- This function is used within this package but also from within - -- System.Tasking.Stages. - -- - -- The output of Exception_Information and Tailored_Exception_Information - -- share a common part which was formerly built using local procedures - -- within Exception_Information. These procedures have been extracted from - -- their original place to be available to Tailored_Exception_Information - -- also. - -- - -- Each of these procedures appends some input to an information string - -- currently being built. The Ptr argument represents the last position - -- in this string at which a character has been written. - - procedure Append_Info_Nat - (N : Natural; - Info : in out String; - Ptr : in out Natural); - -- Append the image of N at the end of the provided information string - - procedure Append_Info_NL - (Info : in out String; - Ptr : in out Natural); - -- Append a LF at the end of the provided information string - - procedure Append_Info_String - (S : String; - Info : in out String; - Ptr : in out Natural); - -- Append a string at the end of the provided information string - - -- To build Exception_Information and Tailored_Exception_Information, - -- we then use three intermediate functions : - - function Basic_Exception_Information - (X : Exception_Occurrence) - return String; - -- Returns the basic exception information string associated with a - -- given exception occurrence. This is the common part shared by both - -- Exception_Information and Tailored_Exception_Infomation. - - function Basic_Exception_Traceback - (X : Exception_Occurrence) - return String; - -- Returns an image of the complete call chain associated with an - -- exception occurrence in its most basic form, that is as a raw sequence - -- of hexadecimal binary addresses. - - function Tailored_Exception_Traceback - (X : Exception_Occurrence) - return String; - -- Returns an image of the complete call chain associated with an - -- exception occurrence, either in its basic form if no decorator is - -- in place, or as formatted by the decorator otherwise. - - -- The overall organization of the exception information related code - -- is summarized below : - -- - -- Exception_Information - -- | - -- +-------+--------+ - -- | | - -- Basic_Exc_Info & Basic_Exc_Tback - -- - -- - -- Tailored_Exception_Information - -- | - -- +----------+----------+ - -- | | - -- Basic_Exc_Info & Tailored_Exc_Tback - -- | - -- +-----------+------------+ - -- | | - -- Basic_Exc_Tback Or Tback_Decorator - -- if no decorator set otherwise - - ---------------------------------------------- - -- Run-Time Exception Notification Routines -- - ---------------------------------------------- - - -- The notification routines described above are low level "handles" for - -- the debugger but what needs to be done at the notification points - -- always involves more than just calling one of these routines. The - -- routines below provide a common run-time interface for this purpose, - -- with variations depending on the handled/not handled status of the - -- occurrence. They are exported to be usable by the Ada exception - -- handling personality routine when the GCC 3 mechanism is used. - - procedure Notify_Handled_Exception - (Handler : Code_Loc; - Is_Others : Boolean; - Low_Notify : Boolean); - pragma Export (C, Notify_Handled_Exception, - "__gnat_notify_handled_exception"); - -- Routine to call when a handled occurrence is about to be propagated. - -- Low_Notify might be set to false to skip the low level debugger - -- notification, which is useful when the information it requires is - -- not available, like in the SJLJ case. - - procedure Notify_Unhandled_Exception (Id : Exception_Id); - pragma Export (C, Notify_Unhandled_Exception, - "__gnat_notify_unhandled_exception"); - -- Routine to call when an unhandled occurrence is about to be propagated. - - -------------------------------- - -- Import Run-Time C Routines -- - -------------------------------- - - -- The purpose of the following pragma Imports is to ensure that we - -- generate appropriate subprogram descriptors for all C routines in - -- the standard GNAT library that can raise exceptions. This ensures - -- that the exception propagation can properly find these routines - - pragma Warnings (Off); -- so old compiler does not complain - pragma Propagate_Exceptions; - - procedure Unhandled_Terminate; - pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate"); - ----------------------- -- Polling Interface -- ----------------------- --- 571,576 ---- *************** package body Ada.Exceptions is *** 868,873 **** --- 578,584 ---- type Unsigned is mod 2 ** 32; Counter : Unsigned := 0; + pragma Warnings (Off, Counter); -- This counter is provided for convenience. It can be used in Poll to -- perform periodic but not systematic operations. *************** package body Ada.Exceptions is *** 885,1097 **** procedure AAA is begin ! null; end AAA; - ------------------- - -- Address_Image -- - ------------------- - - function Address_Image (A : Address) return String is - S : String (1 .. 18); - P : Natural; - N : Integer_Address; - - H : constant array (Integer range 0 .. 15) of Character := - "0123456789abcdef"; - begin - P := S'Last; - N := To_Integer (A); - while N /= 0 loop - S (P) := H (Integer (N mod 16)); - P := P - 1; - N := N / 16; - end loop; - - S (P - 1) := '0'; - S (P) := 'x'; - return S (P - 1 .. S'Last); - end Address_Image; - - --------------------- - -- Append_Info_Nat -- - --------------------- - - procedure Append_Info_Nat - (N : Natural; - Info : in out String; - Ptr : in out Natural) - is - begin - if N > 9 then - Append_Info_Nat (N / 10, Info, Ptr); - end if; - - Ptr := Ptr + 1; - Info (Ptr) := Character'Val (Character'Pos ('0') + N mod 10); - end Append_Info_Nat; - - -------------------- - -- Append_Info_NL -- - -------------------- - - procedure Append_Info_NL - (Info : in out String; - Ptr : in out Natural) - is - begin - Ptr := Ptr + 1; - Info (Ptr) := ASCII.LF; - end Append_Info_NL; - - ------------------------ - -- Append_Info_String -- - ------------------------ - - procedure Append_Info_String - (S : String; - Info : in out String; - Ptr : in out Natural) - is - begin - Info (Ptr + 1 .. Ptr + S'Length) := S; - Ptr := Ptr + S'Length; - end Append_Info_String; - - --------------------------------- - -- Basic_Exception_Information -- - --------------------------------- - - function Basic_Exception_Information - (X : Exception_Occurrence) - return String - is - Name : constant String := Exception_Name (X); - Msg : constant String := Exception_Message (X); - -- Exception name and message that are going to be included in the - -- information to return, if not empty. - - Name_Len : constant Natural := Name'Length; - Msg_Len : constant Natural := Msg'Length; - -- Length of these strings, useful to compute the size of the string - -- we have to allocate for the complete result as well as in the body - -- of this procedure. - - Info_Maxlen : constant Natural := 50 + Name_Len + Msg_Len; - -- Maximum length of the information string we will build, with : - -- - -- 50 = 16 + 2 for the text associated with the name - -- + 9 + 2 for the text associated with the message - -- + 5 + 2 for the text associated with the pid - -- + 14 for the text image of the pid itself and a margin. - -- - -- This is indeed a maximum since some data may not appear at all if - -- not relevant. For example, nothing related to the exception message - -- will be there if this message is empty. - -- - -- WARNING : Do not forget to update these numbers if anything - -- involved in the computation changes. - - Info : String (1 .. Info_Maxlen); - -- Information string we are going to build, containing the common - -- part shared by Exc_Info and Tailored_Exc_Info. - - Ptr : Natural := 0; - - begin - -- Output exception name and message except for _ABORT_SIGNAL, where - -- these two lines are omitted (see discussion above). - - if Name (1) /= '_' then - Append_Info_String ("Exception name: ", Info, Ptr); - Append_Info_String (Name, Info, Ptr); - Append_Info_NL (Info, Ptr); - - if Msg_Len /= 0 then - Append_Info_String ("Message: ", Info, Ptr); - Append_Info_String (Msg, Info, Ptr); - Append_Info_NL (Info, Ptr); - end if; - end if; - - -- Output PID line if non-zero - - if X.Pid /= 0 then - Append_Info_String ("PID: ", Info, Ptr); - Append_Info_Nat (X.Pid, Info, Ptr); - Append_Info_NL (Info, Ptr); - end if; - - return Info (1 .. Ptr); - end Basic_Exception_Information; - - ------------------------------- - -- Basic_Exception_Traceback -- - ------------------------------- - - function Basic_Exception_Traceback - (X : Exception_Occurrence) - return String - is - Info_Maxlen : constant Natural := 35 + X.Num_Tracebacks * 19; - -- Maximum length of the information string we are building, with : - -- 33 = 31 + 4 for the text before and after the traceback, and - -- 19 = 2 + 16 + 1 for each address ("0x" + HHHH + " ") - -- - -- WARNING : Do not forget to update these numbers if anything - -- involved in the computation changes. - - Info : String (1 .. Info_Maxlen); - -- Information string we are going to build, containing an image - -- of the call chain associated with the exception occurrence in its - -- most basic form, that is as a sequence of binary addresses. - - Ptr : Natural := 0; - - begin - if X.Num_Tracebacks > 0 then - Append_Info_String ("Call stack traceback locations:", Info, Ptr); - Append_Info_NL (Info, Ptr); - - for J in 1 .. X.Num_Tracebacks loop - Append_Info_String (Address_Image (X.Tracebacks (J)), Info, Ptr); - exit when J = X.Num_Tracebacks; - Append_Info_String (" ", Info, Ptr); - end loop; - - Append_Info_NL (Info, Ptr); - end if; - - return Info (1 .. Ptr); - end Basic_Exception_Traceback; - - ----------------- - -- Break_Start -- - ----------------- - - procedure Break_Start is - begin - null; - end Break_Start; - ---------------- -- Call_Chain -- ---------------- ! procedure Call_Chain (Excep : EOA) is ! begin ! if Excep.Num_Tracebacks /= 0 then ! -- This is a reraise, no need to store a new (wrong) chain. ! return; ! end if; ! ! System.Traceback.Call_Chain ! (Excep.Tracebacks'Address, ! Max_Tracebacks, ! Excep.Num_Tracebacks, ! AAA'Address, ! ZZZ'Address); ! end Call_Chain; ------------------------------ -- Current_Target_Exception -- --- 596,612 ---- procedure AAA is begin ! <> ! Code_Address_For_AAA := Start_Of_AAA'Address; end AAA; ---------------- -- Call_Chain -- ---------------- ! procedure Call_Chain (Excep : EOA) is separate; ! -- The actual Call_Chain routine is separate, so that it can easily ! -- be dummied out when no exception traceback information is needed. ------------------------------ -- Current_Target_Exception -- *************** package body Ada.Exceptions is *** 1106,1119 **** -- EId_To_String -- ------------------- ! function EId_To_String (X : Exception_Id) return String is ! begin ! if X = Null_Id then ! return ""; ! else ! return Exception_Name (X); ! end if; ! end EId_To_String; ------------------ -- EO_To_String -- --- 621,628 ---- -- EId_To_String -- ------------------- ! function EId_To_String (X : Exception_Id) return String ! renames Stream_Attributes.EId_To_String; ------------------ -- EO_To_String -- *************** package body Ada.Exceptions is *** 1122,1135 **** -- We use the null string to represent the null occurrence, otherwise -- we output the Exception_Information string for the occurrence. ! function EO_To_String (X : Exception_Occurrence) return String is ! begin ! if X.Id = Null_Id then ! return ""; ! else ! return Exception_Information (X); ! end if; ! end EO_To_String; ------------------------ -- Exception_Identity -- --- 631,638 ---- -- We use the null string to represent the null occurrence, otherwise -- we output the Exception_Information string for the occurrence. ! function EO_To_String (X : Exception_Occurrence) return String ! renames Stream_Attributes.EO_To_String; ------------------------ -- Exception_Identity -- *************** package body Ada.Exceptions is *** 1151,1213 **** -- Exception_Information -- --------------------------- ! -- The format of the string is: ! ! -- Exception_Name: nnnnn ! -- Message: mmmmm ! -- PID: ppp ! -- Call stack traceback locations: ! -- 0xhhhh 0xhhhh 0xhhhh ... 0xhhh ! ! -- where ! ! -- nnnn is the fully qualified name of the exception in all upper ! -- case letters. This line is always present. ! ! -- mmmm is the message (this line present only if message is non-null) ! ! -- ppp is the Process Id value as a decimal integer (this line is ! -- present only if the Process Id is non-zero). Currently we are ! -- not making use of this field. ! ! -- The Call stack traceback locations line and the following values ! -- are present only if at least one traceback location was recorded. ! -- the values are given in C style format, with lower case letters ! -- for a-f, and only as many digits present as are necessary. ! ! -- The line terminator sequence at the end of each line, including the ! -- last line is a CR-LF sequence (16#0D# followed by 16#0A#). ! ! -- The Exception_Name and Message lines are omitted in the abort ! -- signal case, since this is not really an exception, and the only ! -- use of this routine is internal for printing termination output. ! ! -- WARNING: if the format of the generated string is changed, please note ! -- that an equivalent modification to the routine String_To_EO must be ! -- made to preserve proper functioning of the stream attributes. ! ! function Exception_Information (X : Exception_Occurrence) return String is ! ! -- This information is now built using the circuitry introduced in ! -- association with the support of traceback decorators, as the ! -- catenation of the exception basic information and the call chain ! -- backtrace in its basic form. ! ! Basic_Info : constant String := Basic_Exception_Information (X); ! Tback_Info : constant String := Basic_Exception_Traceback (X); ! ! Basic_Len : constant Natural := Basic_Info'Length; ! Tback_Len : constant Natural := Tback_Info'Length; ! ! Info : String (1 .. Basic_Len + Tback_Len); ! Ptr : Natural := 0; ! ! begin ! Append_Info_String (Basic_Info, Info, Ptr); ! Append_Info_String (Tback_Info, Info, Ptr); ! ! return Info; ! end Exception_Information; ----------------------- -- Exception_Message -- --- 654,661 ---- -- Exception_Information -- --------------------------- ! function Exception_Information (X : Exception_Occurrence) return String ! renames Exception_Data.Exception_Information; ----------------------- -- Exception_Message -- *************** package body Ada.Exceptions is *** 1258,1263 **** --- 706,746 ---- return Name (P .. Name'Length); end Exception_Name_Simple; + -------------------- + -- Exception_Data -- + -------------------- + + package body Exception_Data is separate; + -- This package can be easily dummied out if we do not want the + -- basic support for exception messages (such as in Ada 83). + + --------------------------- + -- Exception_Propagation -- + --------------------------- + + package body Exception_Propagation is separate; + -- Depending on the actual exception mechanism used (front-end or + -- back-end based), the implementation will differ, which is why this + -- package is separated. + + ---------------------- + -- Exception_Traces -- + ---------------------- + + package body Exception_Traces is separate; + -- Depending on the underlying support for IO the implementation + -- will differ. Moreover we would like to dummy out this package + -- in case we do not want any exception tracing support. This is + -- why this package is separated. + + ----------------------- + -- Stream Attributes -- + ----------------------- + + package body Stream_Attributes is separate; + -- This package can be easily dummied out if we do not want the + -- support for streaming Exception_Ids and Exception_Occurrences. + ----------------------------- -- Process_Raise_Exception -- ----------------------------- *************** package body Ada.Exceptions is *** 1270,1277 **** -- This is so the debugger can reliably inspect the parameter Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all; - Mstate_Ptr : constant Machine_State := - Machine_State (Get_Machine_State_Addr.all); Excep : EOA := Get_Current_Excep.all; begin --- 753,758 ---- *************** package body Ada.Exceptions is *** 1287,1322 **** if Zero_Cost_Exceptions /= 0 then -- Use the front-end tables to propagate if we have them, otherwise ! -- resort to the GCC back-end alternative. The backtrace for the ! -- occurrence is stored while walking up the stack, and thus stops ! -- in the handler's frame if there is one. Notifications are also ! -- not performed here since it is not yet known if the exception is ! -- handled. ! ! -- Set the machine state unless we are raising from a signal handler ! -- since it has already been set properly in that case. ! ! if not From_Signal_Handler then ! Set_Machine_State (Mstate_Ptr); ! end if; ! if Subprogram_Descriptors /= null then ! Propagate_Exception_With_FE_Support (Mstate_Ptr); ! else ! Propagate_Exception_With_GCC_Support (Mstate_Ptr); ! end if; else - -- Compute the backtrace for this occurrence if the corresponding ! -- binder option has been set and we are not raising from a signal ! -- handler. Call_Chain takes care of the reraise case. ! if not From_Signal_Handler ! and then Exception_Tracebacks /= 0 ! then ! Call_Chain (Excep); ! end if; -- If the jump buffer pointer is non-null, transfer control using -- it. Otherwise announce an unhandled exception (note that this --- 768,805 ---- if Zero_Cost_Exceptions /= 0 then -- Use the front-end tables to propagate if we have them, otherwise ! -- resort to the GCC back-end alternative. Backtrace computation is ! -- performed, if required, by the underlying routine. Notifications ! -- for the debugger are also not performed here, because we do not ! -- yet know if the exception is handled. ! Exception_Propagation.Propagate_Exception (From_Signal_Handler); else -- Compute the backtrace for this occurrence if the corresponding ! -- binder option has been set. Call_Chain takes care of the reraise ! -- case. ! Call_Chain (Excep); ! -- We used to only do this if From_Signal_Handler was not set, ! -- based on the assumption that backtracing from a signal handler ! -- would not work due to stack layout oddities. However, since ! -- ! -- 1. The flag is never set in tasking programs (Notify_Exception ! -- performs regular raise statements), and ! -- ! -- 2. No problem has shown up in tasking programs around here so ! -- far, this turned out to be too strong an assumption. ! -- ! -- As, in addition, the test was ! -- ! -- 1. preventing the production of backtraces in non-tasking ! -- programs, and ! -- ! -- 2. introducing a behavior inconsistency between ! -- the tasking and non-tasking cases, ! -- ! -- we have simply removed it. -- If the jump buffer pointer is non-null, transfer control using -- it. Otherwise announce an unhandled exception (note that this *************** package body Ada.Exceptions is *** 1327,1632 **** if not Excep.Exception_Raised then Excep.Exception_Raised := True; ! Notify_Handled_Exception (Null_Loc, False, False); ! ! -- The low level debugger notification is skipped from the ! -- call above because we do not have the necessary information ! -- to "feed" it properly. ! end if; builtin_longjmp (Jumpbuf_Ptr, 1); else ! Notify_Unhandled_Exception (E); ! Unhandled_Exception_Terminate; ! end if; ! end if; ! ! end Process_Raise_Exception; ! ! ----------------------------------------- ! -- Propagate_Exception_With_FE_Support -- ! ----------------------------------------- ! ! procedure Propagate_Exception_With_FE_Support (Mstate : Machine_State) is ! Excep : constant EOA := Get_Current_Excep.all; ! Loc : Code_Loc; ! Lo, Hi : Natural; ! Pdesc : Natural; ! Hrec : Handler_Record_Ptr; ! Info : Subprogram_Info_Type; ! ! type Machine_State_Record is ! new Storage_Array (1 .. Machine_State_Length); ! for Machine_State_Record'Alignment use Standard'Maximum_Alignment; ! ! procedure Duplicate_Machine_State (Dest, Src : Machine_State); ! -- Copy Src into Dest, assuming that a Machine_State is pointing to ! -- an area of Machine_State_Length bytes. ! ! procedure Duplicate_Machine_State (Dest, Src : Machine_State) is ! type Machine_State_Record_Access is access Machine_State_Record; ! function To_MSR is new Unchecked_Conversion ! (Machine_State, Machine_State_Record_Access); ! ! begin ! To_MSR (Dest).all := To_MSR (Src).all; ! end Duplicate_Machine_State; ! ! -- Data for handling the finalization handler case. A simple approach ! -- in this routine would simply to unwind stack frames till we find a ! -- handler and then enter it. But this is undesirable in the case where ! -- we have only finalization handlers, and no "real" handler, i.e. a ! -- case where we have an unhandled exception. ! ! -- In this case we prefer to signal unhandled exception with the stack ! -- intact, and entering finalization handlers would destroy the stack ! -- state. To deal with this, as we unwind the stack, we note the first ! -- finalization handler, and remember it in the following variables. ! -- We then continue to unwind. If and when we find a "real", i.e. non- ! -- finalization handler, then we use these variables to pass control to ! -- the finalization handler. ! ! FH_Found : Boolean := False; ! -- Set when a finalization handler is found ! ! FH_Mstate : aliased Machine_State_Record; ! -- Records the machine state for the finalization handler ! ! FH_Handler : Code_Loc := Null_Address; ! -- Record handler address for finalization handler ! ! FH_Num_Trb : Natural := 0; ! -- Save number of tracebacks for finalization handler ! ! begin ! -- Loop through stack frames as exception propagates ! ! Main_Loop : loop ! Loc := Get_Code_Loc (Mstate); ! exit Main_Loop when Loc = Null_Loc; ! ! -- Record location unless it is inside this unit. Note: this ! -- test should really say Code_Address, but Address is the same ! -- as Code_Address for unnested subprograms, and Code_Address ! -- would cause a bootstrap problem ! ! if Loc < AAA'Address or else Loc > ZZZ'Address then ! ! -- Record location unless we already recorded max tracebacks ! ! if Excep.Num_Tracebacks /= Max_Tracebacks then ! ! -- Do not record location if it is the return point from ! -- a reraise call from within a cleanup handler ! ! if not Excep.Cleanup_Flag then ! Excep.Num_Tracebacks := Excep.Num_Tracebacks + 1; ! Excep.Tracebacks (Excep.Num_Tracebacks) := Loc; ! -- For reraise call from cleanup handler, skip entry and ! -- clear the flag so that we will start to record again ! else ! Excep.Cleanup_Flag := False; ! end if; ! end if; end if; - - -- Do binary search on procedure table - - Lo := 1; - Hi := Num_Subprogram_Descriptors; - - -- Binary search loop - - loop - Pdesc := (Lo + Hi) / 2; - - -- Note that Loc is expected to be the procedure's call point - -- and not the return point. - - if Loc < Subprogram_Descriptors (Pdesc).Code then - Hi := Pdesc - 1; - - elsif Pdesc < Num_Subprogram_Descriptors - and then Loc > Subprogram_Descriptors (Pdesc + 1).Code - then - Lo := Pdesc + 1; - - else - exit; - end if; - - -- This happens when the current Loc is completely outside of - -- the range of the program, which usually means that we reached - -- the top level frame (e.g __start). In this case we have an - -- unhandled exception. - - exit Main_Loop when Hi < Lo; - end loop; - - -- Come here with Subprogram_Descriptors (Pdesc) referencing the - -- procedure descriptor that applies to this PC value. Now do a - -- serial search to see if any handler is applicable to this PC - -- value, and to the exception that we are propagating - - for J in 1 .. Subprogram_Descriptors (Pdesc).Num_Handlers loop - Hrec := Subprogram_Descriptors (Pdesc).Handler_Records (J); - - if Loc >= Hrec.Lo and then Loc < Hrec.Hi then - - -- PC range is applicable, see if handler is for this exception - - -- First test for case of "all others" (finalization) handler. - -- We do not enter such a handler until we are sure there is - -- a real handler further up the stack. - - if Hrec.Id = All_Others_Id then - - -- If this is the first finalization handler, then - -- save the machine state so we can enter it later - -- without having to repeat the search. - - if not FH_Found then - FH_Found := True; - Duplicate_Machine_State - (Machine_State (FH_Mstate'Address), Mstate); - FH_Handler := Hrec.Handler; - FH_Num_Trb := Excep.Num_Tracebacks; - end if; - - -- Normal (non-finalization exception with matching Id) - - elsif Excep.Id = Hrec.Id - or else (Hrec.Id = Others_Id - and not Excep.Id.Not_Handled_By_Others) - then - -- Perform the necessary notification tasks. - - Notify_Handled_Exception - (Hrec.Handler, Hrec.Id = Others_Id, True); - - -- If we already encountered a finalization handler, then - -- reset the context to that handler, and enter it. - - if FH_Found then - Excep.Num_Tracebacks := FH_Num_Trb; - Excep.Cleanup_Flag := True; - - Enter_Handler - (Machine_State (FH_Mstate'Address), FH_Handler); - - -- If we have not encountered a finalization handler, - -- then enter the current handler. - - else - Enter_Handler (Mstate, Hrec.Handler); - end if; - end if; - end if; - end loop; - - Info := Subprogram_Descriptors (Pdesc).Subprogram_Info; - exit Main_Loop when Info = No_Info; - Pop_Frame (Mstate, Info); - end loop Main_Loop; - - -- Fall through if no "real" exception handler found. First thing is to - -- perform the necessary notification tasks with the stack intact. - - Notify_Unhandled_Exception (Excep.Id); - - -- If there were finalization handlers, then enter the top one. - -- Just because there is no handler does not mean we don't have - -- to still execute all finalizations and cleanups before - -- terminating. Note that the process of calling cleanups - -- does not disturb the back trace stack, since he same - -- exception occurrence gets reraised, and new traceback - -- entries added as we go along. - - if FH_Found then - Excep.Num_Tracebacks := FH_Num_Trb; - Excep.Cleanup_Flag := True; - Enter_Handler (Machine_State (FH_Mstate'Address), FH_Handler); end if; ! ! -- If no cleanups, then this is the real unhandled termination ! ! Unhandled_Exception_Terminate; ! ! end Propagate_Exception_With_FE_Support; ! ! ------------------------------------------ ! -- Propagate_Exception_With_GCC_Support -- ! ------------------------------------------ ! ! procedure Propagate_Exception_With_GCC_Support (Mstate : Machine_State) is ! Excep : EOA := Get_Current_Excep.all; ! This_Exception : aliased GNAT_GCC_Exception; ! Status : Unwind_Reason_Code; ! ! begin ! -- ??? Nothing is currently done for backtracing purposes. We could ! -- have used the personality routine to record the addresses while ! -- walking up the stack, but this method has two drawbacks : 1/ the ! -- trace is incomplete if the exception is handled since we don't walk ! -- up the frame with the handler, and 2/ we will miss frames if the ! -- exception propagates through frames for which our personality ! -- routine is not called (e.g. if C or C++ frames are on the way). ! ! -- Fill in the useful flags for the personality routine called for each ! -- frame via the call to Unwind_RaiseException below. ! ! This_Exception.Id := Excep.Id; ! This_Exception.Handled_By_Others := not Excep.Id.Not_Handled_By_Others; ! This_Exception.Has_Cleanup := False; ! ! -- We are looking for a regular handler first. If there is one, either ! -- it or the first at-end handler before it will be entered. If there ! -- is none, control will normally get back to after the call, with ! -- Has_Cleanup set to true if at least one at-end handler has been ! -- found while walking up the stack. ! ! This_Exception.Select_Cleanups := False; ! ! Status := Unwind_RaiseException (This_Exception'Access); ! ! -- If we get here we know the exception is not handled, as otherwise ! -- Unwind_RaiseException arranges for a handler to be entered. We might ! -- have met cleanups handlers, though, requiring to start again with ! -- the Select_Cleanups flag set to True. ! ! -- Before restarting for cleanups, take the necessary steps to enable ! -- the debugger to gain control while the stack is still intact. Flag ! -- the occurrence as raised to avoid notifying again in case cleanup ! -- handlers are entered later. ! ! if not Excep.Exception_Raised then ! Excep.Exception_Raised := True; ! Notify_Unhandled_Exception (Excep.Id); ! end if; ! ! -- Now raise again selecting cleanups as true handlers. Only do this if ! -- we know at least one such handler exists since otherwise we would ! -- perform a complete stack upwalk for nothing. ! ! if This_Exception.Has_Cleanup then ! This_Exception.Select_Cleanups := True; ! Status := Unwind_RaiseException (This_Exception'Access); ! ! -- The first cleanup found is entered. It performs its job, raises ! -- the initial exception again, and the flow goes back to the first ! -- step above with the stack in a different state. ! end if; ! ! -- We get here when there is no handler to be run at all. The debugger ! -- has been notified before the second step above. ! ! Unhandled_Exception_Terminate; ! ! end Propagate_Exception_With_GCC_Support; ---------------------------- -- Raise_Constraint_Error -- --- 810,831 ---- if not Excep.Exception_Raised then Excep.Exception_Raised := True; ! Exception_Traces.Notify_Handled_Exception; end if; builtin_longjmp (Jumpbuf_Ptr, 1); else ! -- The pragma Inspection point here ensures that the debugger ! -- can inspect the parameter. ! pragma Inspection_Point (E); ! Exception_Traces.Notify_Unhandled_Exception; ! Exception_Traces.Unhandled_Exception_Terminate; end if; end if; ! end Process_Raise_Exception; ---------------------------- -- Raise_Constraint_Error -- *************** package body Ada.Exceptions is *** 1637,1643 **** Line : Integer) is begin ! Raise_With_Location (Constraint_Error_Def'Access, File, Line); end Raise_Constraint_Error; -------------------------------- --- 836,843 ---- Line : Integer) is begin ! Raise_With_Location_And_Msg ! (Constraint_Error_Def'Access, File, Line); end Raise_Constraint_Error; -------------------------------- *************** package body Ada.Exceptions is *** 1659,1664 **** --- 859,866 ---- ------------------------- procedure Raise_Current_Excep (E : Exception_Id) is + pragma Inspection_Point (E); + -- This is so the debugger can reliably inspect the parameter begin Process_Raise_Exception (E => E, From_Signal_Handler => False); end Raise_Current_Excep; *************** package body Ada.Exceptions is *** 1671,1685 **** (E : Exception_Id; Message : String := "") is - Len : constant Natural := - Natural'Min (Message'Length, Exception_Msg_Max_Length); - Excep : constant EOA := Get_Current_Excep.all; - begin if E /= null then ! Excep.Msg_Length := Len; ! Excep.Msg (1 .. Len) := Message (1 .. Len); ! Raise_With_Msg (E); end if; end Raise_Exception; --- 873,883 ---- (E : Exception_Id; Message : String := "") is begin if E /= null then ! Exception_Data.Set_Exception_Msg (E, Message); ! Abort_Defer.all; ! Raise_Current_Excep (E); end if; end Raise_Exception; *************** package body Ada.Exceptions is *** 1691,1705 **** (E : Exception_Id; Message : String := "") is - Len : constant Natural := - Natural'Min (Message'Length, Exception_Msg_Max_Length); - - Excep : constant EOA := Get_Current_Excep.all; - begin ! Excep.Msg_Length := Len; ! Excep.Msg (1 .. Len) := Message (1 .. Len); ! Raise_With_Msg (E); end Raise_Exception_Always; ------------------------------- --- 889,898 ---- (E : Exception_Id; Message : String := "") is begin ! Exception_Data.Set_Exception_Msg (E, Message); ! Abort_Defer.all; ! Raise_Current_Excep (E); end Raise_Exception_Always; ------------------------------- *************** package body Ada.Exceptions is *** 1711,1733 **** M : Big_String_Ptr) is begin ! Set_Exception_C_Msg (E, M); Abort_Defer.all; Process_Raise_Exception (E => E, From_Signal_Handler => True); end Raise_From_Signal_Handler; - ------------------ - -- Raise_No_Msg -- - ------------------ - - procedure Raise_No_Msg (E : Exception_Id) is - Excep : constant EOA := Get_Current_Excep.all; - - begin - Excep.Msg_Length := 0; - Raise_With_Msg (E); - end Raise_No_Msg; - ------------------------- -- Raise_Program_Error -- ------------------------- --- 904,914 ---- M : Big_String_Ptr) is begin ! Exception_Data.Set_Exception_C_Msg (E, M); Abort_Defer.all; Process_Raise_Exception (E => E, From_Signal_Handler => True); end Raise_From_Signal_Handler; ------------------------- -- Raise_Program_Error -- ------------------------- *************** package body Ada.Exceptions is *** 1737,1743 **** Line : Integer) is begin ! Raise_With_Location (Program_Error_Def'Access, File, Line); end Raise_Program_Error; ----------------------------- --- 918,925 ---- Line : Integer) is begin ! Raise_With_Location_And_Msg ! (Program_Error_Def'Access, File, Line); end Raise_Program_Error; ----------------------------- *************** package body Ada.Exceptions is *** 1763,1769 **** Line : Integer) is begin ! Raise_With_Location (Storage_Error_Def'Access, File, Line); end Raise_Storage_Error; ----------------------------- --- 945,952 ---- Line : Integer) is begin ! Raise_With_Location_And_Msg ! (Storage_Error_Def'Access, File, Line); end Raise_Storage_Error; ----------------------------- *************** package body Ada.Exceptions is *** 1780,1814 **** (Storage_Error_Def'Access, File, Line, Msg); end Raise_Storage_Error_Msg; - ---------------------- - -- Raise_With_C_Msg -- - ---------------------- - - procedure Raise_With_C_Msg - (E : Exception_Id; - M : Big_String_Ptr) - is - begin - Set_Exception_C_Msg (E, M); - Abort_Defer.all; - Raise_Current_Excep (E); - end Raise_With_C_Msg; - - ------------------------- - -- Raise_With_Location -- - ------------------------- - - procedure Raise_With_Location - (E : Exception_Id; - F : Big_String_Ptr; - L : Integer) - is - begin - Set_Exception_C_Msg (E, F, L); - Abort_Defer.all; - Raise_Current_Excep (E); - end Raise_With_Location; - --------------------------------- -- Raise_With_Location_And_Msg -- --------------------------------- --- 963,968 ---- *************** package body Ada.Exceptions is *** 1817,1826 **** (E : Exception_Id; F : Big_String_Ptr; L : Integer; ! M : Big_String_Ptr) is begin ! Set_Exception_C_Msg (E, F, L, M); Abort_Defer.all; Raise_Current_Excep (E); end Raise_With_Location_And_Msg; --- 971,980 ---- (E : Exception_Id; F : Big_String_Ptr; L : Integer; ! M : Big_String_Ptr := null) is begin ! Exception_Data.Set_Exception_C_Msg (E, F, L, M); Abort_Defer.all; Raise_Current_Excep (E); end Raise_With_Location_And_Msg; *************** package body Ada.Exceptions is *** 1829,1838 **** -- Raise_With_Msg -- -------------------- ! procedure Raise_With_Msg (E : Exception_Id) is Excep : constant EOA := Get_Current_Excep.all; begin Excep.Exception_Raised := False; Excep.Id := E; Excep.Num_Tracebacks := 0; --- 983,996 ---- -- Raise_With_Msg -- -------------------- ! procedure Raise_With_Msg (E : Exception_Id; Setup : Boolean) is Excep : constant EOA := Get_Current_Excep.all; begin + if not Setup then + Exception_Propagation.Setup_Exception (Excep, Excep); + end if; + Excep.Exception_Raised := False; Excep.Id := E; Excep.Num_Tracebacks := 0; *************** package body Ada.Exceptions is *** 1842,1847 **** --- 1000,1168 ---- Raise_Current_Excep (E); end Raise_With_Msg; + procedure Raise_With_Msg (E : Exception_Id) is + begin + Raise_With_Msg (E, Setup => False); + end Raise_With_Msg; + + ----------------------- + -- Raise_After_Setup -- + ----------------------- + + procedure Raise_After_Setup (E : Exception_Id) is + begin + Raise_With_Msg (E, Setup => True); + end Raise_After_Setup; + + -------------------------------------- + -- Calls to Run-Time Check Routines -- + -------------------------------------- + + procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_00'Address)); + end Rcheck_00; + + procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_01'Address)); + end Rcheck_01; + + procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_02'Address)); + end Rcheck_02; + + procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_03'Address)); + end Rcheck_03; + + procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_04'Address)); + end Rcheck_04; + + procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_05'Address)); + end Rcheck_05; + + procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_06'Address)); + end Rcheck_06; + + procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_07'Address)); + end Rcheck_07; + + procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_08'Address)); + end Rcheck_08; + + procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_09'Address)); + end Rcheck_09; + + procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_10'Address)); + end Rcheck_10; + + procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_11'Address)); + end Rcheck_11; + + procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_12'Address)); + end Rcheck_12; + + procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_13'Address)); + end Rcheck_13; + + procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_14'Address)); + end Rcheck_14; + + procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_15'Address)); + end Rcheck_15; + + procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_16'Address)); + end Rcheck_16; + + procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_17'Address)); + end Rcheck_17; + + procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_18'Address)); + end Rcheck_18; + + procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_19'Address)); + end Rcheck_19; + + procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_20'Address)); + end Rcheck_20; + + procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_21'Address)); + end Rcheck_21; + + procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_22'Address)); + end Rcheck_22; + + procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_23'Address)); + end Rcheck_23; + + procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_24'Address)); + end Rcheck_24; + + procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_25'Address)); + end Rcheck_25; + + procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_26'Address)); + end Rcheck_26; + + procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_27'Address)); + end Rcheck_27; + + procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_28'Address)); + end Rcheck_28; + ------------- -- Reraise -- ------------- *************** package body Ada.Exceptions is *** 1851,1856 **** --- 1172,1178 ---- begin Abort_Defer.all; + Exception_Propagation.Setup_Exception (Excep, Excep, Reraised => True); Raise_Current_Excep (Excep.Id); end Reraise; *************** package body Ada.Exceptions is *** 1862,1868 **** begin if X.Id /= null then Abort_Defer.all; ! Save_Occurrence (Get_Current_Excep.all.all, X); Raise_Current_Excep (X.Id); end if; end Reraise_Occurrence; --- 1184,1192 ---- begin if X.Id /= null then Abort_Defer.all; ! Exception_Propagation.Setup_Exception ! (X'Unrestricted_Access, Get_Current_Excep.all, Reraised => True); ! Save_Occurrence_No_Private (Get_Current_Excep.all.all, X); Raise_Current_Excep (X.Id); end if; end Reraise_Occurrence; *************** package body Ada.Exceptions is *** 1874,1880 **** procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is begin Abort_Defer.all; ! Save_Occurrence (Get_Current_Excep.all.all, X); Raise_Current_Excep (X.Id); end Reraise_Occurrence_Always; --- 1198,1206 ---- procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is begin Abort_Defer.all; ! Exception_Propagation.Setup_Exception ! (X'Unrestricted_Access, Get_Current_Excep.all, Reraised => True); ! Save_Occurrence_No_Private (Get_Current_Excep.all.all, X); Raise_Current_Excep (X.Id); end Reraise_Occurrence_Always; *************** package body Ada.Exceptions is *** 1884,1890 **** procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is begin ! Save_Occurrence (Get_Current_Excep.all.all, X); Raise_Current_Excep (X.Id); end Reraise_Occurrence_No_Defer; --- 1210,1218 ---- procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is begin ! Exception_Propagation.Setup_Exception ! (X'Unrestricted_Access, Get_Current_Excep.all, Reraised => True); ! Save_Occurrence_No_Private (Get_Current_Excep.all.all, X); Raise_Current_Excep (X.Id); end Reraise_Occurrence_No_Defer; *************** package body Ada.Exceptions is *** 1897,1913 **** Source : Exception_Occurrence) is begin ! Target.Id := Source.Id; ! Target.Msg_Length := Source.Msg_Length; ! Target.Num_Tracebacks := Source.Num_Tracebacks; ! Target.Pid := Source.Pid; ! Target.Cleanup_Flag := Source.Cleanup_Flag; ! ! Target.Msg (1 .. Target.Msg_Length) := ! Source.Msg (1 .. Target.Msg_Length); ! ! Target.Tracebacks (1 .. Target.Num_Tracebacks) := ! Source.Tracebacks (1 .. Target.Num_Tracebacks); end Save_Occurrence; function Save_Occurrence --- 1225,1231 ---- Source : Exception_Occurrence) is begin ! Save_Occurrence_No_Private (Target, Source); end Save_Occurrence; function Save_Occurrence *************** package body Ada.Exceptions is *** 1921,2549 **** return Target; end Save_Occurrence; ! --------------------- ! -- SDP_Table_Build -- ! --------------------- ! procedure SDP_Table_Build ! (SDP_Addresses : System.Address; ! SDP_Count : Natural; ! Elab_Addresses : System.Address; ! Elab_Addr_Count : Natural) is - type SDLP_Array is array (1 .. SDP_Count) of Subprogram_Descriptors_Ptr; - type SDLP_Array_Ptr is access all SDLP_Array; - - function To_SDLP_Array_Ptr is new Unchecked_Conversion - (System.Address, SDLP_Array_Ptr); - - T : constant SDLP_Array_Ptr := To_SDLP_Array_Ptr (SDP_Addresses); - - type Elab_Array is array (1 .. Elab_Addr_Count) of Code_Loc; - type Elab_Array_Ptr is access all Elab_Array; - - function To_Elab_Array_Ptr is new Unchecked_Conversion - (System.Address, Elab_Array_Ptr); - - EA : constant Elab_Array_Ptr := To_Elab_Array_Ptr (Elab_Addresses); - - Ndes : Natural; - Previous_Subprogram_Descriptors : Subprogram_Descriptor_List_Ptr; - begin ! -- If first call, then initialize count of subprogram descriptors ! ! if Subprogram_Descriptors = null then ! Num_Subprogram_Descriptors := 0; ! end if; ! ! -- First count number of subprogram descriptors. This count includes ! -- entries with duplicated code addresses (resulting from Import). ! ! Ndes := Num_Subprogram_Descriptors + Elab_Addr_Count; ! for J in T'Range loop ! Ndes := Ndes + T (J).Count; ! end loop; ! ! -- Now, allocate the new table (extra zero'th element is for sort call) ! -- after having saved the previous one ! ! Previous_Subprogram_Descriptors := Subprogram_Descriptors; ! Subprogram_Descriptors := new Subprogram_Descriptor_List (0 .. Ndes); ! ! -- If there was a previous Subprogram_Descriptors table, copy it back ! -- into the new one being built. Then free the memory used for the ! -- previous table. ! ! for J in 1 .. Num_Subprogram_Descriptors loop ! Subprogram_Descriptors (J) := Previous_Subprogram_Descriptors (J); ! end loop; ! ! Free (Previous_Subprogram_Descriptors); ! ! -- Next, append the elaboration routine addresses, building dummy ! -- SDP's for them as we go through the list. ! ! Ndes := Num_Subprogram_Descriptors; ! for J in EA'Range loop ! Ndes := Ndes + 1; ! Subprogram_Descriptors (Ndes) := new Subprogram_Descriptor_0; ! ! Subprogram_Descriptors (Ndes).all := ! Subprogram_Descriptor' ! (Num_Handlers => 0, ! Code => Fetch_Code (EA (J)), ! Subprogram_Info => EA (J), ! Handler_Records => (1 .. 0 => null)); ! end loop; ! ! -- Now copy in pointers to SDP addresses of application subprograms ! ! for J in T'Range loop ! for K in 1 .. T (J).Count loop ! Ndes := Ndes + 1; ! Subprogram_Descriptors (Ndes) := T (J).SDesc (K); ! Subprogram_Descriptors (Ndes).Code := ! Fetch_Code (T (J).SDesc (K).Code); ! end loop; ! end loop; ! ! -- Now we need to sort the table into ascending PC order ! ! Sort (Ndes, SDP_Table_Sort_Move'Access, SDP_Table_Sort_Lt'Access); ! ! -- Now eliminate duplicate entries. Note that in the case where ! -- entries have duplicate code addresses, the code for the Lt ! -- routine ensures that the interesting one (i.e. the one with ! -- handler entries if there are any) comes first. ! ! Num_Subprogram_Descriptors := 1; ! ! for J in 2 .. Ndes loop ! if Subprogram_Descriptors (J).Code /= ! Subprogram_Descriptors (Num_Subprogram_Descriptors).Code ! then ! Num_Subprogram_Descriptors := Num_Subprogram_Descriptors + 1; ! Subprogram_Descriptors (Num_Subprogram_Descriptors) := ! Subprogram_Descriptors (J); ! end if; ! end loop; ! ! end SDP_Table_Build; ! ! ----------------------- ! -- SDP_Table_Sort_Lt -- ! ----------------------- ! function SDP_Table_Sort_Lt (Op1, Op2 : Natural) return Boolean is ! SDC1 : constant Code_Loc := Subprogram_Descriptors (Op1).Code; ! SDC2 : constant Code_Loc := Subprogram_Descriptors (Op2).Code; begin ! if SDC1 < SDC2 then ! return True; ! ! elsif SDC1 > SDC2 then ! return False; ! ! -- For two descriptors for the same procedure, we want the more ! -- interesting one first. A descriptor with an exception handler ! -- is more interesting than one without. This happens if the less ! -- interesting one came from a pragma Import. ! ! else ! return Subprogram_Descriptors (Op1).Num_Handlers /= 0 ! and then Subprogram_Descriptors (Op2).Num_Handlers = 0; ! end if; ! end SDP_Table_Sort_Lt; ! -------------------------- ! -- SDP_Table_Sort_Move -- ! -------------------------- ! procedure SDP_Table_Sort_Move (From : Natural; To : Natural) is ! begin ! Subprogram_Descriptors (To) := Subprogram_Descriptors (From); ! end SDP_Table_Sort_Move; ------------------------- ! -- Set_Exception_C_Msg -- ------------------------- ! procedure Set_Exception_C_Msg ! (Id : Exception_Id; ! Msg1 : Big_String_Ptr; ! Line : Integer := 0; ! Msg2 : Big_String_Ptr := null) is - Excep : constant EOA := Get_Current_Excep.all; - Val : Integer := Line; - Remind : Integer; - Size : Integer := 1; - Ptr : Natural; - begin ! Excep.Exception_Raised := False; ! Excep.Id := Id; ! Excep.Num_Tracebacks := 0; ! Excep.Pid := Local_Partition_ID; ! Excep.Msg_Length := 0; ! Excep.Cleanup_Flag := False; ! ! while Msg1 (Excep.Msg_Length + 1) /= ASCII.NUL ! and then Excep.Msg_Length < Exception_Msg_Max_Length ! loop ! Excep.Msg_Length := Excep.Msg_Length + 1; ! Excep.Msg (Excep.Msg_Length) := Msg1 (Excep.Msg_Length); ! end loop; ! ! -- Append line number if present ! ! if Line > 0 then ! ! -- Compute the number of needed characters ! ! while Val > 0 loop ! Val := Val / 10; ! Size := Size + 1; ! end loop; ! ! -- If enough characters are available, put the line number ! ! if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then ! Excep.Msg (Excep.Msg_Length + 1) := ':'; ! Excep.Msg_Length := Excep.Msg_Length + Size; ! Val := Line; ! Size := 0; ! ! while Val > 0 loop ! Remind := Val rem 10; ! Val := Val / 10; ! Excep.Msg (Excep.Msg_Length - Size) := ! Character'Val (Remind + Character'Pos ('0')); ! Size := Size + 1; ! end loop; ! end if; ! end if; ! ! -- Append second message if present ! ! if Msg2 /= null ! and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length ! then ! Excep.Msg_Length := Excep.Msg_Length + 1; ! Excep.Msg (Excep.Msg_Length) := ' '; ! Ptr := 1; ! while Msg2 (Ptr) /= ASCII.NUL ! and then Excep.Msg_Length < Exception_Msg_Max_Length ! loop ! Excep.Msg_Length := Excep.Msg_Length + 1; ! Excep.Msg (Excep.Msg_Length) := Msg2 (Ptr); ! Ptr := Ptr + 1; ! end loop; ! end if; ! end Set_Exception_C_Msg; ------------------- -- String_To_EId -- ------------------- ! function String_To_EId (S : String) return Exception_Id is ! begin ! if S = "" then ! return Null_Id; ! else ! return Exception_Id (Internal_Exception (S)); ! end if; ! end String_To_EId; ------------------ -- String_To_EO -- ------------------ ! function String_To_EO (S : String) return Exception_Occurrence is ! From : Natural; ! To : Integer; ! ! X : Exception_Occurrence; ! -- This is the exception occurrence we will create ! ! procedure Bad_EO; ! pragma No_Return (Bad_EO); ! -- Signal bad exception occurrence string ! ! procedure Next_String; ! -- On entry, To points to last character of previous line of the ! -- message, terminated by LF. On return, From .. To are set to ! -- specify the next string, or From > To if there are no more lines. ! ! procedure Bad_EO is ! begin ! Raise_Exception ! (Program_Error'Identity, ! "bad exception occurrence in stream input"); ! end Bad_EO; ! ! procedure Next_String is ! begin ! From := To + 2; ! ! if From < S'Last then ! To := From + 1; ! ! while To < S'Last - 1 loop ! if To >= S'Last then ! Bad_EO; ! elsif S (To + 1) = ASCII.LF then ! exit; ! else ! To := To + 1; ! end if; ! end loop; ! end if; ! end Next_String; ! ! -- Start of processing for String_To_EO ! ! begin ! if S = "" then ! return Null_Occurrence; ! ! else ! X.Cleanup_Flag := False; ! ! To := S'First - 2; ! Next_String; ! ! if S (From .. From + 15) /= "Exception name: " then ! Bad_EO; ! end if; ! ! X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To))); ! ! Next_String; ! ! if From <= To and then S (From) = 'M' then ! if S (From .. From + 8) /= "Message: " then ! Bad_EO; ! end if; ! ! X.Msg_Length := To - From - 8; ! X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To); ! Next_String; ! ! else ! X.Msg_Length := 0; ! end if; ! ! X.Pid := 0; ! ! if From <= To and then S (From) = 'P' then ! if S (From .. From + 3) /= "PID:" then ! Bad_EO; ! end if; ! ! From := From + 5; -- skip past PID: space ! ! while From <= To loop ! X.Pid := X.Pid * 10 + ! (Character'Pos (S (From)) - Character'Pos ('0')); ! From := From + 1; ! end loop; ! ! Next_String; ! end if; ! ! X.Num_Tracebacks := 0; ! ! if From <= To then ! if S (From .. To) /= "Call stack traceback locations:" then ! Bad_EO; ! end if; ! ! Next_String; ! loop ! exit when From > To; ! ! declare ! Ch : Character; ! C : Integer_Address; ! N : Integer_Address; ! ! begin ! if S (From) /= '0' ! or else S (From + 1) /= 'x' ! then ! Bad_EO; ! else ! From := From + 2; ! end if; ! ! C := 0; ! while From <= To loop ! Ch := S (From); ! ! if Ch in '0' .. '9' then ! N := ! Character'Pos (S (From)) - Character'Pos ('0'); ! ! elsif Ch in 'a' .. 'f' then ! N := ! Character'Pos (S (From)) - Character'Pos ('a') + 10; ! ! elsif Ch = ' ' then ! From := From + 1; ! exit; ! ! else ! Bad_EO; ! end if; ! ! C := C * 16 + N; ! ! From := From + 1; ! end loop; ! ! if X.Num_Tracebacks = Max_Tracebacks then ! Bad_EO; ! end if; ! ! X.Num_Tracebacks := X.Num_Tracebacks + 1; ! X.Tracebacks (X.Num_Tracebacks) := To_Address (C); ! end; ! end loop; ! end if; ! ! -- If an exception was converted to a string, it must have ! -- already been raised, so flag it accordingly and we are done. ! ! X.Exception_Raised := True; ! return X; ! end if; ! end String_To_EO; ! ! ---------------------------------- ! -- Tailored_Exception_Traceback -- ! ---------------------------------- ! ! function Tailored_Exception_Traceback ! (X : Exception_Occurrence) ! return String ! is ! -- We indeed reference the decorator *wrapper* from here and not the ! -- decorator itself. The purpose of the local variable Wrapper is to ! -- prevent a potential crash by race condition in the code below. The ! -- atomicity of this assignment is enforced by pragma Atomic in ! -- System.Soft_Links. ! ! -- The potential race condition here, if no local variable was used, ! -- relates to the test upon the wrapper's value and the call, which ! -- are not performed atomically. With the local variable, potential ! -- changes of the wrapper's global value between the test and the ! -- call become inoffensive. ! ! Wrapper : constant Traceback_Decorator_Wrapper_Call := ! Traceback_Decorator_Wrapper; ! ! begin ! if Wrapper = null then ! return Basic_Exception_Traceback (X); ! else ! return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks); ! end if; ! end Tailored_Exception_Traceback; ! ! ------------------------------------ ! -- Tailored_Exception_Information -- ! ------------------------------------ ! ! function Tailored_Exception_Information ! (X : Exception_Occurrence) ! return String ! is ! -- The tailored exception information is simply the basic information ! -- associated with the tailored call chain backtrace. ! ! Basic_Info : constant String := Basic_Exception_Information (X); ! Tback_Info : constant String := Tailored_Exception_Traceback (X); ! ! Basic_Len : constant Natural := Basic_Info'Length; ! Tback_Len : constant Natural := Tback_Info'Length; ! ! Info : String (1 .. Basic_Len + Tback_Len); ! Ptr : Natural := 0; ! ! begin ! Append_Info_String (Basic_Info, Info, Ptr); ! Append_Info_String (Tback_Info, Info, Ptr); ! ! return Info; ! end Tailored_Exception_Information; ! ! ------------------------- ! -- Unhandled_Exception -- ! ------------------------- ! ! procedure Unhandled_Exception is ! begin ! null; ! end Unhandled_Exception; ! ! ---------------------- ! -- Notify_Exception -- ! ---------------------- ! ! procedure Notify_Exception ! (Id : Exception_Id; ! Handler : Code_Loc; ! Is_Others : Boolean) ! is ! begin ! null; ! end Notify_Exception; ! ! ------------------------------ ! -- Notify_Handled_Exception -- ! ------------------------------ ! ! procedure Notify_Handled_Exception ! (Handler : Code_Loc; ! Is_Others : Boolean; ! Low_Notify : Boolean) ! is ! Excep : constant EOA := Get_Current_Excep.all; ! ! begin ! -- Notify the debugger that we have found a handler and are about to ! -- propagate an exception, but only if specifically told to do so. ! ! if Low_Notify then ! Notify_Exception (Excep.Id, Handler, Is_Others); ! end if; ! ! -- Output some exception information if necessary, as specified by ! -- GNAT.Exception_Traces. Take care not to output information about ! -- internal exceptions. ! -- ! -- ??? In the ZCX case, the traceback entries we have at this point ! -- only include the ones we stored while walking up the stack *up to ! -- the handler*. All the frames above the subprogram in which the ! -- handler is found are missing. ! ! if Exception_Trace = Every_Raise ! and then not Excep.Id.Not_Handled_By_Others ! then ! To_Stderr (Nline); ! To_Stderr ("Exception raised"); ! To_Stderr (Nline); ! To_Stderr (Tailored_Exception_Information (Excep.all)); ! end if; ! ! end Notify_Handled_Exception; ! ! ------------------------------ ! -- Notify_Handled_Exception -- ! ------------------------------ ! ! procedure Notify_Unhandled_Exception (Id : Exception_Id) is ! begin ! -- Simply perform the two necessary low level notification calls. ! ! Unhandled_Exception; ! Notify_Exception (Id, Null_Loc, False); ! ! end Notify_Unhandled_Exception; ! ! ----------------------------------- ! -- Unhandled_Exception_Terminate -- ! ----------------------------------- ! ! adafinal_Called : Boolean := False; ! -- Used to prevent recursive call to adafinal in the event that ! -- adafinal processing itself raises an unhandled exception. ! ! type FILEs is new System.Address; ! type int is new Integer; ! ! procedure Unhandled_Exception_Terminate is ! ! Excep : constant EOA := Save_Occurrence (Get_Current_Excep.all.all); ! -- This occurrence will be used to display a message after finalization. ! -- It is necessary to save a copy here, or else the designated value ! -- could be overwritten if an exception is raised during finalization ! -- (even if that exception is caught). ! ! Msg : constant String := Exception_Message (Excep.all); ! ! -- Start of processing for Unhandled_Exception_Terminate ! ! begin ! -- First call adafinal ! ! if not adafinal_Called then ! adafinal_Called := True; ! System.Soft_Links.Adafinal.all; ! end if; ! ! -- Check for special case of raising _ABORT_SIGNAL, which is not ! -- really an exception at all. We recognize this by the fact that ! -- it is the only exception whose name starts with underscore. ! ! if Exception_Name (Excep.all) (1) = '_' then ! To_Stderr (Nline); ! To_Stderr ("Execution terminated by abort of environment task"); ! To_Stderr (Nline); ! ! -- If no tracebacks, we print the unhandled exception in the old style ! -- (i.e. the style used before ZCX was implemented). We do this to ! -- retain compatibility, especially with the nightly scripts, but ! -- this can be removed at some point ??? ! ! elsif Excep.Num_Tracebacks = 0 then ! To_Stderr (Nline); ! To_Stderr ("raised "); ! To_Stderr (Exception_Name (Excep.all)); ! ! if Msg'Length /= 0 then ! To_Stderr (" : "); ! To_Stderr (Msg); ! end if; ! ! To_Stderr (Nline); ! ! -- New style, zero cost exception case ! ! else ! -- Tailored_Exception_Information is also called here so that the ! -- backtrace decorator gets called if it has been set. This is ! -- currently required because some paths in Raise_Current_Excep ! -- do not go through the calls that display this information. ! -- ! -- Note also that with the current scheme in Raise_Current_Excep ! -- we can have this whole information output twice, typically when ! -- some handler is found on the call chain but none deals with the ! -- occurrence or if this occurrence gets reraised up to here. ! ! To_Stderr (Nline); ! To_Stderr ("Execution terminated by unhandled exception"); ! To_Stderr (Nline); ! To_Stderr (Tailored_Exception_Information (Excep.all)); ! end if; ! ! -- Perform system dependent shutdown code ! ! declare ! procedure Unhandled_Terminate; ! pragma No_Return (Unhandled_Terminate); ! pragma Import ! (C, Unhandled_Terminate, "__gnat_unhandled_terminate"); ! ! begin ! Unhandled_Terminate; ! end; ! ! end Unhandled_Exception_Terminate; ------------------------------ -- Raise_Exception_No_Defer -- --- 1239,1311 ---- return Target; end Save_Occurrence; ! -------------------------------- ! -- Save_Occurrence_And_Private -- ! -------------------------------- ! procedure Save_Occurrence_And_Private ! (Target : out Exception_Occurrence; ! Source : Exception_Occurrence) is begin ! Save_Occurrence_No_Private (Target, Source); ! Target.Private_Data := Source.Private_Data; ! end Save_Occurrence_And_Private; ! -------------------------------- ! -- Save_Occurrence_No_Private -- ! -------------------------------- + procedure Save_Occurrence_No_Private + (Target : out Exception_Occurrence; + Source : Exception_Occurrence) + is begin ! Target.Id := Source.Id; ! Target.Msg_Length := Source.Msg_Length; ! Target.Num_Tracebacks := Source.Num_Tracebacks; ! Target.Pid := Source.Pid; ! Target.Cleanup_Flag := Source.Cleanup_Flag; ! Target.Msg (1 .. Target.Msg_Length) := ! Source.Msg (1 .. Target.Msg_Length); ! Target.Tracebacks (1 .. Target.Num_Tracebacks) := ! Source.Tracebacks (1 .. Target.Num_Tracebacks); ! end Save_Occurrence_No_Private; ------------------------- ! -- Transfer_Occurrence -- ------------------------- ! procedure Transfer_Occurrence ! (Target : Exception_Occurrence_Access; ! Source : Exception_Occurrence) is begin ! -- Setup Target as an exception to be propagated in the calling task ! -- (rendezvous-wise), taking care not to clobber the associated private ! -- data. Target is expected to be a pointer to the calling task's ! -- fixed TSD occurrence, which is very different from Get_Current_Excep ! -- here because this subprogram is called from the called task. ! Exception_Propagation.Setup_Exception (Target, Target); ! Save_Occurrence_No_Private (Target.all, Source); ! end Transfer_Occurrence; ------------------- -- String_To_EId -- ------------------- ! function String_To_EId (S : String) return Exception_Id ! renames Stream_Attributes.String_To_EId; ------------------ -- String_To_EO -- ------------------ ! function String_To_EO (S : String) return Exception_Occurrence ! renames Stream_Attributes.String_To_EO; ------------------------------ -- Raise_Exception_No_Defer -- *************** package body Ada.Exceptions is *** 2553,2593 **** (E : Exception_Id; Message : String := "") is - Len : constant Natural := - Natural'Min (Message'Length, Exception_Msg_Max_Length); - - Excep : constant EOA := Get_Current_Excep.all; - begin ! Excep.Exception_Raised := False; ! Excep.Msg_Length := Len; ! Excep.Msg (1 .. Len) := Message (1 .. Len); ! Excep.Id := E; ! Excep.Num_Tracebacks := 0; ! Excep.Cleanup_Flag := False; ! Excep.Pid := Local_Partition_ID; -- DO NOT CALL Abort_Defer.all; !!!! Raise_Current_Excep (E); end Raise_Exception_No_Defer; - --------------- - -- To_Stderr -- - --------------- - - procedure To_Stderr (S : String) is - procedure put_char_stderr (C : int); - pragma Import (C, put_char_stderr, "put_char_stderr"); - - begin - for J in 1 .. S'Length loop - if S (J) /= ASCII.CR then - put_char_stderr (Character'Pos (S (J))); - end if; - end loop; - end To_Stderr; - --------- -- ZZZ -- --------- --- 1315,1329 ---- (E : Exception_Id; Message : String := "") is begin ! Exception_Data.Set_Exception_Msg (E, Message); -- DO NOT CALL Abort_Defer.all; !!!! + -- why not??? would be nice to have more comments here Raise_Current_Excep (E); end Raise_Exception_No_Defer; --------- -- ZZZ -- --------- *************** package body Ada.Exceptions is *** 2598,2608 **** procedure ZZZ is begin ! null; end ZZZ; begin -- Allocate the Non-Tasking Machine_State Set_Machine_State_Addr_NT (System.Address (Allocate_Machine_State)); end Ada.Exceptions; --- 1334,1351 ---- procedure ZZZ is begin ! <> ! Code_Address_For_ZZZ := Start_Of_ZZZ'Address; end ZZZ; begin -- Allocate the Non-Tasking Machine_State Set_Machine_State_Addr_NT (System.Address (Allocate_Machine_State)); + + -- Call the AAA/ZZZ routines to setup the code addresses for the + -- bounds of this unit. + + AAA; + ZZZ; end Ada.Exceptions; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-except.ads gcc-3.4.0/gcc/ada/a-except.ads *** gcc-3.3.3/gcc/ada/a-except.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-except.ads 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,13 **** -- -- -- 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 -- --- 6,12 ---- -- -- -- 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 -- *************** pragma Polling (Off); *** 42,47 **** --- 41,47 ---- with System; with System.Standard_Library; + with System.Traceback_Entries; package Ada.Exceptions is *************** private *** 114,120 **** subtype Code_Loc is System.Address; -- Code location used in building exception tables and for call ! -- addresses when propagating an exception (also traceback table) -- Values of this type are created by using Label'Address or -- extracted from machine states using Get_Code_Loc. --- 114,120 ---- subtype Code_Loc is System.Address; -- Code location used in building exception tables and for call ! -- addresses when propagating an exception. -- Values of this type are created by using Label'Address or -- extracted from machine states using Get_Code_Loc. *************** private *** 163,173 **** -- calls to Raise_Exception_Always if it can determine this is the case. -- The Export allows this routine to be accessed from Pure units. - procedure Raise_No_Msg (E : Exception_Id); - pragma No_Return (Raise_No_Msg); - -- Raises an exception with no message with given exception id value. - -- Abort is deferred before the raise call. - procedure Raise_From_Signal_Handler (E : Exception_Id; M : SSL.Big_String_Ptr); --- 163,168 ---- *************** private *** 187,201 **** -- some other way ask the operating system to return here rather than -- to the original location. - procedure Raise_With_C_Msg - (E : Exception_Id; - M : SSL.Big_String_Ptr); - pragma Export (Ada, Raise_With_C_Msg, "ada__exceptions__raise_with_c_msg"); - pragma No_Return (Raise_With_C_Msg); - -- Raises an exception with with given exception id value and message. - -- M is a null terminated string with the message to be raised. Abort - -- is deferred before the raise call. - procedure Reraise_Occurrence_Always (X : Exception_Occurrence); pragma No_Return (Reraise_Occurrence_Always); -- This differs from Raise_Occurrence only in that the caller guarantees --- 182,187 ---- *************** private *** 210,252 **** -- occurrence. This is used in generated code when it is known -- that abort is already deferred. - procedure SDP_Table_Build - (SDP_Addresses : System.Address; - SDP_Count : Natural; - Elab_Addresses : System.Address; - Elab_Addr_Count : Natural); - pragma Export (C, SDP_Table_Build, "__gnat_SDP_Table_Build"); - -- This is the routine that is called to build and sort the list of - -- subprogram descriptor pointers. In the normal case it is called - -- once at the start of execution, but it can also be called as part - -- of the explicit initialization routine (adainit) when there is no - -- Ada main program. In particular, in the case where multiple Ada - -- libraries are present, this routine can be called more than once - -- for each library, in which case it augments the previously set - -- table with the new entries specified by the parameters. - -- - -- SDP_Addresses Address of the start of the list of addresses of - -- __gnat_unit_name__SDP values constructed for each - -- unit, (see System.Exceptions). - -- - -- SDP_Count Number of entries in SDP_Addresses - -- - -- Elab_Addresses Address of the start of a list of addresses of - -- generated Ada elaboration routines, as well as - -- one extra entry for the generated main program. - -- These are used to generate the dummy SDP's that - -- mark the outer scope. - -- - -- Elab_Addr_Count Number of entries in Elab_Addresses - - procedure Break_Start; - pragma Export (C, Break_Start, "__gnat_break_start"); - -- This is a dummy procedure that is called at the start of execution. - -- Its sole purpose is to provide a well defined point for the placement - -- of a main program breakpoint. We put the routine in Ada.Exceptions so - -- that the standard mechanism of always stepping up from breakpoints - -- within Ada.Exceptions leaves us sitting in the main program. - ----------------------- -- Polling Interface -- ----------------------- --- 196,201 ---- *************** private *** 276,285 **** -- Exception_Occurrence -- -------------------------- Max_Tracebacks : constant := 50; -- Maximum number of trace backs stored in exception occurrence ! type Tracebacks_Array is array (1 .. Max_Tracebacks) of Code_Loc; -- Traceback array stored in exception occurrence type Exception_Occurrence is record --- 225,236 ---- -- Exception_Occurrence -- -------------------------- + package TBE renames System.Traceback_Entries; + Max_Tracebacks : constant := 50; -- Maximum number of trace backs stored in exception occurrence ! type Tracebacks_Array is array (1 .. Max_Tracebacks) of TBE.Traceback_Entry; -- Traceback array stored in exception occurrence type Exception_Occurrence is record *************** private *** 319,324 **** --- 270,280 ---- Tracebacks : Tracebacks_Array; -- Stored tracebacks (in Tracebacks (1 .. Num_Tracebacks)) + + Private_Data : System.Address := System.Null_Address; + -- Field used by low level exception mechanism to store specific data. + -- Currently used by the GCC exception mechanism to store a pointer to + -- a GNAT_GCC_Exception. end record; function "=" (Left, Right : Exception_Occurrence) return Boolean *************** private *** 340,345 **** Exception_Raised => False, Pid => 0, Num_Tracebacks => 0, ! Tracebacks => (others => Null_Loc)); end Ada.Exceptions; --- 296,302 ---- Exception_Raised => False, Pid => 0, Num_Tracebacks => 0, ! Tracebacks => (others => TBE.Null_TB_Entry), ! Private_Data => System.Null_Address); end Ada.Exceptions; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-excpol.adb gcc-3.4.0/gcc/ada/a-excpol.adb *** gcc-3.3.3/gcc/ada/a-excpol.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-excpol.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 7,13 **** -- B o d y -- -- (dummy version where polling is not used) -- -- -- - -- -- -- Copyright (C) 1992-1998, 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/a-exctra.adb gcc-3.4.0/gcc/ada/a-exctra.adb *** gcc-3.3.3/gcc/ada/a-exctra.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-exctra.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1999-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 -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-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 -- *************** *** 38,50 **** package body Ada.Exceptions.Traceback is ! function Tracebacks ! (E : Exception_Occurrence) ! return GNAT.Traceback.Tracebacks_Array ! is begin ! return ! GNAT.Traceback.Tracebacks_Array (E.Tracebacks (1 .. E.Num_Tracebacks)); end Tracebacks; end Ada.Exceptions.Traceback; --- 37,49 ---- package body Ada.Exceptions.Traceback is ! ---------------- ! -- Tracebacks -- ! ---------------- ! ! function Tracebacks (E : Exception_Occurrence) return Tracebacks_Array is begin ! return Tracebacks_Array (E.Tracebacks (1 .. E.Num_Tracebacks)); end Tracebacks; end Ada.Exceptions.Traceback; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-exctra.ads gcc-3.4.0/gcc/ada/a-exctra.ads *** gcc-3.3.3/gcc/ada/a-exctra.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-exctra.ads 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1999-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 -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-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 -- *************** *** 36,55 **** -- -- ------------------------------------------------------------------------------ ! -- This package is part of the support for tracebacks on exceptions. It is ! -- used ONLY from GNAT.Traceback.Symbolic and is provided to get access to ! -- the tracebacks in an exception occurrence. It may not be used directly ! -- from the Ada hierarchy (since it references GNAT.Traceback). ! with GNAT.Traceback; package Ada.Exceptions.Traceback is ! function Tracebacks ! (E : Exception_Occurrence) ! return GNAT.Traceback.Tracebacks_Array; -- This function extracts the traceback information from an exception -- occurrence, and returns it formatted in the manner required for ! -- processing in GNAT.Traceback. See g-traceb.ads for details. end Ada.Exceptions.Traceback; --- 35,57 ---- -- -- ------------------------------------------------------------------------------ ! -- This package is part of the support for tracebacks on exceptions. ! with System.Traceback_Entries; package Ada.Exceptions.Traceback is ! package TBE renames System.Traceback_Entries; ! ! subtype Code_Loc is System.Address; ! -- Code location in executing program ! ! type Tracebacks_Array is array (Positive range <>) of TBE.Traceback_Entry; ! -- A traceback array is an array of traceback entries. ! ! function Tracebacks (E : Exception_Occurrence) return Tracebacks_Array; -- This function extracts the traceback information from an exception -- occurrence, and returns it formatted in the manner required for ! -- processing in GNAT.Traceback. See g-traceb.ads for further details. end Ada.Exceptions.Traceback; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-exexda.adb gcc-3.4.0/gcc/ada/a-exexda.adb *** gcc-3.3.3/gcc/ada/a-exexda.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-exexda.adb 2003-11-17 14:58:14.000000000 +0000 *************** *** 0 **** --- 1,519 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- ADA.EXCEPTIONS.EXCEPTION_DATA -- + -- -- + -- 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- -- + -- 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. -- + -- -- + ------------------------------------------------------------------------------ + + with System.Storage_Elements; use System.Storage_Elements; + + separate (Ada.Exceptions) + package body Exception_Data is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Address_Image (A : System.Address) return String; + -- Returns at string of the form 0xhhhhhhhhh for an address, with + -- leading zeros suppressed. Hex characters a-f are in lower case. + + procedure Append_Info_Nat + (N : Natural; + Info : in out String; + Ptr : in out Natural); + -- Append the image of N at the end of the provided information string + + procedure Append_Info_NL + (Info : in out String; + Ptr : in out Natural); + -- Append a LF at the end of the provided information string + + procedure Append_Info_String + (S : String; + Info : in out String; + Ptr : in out Natural); + -- Append a string at the end of the provided information string + + -- To build Exception_Information and Tailored_Exception_Information, + -- we then use three intermediate functions : + + function Basic_Exception_Information + (X : Exception_Occurrence) return String; + -- Returns the basic exception information string associated with a + -- given exception occurrence. This is the common part shared by both + -- Exception_Information and Tailored_Exception_Infomation. + + function Basic_Exception_Traceback + (X : Exception_Occurrence) return String; + -- Returns an image of the complete call chain associated with an + -- exception occurence in its most basic form, that is as a raw sequence + -- of hexadecimal binary addresses. + + function Tailored_Exception_Traceback + (X : Exception_Occurrence) return String; + -- Returns an image of the complete call chain associated with an + -- exception occurrence, either in its basic form if no decorator is + -- in place, or as formatted by the decorator otherwise. + + -- The overall organization of the exception information related code + -- is summarized below : + -- + -- Exception_Information + -- | + -- +-------+--------+ + -- | | + -- Basic_Exc_Info & Basic_Exc_Tback + -- + -- + -- Tailored_Exception_Information + -- | + -- +----------+----------+ + -- | | + -- Basic_Exc_Info & Tailored_Exc_Tback + -- | + -- +-----------+------------+ + -- | | + -- Basic_Exc_Tback Or Tback_Decorator + -- if no decorator set otherwise + + ------------------- + -- Address_Image -- + ------------------- + + function Address_Image (A : Address) return String is + S : String (1 .. 18); + P : Natural; + N : Integer_Address; + + H : constant array (Integer range 0 .. 15) of Character := + "0123456789abcdef"; + begin + P := S'Last; + N := To_Integer (A); + loop + S (P) := H (Integer (N mod 16)); + P := P - 1; + N := N / 16; + exit when N = 0; + end loop; + + S (P - 1) := '0'; + S (P) := 'x'; + return S (P - 1 .. S'Last); + end Address_Image; + + --------------------- + -- Append_Info_Nat -- + --------------------- + + procedure Append_Info_Nat + (N : Natural; + Info : in out String; + Ptr : in out Natural) + is + begin + if N > 9 then + Append_Info_Nat (N / 10, Info, Ptr); + end if; + + Ptr := Ptr + 1; + Info (Ptr) := Character'Val (Character'Pos ('0') + N mod 10); + end Append_Info_Nat; + + -------------------- + -- Append_Info_NL -- + -------------------- + + procedure Append_Info_NL + (Info : in out String; + Ptr : in out Natural) + is + begin + Ptr := Ptr + 1; + Info (Ptr) := ASCII.LF; + end Append_Info_NL; + + ------------------------ + -- Append_Info_String -- + ------------------------ + + procedure Append_Info_String + (S : String; + Info : in out String; + Ptr : in out Natural) + is + Last : constant Natural := Integer'Min (Ptr + S'Length, Info'Last); + + begin + Info (Ptr + 1 .. Last) := S; + Ptr := Last; + end Append_Info_String; + + --------------------------------- + -- Basic_Exception_Information -- + --------------------------------- + + function Basic_Exception_Information + (X : Exception_Occurrence) return String + is + Name : constant String := Exception_Name (X); + Msg : constant String := Exception_Message (X); + -- Exception name and message that are going to be included in the + -- information to return, if not empty. + + Name_Len : constant Natural := Name'Length; + Msg_Len : constant Natural := Msg'Length; + -- Length of these strings, useful to compute the size of the string + -- we have to allocate for the complete result as well as in the body + -- of this procedure. + + Info_Maxlen : constant Natural := 50 + Name_Len + Msg_Len; + -- Maximum length of the information string we will build, with : + -- + -- 50 = 16 + 2 for the text associated with the name + -- + 9 + 2 for the text associated with the message + -- + 5 + 2 for the text associated with the pid + -- + 14 for the text image of the pid itself and a margin. + -- + -- This is indeed a maximum since some data may not appear at all if + -- not relevant. For example, nothing related to the exception message + -- will be there if this message is empty. + -- + -- WARNING : Do not forget to update these numbers if anything + -- involved in the computation changes. + + Info : String (1 .. Info_Maxlen); + -- Information string we are going to build, containing the common + -- part shared by Exc_Info and Tailored_Exc_Info. + + Ptr : Natural := 0; + + begin + -- Output exception name and message except for _ABORT_SIGNAL, where + -- these two lines are omitted (see discussion above). + + if Name (1) /= '_' then + Append_Info_String ("Exception name: ", Info, Ptr); + Append_Info_String (Name, Info, Ptr); + Append_Info_NL (Info, Ptr); + + if Msg_Len /= 0 then + Append_Info_String ("Message: ", Info, Ptr); + Append_Info_String (Msg, Info, Ptr); + Append_Info_NL (Info, Ptr); + end if; + end if; + + -- Output PID line if non-zero + + if X.Pid /= 0 then + Append_Info_String ("PID: ", Info, Ptr); + Append_Info_Nat (X.Pid, Info, Ptr); + Append_Info_NL (Info, Ptr); + end if; + + return Info (1 .. Ptr); + end Basic_Exception_Information; + + ------------------------------- + -- Basic_Exception_Traceback -- + ------------------------------- + + function Basic_Exception_Traceback + (X : Exception_Occurrence) return String + is + Info_Maxlen : constant Natural := 35 + X.Num_Tracebacks * 19; + -- Maximum length of the information string we are building, with : + -- 33 = 31 + 4 for the text before and after the traceback, and + -- 19 = 2 + 16 + 1 for each address ("0x" + HHHH + " ") + -- + -- WARNING : Do not forget to update these numbers if anything + -- involved in the computation changes. + + Info : String (1 .. Info_Maxlen); + -- Information string we are going to build, containing an image + -- of the call chain associated with the exception occurrence in its + -- most basic form, that is as a sequence of binary addresses. + + Ptr : Natural := 0; + + begin + if X.Num_Tracebacks > 0 then + Append_Info_String ("Call stack traceback locations:", Info, Ptr); + Append_Info_NL (Info, Ptr); + + for J in 1 .. X.Num_Tracebacks loop + Append_Info_String + (Address_Image (TBE.PC_For (X.Tracebacks (J))), Info, Ptr); + exit when J = X.Num_Tracebacks; + Append_Info_String (" ", Info, Ptr); + end loop; + + Append_Info_NL (Info, Ptr); + end if; + + return Info (1 .. Ptr); + end Basic_Exception_Traceback; + + --------------------------- + -- Exception_Information -- + --------------------------- + + -- The format of the string is: + + -- Exception_Name: nnnnn + -- Message: mmmmm + -- PID: ppp + -- Call stack traceback locations: + -- 0xhhhh 0xhhhh 0xhhhh ... 0xhhh + + -- where + + -- nnnn is the fully qualified name of the exception in all upper + -- case letters. This line is always present. + + -- mmmm is the message (this line present only if message is non-null) + + -- ppp is the Process Id value as a decimal integer (this line is + -- present only if the Process Id is non-zero). Currently we are + -- not making use of this field. + + -- The Call stack traceback locations line and the following values + -- are present only if at least one traceback location was recorded. + -- the values are given in C style format, with lower case letters + -- for a-f, and only as many digits present as are necessary. + + -- The line terminator sequence at the end of each line, including the + -- last line is a CR-LF sequence (16#0D# followed by 16#0A#). + + -- The Exception_Name and Message lines are omitted in the abort + -- signal case, since this is not really an exception, and the only + -- use of this routine is internal for printing termination output. + + -- WARNING: if the format of the generated string is changed, please note + -- that an equivalent modification to the routine String_To_EO must be + -- made to preserve proper functioning of the stream attributes. + + function Exception_Information (X : Exception_Occurrence) return String is + + -- This information is now built using the circuitry introduced in + -- association with the support of traceback decorators, as the + -- catenation of the exception basic information and the call chain + -- backtrace in its basic form. + + Basic_Info : constant String := Basic_Exception_Information (X); + Tback_Info : constant String := Basic_Exception_Traceback (X); + + Basic_Len : constant Natural := Basic_Info'Length; + Tback_Len : constant Natural := Tback_Info'Length; + + Info : String (1 .. Basic_Len + Tback_Len); + Ptr : Natural := 0; + + begin + Append_Info_String (Basic_Info, Info, Ptr); + Append_Info_String (Tback_Info, Info, Ptr); + + return Info; + end Exception_Information; + + + ------------------------- + -- Set_Exception_C_Msg -- + ------------------------- + + procedure Set_Exception_C_Msg + (Id : Exception_Id; + Msg1 : Big_String_Ptr; + Line : Integer := 0; + Msg2 : Big_String_Ptr := null) + is + Excep : constant EOA := Get_Current_Excep.all; + Val : Integer := Line; + Remind : Integer; + Size : Integer := 1; + Ptr : Natural; + + begin + Exception_Propagation.Setup_Exception (Excep, Excep); + Excep.Exception_Raised := False; + Excep.Id := Id; + Excep.Num_Tracebacks := 0; + Excep.Pid := Local_Partition_ID; + Excep.Msg_Length := 0; + Excep.Cleanup_Flag := False; + + while Msg1 (Excep.Msg_Length + 1) /= ASCII.NUL + and then Excep.Msg_Length < Exception_Msg_Max_Length + loop + Excep.Msg_Length := Excep.Msg_Length + 1; + Excep.Msg (Excep.Msg_Length) := Msg1 (Excep.Msg_Length); + end loop; + + -- Append line number if present + + if Line > 0 then + + -- Compute the number of needed characters + + while Val > 0 loop + Val := Val / 10; + Size := Size + 1; + end loop; + + -- If enough characters are available, put the line number + + if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then + Excep.Msg (Excep.Msg_Length + 1) := ':'; + Excep.Msg_Length := Excep.Msg_Length + Size; + Val := Line; + Size := 0; + + while Val > 0 loop + Remind := Val rem 10; + Val := Val / 10; + Excep.Msg (Excep.Msg_Length - Size) := + Character'Val (Remind + Character'Pos ('0')); + Size := Size + 1; + end loop; + end if; + end if; + + -- Append second message if present + + if Msg2 /= null + and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length + then + Excep.Msg_Length := Excep.Msg_Length + 1; + Excep.Msg (Excep.Msg_Length) := ' '; + + Ptr := 1; + while Msg2 (Ptr) /= ASCII.NUL + and then Excep.Msg_Length < Exception_Msg_Max_Length + loop + Excep.Msg_Length := Excep.Msg_Length + 1; + Excep.Msg (Excep.Msg_Length) := Msg2 (Ptr); + Ptr := Ptr + 1; + end loop; + end if; + end Set_Exception_C_Msg; + + ----------------------- + -- Set_Exception_Msg -- + ----------------------- + + procedure Set_Exception_Msg + (Id : Exception_Id; + Message : String) + is + Len : constant Natural := + Natural'Min (Message'Length, Exception_Msg_Max_Length); + First : constant Integer := Message'First; + Excep : constant EOA := Get_Current_Excep.all; + + begin + Exception_Propagation.Setup_Exception (Excep, Excep); + Excep.Exception_Raised := False; + Excep.Msg_Length := Len; + Excep.Msg (1 .. Len) := Message (First .. First + Len - 1); + Excep.Id := Id; + Excep.Num_Tracebacks := 0; + Excep.Pid := Local_Partition_ID; + Excep.Cleanup_Flag := False; + + end Set_Exception_Msg; + + ---------------------------------- + -- Tailored_Exception_Traceback -- + ---------------------------------- + + function Tailored_Exception_Traceback + (X : Exception_Occurrence) return String + is + -- We indeed reference the decorator *wrapper* from here and not the + -- decorator itself. The purpose of the local variable Wrapper is to + -- prevent a potential crash by race condition in the code below. The + -- atomicity of this assignment is enforced by pragma Atomic in + -- System.Soft_Links. + + -- The potential race condition here, if no local variable was used, + -- relates to the test upon the wrapper's value and the call, which + -- are not performed atomically. With the local variable, potential + -- changes of the wrapper's global value between the test and the + -- call become inoffensive. + + Wrapper : constant Traceback_Decorator_Wrapper_Call := + Traceback_Decorator_Wrapper; + + begin + if Wrapper = null then + return Basic_Exception_Traceback (X); + else + return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks); + end if; + end Tailored_Exception_Traceback; + + ------------------------------------ + -- Tailored_Exception_Information -- + ------------------------------------ + + function Tailored_Exception_Information + (X : Exception_Occurrence) return String + is + -- The tailored exception information is simply the basic information + -- associated with the tailored call chain backtrace. + + Basic_Info : constant String := Basic_Exception_Information (X); + Tback_Info : constant String := Tailored_Exception_Traceback (X); + + Basic_Len : constant Natural := Basic_Info'Length; + Tback_Len : constant Natural := Tback_Info'Length; + + Info : String (1 .. Basic_Len + Tback_Len); + Ptr : Natural := 0; + + begin + Append_Info_String (Basic_Info, Info, Ptr); + Append_Info_String (Tback_Info, Info, Ptr); + + return Info; + end Tailored_Exception_Information; + + procedure Tailored_Exception_Information + (X : Exception_Occurrence; + Buff : in out String; + Last : in out Integer) + is + begin + Append_Info_String (Basic_Exception_Information (X), Buff, Last); + Append_Info_String (Tailored_Exception_Traceback (X), Buff, Last); + end Tailored_Exception_Information; + + end Exception_Data; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-exexpr.adb gcc-3.4.0/gcc/ada/a-exexpr.adb *** gcc-3.3.3/gcc/ada/a-exexpr.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-exexpr.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 0 **** --- 1,525 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- ADA.EXCEPTIONS.EXCEPTION_PROPAGATION -- + -- -- + -- 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- -- + -- 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. -- + -- -- + ------------------------------------------------------------------------------ + + with Interfaces; + + with Ada.Unchecked_Conversion; + with Ada.Unchecked_Deallocation; + + pragma Warnings (Off); + -- Since several constructs give warnings in 3.14a1, including unreferenced + -- variables and pragma Unreferenced itself. + + separate (Ada.Exceptions) + package body Exception_Propagation is + + ------------------------------------------------ + -- Entities to interface with the GCC runtime -- + ------------------------------------------------ + + -- These come from "C++ ABI for Itanium: Exception handling", which is + -- the reference for GCC. They are used only when we are relying on + -- back-end tables for exception propagation, which in turn is currenly + -- only the case for Zero_Cost_Exceptions in GNAT5. + + -- Return codes from the GCC runtime functions used to propagate + -- an exception. + + type Unwind_Reason_Code is + (URC_NO_REASON, + URC_FOREIGN_EXCEPTION_CAUGHT, + URC_PHASE2_ERROR, + URC_PHASE1_ERROR, + URC_NORMAL_STOP, + URC_END_OF_STACK, + URC_HANDLER_FOUND, + URC_INSTALL_CONTEXT, + URC_CONTINUE_UNWIND); + + pragma Unreferenced + (URC_FOREIGN_EXCEPTION_CAUGHT, + URC_PHASE2_ERROR, + URC_PHASE1_ERROR, + URC_NORMAL_STOP, + URC_END_OF_STACK, + URC_HANDLER_FOUND, + URC_INSTALL_CONTEXT, + URC_CONTINUE_UNWIND); + + pragma Convention (C, Unwind_Reason_Code); + + -- Phase identifiers + + type Unwind_Action is + (UA_SEARCH_PHASE, + UA_CLEANUP_PHASE, + UA_HANDLER_FRAME, + UA_FORCE_UNWIND); + + for Unwind_Action use + (UA_SEARCH_PHASE => 1, + UA_CLEANUP_PHASE => 2, + UA_HANDLER_FRAME => 4, + UA_FORCE_UNWIND => 8); + + pragma Convention (C, Unwind_Action); + + -- Mandatory common header for any exception object handled by the + -- GCC unwinding runtime. + + subtype Exception_Class is Interfaces.Unsigned_64; + + GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#; + -- "GNU-Ada\0" + + type Unwind_Exception is record + Class : Exception_Class := GNAT_Exception_Class; + Cleanup : System.Address := System.Null_Address; + Private1 : Integer; + Private2 : Integer; + end record; + + pragma Convention (C, Unwind_Exception); + + for Unwind_Exception'Alignment use Standard'Maximum_Alignment; + -- The C++ ABI mandates the common exception header to be at least + -- doubleword aligned, and the libGCC implementation actually makes it + -- maximally aligned (see unwind.h). We need to match this because: + + -- 1/ We pass pointers to such headers down to the underlying + -- libGCC unwinder, + + -- and + + -- 2/ The GNAT_GCC_Exception record below starts with this common + -- common header and has a C counterpart which needs to be laid + -- out identically in raise.c. If the alignment of the C and Ada + -- common headers mismatch, their size may also differ, and the + -- layouts may not match anymore. + + --------------------------------------------------------------- + -- GNAT specific entities to deal with the GCC eh circuitry -- + --------------------------------------------------------------- + + -- A GNAT exception object to be dealt with by the personality routine + -- called by the GCC unwinding runtime. This structure shall match the + -- one in raise.c and is currently experimental as it might be merged + -- with the GNAT runtime definition some day. + + type GNAT_GCC_Exception is record + Header : Unwind_Exception; + -- ABI Exception header first. + + Id : Exception_Id; + -- GNAT Exception identifier. This is used by the personality + -- routine to determine if the context it examines contains a + -- handler for the exception beeing propagated. + + Handled_By_Others : Boolean; + -- Is this exception handled by "when others" ? This is used by the + -- personality routine to determine if an "others" handler in the + -- context it examines may catch the exception beeing propagated. + + N_Cleanups_To_Trigger : Integer; + -- Number of cleanup only frames encountered in SEARCH phase. + -- This is used to control the forced unwinding triggered when + -- no handler has been found. + + Next_Exception : EOA; + -- Used to create a linked list of exception occurrences. + end record; + + pragma Convention (C, GNAT_GCC_Exception); + + type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception; + + function To_GNAT_GCC_Exception is new + Unchecked_Conversion (System.Address, GNAT_GCC_Exception_Access); + + procedure Free is new Unchecked_Deallocation + (GNAT_GCC_Exception, GNAT_GCC_Exception_Access); + + procedure Free is new Unchecked_Deallocation + (Exception_Occurrence, EOA); + + function Remove + (Top : EOA; + Excep : GNAT_GCC_Exception_Access) + return Boolean; + -- Remove Excep from the stack starting at Top. + -- Return True if Excep was found and removed, false otherwise. + + -- Hooks called when entering/leaving an exception handler for a given + -- occurrence, aimed at handling the stack of active occurrences. The + -- calls are generated by gigi in tree_transform/N_Exception_Handler. + + procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access); + pragma Export (C, Begin_Handler, "__gnat_begin_handler"); + + procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access); + pragma Export (C, End_Handler, "__gnat_end_handler"); + + function CleanupUnwind_Handler + (UW_Version : Integer; + UW_Phases : Unwind_Action; + UW_Eclass : Exception_Class; + UW_Exception : access GNAT_GCC_Exception; + UW_Context : System.Address; + UW_Argument : System.Address) + return Unwind_Reason_Code; + -- Hook called at each step of the forced unwinding we perform to + -- trigger cleanups found during the propagation of an unhandled + -- exception. + + -- GCC runtime functions used. These are C non-void functions, actually, + -- but we ignore the return values. See raise.c as to why we are using + -- __gnat stubs for these. + + procedure Unwind_RaiseException + (UW_Exception : access GNAT_GCC_Exception); + pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException"); + + procedure Unwind_ForcedUnwind + (UW_Exception : access GNAT_GCC_Exception; + UW_Handler : System.Address; + UW_Argument : System.Address); + pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind"); + + ------------ + -- Remove -- + ------------ + + function Remove + (Top : EOA; + Excep : GNAT_GCC_Exception_Access) + return Boolean + is + Prev : GNAT_GCC_Exception_Access := null; + Iter : EOA := Top; + GCC_Exception : GNAT_GCC_Exception_Access; + + begin + -- Pop stack + + loop + pragma Assert (Iter.Private_Data /= System.Null_Address); + + GCC_Exception := To_GNAT_GCC_Exception (Iter.Private_Data); + + if GCC_Exception = Excep then + if Prev = null then + + -- Special case for the top of the stack: shift the contents + -- of the next item to the top, since top is at a fixed + -- location and can't be changed. + + Iter := GCC_Exception.Next_Exception; + + if Iter = null then + + -- Stack is now empty + + Top.Private_Data := System.Null_Address; + + else + Save_Occurrence_And_Private (Top.all, Iter.all); + Free (Iter); + end if; + + else + Prev.Next_Exception := GCC_Exception.Next_Exception; + Free (Iter); + end if; + + Free (GCC_Exception); + + return True; + end if; + + exit when GCC_Exception.Next_Exception = null; + + Prev := GCC_Exception; + Iter := GCC_Exception.Next_Exception; + end loop; + + return False; + end Remove; + + --------------------------- + -- CleanupUnwind_Handler -- + --------------------------- + + function CleanupUnwind_Handler + (UW_Version : Integer; + UW_Phases : Unwind_Action; + UW_Eclass : Exception_Class; + UW_Exception : access GNAT_GCC_Exception; + UW_Context : System.Address; + UW_Argument : System.Address) + return Unwind_Reason_Code + is + begin + -- Terminate as soon as we know there is nothing more to run. The + -- count is maintained by the personality routine. + + if UW_Exception.N_Cleanups_To_Trigger = 0 then + Unhandled_Exception_Terminate; + end if; + + -- We know there is at least one cleanup further up. Return so that it + -- is searched and entered, after which Unwind_Resume will be called + -- and this hook will gain control (with an updated count) again. + + return URC_NO_REASON; + end CleanupUnwind_Handler; + + --------------------- + -- Setup_Exception -- + --------------------- + + -- Push the current exception occurrence on the stack before overriding it. + + procedure Setup_Exception + (Excep : EOA; + Current : EOA; + Reraised : Boolean := False) + is + Top : constant EOA := Current; + Next : EOA; + GCC_Exception : GNAT_GCC_Exception_Access; + + -- Note that we make no use of the Reraised indication at this point. + + -- The information is still passed around just in case of future needs, + -- since we've already switched between using/not-using it a number of + -- times. + + begin + -- If the current exception is not live, the stack is empty and there + -- is nothing to do. Note that the stack always appears empty for + -- mechanisms that do not require one. For the mechanism we implement + -- in this unit, the initial Private_Data allocation for an occurrence + -- is issued by Propagate_Exception. + + if Top.Private_Data = System.Null_Address then + return; + end if; + + -- Shift the contents of the Top of the stack in a freshly allocated + -- entry, which leaves the room in the fixed Top entry available for the + -- occurrence about to be propagated. + + Next := new Exception_Occurrence; + Save_Occurrence_And_Private (Next.all, Top.all); + + -- Allocate Private_Data for the occurrence about to be propagated + -- and link everything together. + + GCC_Exception := new GNAT_GCC_Exception; + GCC_Exception.Next_Exception := Next; + + Top.Private_Data := GCC_Exception.all'Address; + + end Setup_Exception; + + ------------------- + -- Begin_Handler -- + ------------------- + + procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is + begin + -- Every necessary operation related to the occurrence stack has + -- already been performed by Propagate_Exception. This hook remains for + -- potential future necessity in optimizing the overall scheme, as well + -- a useful debugging tool. + null; + end Begin_Handler; + + ----------------- + -- End_Handler -- + ----------------- + + procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is + Removed : Boolean; + + begin + Removed := Remove (Get_Current_Excep.all, GCC_Exception); + pragma Assert (Removed); + end End_Handler; + + ------------------------- + -- Propagate_Exception -- + ------------------------- + + -- Build an object suitable for the libgcc processing and call + -- Unwind_RaiseException to actually throw, taking care of handling + -- the two phase scheme it implements. + + procedure Propagate_Exception (From_Signal_Handler : Boolean) is + Excep : EOA := Get_Current_Excep.all; + GCC_Exception : GNAT_GCC_Exception_Access; + + begin + if Excep.Private_Data = System.Null_Address then + GCC_Exception := new GNAT_GCC_Exception; + Excep.Private_Data := GCC_Exception.all'Address; + else + GCC_Exception := To_GNAT_GCC_Exception (Excep.Private_Data); + end if; + + -- Fill in the useful flags for the personality routine called for each + -- frame via Unwind_RaiseException below. + + GCC_Exception.Id := Excep.Id; + GCC_Exception.Handled_By_Others := not Excep.Id.Not_Handled_By_Others; + GCC_Exception.N_Cleanups_To_Trigger := 0; + + -- Compute the backtrace for this occurrence if the corresponding + -- binder option has been set. Call_Chain takes care of the reraise + -- case. + + -- ??? Using Call_Chain here means we are going to walk up the stack + -- once only for backtracing purposes before doing it again for the + -- propagation per se. + + -- The first inspection is much lighter, though, as it only requires + -- partial unwinding of each frame. Additionally, although we could use + -- the personality routine to record the addresses while propagating, + -- this method has two drawbacks: + + -- 1) the trace is incomplete if the exception is handled since we + -- don't walk past the frame with the handler, + + -- and + + -- 2) we would miss the frames for which our personality routine is not + -- called, e.g. if C or C++ calls are on the way. + + Call_Chain (Excep); + + -- Perform a standard raise first. If a regular handler is found, it + -- will be entered after all the intermediate cleanups have run. If + -- there is no regular handler, control will get back to after the + -- call, with N_Cleanups_To_Trigger set to the number of frames with + -- cleanups found on the way up, and none of these already run. + + Unwind_RaiseException (GCC_Exception); + + -- If we get here we know the exception is not handled, as otherwise + -- Unwind_RaiseException arranges for the handler to be entered. Take + -- the necessary steps to enable the debugger to gain control while the + -- stack is still intact. + + Notify_Unhandled_Exception; + + -- Now, if cleanups have been found, run a forced unwind to trigger + -- them. Control should not resume there, as the unwinding hook calls + -- Unhandled_Exception_Terminate as soon as the last cleanup has been + -- triggered. + + if GCC_Exception.N_Cleanups_To_Trigger /= 0 then + Unwind_ForcedUnwind (GCC_Exception, + CleanupUnwind_Handler'Address, + System.Null_Address); + end if; + + -- We get here when there is no handler or cleanup to be run at + -- all. The debugger has been notified before the second step above. + + Unhandled_Exception_Terminate; + end Propagate_Exception; + + ----------- + -- Notes -- + ----------- + + -- The current model implemented for the stack of occurrences is a + -- simplification of previous attempts, which all prooved to be flawed or + -- would have needed significant additional circuitry to be made to work + -- correctly. + + -- We now represent every propagation by a new entry on the stack, which + -- means that an exception occurrence may appear more than once (e.g. when + -- it is reraised during the course of its own handler). + + -- This may seem overcostly compared to the C++ model as implemented in + -- the g++ v3 libstd. This is actually understandable when one considers + -- the extra variations of possible run-time configurations induced by the + -- freedom offered by the Save_Occurrence/Reraise_Occurrence public + -- interface. + + -- The basic point is that arranging for an occurrence to always appear at + -- most once on the stack requires a way to determine if a given occurence + -- is already there, which is not as easy as it might seem. + + -- An attempt was made to use the Private_Data pointer for this purpose. + -- It did not work because: + + -- 1/ The Private_Data has to be saved by Save_Occurrence to be usable + -- as a key in case of a later reraise, + + -- 2/ There is no easy way to synchronize End_Handler for an occurrence + -- and the data attached to potential copies, so these copies may end + -- up pointing to stale data. Moreover ... + + -- 3/ The same address may be reused for different occurrences, which + -- defeats the idea of using it as a key. + + -- The example below illustrates: + + -- Saved_CE : Exception_Occurrence; + -- + -- begin + -- raise Constraint_Error; + -- exception + -- when CE: others => + -- Save_Occurrence (Saved_CE, CE); <= Saved_CE.PDA = CE.PDA + -- end; + -- + -- <= Saved_CE.PDA is stale (!) + -- + -- begin + -- raise Program_Error; <= Saved_CE.PDA = PE.PDA (!!) + -- exception + -- when others => + -- Reraise_Occurrence (Saved_CE); + -- end; + + -- Not releasing the Private_Data via End_Handler could be an option, + -- but making this to work while still avoiding memory leaks is far + -- from trivial. + + -- The current scheme has the advantage of beeing simple, and induces + -- extra costs only in reraise cases which is acceptable. + + end Exception_Propagation; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-exextr.adb gcc-3.4.0/gcc/ada/a-exextr.adb *** gcc-3.3.3/gcc/ada/a-exextr.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-exextr.adb 2003-12-17 13:37:03.000000000 +0000 *************** *** 0 **** --- 1,254 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- ADA.EXCEPTIONS.EXCEPTION_TRACES -- + -- -- + -- 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- -- + -- 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. -- + -- -- + ------------------------------------------------------------------------------ + + with Unchecked_Conversion; + + pragma Warnings (Off); + with Ada.Exceptions.Last_Chance_Handler; + pragma Warnings (On); + -- Bring last chance handler into closure + + separate (Ada.Exceptions) + package body Exception_Traces is + + Nline : constant String := String'(1 => ASCII.LF); + -- Convenient shortcut + + type Exception_Action is access procedure (E : Exception_Occurrence); + Global_Action : Exception_Action := null; + pragma Export + (Ada, Global_Action, "__gnat_exception_actions_global_action"); + -- Global action, executed whenever an exception is raised. Changing the + -- export name must be coordinated with code in g-excact.adb. + + Raise_Hook_Initialized : Boolean := False; + pragma Export + (Ada, Raise_Hook_Initialized, "__gnat_exception_actions_initialized"); + + procedure Last_Chance_Handler + (Except : Exception_Occurrence); + pragma Import + (C, Last_Chance_Handler, "__gnat_last_chance_handler"); + pragma No_Return (Last_Chance_Handler); + -- Users can replace the default version of this routine, + -- Ada.Exceptions.Last_Chance_Handler. + + function To_Action is new Unchecked_Conversion + (Raise_Action, Exception_Action); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Notify_Exception (Excep : EOA; Is_Unhandled : Boolean); + -- Factorizes the common processing for Notify_Handled_Exception and + -- Notify_Unhandled_Exception. Is_Unhandled is set to True only in the + -- latter case because Notify_Handled_Exception may be called for an + -- actually unhandled occurrence in the Front-End-SJLJ case. + + procedure To_Stderr (S : String); + pragma Export (Ada, To_Stderr, "__gnat_to_stderr"); + -- Little routine to output string to stderr that is also used + -- in the tasking run time. + + --------------------------------- + -- Debugger Interface Routines -- + --------------------------------- + + -- The routines here are null routines that normally have no effect. + -- They are provided for the debugger to place breakpoints on their + -- entry points to get control on an exception. + + procedure Unhandled_Exception; + pragma Export (C, Unhandled_Exception, "__gnat_unhandled_exception"); + -- Hook for GDB to support "break exception unhandled". + + -- For "break exception", GDB uses __gnat_raise_nodefer_with_msg, which + -- is not in this section because it fullfills other purposes than a mere + -- debugger interface. + + -------------------------------- + -- Import Run-Time C Routines -- + -------------------------------- + + -- The purpose of the following pragma Import is to ensure that we + -- generate appropriate subprogram descriptors for all C routines in + -- the standard GNAT library that can raise exceptions. This ensures + -- that the exception propagation can properly find these routines + + pragma Propagate_Exceptions; + + ---------------------- + -- Notify_Exception -- + ---------------------- + + procedure Notify_Exception (Excep : EOA; Is_Unhandled : Boolean) is + begin + -- Output the exception information required by the Exception_Trace + -- configuration. Take care not to output information about internal + -- exceptions. + + -- ??? In the Front-End ZCX case, the traceback entries we have at this + -- point only include the ones we stored while walking up the stack *up + -- to the handler*. All the frames above the subprogram in which the + -- handler is found are missing. + + if not Excep.Id.Not_Handled_By_Others + and then + (Exception_Trace = Every_Raise + or else (Exception_Trace = Unhandled_Raise and then Is_Unhandled)) + then + To_Stderr (Nline); + + if Is_Unhandled then + To_Stderr ("Unhandled "); + end if; + + To_Stderr ("Exception raised"); + To_Stderr (Nline); + To_Stderr (Tailored_Exception_Information (Excep.all)); + end if; + + -- Call the user-specific actions + -- ??? We should presumably look at the reraise status here. + + if Raise_Hook_Initialized + and then Exception_Data_Ptr (Excep.Id).Raise_Hook /= null + then + To_Action (Exception_Data_Ptr (Excep.Id).Raise_Hook) (Excep.all); + end if; + + if Global_Action /= null then + Global_Action (Excep.all); + end if; + end Notify_Exception; + + ------------------------------ + -- Notify_Handled_Exception -- + ------------------------------ + + procedure Notify_Handled_Exception is + begin + Notify_Exception (Get_Current_Excep.all, Is_Unhandled => False); + end Notify_Handled_Exception; + + -------------------------------- + -- Notify_Unhandled_Exception -- + -------------------------------- + + procedure Notify_Unhandled_Exception is + begin + Notify_Exception (Get_Current_Excep.all, Is_Unhandled => True); + Unhandled_Exception; + end Notify_Unhandled_Exception; + + ------------------------- + -- Unhandled_Exception -- + ------------------------- + + procedure Unhandled_Exception is + begin + null; + end Unhandled_Exception; + + ----------------------------------- + -- Unhandled_Exception_Terminate -- + ----------------------------------- + + type int is new Integer; + + procedure Unhandled_Exception_Terminate is + Excep : constant EOA := Save_Occurrence (Get_Current_Excep.all.all); + -- This occurrence will be used to display a message after finalization. + -- It is necessary to save a copy here, or else the designated value + -- could be overwritten if an exception is raised during finalization + -- (even if that exception is caught). + + begin + Last_Chance_Handler (Excep.all); + end Unhandled_Exception_Terminate; + + --------------- + -- To_Stderr -- + --------------- + + procedure To_Stderr (S : String) is + procedure put_char_stderr (C : int); + pragma Import (C, put_char_stderr, "put_char_stderr"); + + begin + for J in 1 .. S'Length loop + if S (J) /= ASCII.CR then + put_char_stderr (Character'Pos (S (J))); + end if; + end loop; + end To_Stderr; + + + ------------------------------------ + -- Handling GNAT.Exception_Traces -- + ------------------------------------ + + -- The bulk of exception traces output is centralized in Notify_Exception, + -- for both the Handled and Unhandled cases. Extra task specific output is + -- triggered in the task wrapper for unhandled occurrences in tasks. It is + -- not performed in this unit to avoid dragging dependencies against the + -- tasking units here. + + -- We used to rely on the output performed by Unhanded_Exception_Terminate + -- for the case of an unhandled occurrence in the environment thread, and + -- the task wrapper was responsible for the whole output in the tasking + -- case. + + -- This initial scheme had a drawback: the output from Terminate only + -- occurs after finalization is done, which means possibly never if some + -- tasks keep hanging around. + + -- The first "presumably obvious" fix consists in moving the Terminate + -- output before the finalization. It has not been retained because it + -- introduces annoying changes in output orders when the finalization + -- itself issues outputs, this also in "regular" cases not resorting to + -- Exception_Traces. + + -- Today's solution has the advantage of simplicity and better isolates + -- the Exception_Traces machinery. + + -- It currently outputs the information about unhandled exceptions twice + -- in the environment thread, once in the notification routine and once in + -- the termination routine. Avoiding the second output is possible but so + -- far has been considered undesirable. It would mean changing the order + -- of outputs between the two runs with or without exception traces, while + -- it seems preferrable to only have additional outputs in the former + -- case. + + end Exception_Traces; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-exstat.adb gcc-3.4.0/gcc/ada/a-exstat.adb *** gcc-3.3.3/gcc/ada/a-exstat.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-exstat.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 0 **** --- 1,255 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- ADA.EXCEPTIONS.STREAM_ATTRIBUTES -- + -- -- + -- 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- -- + -- 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. -- + -- -- + ------------------------------------------------------------------------------ + + with System.Exception_Table; use System.Exception_Table; + with System.Storage_Elements; use System.Storage_Elements; + + separate (Ada.Exceptions) + package body Stream_Attributes is + + ------------------- + -- EId_To_String -- + ------------------- + + function EId_To_String (X : Exception_Id) return String is + begin + if X = Null_Id then + return ""; + else + return Exception_Name (X); + end if; + end EId_To_String; + + ------------------ + -- EO_To_String -- + ------------------ + + -- We use the null string to represent the null occurrence, otherwise + -- we output the Exception_Information string for the occurrence. + + function EO_To_String (X : Exception_Occurrence) return String is + begin + if X.Id = Null_Id then + return ""; + else + return Exception_Information (X); + end if; + end EO_To_String; + + ------------------- + -- String_To_EId -- + ------------------- + + function String_To_EId (S : String) return Exception_Id is + begin + if S = "" then + return Null_Id; + else + return Exception_Id (Internal_Exception (S)); + end if; + end String_To_EId; + + ------------------ + -- String_To_EO -- + ------------------ + + function String_To_EO (S : String) return Exception_Occurrence is + From : Natural; + To : Integer; + + X : aliased Exception_Occurrence; + -- This is the exception occurrence we will create + + procedure Bad_EO; + pragma No_Return (Bad_EO); + -- Signal bad exception occurrence string + + procedure Next_String; + -- On entry, To points to last character of previous line of the + -- message, terminated by LF. On return, From .. To are set to + -- specify the next string, or From > To if there are no more lines. + + procedure Bad_EO is + begin + Raise_Exception + (Program_Error'Identity, + "bad exception occurrence in stream input"); + + -- The following junk raise of Program_Error is required because + -- this is a No_Return function, and unfortunately Raise_Exception + -- can return (this particular call can't, but the back end is not + -- clever enough to know that). + + raise Program_Error; + end Bad_EO; + + procedure Next_String is + begin + From := To + 2; + + if From < S'Last then + To := From + 1; + + while To < S'Last - 1 loop + if To >= S'Last then + Bad_EO; + elsif S (To + 1) = ASCII.LF then + exit; + else + To := To + 1; + end if; + end loop; + end if; + end Next_String; + + -- Start of processing for String_To_EO + + begin + if S = "" then + return Null_Occurrence; + + else + X.Cleanup_Flag := False; + + To := S'First - 2; + Next_String; + + if S (From .. From + 15) /= "Exception name: " then + Bad_EO; + end if; + + X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To))); + + Next_String; + + if From <= To and then S (From) = 'M' then + if S (From .. From + 8) /= "Message: " then + Bad_EO; + end if; + + X.Msg_Length := To - From - 8; + X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To); + Next_String; + + else + X.Msg_Length := 0; + end if; + + X.Pid := 0; + + if From <= To and then S (From) = 'P' then + if S (From .. From + 3) /= "PID:" then + Bad_EO; + end if; + + From := From + 5; -- skip past PID: space + + while From <= To loop + X.Pid := X.Pid * 10 + + (Character'Pos (S (From)) - Character'Pos ('0')); + From := From + 1; + end loop; + + Next_String; + end if; + + X.Num_Tracebacks := 0; + + if From <= To then + if S (From .. To) /= "Call stack traceback locations:" then + Bad_EO; + end if; + + Next_String; + loop + exit when From > To; + + declare + Ch : Character; + C : Integer_Address; + N : Integer_Address; + + begin + if S (From) /= '0' + or else S (From + 1) /= 'x' + then + Bad_EO; + else + From := From + 2; + end if; + + C := 0; + while From <= To loop + Ch := S (From); + + if Ch in '0' .. '9' then + N := + Character'Pos (S (From)) - Character'Pos ('0'); + + elsif Ch in 'a' .. 'f' then + N := + Character'Pos (S (From)) - Character'Pos ('a') + 10; + + elsif Ch = ' ' then + From := From + 1; + exit; + + else + Bad_EO; + end if; + + C := C * 16 + N; + + From := From + 1; + end loop; + + if X.Num_Tracebacks = Max_Tracebacks then + Bad_EO; + end if; + + X.Num_Tracebacks := X.Num_Tracebacks + 1; + X.Tracebacks (X.Num_Tracebacks) := + TBE.TB_Entry_For (To_Address (C)); + end; + end loop; + end if; + + -- If an exception was converted to a string, it must have + -- already been raised, so flag it accordingly and we are done. + + X.Exception_Raised := True; + return X; + end if; + end String_To_EO; + + end Stream_Attributes; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-filico.adb gcc-3.4.0/gcc/ada/a-filico.adb *** gcc-3.3.3/gcc/ada/a-filico.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-filico.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 1,4 **** ! ----------------------------------------------------------------------------- -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- 1,4 ---- ! ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- *************** *** 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-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- -- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-filico.ads gcc-3.4.0/gcc/ada/a-filico.ads *** gcc-3.3.3/gcc/ada/a-filico.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-filico.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-finali.adb gcc-3.4.0/gcc/ada/a-finali.adb *** gcc-3.3.3/gcc/ada/a-finali.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-finali.adb 2003-04-24 17:53:53.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/a-finali.ads gcc-3.4.0/gcc/ada/a-finali.ads *** gcc-3.3.3/gcc/ada/a-finali.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-finali.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-flteio.ads gcc-3.4.0/gcc/ada/a-flteio.ads *** gcc-3.3.3/gcc/ada/a-flteio.ads 2002-03-14 10:58:48.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-flteio.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-fwteio.ads gcc-3.4.0/gcc/ada/a-fwteio.ads *** gcc-3.3.3/gcc/ada/a-fwteio.ads 2002-03-14 10:58:48.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-fwteio.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-inteio.ads gcc-3.4.0/gcc/ada/a-inteio.ads *** gcc-3.3.3/gcc/ada/a-inteio.ads 2002-03-14 10:58:48.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-inteio.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-interr.adb gcc-3.4.0/gcc/ada/a-interr.adb *** gcc-3.3.3/gcc/ada/a-interr.adb 2002-03-14 10:58:48.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-interr.adb 2003-10-21 13:41:53.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. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/a-interr.ads gcc-3.4.0/gcc/ada/a-interr.ads *** gcc-3.3.3/gcc/ada/a-interr.ads 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-interr.ads 2003-04-24 17:53:53.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/a-intnam.ads gcc-3.4.0/gcc/ada/a-intnam.ads *** gcc-3.3.3/gcc/ada/a-intnam.ads 2002-03-14 10:58:49.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-intnam.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-intsig.adb gcc-3.4.0/gcc/ada/a-intsig.adb *** gcc-3.3.3/gcc/ada/a-intsig.adb 2002-10-23 07:33:20.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-intsig.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 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) 2000-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,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. -- -- -- ------------------------------------------------------------------------------ ! -- with System.Interrupt_Management.Operations; package body Ada.Interrupts.Signal is --- 27,36 ---- -- 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. -- -- -- ------------------------------------------------------------------------------ ! with System.Interrupt_Management.Operations; package body Ada.Interrupts.Signal is diff -Nrc3pad gcc-3.3.3/gcc/ada/a-intsig.ads gcc-3.4.0/gcc/ada/a-intsig.ads *** gcc-3.3.3/gcc/ada/a-intsig.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-intsig.ads 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 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) 2000-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,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. -- -- -- ------------------------------------------------------------------------------ ! -- -- This package encapsulates the procedures for generating interrupts -- by user programs and avoids importing low level children of System -- (e.g. System.Interrupt_Management.Operations), or defining an interface --- 27,36 ---- -- 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 package encapsulates the procedures for generating interrupts -- by user programs and avoids importing low level children of System -- (e.g. System.Interrupt_Management.Operations), or defining an interface diff -Nrc3pad gcc-3.3.3/gcc/ada/a-ioexce.ads gcc-3.4.0/gcc/ada/a-ioexce.ads *** gcc-3.3.3/gcc/ada/a-ioexce.ads 2002-03-14 10:58:49.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-ioexce.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-iwteio.ads gcc-3.4.0/gcc/ada/a-iwteio.ads *** gcc-3.3.3/gcc/ada/a-iwteio.ads 2002-03-14 10:58:49.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-iwteio.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-lfteio.ads gcc-3.4.0/gcc/ada/a-lfteio.ads *** gcc-3.3.3/gcc/ada/a-lfteio.ads 2002-03-14 10:58:49.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-lfteio.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-lfwtio.ads gcc-3.4.0/gcc/ada/a-lfwtio.ads *** gcc-3.3.3/gcc/ada/a-lfwtio.ads 2002-03-14 10:58:49.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-lfwtio.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/ali.adb gcc-3.4.0/gcc/ada/ali.adb *** gcc-3.3.3/gcc/ada/ali.adb 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/ali.adb 2004-01-05 15:20:43.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-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- -- *************** *** 25,36 **** -- -- ------------------------------------------------------------------------------ ! with Butil; use Butil; ! with Debug; use Debug; ! with Fname; use Fname; ! with Namet; use Namet; ! with Osint; use Osint; ! with Output; use Output; package body ALI is --- 24,36 ---- -- -- ------------------------------------------------------------------------------ ! with Butil; use Butil; ! with Debug; use Debug; ! with Fname; use Fname; ! with Namet; use Namet; ! with Opt; use Opt; ! with Osint; use Osint; ! with Output; use Output; package body ALI is *************** package body ALI is *** 46,57 **** -- When (re)initializing ALI data structures the ALI user expects to -- get a fresh set of data structures. Thus we first need to erase the -- marks put in the name table by the previous set of ALI routine calls. ! -- This loop is empty and harmless the first time in. for J in ALIs.First .. ALIs.Last loop Set_Name_Table_Info (ALIs.Table (J).Afile, 0); end loop; ALIs.Init; Units.Init; Withs.Init; --- 46,69 ---- -- When (re)initializing ALI data structures the ALI user expects to -- get a fresh set of data structures. Thus we first need to erase the -- marks put in the name table by the previous set of ALI routine calls. ! -- These two loops are empty and harmless the first time in. for J in ALIs.First .. ALIs.Last loop Set_Name_Table_Info (ALIs.Table (J).Afile, 0); end loop; + for J in Units.First .. Units.Last loop + Set_Name_Table_Info (Units.Table (J).Uname, 0); + end loop; + + -- Free argument table strings + + for J in Args.First .. Args.Last loop + Free (Args.Table (J)); + end loop; + + -- Initialize all tables + ALIs.Init; Units.Init; Withs.Init; *************** package body ALI is *** 75,87 **** No_Normalize_Scalars_Specified := False; No_Object_Specified := False; Normalize_Scalars_Specified := False; - No_Run_Time_Specified := False; Queuing_Policy_Specified := ' '; Static_Elaboration_Model_Used := False; Task_Dispatching_Policy_Specified := ' '; Unreserve_All_Interrupts_Specified := False; Zero_Cost_Exceptions_Specified := False; - end Initialize_ALI; -------------- --- 87,97 ---- *************** package body ALI is *** 89,100 **** -------------- function Scan_ALI ! (F : File_Name_Type; ! T : Text_Buffer_Ptr; ! Ignore_ED : Boolean; ! Err : Boolean; ! Read_Xref : Boolean := False) ! return ALI_Id is P : Text_Ptr := T'First; Line : Logical_Line_Number := 1; --- 99,112 ---- -------------- function Scan_ALI ! (F : File_Name_Type; ! T : Text_Buffer_Ptr; ! Ignore_ED : Boolean; ! Err : Boolean; ! Read_Xref : Boolean := False; ! Read_Lines : String := ""; ! Ignore_Lines : String := "X") ! return ALI_Id is P : Text_Ptr := T'First; Line : Logical_Line_Number := 1; *************** package body ALI is *** 103,108 **** --- 115,128 ---- NS_Found : Boolean; First_Arg : Arg_Id; + Ignore : array (Character range 'A' .. 'Z') of Boolean; + -- Ignore (X) is set to True if lines starting with X are to + -- be ignored by Scan_ALI and skipped, and False if the lines + -- are to be read and processed. + + Bad_ALI_Format : exception; + -- Exception raised by Fatal_Error if Err is True + function At_Eol return Boolean; -- Test if at end of line *************** package body ALI is *** 115,122 **** procedure Checkc (C : Character); -- Check next character is C. If so bump past it, if not fatal error - Bad_ALI_Format : exception; - procedure Fatal_Error; -- Generate fatal error message for badly formatted ALI file if -- Err is false, or raise Bad_ALI_Format if Err is True. --- 135,140 ---- *************** package body ALI is *** 124,142 **** function Getc return Character; -- Get next character, bumping P past the character obtained ! function Get_Name (Lower : Boolean := False) return Name_Id; -- Skip blanks, then scan out a name (name is left in Name_Buffer with -- length in Name_Len, as well as being returned in Name_Id form). -- If Lower is set to True then the Name_Buffer will be converted to -- all lower case, for systems where file names are not case sensitive. -- This ensures that gnatbind works correctly regardless of the case -- of the file name on all systems. The name is terminated by a either ! -- white space or a typeref bracket or an equal sign except for the ! -- special case of an operator name starting with a double quite which ! -- is terminated by another double quote. function Get_Nat return Nat; ! -- Skip blanks, then scan out an unsigned integer value in Nat range function Get_Stamp return Time_Stamp_Type; -- Skip blanks, then scan out a time stamp --- 142,163 ---- function Getc return Character; -- Get next character, bumping P past the character obtained ! function Get_Name ! (Lower : Boolean := False; ! Ignore_Spaces : Boolean := False) return Name_Id; -- Skip blanks, then scan out a name (name is left in Name_Buffer with -- length in Name_Len, as well as being returned in Name_Id form). -- If Lower is set to True then the Name_Buffer will be converted to -- all lower case, for systems where file names are not case sensitive. -- This ensures that gnatbind works correctly regardless of the case -- of the file name on all systems. The name is terminated by a either ! -- white space (when Ignore_Spaces is False) or a typeref bracket or ! -- an equal sign except for the special case of an operator name ! -- starting with a double quite which is terminated by another double ! -- quote. function Get_Nat return Nat; ! -- Skip blanks, then scan out an unsigned integer value in Nat range. function Get_Stamp return Time_Stamp_Type; -- Skip blanks, then scan out a time stamp *************** package body ALI is *** 145,155 **** -- Return current character without modifying pointer P procedure Skip_Eol; ! -- Skip past end of line (fatal error if not at end of line) procedure Skip_Space; -- Skip past white space (blanks or horizontal tab) --------------------- -- At_End_Of_Field -- --------------------- --- 166,184 ---- -- Return current character without modifying pointer P procedure Skip_Eol; ! -- Skip past spaces, then skip past end of line (fatal error if not ! -- at end of line). Also skips past any following blank lines. ! ! procedure Skip_Line; ! -- Skip rest of current line and any following blank lines. procedure Skip_Space; -- Skip past white space (blanks or horizontal tab) + procedure Skipc; + -- Skip past next character, does not affect value in C. This call + -- is like calling Getc and ignoring the returned result. + --------------------- -- At_End_Of_Field -- --------------------- *************** package body ALI is *** 292,298 **** -- Get_Name -- -------------- ! function Get_Name (Lower : Boolean := False) return Name_Id is begin Name_Len := 0; Skip_Space; --- 321,328 ---- -- Get_Name -- -------------- ! function Get_Name (Lower : Boolean := False; ! Ignore_Spaces : Boolean := False) return Name_Id is begin Name_Len := 0; Skip_Space; *************** package body ALI is *** 305,317 **** Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Getc; ! exit when At_End_Of_Field; if Name_Buffer (1) = '"' then exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"'; else ! exit when At_End_Of_Field or else Nextc = '(' or else Nextc = ')' or else Nextc = '{' or else Nextc = '}' or else Nextc = '<' or else Nextc = '>' --- 335,347 ---- Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Getc; ! exit when At_End_Of_Field and not Ignore_Spaces; if Name_Buffer (1) = '"' then exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"'; else ! exit when (At_End_Of_Field and not Ignore_Spaces) or else Nextc = '(' or else Nextc = ')' or else Nextc = '{' or else Nextc = '}' or else Nextc = '<' or else Nextc = '>' *************** package body ALI is *** 416,421 **** --- 446,452 ---- procedure Skip_Eol is begin Skip_Space; + if not At_Eol then Fatal_Error; end if; -- Loop to skip past blank lines (first time through skips this EOL) *************** package body ALI is *** 429,434 **** --- 460,478 ---- end loop; end Skip_Eol; + --------------- + -- Skip_Line -- + --------------- + + procedure Skip_Line is + begin + while not At_Eol loop + P := P + 1; + end loop; + + Skip_Eol; + end Skip_Line; + ---------------- -- Skip_Space -- ---------------- *************** package body ALI is *** 440,450 **** end loop; end Skip_Space; ! -------------------------------------- ! -- Start of processing for Scan_ALI -- ! -------------------------------------- begin ALIs.Increment_Last; Id := ALIs.Last; Set_Name_Table_Info (F, Int (Id)); --- 484,530 ---- end loop; end Skip_Space; ! ----------- ! -- Skipc -- ! ----------- ! ! procedure Skipc is ! begin ! if P /= T'Last then ! P := P + 1; ! end if; ! end Skipc; ! ! -- Start of processing for Scan_ALI begin + -- Acquire lines to be ignored + + if Read_Xref then + Ignore := ('U' | 'W' | 'D' | 'X' => False, others => True); + + -- Read_Lines parameter given + + elsif Read_Lines /= "" then + Ignore := ('U' => False, others => True); + + for J in Read_Lines'Range loop + Ignore (Read_Lines (J)) := False; + end loop; + + -- Process Ignore_Lines parameter + + else + Ignore := (others => False); + + for J in Ignore_Lines'Range loop + pragma Assert (Ignore_Lines (J) /= 'U'); + Ignore (Ignore_Lines (J)) := True; + end loop; + end if; + + -- Setup ALI Table entry with appropriate defaults + ALIs.Increment_Last; Id := ALIs.Last; Set_Name_Table_Info (F, Int (Id)); *************** package body ALI is *** 452,467 **** ALIs.Table (Id) := ( Afile => F, Compile_Errors => False, First_Sdep => No_Sdep_Id, First_Unit => No_Unit_Id, Float_Format => 'I', Last_Sdep => No_Sdep_Id, Last_Unit => No_Unit_Id, Locking_Policy => ' ', Main_Priority => -1, Main_Program => None, No_Object => False, - No_Run_Time => False, Normalize_Scalars => False, Ofile_Full_Name => Full_Object_File_Name, Queuing_Policy => ' ', --- 532,548 ---- ALIs.Table (Id) := ( Afile => F, Compile_Errors => False, + First_Interrupt_State => Interrupt_States.Last + 1, First_Sdep => No_Sdep_Id, First_Unit => No_Unit_Id, Float_Format => 'I', + Last_Interrupt_State => Interrupt_States.Last, Last_Sdep => No_Sdep_Id, Last_Unit => No_Unit_Id, Locking_Policy => ' ', Main_Priority => -1, Main_Program => None, No_Object => False, Normalize_Scalars => False, Ofile_Full_Name => Full_Object_File_Name, Queuing_Policy => ' ', *************** package body ALI is *** 473,540 **** Unit_Exception_Table => False, Ver => (others => ' '), Ver_Len => 0, Zero_Cost_Exceptions => False); -- Acquire library version ! Checkc ('V'); ! Checkc (' '); ! Skip_Space; ! Checkc ('"'); ! for J in 1 .. Ver_Len_Max loop ! C := Getc; ! exit when C = '"'; ! ALIs.Table (Id).Ver (J) := C; ! ALIs.Table (Id).Ver_Len := J; ! end loop; ! Skip_Eol; ! -- Acquire main program line if present C := Getc; ! if C = 'M' then ! Checkc (' '); ! Skip_Space; ! C := Getc; - if C = 'F' then - ALIs.Table (Id).Main_Program := Func; - elsif C = 'P' then - ALIs.Table (Id).Main_Program := Proc; else ! P := P - 1; ! Fatal_Error; ! end if; ! Skip_Space; ! if not At_Eol then ! if Nextc < 'A' then ! ALIs.Table (Id).Main_Priority := Get_Nat; end if; Skip_Space; ! if Nextc = 'T' then ! P := P + 1; Checkc ('='); ! ALIs.Table (Id).Time_Slice_Value := Get_Nat; end if; ! Skip_Space; ! ! Checkc ('W'); ! Checkc ('='); ! ALIs.Table (Id).WC_Encoding := Getc; end if; - Skip_Eol; C := Getc; - end if; -- Acquire argument lines --- 554,640 ---- Unit_Exception_Table => False, Ver => (others => ' '), Ver_Len => 0, + Interface => False, Zero_Cost_Exceptions => False); + -- Now we acquire the input lines from the ALI file. Note that the + -- convention in the following code is that as we enter each section, + -- C is set to contain the first character of the following line. + + C := Getc; + -- Acquire library version ! if C /= 'V' then ! Fatal_Error; ! elsif Ignore ('V') then ! Skip_Line; ! else ! Checkc (' '); ! Skip_Space; ! Checkc ('"'); ! for J in 1 .. Ver_Len_Max loop ! C := Getc; ! exit when C = '"'; ! ALIs.Table (Id).Ver (J) := C; ! ALIs.Table (Id).Ver_Len := J; ! end loop; ! ! Skip_Eol; ! end if; C := Getc; ! -- Acquire main program line if present ! if C = 'M' then ! if Ignore ('M') then ! Skip_Line; else ! Checkc (' '); ! Skip_Space; ! C := Getc; ! if C = 'F' then ! ALIs.Table (Id).Main_Program := Func; ! elsif C = 'P' then ! ALIs.Table (Id).Main_Program := Proc; ! else ! P := P - 1; ! Fatal_Error; end if; Skip_Space; ! if not At_Eol then ! if Nextc < 'A' then ! ALIs.Table (Id).Main_Priority := Get_Nat; ! end if; ! ! Skip_Space; ! ! if Nextc = 'T' then ! P := P + 1; ! Checkc ('='); ! ALIs.Table (Id).Time_Slice_Value := Get_Nat; ! end if; ! ! Skip_Space; ! ! Checkc ('W'); Checkc ('='); ! ALIs.Table (Id).WC_Encoding := Getc; end if; ! Skip_Eol; end if; C := Getc; end if; -- Acquire argument lines *************** package body ALI is *** 542,647 **** First_Arg := Args.Last + 1; Arg_Loop : while C = 'A' loop ! Checkc (' '); ! Name_Len := 0; ! while not At_Eol loop ! Name_Len := Name_Len + 1; ! Name_Buffer (Name_Len) := Getc; ! end loop; ! Args.Increment_Last; ! Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len)); - Skip_Eol; C := Getc; end loop Arg_Loop; ! -- Acquire P line, first set defaults if C /= 'P' then Fatal_Error; - end if; ! NS_Found := False; ! while not At_Eol loop ! Checkc (' '); ! Skip_Space; ! C := Getc; ! if C = 'C' then ! Checkc ('E'); ! ALIs.Table (Id).Compile_Errors := True; ! elsif C = 'F' then ! Float_Format_Specified := Getc; ! ALIs.Table (Id).Float_Format := Float_Format_Specified; ! elsif C = 'L' then ! Locking_Policy_Specified := Getc; ! ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified; ! elsif C = 'N' then ! C := Getc; ! if C = 'O' then ! ALIs.Table (Id).No_Object := True; ! No_Object_Specified := True; ! elsif C = 'R' then ! No_Run_Time_Specified := True; ! ALIs.Table (Id).No_Run_Time := True; elsif C = 'S' then ! ALIs.Table (Id).Normalize_Scalars := True; ! Normalize_Scalars_Specified := True; ! NS_Found := True; ! else ! Fatal_Error; ! end if; ! elsif C = 'Q' then ! Queuing_Policy_Specified := Getc; ! ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified; ! elsif C = 'T' then ! Task_Dispatching_Policy_Specified := Getc; ! ALIs.Table (Id).Task_Dispatching_Policy := ! Task_Dispatching_Policy_Specified; ! elsif C = 'U' then ! if Nextc = 'A' then ! Unreserve_All_Interrupts_Specified := True; C := Getc; ! else Checkc ('X'); ! ALIs.Table (Id).Unit_Exception_Table := True; ! end if; ! elsif C = 'Z' then ! Checkc ('X'); ! ALIs.Table (Id).Zero_Cost_Exceptions := True; ! Zero_Cost_Exceptions_Specified := True; ! else ! Fatal_Error; end if; - end loop; ! if not NS_Found then ! No_Normalize_Scalars_Specified := True; end if; ! Skip_Eol; -- Acquire restrictions line ! if Getc /= 'R' then Fatal_Error; else Checkc (' '); Skip_Space; --- 642,816 ---- First_Arg := Args.Last + 1; Arg_Loop : while C = 'A' loop ! if Ignore ('A') then ! Skip_Line; ! else ! Checkc (' '); ! Name_Len := 0; ! while not At_Eol loop ! Name_Len := Name_Len + 1; ! Name_Buffer (Name_Len) := Getc; ! end loop; ! ! Args.Increment_Last; ! Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len)); ! ! Skip_Eol; ! end if; C := Getc; end loop Arg_Loop; ! -- Acquire P line if C /= 'P' then Fatal_Error; ! elsif Ignore ('P') then ! Skip_Line; ! else ! NS_Found := False; ! while not At_Eol loop ! Checkc (' '); ! Skip_Space; ! C := Getc; ! -- Processing for CE ! if C = 'C' then ! Checkc ('E'); ! ALIs.Table (Id).Compile_Errors := True; ! -- Processing for FD/FG/FI ! elsif C = 'F' then ! Float_Format_Specified := Getc; ! ALIs.Table (Id).Float_Format := Float_Format_Specified; ! -- Processing for Lx ! ! elsif C = 'L' then ! Locking_Policy_Specified := Getc; ! ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified; ! ! -- Processing for flags starting with N ! ! elsif C = 'N' then ! C := Getc; ! ! -- Processing for NO ! ! if C = 'O' then ! ALIs.Table (Id).No_Object := True; ! No_Object_Specified := True; ! ! -- Processing for NR ! ! elsif C = 'R' then ! No_Run_Time_Mode := True; ! Configurable_Run_Time_Mode := True; ! ! -- Processing for NS ! ! elsif C = 'S' then ! ALIs.Table (Id).Normalize_Scalars := True; ! Normalize_Scalars_Specified := True; ! NS_Found := True; ! ! -- Invalid switch starting with N ! ! else ! Fatal_Error; ! end if; ! ! -- Processing for Qx ! ! elsif C = 'Q' then ! Queuing_Policy_Specified := Getc; ! ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified; ! ! -- Processing fir flags starting with S elsif C = 'S' then ! C := Getc; ! -- Processing for SL ! if C = 'L' then ! ALIs.Table (Id).Interface := True; ! -- Processing for SS ! elsif C = 'S' then ! Opt.Sec_Stack_Used := True; ! ! -- Invalid switch starting with S ! ! else ! Fatal_Error; ! end if; ! ! -- Processing for Tx ! ! elsif C = 'T' then ! Task_Dispatching_Policy_Specified := Getc; ! ALIs.Table (Id).Task_Dispatching_Policy := ! Task_Dispatching_Policy_Specified; ! ! -- Processing for switch starting with U ! ! elsif C = 'U' then C := Getc; ! -- Processing for UA ! ! if C = 'A' then ! Unreserve_All_Interrupts_Specified := True; ! ! -- Processing for UX ! ! elsif C = 'X' then ! ALIs.Table (Id).Unit_Exception_Table := True; ! ! -- Invalid switches starting with U ! ! else ! Fatal_Error; ! end if; ! ! -- Processing for ZX ! ! elsif C = 'Z' then Checkc ('X'); ! ALIs.Table (Id).Zero_Cost_Exceptions := True; ! Zero_Cost_Exceptions_Specified := True; ! else ! Fatal_Error; ! end if; ! end loop; ! if not NS_Found then ! No_Normalize_Scalars_Specified := True; end if; ! Skip_Eol; end if; ! C := Getc; -- Acquire restrictions line ! if C /= 'R' then Fatal_Error; + elsif Ignore ('R') then + Skip_Line; + else Checkc (' '); Skip_Space; *************** package body ALI is *** 667,683 **** end case; end loop; ! if At_Eol then ! Skip_Eol; ! C := Getc; else ! Fatal_Error; end if; ! end if; -- Loop to acquire unit entries Unit_Loop : while C = 'U' loop Checkc (' '); Skip_Space; Units.Increment_Last; --- 836,883 ---- end case; end loop; ! Skip_Eol; ! end if; ! ! C := Getc; ! ! -- Acquire 'I' lines if present ! ! while C = 'I' loop ! if Ignore ('I') then ! Skip_Line; ! else ! declare ! Int_Num : Nat; ! I_State : Character; ! Line_No : Nat; ! ! begin ! Int_Num := Get_Nat; ! Skip_Space; ! I_State := Getc; ! Line_No := Get_Nat; ! ! Interrupt_States.Append ( ! (Interrupt_Id => Int_Num, ! Interrupt_State => I_State, ! IS_Pragma_Line => Line_No)); ! ! ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last; ! Skip_Eol; ! end; end if; ! ! C := Getc; ! end loop; -- Loop to acquire unit entries Unit_Loop : while C = 'U' loop + + -- Note: as per spec, we never ignore U lines + Checkc (' '); Skip_Space; Units.Increment_Last; *************** package body ALI is *** 709,714 **** --- 909,915 ---- Units.Table (Units.Last).First_With := Withs.Last + 1; Units.Table (Units.Last).First_Arg := First_Arg; Units.Table (Units.Last).Elab_Position := 0; + Units.Table (Units.Last).Interface := ALIs.Table (Id).Interface; if Debug_Flag_U then Write_Str (" ----> reading unit "); *************** package body ALI is *** 791,796 **** --- 992,1004 ---- Units.Table (Units.Last).Version (J) := C; end loop; + -- BN parameter (Body needed) + + elsif C = 'B' then + Checkc ('N'); + Check_At_End_Of_Field; + Units.Table (Units.Last).Body_Needed_For_SAL := True; + -- DE parameter (Dynamic elaboration checks elsif C = 'D' then *************** package body ALI is *** 942,948 **** else Fatal_Error; end if; - end loop; Skip_Eol; --- 1150,1155 ---- *************** package body ALI is *** 955,1018 **** Static_Elaboration_Model_Used := True; end if; - -- Scan out With lines for this unit - C := Getc; ! With_Loop : while C = 'W' loop ! Checkc (' '); ! Skip_Space; ! Withs.Increment_Last; ! Withs.Table (Withs.Last).Uname := Get_Name; ! Withs.Table (Withs.Last).Elaborate := False; ! Withs.Table (Withs.Last).Elaborate_All := False; ! Withs.Table (Withs.Last).Elab_All_Desirable := False; ! -- Generic case with no object file available ! if At_Eol then ! Withs.Table (Withs.Last).Sfile := No_File; ! Withs.Table (Withs.Last).Afile := No_File; ! -- Normal case ! else ! Withs.Table (Withs.Last).Sfile := Get_Name (Lower => True); ! Withs.Table (Withs.Last).Afile := Get_Name; ! -- Scan out possible E, EA, and NE parameters ! while not At_Eol loop ! Skip_Space; ! if Nextc = 'E' then ! P := P + 1; ! if At_End_Of_Field then ! Withs.Table (Withs.Last).Elaborate := True; ! elsif Nextc = 'A' then P := P + 1; - Check_At_End_Of_Field; - Withs.Table (Withs.Last).Elaborate_All := True; ! else ! Checkc ('D'); ! Check_At_End_Of_Field; ! -- Store ED indication unless ignore required ! if not Ignore_ED then ! Withs.Table (Withs.Last).Elab_All_Desirable := True; end if; end if; ! end if; ! end loop; end if; - Skip_Eol; C := Getc; - end loop With_Loop; Units.Table (Units.Last).Last_With := Withs.Last; --- 1162,1232 ---- Static_Elaboration_Model_Used := True; end if; C := Getc; ! -- Scan out With lines for this unit ! With_Loop : while C = 'W' loop ! if Ignore ('W') then ! Skip_Line; ! else ! Checkc (' '); ! Skip_Space; ! Withs.Increment_Last; ! Withs.Table (Withs.Last).Uname := Get_Name; ! Withs.Table (Withs.Last).Elaborate := False; ! Withs.Table (Withs.Last).Elaborate_All := False; ! Withs.Table (Withs.Last).Elab_All_Desirable := False; ! Withs.Table (Withs.Last).Interface := False; ! -- Generic case with no object file available ! if At_Eol then ! Withs.Table (Withs.Last).Sfile := No_File; ! Withs.Table (Withs.Last).Afile := No_File; ! -- Normal case ! else ! Withs.Table (Withs.Last).Sfile := Get_Name (Lower => True); ! Withs.Table (Withs.Last).Afile := Get_Name; ! -- Scan out possible E, EA, and NE parameters ! while not At_Eol loop ! Skip_Space; ! if Nextc = 'E' then P := P + 1; ! if At_End_Of_Field then ! Withs.Table (Withs.Last).Elaborate := True; ! elsif Nextc = 'A' then ! P := P + 1; ! Check_At_End_Of_Field; ! Withs.Table (Withs.Last).Elaborate_All := True; ! else ! Checkc ('D'); ! Check_At_End_Of_Field; ! ! -- Store ED indication unless ignore required ! ! if not Ignore_ED then ! Withs.Table (Withs.Last).Elab_All_Desirable := ! True; ! end if; end if; end if; ! end loop; ! end if; ! ! Skip_Eol; end if; C := Getc; end loop With_Loop; Units.Table (Units.Last).Last_With := Withs.Last; *************** package body ALI is *** 1023,1086 **** Name_Len := 0; Linker_Options_Loop : while C = 'L' loop - Checkc (' '); - Skip_Space; - Checkc ('"'); ! loop ! C := Getc; ! if C < Character'Val (16#20#) ! or else C > Character'Val (16#7E#) ! then ! Fatal_Error; ! elsif C = '{' then ! C := Character'Val (0); ! declare ! V : Natural; ! begin ! V := 0; ! for J in 1 .. 2 loop ! C := Getc; ! if C in '0' .. '9' then ! V := V * 16 + ! Character'Pos (C) - Character'Pos ('0'); ! elsif C in 'A' .. 'F' then ! V := V * 16 + ! Character'Pos (C) - Character'Pos ('A') + 10; ! else ! Fatal_Error; ! end if; ! end loop; ! Checkc ('}'); ! Add_Char_To_Name_Buffer (Character'Val (V)); ! end; ! else ! if C = '"' then ! exit when Nextc /= '"'; ! C := Getc; ! end if; ! Add_Char_To_Name_Buffer (C); ! end if; ! end loop; ! Add_Char_To_Name_Buffer (nul); - Skip_Eol; C := Getc; end loop Linker_Options_Loop; ! -- Store the linker options entry if Name_Len /= 0 then Linker_Options.Increment_Last; --- 1237,1308 ---- Name_Len := 0; Linker_Options_Loop : while C = 'L' loop ! if Ignore ('L') then ! Skip_Line; ! else ! Checkc (' '); ! Skip_Space; ! Checkc ('"'); ! loop ! C := Getc; ! if C < Character'Val (16#20#) ! or else C > Character'Val (16#7E#) ! then ! Fatal_Error; ! elsif C = '{' then ! C := Character'Val (0); ! declare ! V : Natural; ! begin ! V := 0; ! for J in 1 .. 2 loop ! C := Getc; ! if C in '0' .. '9' then ! V := V * 16 + ! Character'Pos (C) - ! Character'Pos ('0'); ! elsif C in 'A' .. 'F' then ! V := V * 16 + ! Character'Pos (C) - ! Character'Pos ('A') + ! 10; ! else ! Fatal_Error; ! end if; ! end loop; ! Checkc ('}'); ! Add_Char_To_Name_Buffer (Character'Val (V)); ! end; ! else ! if C = '"' then ! exit when Nextc /= '"'; ! C := Getc; ! end if; ! Add_Char_To_Name_Buffer (C); ! end if; ! end loop; ! ! Add_Char_To_Name_Buffer (nul); ! Skip_Eol; ! end if; C := Getc; end loop Linker_Options_Loop; ! -- Store the linker options entry if one was found if Name_Len /= 0 then Linker_Options.Increment_Last; *************** package body ALI is *** 1127,1150 **** -- Scan out external version references and put in hash table while C = 'E' loop ! Checkc (' '); ! Skip_Space; ! Name_Len := 0; ! Name_Len := 0; ! loop ! C := Getc; ! if C < ' ' then ! Fatal_Error; ! end if; ! exit when At_End_Of_Field; ! Add_Char_To_Name_Buffer (C); ! end loop; - Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True); - Skip_Eol; C := Getc; end loop; --- 1349,1378 ---- -- Scan out external version references and put in hash table while C = 'E' loop ! if Ignore ('E') then ! Skip_Line; ! else ! Checkc (' '); ! Skip_Space; ! Name_Len := 0; ! Name_Len := 0; ! loop ! C := Getc; ! if C < ' ' then ! Fatal_Error; ! end if; ! ! exit when At_End_Of_Field; ! Add_Char_To_Name_Buffer (C); ! end loop; ! ! Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True); ! Skip_Eol; ! end if; C := Getc; end loop; *************** package body ALI is *** 1153,1253 **** ALIs.Table (Id).First_Sdep := Sdep.Last + 1; while C = 'D' loop ! Checkc (' '); ! Skip_Space; ! Sdep.Increment_Last; ! Sdep.Table (Sdep.Last).Sfile := Get_Name (Lower => True); ! Sdep.Table (Sdep.Last).Stamp := Get_Stamp; ! Sdep.Table (Sdep.Last).Dummy_Entry := ! (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp); ! -- Acquire checksum value ! Skip_Space; ! declare ! Ctr : Natural; ! Chk : Word; ! begin ! Ctr := 0; ! Chk := 0; ! loop ! exit when At_Eol or else Ctr = 8; ! if Nextc in '0' .. '9' then ! Chk := Chk * 16 + ! Character'Pos (Nextc) - Character'Pos ('0'); ! elsif Nextc in 'a' .. 'f' then ! Chk := Chk * 16 + ! Character'Pos (Nextc) - Character'Pos ('a') + 10; ! else ! exit; ! end if; ! Ctr := Ctr + 1; ! P := P + 1; ! end loop; ! if Ctr = 8 and then At_End_Of_Field then ! Sdep.Table (Sdep.Last).Checksum := Chk; ! else ! Fatal_Error; ! end if; ! end; ! -- Acquire subunit and reference file name entries ! Sdep.Table (Sdep.Last).Subunit_Name := No_Name; ! Sdep.Table (Sdep.Last).Rfile := Sdep.Table (Sdep.Last).Sfile; ! Sdep.Table (Sdep.Last).Start_Line := 1; ! if not At_Eol then ! Skip_Space; ! -- Here for subunit name ! if Nextc not in '0' .. '9' then ! Name_Len := 0; ! while not At_End_Of_Field loop ! Name_Len := Name_Len + 1; ! Name_Buffer (Name_Len) := Getc; ! end loop; ! Sdep.Table (Sdep.Last).Subunit_Name := Name_Enter; ! Skip_Space; ! end if; ! -- Here for reference file name entry ! if Nextc in '0' .. '9' then ! Sdep.Table (Sdep.Last).Start_Line := Get_Nat; ! Checkc (':'); ! Name_Len := 0; ! while not At_End_Of_Field loop ! Name_Len := Name_Len + 1; ! Name_Buffer (Name_Len) := Getc; ! end loop; ! Sdep.Table (Sdep.Last).Rfile := Name_Enter; end if; end if; - Skip_Eol; C := Getc; end loop; ALIs.Table (Id).Last_Sdep := Sdep.Last; ! -- Loop through Xref sections (skip loop if not reading xref stuff) ! while Read_Xref and then C = 'X' loop -- Make new entry in section table --- 1381,1501 ---- ALIs.Table (Id).First_Sdep := Sdep.Last + 1; while C = 'D' loop ! if Ignore ('D') then ! Skip_Line; ! else ! Checkc (' '); ! Skip_Space; ! Sdep.Increment_Last; ! Sdep.Table (Sdep.Last).Sfile := Get_Name (Lower => True); ! Sdep.Table (Sdep.Last).Stamp := Get_Stamp; ! Sdep.Table (Sdep.Last).Dummy_Entry := ! (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp); ! -- Acquire checksum value ! Skip_Space; ! declare ! Ctr : Natural; ! Chk : Word; ! begin ! Ctr := 0; ! Chk := 0; ! loop ! exit when At_Eol or else Ctr = 8; ! if Nextc in '0' .. '9' then ! Chk := Chk * 16 + ! Character'Pos (Nextc) - Character'Pos ('0'); ! elsif Nextc in 'a' .. 'f' then ! Chk := Chk * 16 + ! Character'Pos (Nextc) - Character'Pos ('a') + 10; ! else ! exit; ! end if; ! Ctr := Ctr + 1; ! P := P + 1; ! end loop; ! if Ctr = 8 and then At_End_Of_Field then ! Sdep.Table (Sdep.Last).Checksum := Chk; ! else ! Fatal_Error; ! end if; ! end; ! -- Acquire subunit and reference file name entries ! Sdep.Table (Sdep.Last).Subunit_Name := No_Name; ! Sdep.Table (Sdep.Last).Rfile := ! Sdep.Table (Sdep.Last).Sfile; ! Sdep.Table (Sdep.Last).Start_Line := 1; ! if not At_Eol then ! Skip_Space; ! -- Here for subunit name ! if Nextc not in '0' .. '9' then ! Name_Len := 0; ! while not At_End_Of_Field loop ! Name_Len := Name_Len + 1; ! Name_Buffer (Name_Len) := Getc; ! end loop; ! Sdep.Table (Sdep.Last).Subunit_Name := Name_Enter; ! Skip_Space; ! end if; ! -- Here for reference file name entry ! if Nextc in '0' .. '9' then ! Sdep.Table (Sdep.Last).Start_Line := Get_Nat; ! Checkc (':'); ! Name_Len := 0; ! while not At_End_Of_Field loop ! Name_Len := Name_Len + 1; ! Name_Buffer (Name_Len) := Getc; ! end loop; ! ! Sdep.Table (Sdep.Last).Rfile := Name_Enter; ! end if; end if; + + Skip_Eol; end if; C := Getc; end loop; ALIs.Table (Id).Last_Sdep := Sdep.Last; ! -- We must at this stage be at an Xref line or the end of file ! if C /= EOF and then C /= 'X' then ! Fatal_Error; ! end if; ! ! -- If we are ignoring Xref sections we are done (we ignore all ! -- remaining lines since only xref related lines follow X). ! ! if Ignore ('X') and then not Debug_Flag_X then ! return Id; ! end if; ! ! -- Loop through Xref sections ! ! while C = 'X' loop -- Make new entry in section table *************** package body ALI is *** 1267,1272 **** --- 1515,1522 ---- Current_File_Num := XS.File_Num; + Skip_Space; + Skip_Eol; C := Nextc; *************** package body ALI is *** 1276,1286 **** Xref_Entity.Increment_Last; Read_Refs_For_One_Entity : declare - XE : Xref_Entity_Record renames Xref_Entity.Table (Xref_Entity.Last); ! ! N : Nat; procedure Read_Instantiation_Reference; -- Acquire instantiation reference. Caller has checked --- 1526,1534 ---- Xref_Entity.Increment_Last; Read_Refs_For_One_Entity : declare XE : Xref_Entity_Record renames Xref_Entity.Table (Xref_Entity.Last); ! N : Nat; procedure Read_Instantiation_Reference; -- Acquire instantiation reference. Caller has checked *************** package body ALI is *** 1340,1345 **** --- 1588,1595 ---- XE.Lib := (Getc = '*'); XE.Entity := Get_Name; + Current_File_Num := XS.File_Num; + -- Renaming reference is present if Nextc = '=' then *************** package body ALI is *** 1380,1386 **** XE.Tref_Line := 0; XE.Tref_Type := ' '; XE.Tref_Col := 0; ! XE.Tref_Standard_Entity := Get_Name; else N := Get_Nat; --- 1630,1637 ---- XE.Tref_Line := 0; XE.Tref_Type := ' '; XE.Tref_Col := 0; ! XE.Tref_Standard_Entity := ! Get_Name (Ignore_Spaces => True); else N := Get_Nat; *************** package body ALI is *** 1401,1406 **** --- 1652,1681 ---- XE.Tref_Standard_Entity := No_Name; end if; + -- ??? Temporary workaround for nested generics case: + -- 4i4 Directories{1|4I9[4|6[3|3]]} + -- See C918-002 + + declare + Nested_Brackets : Natural := 0; + + begin + loop + case Nextc is + when '[' => + Nested_Brackets := Nested_Brackets + 1; + when ']' => + Nested_Brackets := Nested_Brackets - 1; + when others => + if Nested_Brackets = 0 then + exit; + end if; + end case; + + Skipc; + end loop; + end; + P := P + 1; -- skip closing bracket Skip_Space; *************** package body ALI is *** 1418,1425 **** -- Loop through cross-references for this entity - Current_File_Num := XS.File_Num; - loop Skip_Space; --- 1693,1698 ---- *************** package body ALI is *** 1443,1455 **** Current_File_Num := XR.File_Num; P := P + 1; N := Get_Nat; - else XR.File_Num := Current_File_Num; end if; XR.Line := N; XR.Rtype := Getc; XR.Col := Get_Nat; if Nextc = '[' then --- 1716,1738 ---- Current_File_Num := XR.File_Num; P := P + 1; N := Get_Nat; else XR.File_Num := Current_File_Num; end if; XR.Line := N; XR.Rtype := Getc; + + -- Imported entities reference as in: + -- 494b25 + -- ??? Simply skipped for now + + if Nextc = '<' then + while Getc /= '>' loop + null; + end loop; + end if; + XR.Col := Get_Nat; if Nextc = '[' then *************** package body ALI is *** 1462,1468 **** XE.Last_Xref := Xref.Last; C := Nextc; - end Read_Refs_For_One_Entity; end loop; --- 1745,1750 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/ali.ads gcc-3.4.0/gcc/ada/ali.ads *** gcc-3.3.3/gcc/ada/ali.ads 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/ali.ads 2003-10-21 13:41:58.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1992-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- -- --- 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- -- *************** package ALI is *** 65,70 **** --- 64,72 ---- type Source_Id is range 5_000_000 .. 5_999_999; -- Id values used for Source table entries + type Interrupt_State_Id is range 6_000_000 .. 6_999_999; + -- Id values used for Interrupt_State table entries + -------------------- -- ALI File Table -- -------------------- *************** package ALI is *** 97,106 **** -- this ALI file, since the body if present is always first). Ver : String (1 .. Ver_Len_Max); ! -- Value of library version (V line in ALI file) Ver_Len : Natural; ! -- Length of characters stored in Ver First_Unit : Unit_Id; -- Id of first Unit table entry for this file --- 99,113 ---- -- this ALI file, since the body if present is always first). Ver : String (1 .. Ver_Len_Max); ! -- Value of library version (V line in ALI file). Not set if ! -- V lines are ignored as a result of the Ignore_Lines parameter. Ver_Len : Natural; ! -- Length of characters stored in Ver. Not set if V lines are ! -- ignored as a result of the Ignore_Lines parameter. ! ! Interface : Boolean; ! -- Set True when this is an interface to a standalone library First_Unit : Unit_Id; -- Id of first Unit table entry for this file *************** package ALI is *** 115,177 **** -- Id of last Sdep table entry for this file Main_Program : Main_Program_Type; ! -- Indicator of whether first unit can be used as main program Main_Priority : Int; -- Indicates priority value if Main_Program field indicates that -- this can be a main program. A value of -1 (No_Main_Priority) -- indicates that no parameter was found, or no M line was present. Time_Slice_Value : Int; -- Indicates value of time slice parameter from T=xxx on main program -- line. A value of -1 indicates that no T=xxx parameter was found, -- or no M line was present. WC_Encoding : Character; -- Wide character encoding if main procedure. Otherwise not relevant. Locking_Policy : Character; -- Indicates locking policy for units in this file. Space means -- tasking was not used, or that no Locking_Policy pragma was -- present or that this is a language defined unit. Otherwise set -- to first character (upper case) of policy name. Queuing_Policy : Character; -- Indicates queuing policy for units in this file. Space means -- tasking was not used, or that no Queuing_Policy pragma was -- present or that this is a language defined unit. Otherwise set -- to first character (upper case) of policy name. Task_Dispatching_Policy : Character; -- Indicates task dispatching policy for units in this file. Space -- means tasking was not used, or that no Task_Dispatching_Policy -- pragma was present or that this is a language defined unit. -- Otherwise set to first character (upper case) of policy name. Compile_Errors : Boolean; -- Set to True if compile errors for unit. Note that No_Object -- will always be set as well in this case. Float_Format : Character; ! -- Set to float format (set to I if no float-format given) No_Object : Boolean; ! -- Set to True if no object file generated ! ! No_Run_Time : Boolean; ! -- Set to True if file was compiled with pragma No_Run_Time Normalize_Scalars : Boolean; ! -- Set to True if file was compiled with Normalize_Scalars Unit_Exception_Table : Boolean; ! -- Set to True if unit exception table pointer generated Zero_Cost_Exceptions : Boolean; ! -- Set to True if file was compiled with zero cost exceptions Restrictions : Restrictions_String; ! -- Copy of restrictions letters from R line end record; --- 122,204 ---- -- Id of last Sdep table entry for this file Main_Program : Main_Program_Type; ! -- Indicator of whether first unit can be used as main program. ! -- Not set if 'M' appears in Ignore_Lines. Main_Priority : Int; -- Indicates priority value if Main_Program field indicates that -- this can be a main program. A value of -1 (No_Main_Priority) -- indicates that no parameter was found, or no M line was present. + -- Not set if 'M' appears in Ignore_Lines. Time_Slice_Value : Int; -- Indicates value of time slice parameter from T=xxx on main program -- line. A value of -1 indicates that no T=xxx parameter was found, -- or no M line was present. + -- Not set if 'M' appears in Ignore_Lines. WC_Encoding : Character; -- Wide character encoding if main procedure. Otherwise not relevant. + -- Not set if 'M' appears in Ignore_Lines. Locking_Policy : Character; -- Indicates locking policy for units in this file. Space means -- tasking was not used, or that no Locking_Policy pragma was -- present or that this is a language defined unit. Otherwise set -- to first character (upper case) of policy name. + -- Not set if 'P' appears in Ignore_Lines. Queuing_Policy : Character; -- Indicates queuing policy for units in this file. Space means -- tasking was not used, or that no Queuing_Policy pragma was -- present or that this is a language defined unit. Otherwise set -- to first character (upper case) of policy name. + -- Not set if 'P' appears in Ignore_Lines. Task_Dispatching_Policy : Character; -- Indicates task dispatching policy for units in this file. Space -- means tasking was not used, or that no Task_Dispatching_Policy -- pragma was present or that this is a language defined unit. -- Otherwise set to first character (upper case) of policy name. + -- Not set if 'P' appears in Ignore_Lines. Compile_Errors : Boolean; -- Set to True if compile errors for unit. Note that No_Object -- will always be set as well in this case. + -- Not set if 'P' appears in Ignore_Lines. Float_Format : Character; ! -- Set to float format (set to I if no float-format given). ! -- Not set if 'P' appears in Ignore_Lines. No_Object : Boolean; ! -- Set to True if no object file generated. ! -- Not set if 'P' appears in Ignore_Lines. Normalize_Scalars : Boolean; ! -- Set to True if file was compiled with Normalize_Scalars. ! -- Not set if 'P' appears in Ignore_Lines. Unit_Exception_Table : Boolean; ! -- Set to True if unit exception table pointer generated. ! -- Not set if 'P' appears in Ignore_Lines. Zero_Cost_Exceptions : Boolean; ! -- Set to True if file was compiled with zero cost exceptions. ! -- Not set if 'P' appears in Ignore_Lines. Restrictions : Restrictions_String; ! -- Copy of restrictions letters from R line. ! -- Not set if 'R' appears in Ignore_Lines. ! ! First_Interrupt_State : Interrupt_State_Id; ! Last_Interrupt_State : Interrupt_State_Id'Base; ! -- These point to the first and last entries in the interrupt ! -- state table for this unit. If there are no entries, then ! -- Last_Interrupt_State = First_Interrupt_State - 1 (that's ! -- why the 'Base reference is there, it can be one less than ! -- the lower bound of the subtype). ! -- Not set if 'I' appears in Ignore_Lines end record; *************** package ALI is *** 309,314 **** --- 336,347 ---- -- Set True if IS qualifier appears in ALI file, indicating that -- an Initialize_Scalars pragma applies to the unit. + Interface : Boolean; + -- Set True when this is an interface to a standalone library + + Body_Needed_For_SAL : Boolean; + -- Indicates that the source for the body of the unit (subprogram, + -- package, or generic unit) must be included in a standalone library. end record; package Units is new Table.Table ( *************** package ALI is *** 319,324 **** --- 352,385 ---- Table_Increment => 200, Table_Name => "Unit"); + --------------------------- + -- Interrupt State Table -- + --------------------------- + + -- An entry is made in this table for each I (interrupt state) line + -- encountered in the input ALI file. The First/Last_Interrupt_Id + -- fields of the ALI file entry show the range of entries defined + -- within a particular ALI file. + + type Interrupt_State_Record is record + Interrupt_Id : Nat; + -- Id from interrupt state entry + + Interrupt_State : Character; + -- State from interrupt state entry ('u'/'r'/'s') + + IS_Pragma_Line : Nat; + -- Line number of Interrupt_State pragma + end record; + + package Interrupt_States is new Table.Table ( + Table_Component_Type => Interrupt_State_Record, + Table_Index_Type => Interrupt_State_Id'Base, + Table_Low_Bound => Interrupt_State_Id'First, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "Interrupt_States"); + -------------- -- Switches -- -------------- *************** package ALI is *** 326,333 **** -- These switches record status information about ali files that -- have been read, for quick reference without searching tables. Dynamic_Elaboration_Checks_Specified : Boolean := False; ! -- Set to False by Initialize_ALI. Set to True if Read_ALI reads -- a unit for which dynamic elaboration checking is enabled. Float_Format_Specified : Character := ' '; --- 387,397 ---- -- These switches record status information about ali files that -- have been read, for quick reference without searching tables. + -- Note: a switch will be left set at its default value if the line + -- which might otherwise set it is ignored (from Ignore_Lines). + Dynamic_Elaboration_Checks_Specified : Boolean := False; ! -- Set to False by Initialize_ALI. Set to True if Scan_ALI reads -- a unit for which dynamic elaboration checking is enabled. Float_Format_Specified : Character := ' '; *************** package ALI is *** 354,363 **** -- Set to False by Initialize_ALI. Set to True if an ali file indicates -- that the file was compiled in Normalize_Scalars mode. - No_Run_Time_Specified : Boolean := False; - -- Set to False by Initialize_ALI, Set to True if an ali file indicates - -- that the file was compiled in No_Run_Time mode. - Queuing_Policy_Specified : Character := ' '; -- Set to blank by Initialize_ALI. Set to the appropriate queuing policy -- character if an ali file contains a P line setting the queuing policy. --- 418,423 ---- *************** package ALI is *** 392,397 **** --- 452,459 ---- -- Each With line (W line) in an ALI file generates a Withs table entry + -- Note: there will be no entries in this table if 'W' lines are ignored + No_With_Id : constant With_Id := With_Id'First; -- Special value indicating no withs table entry *************** package ALI is *** 418,423 **** --- 480,488 ---- Elab_All_Desirable : Boolean; -- Indicates presence of ED parameter + Interface : Boolean := False; + -- True if the Unit is an Interface of a Stand-Alole Library + end record; package Withs is new Table.Table ( *************** package ALI is *** 434,439 **** --- 499,506 ---- -- Each Arg line (A line) in an ALI file generates an Args table entry + -- Note: there will be no entries in this table if 'A' lines are ignored + No_Arg_Id : constant Arg_Id := Arg_Id'First; -- Special value indicating no args table entry *************** package ALI is *** 458,463 **** --- 525,532 ---- -- to form the entry in this table, using a NUL character as the -- separator, and a final NUL character is appended to the end. + -- Note: there will be no entries in this table if 'L' lines are ignored + type Linker_Option_Record is record Name : Name_Id; -- Name entry containing concatenated list of Linker_Options *************** package ALI is *** 498,503 **** --- 567,574 ---- -- as read from E lines in the ali file. The stored values do not -- include the terminating quote characters. + -- Note: there will be no entries in this table if 'E' lines are ignored + type Vindex is range 0 .. 98; -- Type to define range of headers *************** package ALI is *** 522,527 **** --- 593,600 ---- -- Each source dependency (D line) in an ALI file generates an -- entry in the Sdep table. + -- Note: there will be no entries in this table if 'D' lines are ignored + No_Sdep_Id : constant Sdep_Id := Sdep_Id'First; -- Special value indicating no Sdep table entry *************** package ALI is *** 585,592 **** -- The following table records cross-reference sections, there is one -- entry for each X header line in the ALI file for an xref section. ! -- Note that there will be no entries in this table if the Read_Xref ! -- parameter to Scan_ALI was set to False. type Xref_Section_Record is record File_Num : Sdep_Id; --- 658,665 ---- -- The following table records cross-reference sections, there is one -- entry for each X header line in the ALI file for an xref section. ! ! -- Note: there will be no entries in this table if 'X' lines are ignored type Xref_Section_Record is record File_Num : Sdep_Id; *************** package ALI is *** 600,606 **** Last_Entity : Nat; -- Last entry in Xref_Entity table - end record; package Xref_Section is new Table.Table ( --- 673,678 ---- *************** package ALI is *** 628,634 **** Etype : Character; -- Set to the identification character for the entity. See section ! -- "Cross-Reference Entity Identifiers in lib-xref.ads for details. Col : Pos; -- Column number of definition --- 700,706 ---- Etype : Character; -- Set to the identification character for the entity. See section ! -- "Cross-Reference Entity Identifiers" in lib-xref.ads for details. Col : Pos; -- Column number of definition *************** package ALI is *** 666,672 **** -- This field is set to blank if no typeref is present, or if the -- typeref refers to an entity in standard. Otherwise it contains -- the identification character for the typeref entity. See section ! -- "Cross-Reference Entity Identifiers in lib-xref.ads for details. Tref_Col : Nat; -- This field is set to zero if no typeref is present, or if the --- 738,744 ---- -- This field is set to blank if no typeref is present, or if the -- typeref refers to an entity in standard. Otherwise it contains -- the identification character for the typeref entity. See section ! -- "Cross-Reference Entity Identifiers" in lib-xref.ads for details. Tref_Col : Nat; -- This field is set to zero if no typeref is present, or if the *************** package ALI is *** 741,752 **** -- Initialize the ALI tables. Also resets all switch values to defaults. function Scan_ALI ! (F : File_Name_Type; ! T : Text_Buffer_Ptr; ! Ignore_ED : Boolean; ! Err : Boolean; ! Read_Xref : Boolean := False) ! return ALI_Id; -- Given the text, T, of an ALI file, F, scan and store the information -- from the file, and return the Id of the resulting entry in the ALI -- table. Switch settings may be modified as described above in the --- 813,826 ---- -- Initialize the ALI tables. Also resets all switch values to defaults. function Scan_ALI ! (F : File_Name_Type; ! T : Text_Buffer_Ptr; ! Ignore_ED : Boolean; ! Err : Boolean; ! Read_Xref : Boolean := False; ! Read_Lines : String := ""; ! Ignore_Lines : String := "X") ! return ALI_Id; -- Given the text, T, of an ALI file, F, scan and store the information -- from the file, and return the Id of the resulting entry in the ALI -- table. Switch settings may be modified as described above in the *************** package ALI is *** 761,768 **** -- is terminated. If Err is True, then no error message is output, -- and No_ALI_Id is returned. -- -- Read_XREF is set True to read and acquire the cross-reference ! -- information, otherwise the scan is terminated when a cross- ! -- reference line is encountered. end ALI; --- 835,864 ---- -- is terminated. If Err is True, then no error message is output, -- and No_ALI_Id is returned. -- + -- Ignore_Lines requests that Scan_ALI ignore any lines that start + -- with any given key character. The default value of X causes all + -- Xref lines to be ignored. The corresponding data in the ALI + -- tables will not be filled in in this case. It is not possible + -- to ignore U (unit) lines, they are always read. + -- + -- Read_Lines requests that Scan_ALI process only lines that start + -- with one of the given characters. The corresponding data in the + -- ALI file for any characters not given in the list will not be + -- set. The default value of the null string indicates that all + -- lines should be read (unless Ignore_Lines is specified). U + -- (unit) lines are always read regardless of the value of this + -- parameter. + -- + -- Note: either Ignore_Lines or Read_Lines should be non-null. + -- but not both. If both are given then only the Read_Lines + -- value is processed, and the Ignore_Lines parameter is + -- not processed. + -- -- Read_XREF is set True to read and acquire the cross-reference ! -- information. If Read_XREF is set to True, then the effect is ! -- to ignore all lines other than U, W, D and X lines and the ! -- Ignore_Lines and Read_Lines parameters are ignored (i.e. the ! -- use of True for Read_XREF is equivalent to specifying an ! -- argument of "UWDX" for Read_Lines. end ALI; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-liteio.ads gcc-3.4.0/gcc/ada/a-liteio.ads *** gcc-3.3.3/gcc/ada/a-liteio.ads 2002-03-14 10:58:49.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-liteio.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/ali-util.adb gcc-3.4.0/gcc/ada/ali-util.adb *** gcc-3.3.3/gcc/ada/ali-util.adb 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/ali-util.adb 2003-10-21 13:41:58.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1992-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- -- --- 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- -- *************** *** 25,41 **** -- -- ------------------------------------------------------------------------------ with Binderr; use Binderr; with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; with System.CRC32; with System.Memory; - with System.Address_To_Access_Conversions; package body ALI.Util is ----------------------- -- Local Subprograms -- ----------------------- --- 24,55 ---- -- -- ------------------------------------------------------------------------------ + with Debug; use Debug; with Binderr; use Binderr; + with Lib; use Lib; with Namet; use Namet; with Opt; use Opt; + with Output; use Output; with Osint; use Osint; with System.CRC32; with System.Memory; package body ALI.Util is + type Header_Num is range 0 .. 1_000; + + function Hash (F : File_Name_Type) return Header_Num; + -- Function used to compute hash of ALI file name + + package Interfaces is new Simple_HTable ( + Header_Num => Header_Num, + Element => Boolean, + No_Element => False, + Key => File_Name_Type, + Hash => Hash, + Equal => "="); + ----------------------- -- Local Subprograms -- ----------------------- *************** package body ALI.Util is *** 88,107 **** use ASCII; -- Make control characters visible - procedure Free_Source; - -- Free source file buffer - - procedure Free_Source is - - package SB is - new System.Address_To_Access_Conversions (Big_Source_Buffer); - - begin - System.Memory.Free (SB.To_Address (SB.Object_Pointer (Src))); - end Free_Source; - - -- Start of processing for Get_File_Checksum - begin Read_Source_File (Fname, 0, Hi, Src); --- 102,107 ---- *************** package body ALI.Util is *** 128,134 **** when EOF => if Ptr = Hi then ! Free_Source; return Csum; else Ptr := Ptr + 1; --- 128,134 ---- when EOF => if Ptr = Hi then ! System.Memory.Free (Src.all'Address); return Csum; else Ptr := Ptr + 1; *************** package body ALI.Util is *** 260,270 **** exception when Bad => ! Free_Source; return Checksum_Error; - end Get_File_Checksum; --------------------------- -- Initialize_ALI_Source -- --------------------------- --- 260,278 ---- exception when Bad => ! System.Memory.Free (Src.all'Address); return Checksum_Error; end Get_File_Checksum; + ---------- + -- Hash -- + ---------- + + function Hash (F : File_Name_Type) return Header_Num is + begin + return Header_Num (Int (F) rem Header_Num'Range_Length); + end Hash; + --------------------------- -- Initialize_ALI_Source -- --------------------------- *************** package body ALI.Util is *** 282,287 **** --- 290,296 ---- end loop; Source.Init; + Interfaces.Reset; end Initialize_ALI_Source; ------------------------- *************** package body ALI.Util is *** 303,328 **** Idread : ALI_Id; begin ! for I in ALIs.Table (Id).First_Unit .. ALIs.Table (Id).Last_Unit loop ! for J in Units.Table (I).First_With .. Units.Table (I).Last_With loop ! Afile := Withs.Table (J).Afile; -- Only process if not a generic (Afile /= No_File) and if -- file has not been processed already. ! if Afile /= No_File and then Get_Name_Table_Info (Afile) = 0 then ! Text := Read_Library_Info (Afile); if Text = null then ! Error_Msg_Name_1 := Afile; ! Error_Msg_Name_2 := Withs.Table (J).Sfile; ! Error_Msg ("% not found, % must be compiled"); ! Set_Name_Table_Info (Afile, Int (No_Unit_Id)); ! return; end if; Idread := Scan_ALI (F => Afile, --- 312,352 ---- Idread : ALI_Id; begin ! -- Process all dependent units ! for U in ALIs.Table (Id).First_Unit .. ALIs.Table (Id).Last_Unit loop ! for ! W in Units.Table (U).First_With .. Units.Table (U).Last_With ! loop ! Afile := Withs.Table (W).Afile; -- Only process if not a generic (Afile /= No_File) and if -- file has not been processed already. ! if Afile /= No_File ! and then Get_Name_Table_Info (Afile) = 0 ! then Text := Read_Library_Info (Afile); + -- Return with an error if source cannot be found and if this + -- is not a library generic (now we can, but does not have to + -- compile library generics) + if Text = null then ! if Generic_Separately_Compiled (Withs.Table (W).Sfile) then ! Error_Msg_Name_1 := Afile; ! Error_Msg_Name_2 := Withs.Table (W).Sfile; ! Error_Msg ("% not found, % must be compiled"); ! Set_Name_Table_Info (Afile, Int (No_Unit_Id)); ! return; ! ! else ! goto Skip_Library_Generics; ! end if; end if; + -- Enter in ALIs table + Idread := Scan_ALI (F => Afile, *************** package body ALI.Util is *** 333,355 **** Free (Text); if ALIs.Table (Idread).Compile_Errors then ! Error_Msg_Name_1 := Withs.Table (J).Sfile; Error_Msg ("% had errors, must be fixed, and recompiled"); Set_Name_Table_Info (Afile, Int (No_Unit_Id)); elsif ALIs.Table (Idread).No_Object then ! Error_Msg_Name_1 := Withs.Table (J).Sfile; Error_Msg ("% must be recompiled"); Set_Name_Table_Info (Afile, Int (No_Unit_Id)); end if; ! -- Recurse to get new dependents ! Read_ALI (Idread); end if; end loop; end loop; - end Read_ALI; ---------------------- --- 357,402 ---- Free (Text); if ALIs.Table (Idread).Compile_Errors then ! Error_Msg_Name_1 := Withs.Table (W).Sfile; Error_Msg ("% had errors, must be fixed, and recompiled"); Set_Name_Table_Info (Afile, Int (No_Unit_Id)); elsif ALIs.Table (Idread).No_Object then ! Error_Msg_Name_1 := Withs.Table (W).Sfile; Error_Msg ("% must be recompiled"); Set_Name_Table_Info (Afile, Int (No_Unit_Id)); end if; ! -- If the Unit is an Interface to a Stand-Alone Library, ! -- set the Interface flag in the Withs table, so that its ! -- dependant are not considered for elaboration order. ! if ALIs.Table (Idread).Interface then ! Withs.Table (W).Interface := True; ! Interface_Library_Unit := True; ! ! -- Set the entry in the Interfaces hash table, so that other ! -- units that import this unit will set the flag in their ! -- entry in the Withs table. ! ! Interfaces.Set (Afile, True); ! ! else ! -- Otherwise, recurse to get new dependents ! ! Read_ALI (Idread); ! end if; ! ! <> null; ! ! -- If the ALI file has already been processed and is an interface, ! -- set the flag in the entry of the Withs table. ! ! elsif Interface_Library_Unit and then Interfaces.Get (Afile) then ! Withs.Table (W).Interface := True; end if; end loop; end loop; end Read_ALI; ---------------------- *************** package body ALI.Util is *** 367,484 **** loop F := Sdep.Table (D).Sfile; ! -- If this is the first time we are seeing this source file, ! -- then make a new entry in the source table. ! if Get_Name_Table_Info (F) = 0 then ! Source.Increment_Last; ! S := Source.Last; ! Set_Name_Table_Info (F, Int (S)); ! Source.Table (S).Sfile := F; ! Source.Table (S).All_Timestamps_Match := True; ! -- Initialize checksum fields ! Source.Table (S).Checksum := Sdep.Table (D).Checksum; ! Source.Table (S).All_Checksums_Match := True; ! -- In check source files mode, try to get time stamp from file ! if Opt.Check_Source_Files then ! Stamp := Source_File_Stamp (F); ! -- If we got the stamp, then set the stamp in the source ! -- table entry and mark it as set from the source so that ! -- it does not get subsequently changed. ! if Stamp (Stamp'First) /= ' ' then ! Source.Table (S).Stamp := Stamp; ! Source.Table (S).Source_Found := True; ! -- If we could not find the file, then the stamp is set ! -- from the dependency table entry (to be possibly reset ! -- if we find a later stamp in subsequent processing) ! else ! Source.Table (S).Stamp := Sdep.Table (D).Stamp; ! Source.Table (S).Source_Found := False; ! -- In All_Sources mode, flag error of file not found ! if Opt.All_Sources then ! Error_Msg_Name_1 := F; ! Error_Msg ("cannot locate %"); end if; - end if; ! -- First time for this source file, but Check_Source_Files ! -- is off, so simply initialize the stamp from the Sdep entry ! else ! Source.Table (S).Source_Found := False; ! Source.Table (S).Stamp := Sdep.Table (D).Stamp; ! end if; ! -- Here if this is not the first time for this source file, ! -- so that the source table entry is already constructed. ! else ! S := Source_Id (Get_Name_Table_Info (F)); ! -- Update checksum flag ! if not Checksums_Match ! (Sdep.Table (D).Checksum, Source.Table (S).Checksum) ! then ! Source.Table (S).All_Checksums_Match := False; ! end if; ! -- Check for time stamp mismatch ! if Sdep.Table (D).Stamp /= Source.Table (S).Stamp then ! Source.Table (S).All_Timestamps_Match := False; ! -- When we have a time stamp mismatch, we go look for the ! -- source file even if Check_Source_Files is false, since ! -- if we find it, then we can use it to resolve which of the ! -- two timestamps in the ALI files is likely to be correct. ! if not Check_Source_Files then ! Stamp := Source_File_Stamp (F); ! if Stamp (Stamp'First) /= ' ' then ! Source.Table (S).Stamp := Stamp; ! Source.Table (S).Source_Found := True; end if; - end if; ! -- If the stamp in the source table entry was set from the ! -- source file, then we do not change it (the stamp in the ! -- source file is always taken as the "right" one). ! if Source.Table (S).Source_Found then ! null; ! -- Otherwise, we have no source file available, so we guess ! -- that the later of the two timestamps is the right one. ! -- Note that this guess only affects which error messages ! -- are issued later on, not correct functionality. ! else ! if Sdep.Table (D).Stamp > Source.Table (S).Stamp then ! Source.Table (S).Stamp := Sdep.Table (D).Stamp; end if; end if; end if; - end if; ! -- Set the checksum value in the source table ! S := Source_Id (Get_Name_Table_Info (F)); ! Source.Table (S).Checksum := Sdep.Table (D).Checksum; end loop Sdep_Loop; - end Set_Source_Table; ---------------------- --- 414,533 ---- loop F := Sdep.Table (D).Sfile; ! if F /= No_Name then ! -- If this is the first time we are seeing this source file, ! -- then make a new entry in the source table. ! if Get_Name_Table_Info (F) = 0 then ! Source.Increment_Last; ! S := Source.Last; ! Set_Name_Table_Info (F, Int (S)); ! Source.Table (S).Sfile := F; ! Source.Table (S).All_Timestamps_Match := True; ! -- Initialize checksum fields ! Source.Table (S).Checksum := Sdep.Table (D).Checksum; ! Source.Table (S).All_Checksums_Match := True; ! -- In check source files mode, try to get time stamp from file ! if Opt.Check_Source_Files then ! Stamp := Source_File_Stamp (F); ! -- If we got the stamp, then set the stamp in the source ! -- table entry and mark it as set from the source so that ! -- it does not get subsequently changed. ! if Stamp (Stamp'First) /= ' ' then ! Source.Table (S).Stamp := Stamp; ! Source.Table (S).Source_Found := True; ! -- If we could not find the file, then the stamp is set ! -- from the dependency table entry (to be possibly reset ! -- if we find a later stamp in subsequent processing) ! else ! Source.Table (S).Stamp := Sdep.Table (D).Stamp; ! Source.Table (S).Source_Found := False; ! -- In All_Sources mode, flag error of file not found ! ! if Opt.All_Sources then ! Error_Msg_Name_1 := F; ! Error_Msg ("cannot locate %"); ! end if; end if; ! -- First time for this source file, but Check_Source_Files ! -- is off, so simply initialize the stamp from the Sdep entry ! else ! Source.Table (S).Source_Found := False; ! Source.Table (S).Stamp := Sdep.Table (D).Stamp; ! end if; ! -- Here if this is not the first time for this source file, ! -- so that the source table entry is already constructed. ! else ! S := Source_Id (Get_Name_Table_Info (F)); ! -- Update checksum flag ! if not Checksums_Match ! (Sdep.Table (D).Checksum, Source.Table (S).Checksum) ! then ! Source.Table (S).All_Checksums_Match := False; ! end if; ! -- Check for time stamp mismatch ! if Sdep.Table (D).Stamp /= Source.Table (S).Stamp then ! Source.Table (S).All_Timestamps_Match := False; ! -- When we have a time stamp mismatch, we go look for the ! -- source file even if Check_Source_Files is false, since ! -- if we find it, then we can use it to resolve which of the ! -- two timestamps in the ALI files is likely to be correct. ! if not Check_Source_Files then ! Stamp := Source_File_Stamp (F); ! if Stamp (Stamp'First) /= ' ' then ! Source.Table (S).Stamp := Stamp; ! Source.Table (S).Source_Found := True; ! end if; end if; ! -- If the stamp in the source table entry was set from the ! -- source file, then we do not change it (the stamp in the ! -- source file is always taken as the "right" one). ! if Source.Table (S).Source_Found then ! null; ! -- Otherwise, we have no source file available, so we guess ! -- that the later of the two timestamps is the right one. ! -- Note that this guess only affects which error messages ! -- are issued later on, not correct functionality. ! else ! if Sdep.Table (D).Stamp > Source.Table (S).Stamp then ! Source.Table (S).Stamp := Sdep.Table (D).Stamp; ! end if; end if; end if; end if; ! -- Set the checksum value in the source table ! S := Source_Id (Get_Name_Table_Info (F)); ! Source.Table (S).Checksum := Sdep.Table (D).Checksum; ! end if; end loop Sdep_Loop; end Set_Source_Table; ---------------------- *************** package body ALI.Util is *** 490,503 **** for A in ALIs.First .. ALIs.Last loop Set_Source_Table (A); end loop; - end Set_Source_Table; ------------------------- -- Time_Stamp_Mismatch -- ------------------------- ! function Time_Stamp_Mismatch (A : ALI_Id) return File_Name_Type is Src : Source_Id; -- Source file Id for the current Sdep entry --- 539,555 ---- for A in ALIs.First .. ALIs.Last loop Set_Source_Table (A); end loop; end Set_Source_Table; ------------------------- -- Time_Stamp_Mismatch -- ------------------------- ! function Time_Stamp_Mismatch ! (A : ALI_Id; ! Read_Only : Boolean := False) ! return File_Name_Type ! is Src : Source_Id; -- Source file Id for the current Sdep entry *************** package body ALI.Util is *** 508,514 **** if Opt.Minimal_Recompilation and then Sdep.Table (D).Stamp /= Source.Table (Src).Stamp then - -- If minimal recompilation is in action, replace the stamp -- of the source file in the table if checksums match. --- 560,565 ---- *************** package body ALI.Util is *** 524,538 **** end if; ! if not Source.Table (Src).Source_Found ! or else Sdep.Table (D).Stamp /= Source.Table (Src).Stamp ! then ! return Source.Table (Src).Sfile; end if; end loop; return No_File; - end Time_Stamp_Mismatch; end ALI.Util; --- 575,607 ---- end if; ! if (not Read_Only) or else Source.Table (Src).Source_Found then ! if not Source.Table (Src).Source_Found ! or else Sdep.Table (D).Stamp /= Source.Table (Src).Stamp ! then ! -- If -t debug flag set, output time stamp found/expected ! ! if Source.Table (Src).Source_Found and Debug_Flag_T then ! Write_Str ("Source: """); ! Get_Name_String (Sdep.Table (D).Sfile); ! Write_Str (Name_Buffer (1 .. Name_Len)); ! Write_Line (""""); ! ! Write_Str (" time stamp expected: "); ! Write_Line (String (Sdep.Table (D).Stamp)); ! ! Write_Str (" time stamp found: "); ! Write_Line (String (Source.Table (Src).Stamp)); ! end if; ! ! -- Return the source file ! ! return Source.Table (Src).Sfile; ! end if; end if; end loop; return No_File; end Time_Stamp_Mismatch; end ALI.Util; diff -Nrc3pad gcc-3.3.3/gcc/ada/ali-util.ads gcc-3.4.0/gcc/ada/ali-util.ads *** gcc-3.3.3/gcc/ada/ali-util.ads 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/ali-util.ads 2003-10-21 13:41:58.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- -- *************** package ALI.Util is *** 105,113 **** procedure Read_ALI (Id : ALI_Id); -- Process an ALI file which has been read and scanned by looping ! -- through all withed units in the ALI file; checking if they have ! -- been processed; and for each that hasn't, reading, scanning, and ! -- recursively processing. procedure Set_Source_Table (A : ALI_Id); -- Build source table entry corresponding to the ALI file whose id is A. --- 104,112 ---- procedure Read_ALI (Id : ALI_Id); -- Process an ALI file which has been read and scanned by looping ! -- through all withed units in the ALI file, checking if they have ! -- been processed. Each unit that has not yet been processed will ! -- be read, scanned, and processed recursively. procedure Set_Source_Table (A : ALI_Id); -- Build source table entry corresponding to the ALI file whose id is A. *************** package ALI.Util is *** 115,121 **** procedure Set_Source_Table; -- Build the entire source table. ! function Time_Stamp_Mismatch (A : ALI_Id) return File_Name_Type; -- Looks in the Source_Table and checks time stamp mismatches between -- the sources there and the sources in the Sdep section of ali file whose -- id is A. If no time stamp mismatches are found No_File is returned. --- 114,123 ---- procedure Set_Source_Table; -- Build the entire source table. ! function Time_Stamp_Mismatch ! (A : ALI_Id; ! Read_Only : Boolean := False) ! return File_Name_Type; -- Looks in the Source_Table and checks time stamp mismatches between -- the sources there and the sources in the Sdep section of ali file whose -- id is A. If no time stamp mismatches are found No_File is returned. *************** package ALI.Util is *** 124,129 **** --- 126,132 ---- -- time stamp in the Source_Table should be the actual time stamp of the -- source files. In minimal recompilation mode (Minimal_Recompilation set -- to True, no mismatch is found if the file's timestamp has not changed. + -- If Read_Only is True, missing sources are not considered. -------------------------------------------- -- Subprograms for manipulating checksums -- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-liwtio.ads gcc-3.4.0/gcc/ada/a-liwtio.ads *** gcc-3.3.3/gcc/ada/a-liwtio.ads 2002-03-14 10:58:49.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-liwtio.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-llftio.ads gcc-3.4.0/gcc/ada/a-llftio.ads *** gcc-3.3.3/gcc/ada/a-llftio.ads 2002-03-14 10:58:49.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-llftio.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-llfwti.ads gcc-3.4.0/gcc/ada/a-llfwti.ads *** gcc-3.3.3/gcc/ada/a-llfwti.ads 2002-03-14 10:58:49.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-llfwti.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-llitio.ads gcc-3.4.0/gcc/ada/a-llitio.ads *** gcc-3.3.3/gcc/ada/a-llitio.ads 2002-03-14 10:58:49.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-llitio.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-lliwti.ads gcc-3.4.0/gcc/ada/a-lliwti.ads *** gcc-3.3.3/gcc/ada/a-lliwti.ads 2002-03-14 10:58:49.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-lliwti.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/alloc.ads gcc-3.4.0/gcc/ada/alloc.ads *** gcc-3.3.3/gcc/ada/alloc.ads 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/alloc.ads 2003-04-24 17:53:57.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-ncelfu.ads gcc-3.4.0/gcc/ada/a-ncelfu.ads *** gcc-3.3.3/gcc/ada/a-ncelfu.ads 2002-03-14 10:58:49.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-ncelfu.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-ngcefu.adb gcc-3.4.0/gcc/ada/a-ngcefu.adb *** gcc-3.3.3/gcc/ada/a-ngcefu.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-ngcefu.adb 2003-10-21 13:41:53.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-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.Numerics.Generic_Comple *** 306,311 **** --- 305,312 ---- Result : Complex; begin + -- For very small argument, sin (x) = x. + if abs Re (X) < Square_Root_Epsilon and then abs Im (X) < Square_Root_Epsilon then *************** package body Ada.Numerics.Generic_Comple *** 322,327 **** --- 323,330 ---- elsif Im (Result) < -PI_2 then Set_Im (Result, -(PI + Im (X))); end if; + + return Result; end if; Result := -Complex_I * Log (Complex_I * X + Sqrt (1.0 - X * X)); *************** package body Ada.Numerics.Generic_Comple *** 480,495 **** --------- function Exp (X : Complex) return Complex is ! EXP_RE_X : Real'Base := Exp (Re (X)); begin return Compose_From_Cartesian (EXP_RE_X * Cos (Im (X)), EXP_RE_X * Sin (Im (X))); end Exp; - function Exp (X : Imaginary) return Complex is ! ImX : Real'Base := Im (X); begin return Compose_From_Cartesian (Cos (ImX), Sin (ImX)); --- 483,497 ---- --------- function Exp (X : Complex) return Complex is ! EXP_RE_X : constant Real'Base := Exp (Re (X)); begin return Compose_From_Cartesian (EXP_RE_X * Cos (Im (X)), EXP_RE_X * Sin (Im (X))); end Exp; function Exp (X : Imaginary) return Complex is ! ImX : constant Real'Base := Im (X); begin return Compose_From_Cartesian (Cos (ImX), Sin (ImX)); diff -Nrc3pad gcc-3.3.3/gcc/ada/a-ngcefu.ads gcc-3.4.0/gcc/ada/a-ngcefu.ads *** gcc-3.3.3/gcc/ada/a-ngcefu.ads 2002-03-14 10:58:49.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-ngcefu.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-ngcoty.adb gcc-3.4.0/gcc/ada/a-ngcoty.adb *** gcc-3.3.3/gcc/ada/a-ngcoty.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-ngcoty.adb 2003-10-21 13:41:53.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-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.Numerics.Generic_Comple *** 55,66 **** -- If either component overflows, try to scale. if abs (X) > R'Last then ! X := R' (4.0) * (R'(Left.Re / 2.0) * R'(Right.Re / 2.0) - R'(Left.Im / 2.0) * R'(Right.Im / 2.0)); end if; if abs (Y) > R'Last then ! Y := R' (4.0) * (R'(Left.Re / 2.0) * R'(Right.Im / 2.0) - R'(Left.Im / 2.0) * R'(Right.Re / 2.0)); end if; --- 54,65 ---- -- If either component overflows, try to scale. if abs (X) > R'Last then ! X := R'(4.0) * (R'(Left.Re / 2.0) * R'(Right.Re / 2.0) - R'(Left.Im / 2.0) * R'(Right.Im / 2.0)); end if; if abs (Y) > R'Last then ! Y := R'(4.0) * (R'(Left.Re / 2.0) * R'(Right.Im / 2.0) - R'(Left.Im / 2.0) * R'(Right.Re / 2.0)); end if; *************** package body Ada.Numerics.Generic_Comple *** 153,159 **** Exp := Exp / 2; end loop; ! return R ' (1.0) / Result; exception --- 152,158 ---- Exp := Exp / 2; end loop; ! return R'(1.0) / Result; exception *************** package body Ada.Numerics.Generic_Comple *** 164,170 **** end "**"; function "**" (Left : Imaginary; Right : Integer) return Complex is ! M : R := R (Left) ** Right; begin case Right mod 4 is when 0 => return (M, 0.0); --- 163,169 ---- end "**"; function "**" (Left : Imaginary; Right : Integer) return Complex is ! M : constant R := R (Left) ** Right; begin case Right mod 4 is when 0 => return (M, 0.0); *************** package body Ada.Numerics.Generic_Comple *** 620,626 **** return abs (X.Im); end if; - elsif Im2 = 0.0 then return abs (X.Re); --- 619,624 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-ngcoty.ads gcc-3.4.0/gcc/ada/a-ngcoty.ads *** gcc-3.3.3/gcc/ada/a-ngcoty.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-ngcoty.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-ngelfu.adb gcc-3.4.0/gcc/ada/a-ngelfu.adb *** gcc-3.3.3/gcc/ada/a-ngelfu.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-ngelfu.adb 2003-10-21 13:41:53.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-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.Numerics.Generic_Elemen *** 54,73 **** subtype T is Float_Type'Base; subtype Double is Aux.Double; ! Two_Pi : constant T := 2.0 * Pi; ! Half_Pi : constant T := Pi / 2.0; ! Fourth_Pi : constant T := Pi / 4.0; - Epsilon : constant T := 2.0 ** (1 - T'Model_Mantissa); - IEpsilon : constant T := 2.0 ** (T'Model_Mantissa - 1); - Log_Epsilon : constant T := T (1 - T'Model_Mantissa) * Log_Two; Half_Log_Epsilon : constant T := T (1 - T'Model_Mantissa) * Half_Log_Two; Log_Inverse_Epsilon : constant T := T (T'Model_Mantissa - 1) * Log_Two; Sqrt_Epsilon : constant T := Sqrt_Two ** (1 - T'Model_Mantissa); - DEpsilon : constant Double := Double (Epsilon); - DIEpsilon : constant Double := Double (IEpsilon); - ----------------------- -- Local Subprograms -- ----------------------- --- 53,65 ---- subtype T is Float_Type'Base; subtype Double is Aux.Double; ! Two_Pi : constant T := 2.0 * Pi; ! Half_Pi : constant T := Pi / 2.0; Half_Log_Epsilon : constant T := T (1 - T'Model_Mantissa) * Half_Log_Two; Log_Inverse_Epsilon : constant T := T (T'Model_Mantissa - 1) * Log_Two; Sqrt_Epsilon : constant T := Sqrt_Two ** (1 - T'Model_Mantissa); ----------------------- -- Local Subprograms -- ----------------------- *************** package body Ada.Numerics.Generic_Elemen *** 564,570 **** function Cosh (X : Float_Type'Base) return Float_Type'Base is Lnv : constant Float_Type'Base := 8#0.542714#; V2minus1 : constant Float_Type'Base := 0.13830_27787_96019_02638E-4; ! Y : Float_Type'Base := abs X; Z : Float_Type'Base; begin --- 556,562 ---- function Cosh (X : Float_Type'Base) return Float_Type'Base is Lnv : constant Float_Type'Base := 8#0.542714#; V2minus1 : constant Float_Type'Base := 0.13830_27787_96019_02638E-4; ! Y : constant Float_Type'Base := abs X; Z : Float_Type'Base; begin *************** package body Ada.Numerics.Generic_Elemen *** 623,629 **** else T := T / Cycle * Two_Pi; ! return Cos (T) / Sin (T); end if; end Cot; --- 615,621 ---- else T := T / Cycle * Two_Pi; ! return Cos (T) / Sin (T); end if; end Cot; *************** package body Ada.Numerics.Generic_Elemen *** 862,868 **** -- an exact value in those cases. It is not clear that -- this is worth the extra test though. ! return Float_Type'Base (Aux.Sin (Double (T / Cycle * Two_Pi))); end Sin; ---------- --- 854,860 ---- -- an exact value in those cases. It is not clear that -- this is worth the extra test though. ! return Float_Type'Base (Aux.Sin (Double (T / Cycle * Two_Pi))); end Sin; ---------- *************** package body Ada.Numerics.Generic_Elemen *** 872,878 **** function Sinh (X : Float_Type'Base) return Float_Type'Base is Lnv : constant Float_Type'Base := 8#0.542714#; V2minus1 : constant Float_Type'Base := 0.13830_27787_96019_02638E-4; ! Y : Float_Type'Base := abs X; F : constant Float_Type'Base := Y * Y; Z : Float_Type'Base; --- 864,870 ---- function Sinh (X : Float_Type'Base) return Float_Type'Base is Lnv : constant Float_Type'Base := 8#0.542714#; V2minus1 : constant Float_Type'Base := 0.13830_27787_96019_02638E-4; ! Y : constant Float_Type'Base := abs X; F : constant Float_Type'Base := Y * Y; Z : Float_Type'Base; *************** package body Ada.Numerics.Generic_Elemen *** 1012,1019 **** Half_Ln3 : constant Float_Type'Base := 0.54930_61443; P, Q, R : Float_Type'Base; ! Y : Float_Type'Base := abs X; ! G : Float_Type'Base := Y * Y; Float_Type_Digits_15_Or_More : constant Boolean := Float_Type'Digits > 14; --- 1004,1011 ---- Half_Ln3 : constant Float_Type'Base := 0.54930_61443; P, Q, R : Float_Type'Base; ! Y : constant Float_Type'Base := abs X; ! G : constant Float_Type'Base := Y * Y; Float_Type_Digits_15_Or_More : constant Boolean := Float_Type'Digits > 14; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-ngelfu.ads gcc-3.4.0/gcc/ada/a-ngelfu.ads *** gcc-3.3.3/gcc/ada/a-ngelfu.ads 2002-03-14 10:58:50.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-ngelfu.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-nlcefu.ads gcc-3.4.0/gcc/ada/a-nlcefu.ads *** gcc-3.3.3/gcc/ada/a-nlcefu.ads 2002-03-14 10:58:50.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-nlcefu.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-nlcoty.ads gcc-3.4.0/gcc/ada/a-nlcoty.ads *** gcc-3.3.3/gcc/ada/a-nlcoty.ads 2002-03-14 10:58:50.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-nlcoty.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-nlelfu.ads gcc-3.4.0/gcc/ada/a-nlelfu.ads *** gcc-3.3.3/gcc/ada/a-nlelfu.ads 2002-03-14 10:58:51.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-nlelfu.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-nllcef.ads gcc-3.4.0/gcc/ada/a-nllcef.ads *** gcc-3.3.3/gcc/ada/a-nllcef.ads 2002-03-14 10:58:51.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-nllcef.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-nllcty.ads gcc-3.4.0/gcc/ada/a-nllcty.ads *** gcc-3.3.3/gcc/ada/a-nllcty.ads 2002-03-14 10:58:51.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-nllcty.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-nllefu.ads gcc-3.4.0/gcc/ada/a-nllefu.ads *** gcc-3.3.3/gcc/ada/a-nllefu.ads 2002-03-14 10:58:51.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-nllefu.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-nscefu.ads gcc-3.4.0/gcc/ada/a-nscefu.ads *** gcc-3.3.3/gcc/ada/a-nscefu.ads 2002-03-14 10:58:51.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-nscefu.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-nscoty.ads gcc-3.4.0/gcc/ada/a-nscoty.ads *** gcc-3.3.3/gcc/ada/a-nscoty.ads 2002-03-14 10:58:51.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-nscoty.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-nselfu.ads gcc-3.4.0/gcc/ada/a-nselfu.ads *** gcc-3.3.3/gcc/ada/a-nselfu.ads 2002-03-14 10:58:51.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-nselfu.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-nucoty.ads gcc-3.4.0/gcc/ada/a-nucoty.ads *** gcc-3.3.3/gcc/ada/a-nucoty.ads 2002-03-14 10:58:51.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-nucoty.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-nudira.adb gcc-3.4.0/gcc/ada/a-nudira.adb *** gcc-3.3.3/gcc/ada/a-nudira.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-nudira.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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.Numerics.Discrete_Rando *** 54,59 **** --- 53,62 ---- type Pointer is access all State; Need_64 : constant Boolean := Rst'Pos (Rst'Last) > Int'Last; + -- Set if we need more than 32 bits in the result. In practice we will + -- only use the meaningful 48 bits of any 64 bit number generated, since + -- if more than 48 bits are required, we split the computation into two + -- separate parts, since the algorithm does not behave above 48 bits. ----------------------- -- Local Subprograms -- *************** package body Ada.Numerics.Discrete_Rando *** 110,116 **** Temp := Temp + Genp.Q; end if; ! TF := Offs + (Flt (Temp) * Flt (Genp.P) + Flt (Genp.X1)) * Genp.Scl; -- Pathological, but there do exist cases where the rounding implicit -- in calculating the scale factor will cause rounding to 'Last + 1. --- 113,119 ---- Temp := Temp + Genp.Q; end if; ! TF := Offs + (Flt (Temp) * Flt (Genp.P) + Flt (Genp.X1)) * Genp.Scl; -- Pathological, but there do exist cases where the rounding implicit -- in calculating the scale factor will cause rounding to 'Last + 1. *************** package body Ada.Numerics.Discrete_Rando *** 125,131 **** else return Rst'Val (Int (TF)); end if; - end Random; ----------- --- 128,133 ---- *************** package body Ada.Numerics.Discrete_Rando *** 145,151 **** X2 := Square_Mod_N (X2, K2); end loop; ! -- eliminate effects of small Initiators. Genp.all := (X1 => X1, --- 147,153 ---- X2 := Square_Mod_N (X2, K2); end loop; ! -- Eliminate effects of small Initiators Genp.all := (X1 => X1, diff -Nrc3pad gcc-3.3.3/gcc/ada/a-nudira.ads gcc-3.4.0/gcc/ada/a-nudira.ads *** gcc-3.3.3/gcc/ada/a-nudira.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-nudira.ads 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,13 **** -- -- -- 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 -- --- 6,12 ---- -- -- -- 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 -- *************** generic *** 53,58 **** --- 52,66 ---- package Ada.Numerics.Discrete_Random is + -- The algorithm used here is reliable from a required statistical point + -- of view only up to 48 bits. We try to behave reasonably in the case + -- of larger types, but we can't guarantee the required properties. + -- So generate a warning for these (slightly) dubious cases. + + pragma Compile_Time_Warning + (Result_Subtype'Size > 48, + "statistical properties not guaranteed for size '> 48"); + -- Basic facilities. type Generator is limited private; *************** private *** 78,84 **** subtype Int is Interfaces.Integer_32; subtype Rst is Result_Subtype; ! type Flt is digits 14; RstF : constant Flt := Flt (Rst'Pos (Rst'First)); RstL : constant Flt := Flt (Rst'Pos (Rst'Last)); --- 86,94 ---- subtype Int is Interfaces.Integer_32; subtype Rst is Result_Subtype; ! -- We prefer to use 14 digits for Flt, but some targets are more limited ! ! type Flt is digits Positive'Min (14, Long_Long_Float'Digits); RstF : constant Flt := Flt (Rst'Pos (Rst'First)); RstL : constant Flt := Flt (Rst'Pos (Rst'Last)); diff -Nrc3pad gcc-3.3.3/gcc/ada/a-nuelfu.ads gcc-3.4.0/gcc/ada/a-nuelfu.ads *** gcc-3.3.3/gcc/ada/a-nuelfu.ads 2002-03-14 10:58:51.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-nuelfu.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-nuflra.adb gcc-3.4.0/gcc/ada/a-nuflra.adb *** gcc-3.3.3/gcc/ada/a-nuflra.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-nuflra.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-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.Numerics.Float_Random i *** 214,220 **** X2 := Square_Mod_N (X2, K2); end loop; - Genp.all := (X1 => X1, X2 => X2, --- 213,218 ---- *************** package body Ada.Numerics.Float_Random i *** 239,248 **** ------------------ function Square_Mod_N (X, N : Int) return Int is ! Temp : Flt := Flt (X) * Flt (X); ! Div : Int := Int (Temp / Flt (N)); begin Div := Int (Temp - Flt (Div) * Flt (N)); if Div < 0 then --- 237,247 ---- ------------------ function Square_Mod_N (X, N : Int) return Int is ! Temp : constant Flt := Flt (X) * Flt (X); ! Div : Int; begin + Div := Int (Temp / Flt (N)); Div := Int (Temp - Flt (Div) * Flt (N)); if Div < 0 then diff -Nrc3pad gcc-3.3.3/gcc/ada/a-nuflra.ads gcc-3.4.0/gcc/ada/a-nuflra.ads *** gcc-3.3.3/gcc/ada/a-nuflra.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-nuflra.ads 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1992-1998 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 -- --- 6,12 ---- -- -- -- 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 -- *************** *** 44,51 **** -- excellent randomness properties. For further details, see the -- paper "Fast Generation of Trustworthy Random Numbers", by Robert -- Eachus, which describes both the algorithm and the efficient ! -- implementation approach used here. This paper is available at ! -- the Ada Core Technologies web site (http://www.gnat.com). with Interfaces; --- 43,49 ---- -- excellent randomness properties. For further details, see the -- paper "Fast Generation of Trustworthy Random Numbers", by Robert -- Eachus, which describes both the algorithm and the efficient ! -- implementation approach used here. with Interfaces; *************** package Ada.Numerics.Float_Random is *** 76,82 **** private type Int is new Interfaces.Integer_32; ! type Flt is digits 14; K1 : constant := 94_833_359; K1F : constant := 94_833_359.0; --- 74,83 ---- private type Int is new Interfaces.Integer_32; ! ! -- We prefer to use 14 digits for Flt, but some targets are more limited ! ! type Flt is digits Positive'Min (14, Long_Long_Float'Digits); K1 : constant := 94_833_359; K1F : constant := 94_833_359.0; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-numaux.ads gcc-3.4.0/gcc/ada/a-numaux.ads *** gcc-3.3.3/gcc/ada/a-numaux.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-numaux.ads 2004-01-05 15:20:43.000000000 +0000 *************** *** 7,14 **** -- S p e c -- -- (C Library Version, non-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, non-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- -- *************** *** 40,48 **** -- One advantage of using this package is that it will interface directly to -- hardware instructions, such as the those provided on the Intel x86. ! -- Note: there are two versions of this package. One using the normal IEEE ! -- 64-bit double format (which is this version), and one using 80-bit x86 ! -- long double (see file 4onumaux.ads). package Ada.Numerics.Aux is pragma Pure (Aux); --- 39,49 ---- -- One advantage of using this package is that it will interface directly to -- hardware instructions, such as the those provided on the Intel x86. ! -- This version is for use with normal Unix math functions. Alternative ! -- packages are used on OpenVMS (different import names), VxWorks (no ! -- need for the -lm Linker_Options), and on the x86 (where we have two ! -- versions one using inline ASM, and one importing from the C long ! -- routines that take 80-bit arguments). package Ada.Numerics.Aux is pragma Pure (Aux); *************** pragma Pure (Aux); *** 50,97 **** pragma Linker_Options ("-lm"); 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; --- 51,111 ---- pragma Linker_Options ("-lm"); 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/a-numeri.ads gcc-3.4.0/gcc/ada/a-numeri.ads *** gcc-3.3.3/gcc/ada/a-numeri.ads 2002-03-14 10:58:51.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-numeri.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-reatim.adb gcc-3.4.0/gcc/ada/a-reatim.adb *** gcc-3.3.3/gcc/ada/a-reatim.adb 2002-03-14 10:58:51.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-reatim.adb 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,13 **** -- -- -- 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- -- --- 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,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). -- -- -- ------------------------------------------------------------------------------ --- 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 Ada.Real_Time is *** 185,191 **** if T_Val < 0.5 then SC := 0; else ! SC := Seconds_Count (Time_Span' (T_Val - 0.5)); end if; if T < 0.0 then --- 185,191 ---- if T_Val < 0.5 then SC := 0; else ! SC := Seconds_Count (Time_Span'(T_Val - 0.5)); end if; if T < 0.0 then diff -Nrc3pad gcc-3.3.3/gcc/ada/a-reatim.ads gcc-3.4.0/gcc/ada/a-reatim.ads *** gcc-3.3.3/gcc/ada/a-reatim.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-reatim.ads 2003-10-21 13:41:53.000000000 +0000 *************** *** 6,13 **** -- -- -- 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 -- --- 6,12 ---- -- -- -- 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 -- *************** package Ada.Real_Time is *** 48,56 **** type Time_Span is private; Time_Span_First : constant Time_Span; ! Time_Span_Last : constant Time_Span; ! Time_Span_Zero : constant Time_Span; ! Time_Span_Unit : constant Time_Span; Tick : constant Time_Span; function Clock return Time; --- 47,55 ---- type Time_Span is private; Time_Span_First : constant Time_Span; ! Time_Span_Last : constant Time_Span; ! Time_Span_Zero : constant Time_Span; ! Time_Span_Unit : constant Time_Span; Tick : constant Time_Span; function Clock return Time; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-retide.adb gcc-3.4.0/gcc/ada/a-retide.adb *** gcc-3.3.3/gcc/ada/a-retide.adb 2002-10-28 16:19:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-retide.adb 2003-04-24 17:53:53.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 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-retide.ads gcc-3.4.0/gcc/ada/a-retide.ads *** gcc-3.3.3/gcc/ada/a-retide.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-retide.ads 2003-10-21 13:41:54.000000000 +0000 *************** *** 1,4 **** ! ------------------------------------------------------------------------------- -- -- -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- --- 1,4 ---- ! ------------------------------------------------------------------------------ -- -- -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1992-1999, 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. -- -- -- ------------------------------------------------------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/argv.c gcc-3.4.0/gcc/ada/argv.c *** gcc-3.3.3/gcc/ada/argv.c 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/argv.c 2003-11-04 12:51:45.000000000 +0000 *************** *** 6,13 **** * * * C Implementation File * * * ! * * ! * 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 ---- * * * C Implementation File * * * ! * 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- * *************** int gnat_argc = 0; *** 62,90 **** const char **gnat_argv = (const char **) 0; const char **gnat_envp = (const char **) 0; int ! __gnat_arg_count () { return gnat_argc; } int ! __gnat_len_arg (arg_num) ! int arg_num; { return strlen (gnat_argv[arg_num]); } void ! __gnat_fill_arg (a, i) ! char *a; ! int i; { strncpy (a, gnat_argv[i], strlen(gnat_argv[i])); } int ! __gnat_env_count () { int i; --- 61,95 ---- const char **gnat_argv = (const char **) 0; const char **gnat_envp = (const char **) 0; + #ifdef _WIN32 + /* Note that on Windows environment the environ point to a buffer that could + be reallocated if needed. It means that gnat_envp needs to be updated + before using gnat_envp to point to the right environment space */ + #include + /* for the environ variable definition */ + #define gnat_envp (environ) + #endif + int ! __gnat_arg_count (void) { return gnat_argc; } int ! __gnat_len_arg (int arg_num) { return strlen (gnat_argv[arg_num]); } void ! __gnat_fill_arg (char *a, int i) { strncpy (a, gnat_argv[i], strlen(gnat_argv[i])); } int ! __gnat_env_count (void) { int i; *************** __gnat_env_count () *** 94,109 **** } int ! __gnat_len_env (env_num) ! int env_num; { return strlen (gnat_envp[env_num]); } void ! __gnat_fill_env (a, i) ! char *a; ! int i; { strncpy (a, gnat_envp[i], strlen (gnat_envp[i])); } --- 99,111 ---- } int ! __gnat_len_env (int env_num) { return strlen (gnat_envp[env_num]); } void ! __gnat_fill_env (char *a, int i) { strncpy (a, gnat_envp[i], strlen (gnat_envp[i])); } diff -Nrc3pad gcc-3.3.3/gcc/ada/a-sequio.adb gcc-3.4.0/gcc/ada/a-sequio.adb *** gcc-3.3.3/gcc/ada/a-sequio.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-sequio.adb 2003-12-15 11:51:00.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1992-1999, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** *** 39,44 **** --- 38,44 ---- with Interfaces.C_Streams; use Interfaces.C_Streams; with System; + with System.CRTL; with System.File_Control_Block; with System.File_IO; with System.Storage_Elements; *************** package body Ada.Sequential_IO is *** 59,64 **** --- 59,66 ---- function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode); function To_SIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode); + use type System.CRTL.size_t; + ----------- -- Close -- ----------- *************** package body Ada.Sequential_IO is *** 184,198 **** RsizS : constant SSE.Storage_Offset := SSE.Storage_Offset (Rsiz - 1); ! subtype SA is SSE.Storage_Array (0 .. RsizS); type SAP is access all SA; type ItemP is access all Element_Type; pragma Warnings (Off); ! -- We have to turn warnings off for this function, because ! -- it gets analyzed for all types, including ones which ! -- can't possibly come this way, and for which the size ! -- of the access types differs. function To_ItemP is new Unchecked_Conversion (SAP, ItemP); --- 186,206 ---- RsizS : constant SSE.Storage_Offset := SSE.Storage_Offset (Rsiz - 1); ! type SA is new SSE.Storage_Array (0 .. RsizS); ! ! for SA'Alignment use Standard'Maximum_Alignment; ! -- We will perform an unchecked conversion of a pointer-to-SA ! -- into pointer-to-Element_Type. We need to ensure that the ! -- source is always at least as strictly aligned as the target. ! type SAP is access all SA; type ItemP is access all Element_Type; pragma Warnings (Off); ! -- We have to turn warnings off for function To_ItemP, ! -- because it gets analyzed for all types, including ones ! -- which can't possibly come this way, and for which the ! -- size of the access types differs. function To_ItemP is new Unchecked_Conversion (SAP, ItemP); diff -Nrc3pad gcc-3.3.3/gcc/ada/a-sequio.ads gcc-3.4.0/gcc/ada/a-sequio.ads *** gcc-3.3.3/gcc/ada/a-sequio.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-sequio.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-sfteio.ads gcc-3.4.0/gcc/ada/a-sfteio.ads *** gcc-3.3.3/gcc/ada/a-sfteio.ads 2002-03-14 10:58:52.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-sfteio.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-sfwtio.ads gcc-3.4.0/gcc/ada/a-sfwtio.ads *** gcc-3.3.3/gcc/ada/a-sfwtio.ads 2002-03-14 10:58:52.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-sfwtio.ads 2003-04-24 17:53:53.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-siocst.adb gcc-3.4.0/gcc/ada/a-siocst.adb *** gcc-3.3.3/gcc/ada/a-siocst.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-siocst.adb 2003-10-21 13:41:54.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-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.Sequential_IO.C_Streams *** 64,80 **** procedure Open (File : in out File_Type; ! Mode : in File_Mode; ! C_Stream : in FILEs; ! Form : in String := "") is ! File_Control_Block : SIO.Sequential_AFCB; begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => File_Control_Block, Mode => To_FCB (Mode), ! Name => "", Form => Form, Amethod => 'Q', Creat => False, --- 63,83 ---- procedure Open (File : in out File_Type; ! Mode : File_Mode; ! C_Stream : FILEs; ! Form : String := ""; ! Name : String := "") is ! Dummy_File_Control_Block : SIO.Sequential_AFCB; ! pragma Warnings (Off, Dummy_File_Control_Block); ! -- Yes, we know this is never assigned a value, only the tag ! -- is used for dispatching purposes, so that's expected. begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => Dummy_File_Control_Block, Mode => To_FCB (Mode), ! Name => Name, Form => Form, Amethod => 'Q', Creat => False, diff -Nrc3pad gcc-3.3.3/gcc/ada/a-siocst.ads gcc-3.4.0/gcc/ada/a-siocst.ads *** gcc-3.3.3/gcc/ada/a-siocst.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-siocst.ads 2003-10-21 13:41:54.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1992,1993,1994,1995 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-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 Ada.Sequential_IO.C_Streams is *** 48,56 **** procedure Open (File : in out File_Type; ! Mode : in File_Mode; ! C_Stream : in ICS.FILEs; ! Form : in String := ""); -- Create new file from existing stream end Ada.Sequential_IO.C_Streams; --- 47,56 ---- procedure Open (File : in out File_Type; ! Mode : File_Mode; ! C_Stream : ICS.FILEs; ! Form : String := ""; ! Name : String := ""); -- Create new file from existing stream end Ada.Sequential_IO.C_Streams; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-siteio.ads gcc-3.4.0/gcc/ada/a-siteio.ads *** gcc-3.3.3/gcc/ada/a-siteio.ads 2002-03-14 10:58:52.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-siteio.ads 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-siwtio.ads gcc-3.4.0/gcc/ada/a-siwtio.ads *** gcc-3.3.3/gcc/ada/a-siwtio.ads 2002-03-14 10:58:52.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-siwtio.ads 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-ssicst.adb gcc-3.4.0/gcc/ada/a-ssicst.adb *** gcc-3.3.3/gcc/ada/a-ssicst.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-ssicst.adb 2003-10-21 13:41:54.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-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.Streams.Stream_IO.C_Str *** 62,78 **** procedure Open (File : in out File_Type; ! Mode : in File_Mode; ! C_Stream : in FILEs; ! Form : in String := "") is ! File_Control_Block : Stream_AFCB; begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => File_Control_Block, Mode => To_FCB (Mode), ! Name => "", Form => Form, Amethod => 'S', Creat => False, --- 61,81 ---- procedure Open (File : in out File_Type; ! Mode : File_Mode; ! C_Stream : FILEs; ! Form : String := ""; ! Name : String := "") is ! Dummy_File_Control_Block : Stream_AFCB; ! pragma Warnings (Off, Dummy_File_Control_Block); ! -- Yes, we know this is never assigned a value, only the tag ! -- is used for dispatching purposes, so that's expected. begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => Dummy_File_Control_Block, Mode => To_FCB (Mode), ! Name => Name, Form => Form, Amethod => 'S', Creat => False, diff -Nrc3pad gcc-3.3.3/gcc/ada/a-ssicst.ads gcc-3.4.0/gcc/ada/a-ssicst.ads *** gcc-3.3.3/gcc/ada/a-ssicst.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-ssicst.ads 2003-10-21 13:41:54.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1992,1993,1994,1995 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-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 Ada.Streams.Stream_IO.C_Streams *** 47,55 **** procedure Open (File : in out File_Type; ! Mode : in File_Mode; ! C_Stream : in ICS.FILEs; ! Form : in String := ""); -- Create new file from existing stream end Ada.Streams.Stream_IO.C_Streams; --- 46,55 ---- procedure Open (File : in out File_Type; ! Mode : File_Mode; ! C_Stream : ICS.FILEs; ! Form : String := ""; ! Name : String := ""); -- Create new file from existing stream end Ada.Streams.Stream_IO.C_Streams; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-ssitio.ads gcc-3.4.0/gcc/ada/a-ssitio.ads *** gcc-3.3.3/gcc/ada/a-ssitio.ads 2002-03-14 10:58:52.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-ssitio.ads 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-ssiwti.ads gcc-3.4.0/gcc/ada/a-ssiwti.ads *** gcc-3.3.3/gcc/ada/a-ssiwti.ads 2002-03-14 10:58:52.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-ssiwti.ads 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-stmaco.ads gcc-3.4.0/gcc/ada/a-stmaco.ads *** gcc-3.3.3/gcc/ada/a-stmaco.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-stmaco.ads 2003-04-24 17:53:54.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/a-storio.adb gcc-3.4.0/gcc/ada/a-storio.adb *** gcc-3.3.3/gcc/ada/a-storio.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-storio.adb 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992,1993,1994 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/a-storio.ads gcc-3.4.0/gcc/ada/a-storio.ads *** gcc-3.3.3/gcc/ada/a-storio.ads 2002-03-14 10:58:52.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-storio.ads 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-strbou.adb gcc-3.4.0/gcc/ada/a-strbou.adb *** gcc-3.3.3/gcc/ada/a-strbou.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-strbou.adb 2003-10-21 13:41:54.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-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,154 **** -- -- ------------------------------------------------------------------------------ - with Ada.Strings.Maps; use Ada.Strings.Maps; - with Ada.Strings.Search; - package body Ada.Strings.Bounded is package body Generic_Bounded_Length is --------- - -- "&" -- - --------- - - function "&" - (Left : in Bounded_String; - Right : in Bounded_String) - return Bounded_String - is - Result : Bounded_String; - Llen : constant Length_Range := Left.Length; - Rlen : constant Length_Range := Right.Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen > Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - end if; - - return Result; - end "&"; - - function "&" - (Left : in Bounded_String; - Right : in String) - return Bounded_String - is - Result : Bounded_String; - Llen : constant Length_Range := Left.Length; - - Nlen : constant Natural := Llen + Right'Length; - - begin - if Nlen > Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right; - end if; - return Result; - end "&"; - - function "&" - (Left : in String; - Right : in Bounded_String) - return Bounded_String - is - Result : Bounded_String; - Llen : constant Length_Range := Left'Length; - Rlen : constant Length_Range := Right.Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen > Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Length := Nlen; - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - end if; - - return Result; - end "&"; - - function "&" - (Left : in Bounded_String; - Right : in Character) - return Bounded_String - is - Result : Bounded_String; - Llen : constant Length_Range := Left.Length; - - begin - if Llen = Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Length := Llen + 1; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Result.Length) := Right; - end if; - - return Result; - end "&"; - - function "&" - (Left : in Character; - Right : in Bounded_String) - return Bounded_String - is - Result : Bounded_String; - Rlen : Length_Range := Right.Length; - - begin - if Rlen = Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Length := Rlen + 1; - Result.Data (1) := Left; - Result.Data (2 .. Result.Length) := Right.Data (1 .. Rlen); - end if; - - return Result; - end "&"; - - --------- -- "*" -- --------- --- 31,41 ---- *************** package body Ada.Strings.Bounded is *** 157,176 **** Right : in Character) return Bounded_String is - Result : Bounded_String; - begin ! if Left > Max_Length then ! raise Ada.Strings.Length_Error; ! else ! Result.Length := Left; ! ! for J in 1 .. Left loop ! Result.Data (J) := Right; ! end loop; ! end if; ! ! return Result; end "*"; function "*" --- 44,51 ---- Right : in Character) return Bounded_String is begin ! return Times (Left, Right, Max_Length); end "*"; function "*" *************** package body Ada.Strings.Bounded is *** 178,1335 **** Right : in String) return Bounded_String is - Result : Bounded_String; - Pos : Positive := 1; - Rlen : constant Natural := Right'Length; - Nlen : constant Natural := Left * Rlen; - begin ! if Nlen > Max_Length then ! raise Ada.Strings.Index_Error; ! else ! Result.Length := Nlen; ! ! if Nlen > 0 then ! for J in 1 .. Left loop ! Result.Data (Pos .. Pos + Rlen - 1) := Right; ! Pos := Pos + Rlen; ! end loop; ! end if; ! end if; ! ! return Result; ! end "*"; ! ! function "*" ! (Left : in Natural; ! Right : in Bounded_String) ! return Bounded_String ! is ! Result : Bounded_String; ! Pos : Positive := 1; ! Rlen : constant Length_Range := Right.Length; ! Nlen : constant Natural := Left * Rlen; ! ! begin ! if Nlen > Max_Length then ! raise Ada.Strings.Length_Error; ! ! else ! Result.Length := Nlen; ! ! if Nlen > 0 then ! for J in 1 .. Left loop ! Result.Data (Pos .. Pos + Rlen - 1) := ! Right.Data (1 .. Rlen); ! Pos := Pos + Rlen; ! end loop; ! end if; ! end if; ! ! return Result; end "*"; - --------- - -- "<" -- - --------- - - function "<" (Left, Right : in Bounded_String) return Boolean is - begin - return Left.Data (1 .. Left.Length) < Right.Data (1 .. Right.Length); - end "<"; - - function "<" - (Left : in Bounded_String; - Right : in String) - return Boolean - is - begin - return Left.Data (1 .. Left.Length) < Right; - end "<"; - - function "<" - (Left : in String; - Right : in Bounded_String) - return Boolean - is - begin - return Left < Right.Data (1 .. Right.Length); - end "<"; - - ---------- - -- "<=" -- - ---------- - - function "<=" (Left, Right : in Bounded_String) return Boolean is - begin - return Left.Data (1 .. Left.Length) <= Right.Data (1 .. Right.Length); - end "<="; - - function "<=" - (Left : in Bounded_String; - Right : in String) - return Boolean - is - begin - return Left.Data (1 .. Left.Length) <= Right; - end "<="; - - function "<=" - (Left : in String; - Right : in Bounded_String) - return Boolean - is - begin - return Left <= Right.Data (1 .. Right.Length); - end "<="; - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : in Bounded_String) return Boolean is - begin - return Left.Length = Right.Length - and then Left.Data (1 .. Left.Length) = - Right.Data (1 .. Right.Length); - end "="; - - function "=" (Left : in Bounded_String; Right : in String) - return Boolean is - begin - return Left.Length = Right'Length - and then Left.Data (1 .. Left.Length) = Right; - end "="; - - function "=" (Left : in String; Right : in Bounded_String) - return Boolean is - begin - return Left'Length = Right.Length - and then Left = Right.Data (1 .. Right.Length); - end "="; - - --------- - -- ">" -- - --------- - - function ">" (Left, Right : in Bounded_String) return Boolean is - begin - return Left.Data (1 .. Left.Length) > Right.Data (1 .. Right.Length); - end ">"; - - function ">" - (Left : in Bounded_String; - Right : in String) - return Boolean - is - begin - return Left.Data (1 .. Left.Length) > Right; - end ">"; - - function ">" - (Left : in String; - Right : in Bounded_String) - return Boolean - is - begin - return Left > Right.Data (1 .. Right.Length); - end ">"; - - ---------- - -- ">=" -- - ---------- - - function ">=" (Left, Right : in Bounded_String) return Boolean is - begin - return Left.Data (1 .. Left.Length) >= Right.Data (1 .. Right.Length); - end ">="; - - function ">=" - (Left : in Bounded_String; - Right : in String) - return Boolean - is - begin - return Left.Data (1 .. Left.Length) >= Right; - end ">="; - - function ">=" - (Left : in String; - Right : in Bounded_String) - return Boolean - is - begin - return Left >= Right.Data (1 .. Right.Length); - end ">="; - - ------------ - -- Append -- - ------------ - - -- Case of Bounded_String and Bounded_String - - function Append - (Left, Right : in Bounded_String; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_String - is - Result : Bounded_String; - Llen : constant Length_Range := Left.Length; - Rlen : constant Length_Range := Right.Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Result.Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - - else - Result.Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen >= Max_Length then -- only case is Llen = Max_Length - Result.Data := Left.Data; - - else - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Max_Length) := - Right.Data (1 .. Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then -- only case is Rlen = Max_Length - Result.Data := Right.Data; - - else - Result.Data (1 .. Max_Length - Rlen) := - Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Result.Data (Max_Length - Rlen + 1 .. Max_Length) := - Right.Data (1 .. Rlen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Append; - - procedure Append - (Source : in out Bounded_String; - New_Item : in Bounded_String; - Drop : in Truncation := Error) - is - Llen : constant Length_Range := Source.Length; - Rlen : constant Length_Range := New_Item.Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Source.Length := Nlen; - Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen); - - else - Source.Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen < Max_Length then - Source.Data (Llen + 1 .. Max_Length) := - New_Item.Data (1 .. Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then -- only case is Rlen = Max_Length - Source.Data := New_Item.Data; - - else - Source.Data (1 .. Max_Length - Rlen) := - Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Source.Data (Max_Length - Rlen + 1 .. Max_Length) := - New_Item.Data (1 .. Rlen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - end Append; - - -- Case of Bounded_String and String - - function Append - (Left : in Bounded_String; - Right : in String; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_String - is - Result : Bounded_String; - Llen : constant Length_Range := Left.Length; - Rlen : constant Length_Range := Right'Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Result.Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right; - - else - Result.Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen >= Max_Length then -- only case is Llen = Max_Length - Result.Data := Left.Data; - - else - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Max_Length) := - Right (Right'First .. Right'First - 1 + - Max_Length - Llen); - - end if; - - when Strings.Left => - if Rlen >= Max_Length then - Result.Data (1 .. Max_Length) := - Right (Right'Last - (Max_Length - 1) .. Right'Last); - - else - Result.Data (1 .. Max_Length - Rlen) := - Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Result.Data (Max_Length - Rlen + 1 .. Max_Length) := - Right; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Append; - - procedure Append - (Source : in out Bounded_String; - New_Item : in String; - Drop : in Truncation := Error) - is - Llen : constant Length_Range := Source.Length; - Rlen : constant Length_Range := New_Item'Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Source.Length := Nlen; - Source.Data (Llen + 1 .. Nlen) := New_Item; - - else - Source.Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen < Max_Length then - Source.Data (Llen + 1 .. Max_Length) := - New_Item (New_Item'First .. - New_Item'First - 1 + Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then - Source.Data (1 .. Max_Length) := - New_Item (New_Item'Last - (Max_Length - 1) .. - New_Item'Last); - - else - Source.Data (1 .. Max_Length - Rlen) := - Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Source.Data (Max_Length - Rlen + 1 .. Max_Length) := - New_Item; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - end Append; - - -- Case of String and Bounded_String - - function Append - (Left : in String; - Right : in Bounded_String; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_String - is - Result : Bounded_String; - Llen : constant Length_Range := Left'Length; - Rlen : constant Length_Range := Right.Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Result.Length := Nlen; - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen); - - else - Result.Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen >= Max_Length then - Result.Data (1 .. Max_Length) := - Left (Left'First .. Left'First + (Max_Length - 1)); - - else - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Max_Length) := - Right.Data (1 .. Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then - Result.Data (1 .. Max_Length) := - Right.Data (Rlen - (Max_Length - 1) .. Rlen); - - else - Result.Data (1 .. Max_Length - Rlen) := - Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last); - Result.Data (Max_Length - Rlen + 1 .. Max_Length) := - Right.Data (1 .. Rlen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Append; - - -- Case of Bounded_String and Character - - function Append - (Left : in Bounded_String; - Right : in Character; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_String - is - Result : Bounded_String; - Llen : constant Length_Range := Left.Length; - - begin - if Llen < Max_Length then - Result.Length := Llen + 1; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1) := Right; - return Result; - - else - case Drop is - when Strings.Right => - return Left; - - when Strings.Left => - Result.Length := Max_Length; - Result.Data (1 .. Max_Length - 1) := - Left.Data (2 .. Max_Length); - Result.Data (Max_Length) := Right; - return Result; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Append; - - procedure Append - (Source : in out Bounded_String; - New_Item : in Character; - Drop : in Truncation := Error) - is - Llen : constant Length_Range := Source.Length; - - begin - if Llen < Max_Length then - Source.Length := Llen + 1; - Source.Data (Llen + 1) := New_Item; - - else - Source.Length := Max_Length; - - case Drop is - when Strings.Right => - null; - - when Strings.Left => - Source.Data (1 .. Max_Length - 1) := - Source.Data (2 .. Max_Length); - Source.Data (Max_Length) := New_Item; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - end Append; - - -- Case of Character and Bounded_String - - function Append - (Left : in Character; - Right : in Bounded_String; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_String - is - Result : Bounded_String; - Rlen : constant Length_Range := Right.Length; - - begin - if Rlen < Max_Length then - Result.Length := Rlen + 1; - Result.Data (1) := Left; - Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen); - return Result; - - else - case Drop is - when Strings.Right => - Result.Length := Max_Length; - Result.Data (1) := Left; - Result.Data (2 .. Max_Length) := - Right.Data (1 .. Max_Length - 1); - return Result; - - when Strings.Left => - return Right; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Append; - - ----------- - -- Count -- - ----------- - - function Count - (Source : in Bounded_String; - Pattern : in String; - Mapping : in Maps.Character_Mapping := Maps.Identity) - return Natural - is - begin - return - Search.Count (Source.Data (1 .. Source.Length), Pattern, Mapping); - end Count; - - function Count - (Source : in Bounded_String; - Pattern : in String; - Mapping : in Maps.Character_Mapping_Function) - return Natural - is - begin - return - Search.Count (Source.Data (1 .. Source.Length), Pattern, Mapping); - end Count; - - function Count - (Source : in Bounded_String; - Set : in Maps.Character_Set) - return Natural - is - begin - return Search.Count (Source.Data (1 .. Source.Length), Set); - end Count; - - ------------ - -- Delete -- - ------------ - - function Delete - (Source : in Bounded_String; - From : in Positive; - Through : in Natural) - return Bounded_String - is - Slen : constant Natural := Source.Length; - Num_Delete : constant Integer := Through - From + 1; - Result : Bounded_String; - - begin - if Num_Delete <= 0 then - return Source; - - elsif From > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif Through >= Slen then - Result.Length := From - 1; - Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); - return Result; - - else - Result.Length := Slen - Num_Delete; - Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); - Result.Data (From .. Result.Length) := - Source.Data (Through + 1 .. Slen); - return Result; - end if; - end Delete; - - procedure Delete - (Source : in out Bounded_String; - From : in Positive; - Through : in Natural) - is - Slen : constant Natural := Source.Length; - Num_Delete : constant Integer := Through - From + 1; - - begin - if Num_Delete <= 0 then - return; - - elsif From > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif Through >= Slen then - Source.Length := From - 1; - - else - Source.Length := Slen - Num_Delete; - Source.Data (From .. Source.Length) := - Source.Data (Through + 1 .. Slen); - end if; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element - (Source : in Bounded_String; - Index : in Positive) - return Character - is - begin - if Index in 1 .. Source.Length then - return Source.Data (Index); - else - raise Strings.Index_Error; - end if; - end Element; - - ---------------- - -- Find_Token -- - ---------------- - - procedure Find_Token - (Source : in Bounded_String; - Set : in Maps.Character_Set; - Test : in Strings.Membership; - First : out Positive; - Last : out Natural) - is - begin - Search.Find_Token - (Source.Data (1 .. Source.Length), Set, Test, First, Last); - end Find_Token; - - - ---------- - -- Head -- - ---------- - - function Head - (Source : in Bounded_String; - Count : in Natural; - Pad : in Character := Space; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_String - is - Result : Bounded_String; - Slen : constant Natural := Source.Length; - Npad : constant Integer := Count - Slen; - - begin - if Npad <= 0 then - Result.Length := Count; - Result.Data (1 .. Count) := Source.Data (1 .. Count); - - elsif Count <= Max_Length then - Result.Length := Count; - Result.Data (1 .. Slen) := Source.Data (1 .. Slen); - Result.Data (Slen + 1 .. Count) := (others => Pad); - - else - Result.Length := Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Slen) := Source.Data (1 .. Slen); - Result.Data (Slen + 1 .. Max_Length) := (others => Pad); - - when Strings.Left => - if Npad >= Max_Length then - Result.Data := (others => Pad); - - else - Result.Data (1 .. Max_Length - Npad) := - Source.Data (Count - Max_Length + 1 .. Slen); - Result.Data (Max_Length - Npad + 1 .. Max_Length) := - (others => Pad); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Head; - - procedure Head - (Source : in out Bounded_String; - Count : in Natural; - Pad : in Character := Space; - Drop : in Truncation := Error) - is - Slen : constant Natural := Source.Length; - Npad : constant Integer := Count - Slen; - Temp : String (1 .. Max_Length); - - begin - if Npad <= 0 then - Source.Length := Count; - - elsif Count <= Max_Length then - Source.Length := Count; - Source.Data (Slen + 1 .. Count) := (others => Pad); - - else - Source.Length := Max_Length; - - case Drop is - when Strings.Right => - Source.Data (Slen + 1 .. Max_Length) := (others => Pad); - - when Strings.Left => - if Npad > Max_Length then - Source.Data := (others => Pad); - - else - Temp := Source.Data; - Source.Data (1 .. Max_Length - Npad) := - Temp (Count - Max_Length + 1 .. Slen); - - for J in Max_Length - Npad + 1 .. Max_Length loop - Source.Data (J) := Pad; - end loop; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - end Head; - - ----------- - -- Index -- - ----------- - - function Index - (Source : in Bounded_String; - Pattern : in String; - Going : in Strings.Direction := Strings.Forward; - Mapping : in Maps.Character_Mapping := Maps.Identity) - return Natural - is - begin - return Search.Index - (Source.Data (1 .. Source.Length), Pattern, Going, Mapping); - end Index; - - function Index - (Source : in Bounded_String; - Pattern : in String; - Going : in Direction := Forward; - Mapping : in Maps.Character_Mapping_Function) - return Natural - is - begin - return Search.Index - (Source.Data (1 .. Source.Length), Pattern, Going, Mapping); - end Index; - - function Index - (Source : in Bounded_String; - Set : in Maps.Character_Set; - Test : in Strings.Membership := Strings.Inside; - Going : in Strings.Direction := Strings.Forward) - return Natural - is - begin - return Search.Index - (Source.Data (1 .. Source.Length), Set, Test, Going); - end Index; - - --------------------- - -- Index_Non_Blank -- - --------------------- - - function Index_Non_Blank - (Source : in Bounded_String; - Going : in Strings.Direction := Strings.Forward) - return Natural - is - begin - return - Search.Index_Non_Blank (Source.Data (1 .. Source.Length), Going); - end Index_Non_Blank; - - ------------ - -- Insert -- - ------------ - - function Insert - (Source : in Bounded_String; - Before : in Positive; - New_Item : in String; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_String - is - Slen : constant Natural := Source.Length; - Nlen : constant Natural := New_Item'Length; - Tlen : constant Natural := Slen + Nlen; - Blen : constant Natural := Before - 1; - Alen : constant Integer := Slen - Blen; - Droplen : constant Integer := Tlen - Max_Length; - Result : Bounded_String; - - -- Tlen is the length of the total string before possible truncation. - -- Blen, Alen are the lengths of the before and after pieces of the - -- source string. - - begin - if Alen < 0 then - raise Ada.Strings.Index_Error; - - elsif Droplen <= 0 then - Result.Length := Tlen; - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - Result.Data (Before .. Before + Nlen - 1) := New_Item; - Result.Data (Before + Nlen .. Tlen) := - Source.Data (Before .. Slen); - - else - Result.Length := Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - - if Droplen > Alen then - Result.Data (Before .. Max_Length) := - New_Item (New_Item'First - .. New_Item'First + Max_Length - Before); - else - Result.Data (Before .. Before + Nlen - 1) := New_Item; - Result.Data (Before + Nlen .. Max_Length) := - Source.Data (Before .. Slen - Droplen); - end if; - - when Strings.Left => - Result.Data (Max_Length - (Alen - 1) .. Max_Length) := - Source.Data (Before .. Slen); - - if Droplen >= Blen then - Result.Data (1 .. Max_Length - Alen) := - New_Item (New_Item'Last - (Max_Length - Alen) + 1 - .. New_Item'Last); - else - Result.Data - (Blen - Droplen + 1 .. Max_Length - Alen) := - New_Item; - Result.Data (1 .. Blen - Droplen) := - Source.Data (Droplen + 1 .. Blen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Insert; - - procedure Insert - (Source : in out Bounded_String; - Before : in Positive; - New_Item : in String; - Drop : in Strings.Truncation := Strings.Error) - is - begin - -- We do a double copy here because this is one of the situations - -- in which we move data to the right, and at least at the moment, - -- GNAT is not handling such cases correctly ??? - - Source := Insert (Source, Before, New_Item, Drop); - end Insert; - - ------------ - -- Length -- - ------------ - - function Length (Source : in Bounded_String) return Length_Range is - begin - return Source.Length; - end Length; - - --------------- - -- Overwrite -- - --------------- - - function Overwrite - (Source : in Bounded_String; - Position : in Positive; - New_Item : in String; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_String - is - Result : Bounded_String; - Endpos : constant Natural := Position + New_Item'Length - 1; - Slen : constant Natural := Source.Length; - Droplen : Natural; - - begin - if Position > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif New_Item'Length = 0 then - return Source; - - elsif Endpos <= Slen then - Result.Length := Source.Length; - Result.Data (1 .. Slen) := Source.Data (1 .. Slen); - Result.Data (Position .. Endpos) := New_Item; - return Result; - - elsif Endpos <= Max_Length then - Result.Length := Endpos; - Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1); - Result.Data (Position .. Endpos) := New_Item; - return Result; - - else - Result.Length := Max_Length; - Droplen := Endpos - Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Position - 1) := - Source.Data (1 .. Position - 1); - - Result.Data (Position .. Max_Length) := - New_Item (New_Item'First .. New_Item'Last - Droplen); - return Result; - - when Strings.Left => - if New_Item'Length >= Max_Length then - Result.Data (1 .. Max_Length) := - New_Item (New_Item'Last - Max_Length + 1 .. - New_Item'Last); - return Result; - - else - Result.Data (1 .. Max_Length - New_Item'Length) := - Source.Data (Droplen + 1 .. Position - 1); - Result.Data - (Max_Length - New_Item'Length + 1 .. Max_Length) := - New_Item; - return Result; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Overwrite; - - procedure Overwrite - (Source : in out Bounded_String; - Position : in Positive; - New_Item : in String; - Drop : in Strings.Truncation := Strings.Error) - is - Endpos : constant Positive := Position + New_Item'Length - 1; - Slen : constant Natural := Source.Length; - Droplen : Natural; - - begin - if Position > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif Endpos <= Slen then - Source.Data (Position .. Endpos) := New_Item; - - elsif Endpos <= Max_Length then - Source.Data (Position .. Endpos) := New_Item; - Source.Length := Endpos; - - else - Source.Length := Max_Length; - Droplen := Endpos - Max_Length; - - case Drop is - when Strings.Right => - Source.Data (Position .. Max_Length) := - New_Item (New_Item'First .. New_Item'Last - Droplen); - - when Strings.Left => - if New_Item'Length > Max_Length then - Source.Data (1 .. Max_Length) := - New_Item (New_Item'Last - Max_Length + 1 .. - New_Item'Last); - - else - Source.Data (1 .. Max_Length - New_Item'Length) := - Source.Data (Droplen + 1 .. Position - 1); - - Source.Data - (Max_Length - New_Item'Length + 1 .. Max_Length) := - New_Item; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Overwrite; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Source : in out Bounded_String; - Index : in Positive; - By : in Character) - is - begin - if Index <= Source.Length then - Source.Data (Index) := By; - else - raise Ada.Strings.Index_Error; - end if; - end Replace_Element; - - ------------------- - -- Replace_Slice -- - ------------------- - - function Replace_Slice - (Source : in Bounded_String; - Low : in Positive; - High : in Natural; - By : in String; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_String - is - Slen : constant Natural := Source.Length; - - begin - if Low > Slen + 1 then - raise Strings.Index_Error; - - elsif High < Low then - return Insert (Source, Low, By, Drop); - - else - declare - Blen : constant Natural := Natural'Max (0, Low - 1); - Alen : constant Natural := Natural'Max (0, Slen - High); - Tlen : constant Natural := Blen + By'Length + Alen; - Droplen : constant Integer := Tlen - Max_Length; - Result : Bounded_String; - - -- Tlen is the total length of the result string before any - -- truncation. Blen and Alen are the lengths of the pieces - -- of the original string that end up in the result string - -- before and after the replaced slice. - - begin - if Droplen <= 0 then - Result.Length := Tlen; - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - Result.Data (Low .. Low + By'Length - 1) := By; - Result.Data (Low + By'Length .. Tlen) := - Source.Data (High + 1 .. Slen); - - else - Result.Length := Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - - if Droplen > Alen then - Result.Data (Low .. Max_Length) := - By (By'First .. By'First + Max_Length - Low); - else - Result.Data (Low .. Low + By'Length - 1) := By; - Result.Data (Low + By'Length .. Max_Length) := - Source.Data (High + 1 .. Slen - Droplen); - end if; - - when Strings.Left => - Result.Data (Max_Length - (Alen - 1) .. Max_Length) := - Source.Data (High + 1 .. Slen); - - if Droplen >= Blen then - Result.Data (1 .. Max_Length - Alen) := - By (By'Last - (Max_Length - Alen) + 1 .. By'Last); - else - Result.Data - (Blen - Droplen + 1 .. Max_Length - Alen) := By; - Result.Data (1 .. Blen - Droplen) := - Source.Data (Droplen + 1 .. Blen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end; - end if; - end Replace_Slice; - - procedure Replace_Slice - (Source : in out Bounded_String; - Low : in Positive; - High : in Natural; - By : in String; - Drop : in Strings.Truncation := Strings.Error) - is - begin - -- We do a double copy here because this is one of the situations - -- in which we move data to the right, and at least at the moment, - -- GNAT is not handling such cases correctly ??? - - Source := Replace_Slice (Source, Low, High, By, Drop); - end Replace_Slice; - --------------- -- Replicate -- --------------- --- 53,62 ---- Right : in String) return Bounded_String is begin ! return Times (Left, Right, Max_Length); end "*"; --------------- -- Replicate -- --------------- *************** package body Ada.Strings.Bounded is *** 1340,1360 **** Drop : in Strings.Truncation := Strings.Error) return Bounded_String is - Result : Bounded_String; - begin ! if Count <= Max_Length then ! Result.Length := Count; ! ! elsif Drop = Strings.Error then ! raise Ada.Strings.Length_Error; ! ! else ! Result.Length := Max_Length; ! end if; ! ! Result.Data (1 .. Result.Length) := (others => Item); ! return Result; end Replicate; function Replicate --- 67,74 ---- Drop : in Strings.Truncation := Strings.Error) return Bounded_String is begin ! return Super_Replicate (Count, Item, Drop, Max_Length); end Replicate; function Replicate *************** package body Ada.Strings.Bounded is *** 1363,1551 **** Drop : in Strings.Truncation := Strings.Error) return Bounded_String is - Length : constant Integer := Count * Item'Length; - Result : Bounded_String; - Indx : Positive; - - begin - if Length <= Max_Length then - Result.Length := Length; - - if Length > 0 then - Indx := 1; - - for J in 1 .. Count loop - Result.Data (Indx .. Indx + Item'Length - 1) := Item; - Indx := Indx + Item'Length; - end loop; - end if; - - else - Result.Length := Max_Length; - - case Drop is - when Strings.Right => - Indx := 1; - - while Indx + Item'Length <= Max_Length + 1 loop - Result.Data (Indx .. Indx + Item'Length - 1) := Item; - Indx := Indx + Item'Length; - end loop; - - Result.Data (Indx .. Max_Length) := - Item (Item'First .. Item'First + Max_Length - Indx); - - when Strings.Left => - Indx := Max_Length; - - while Indx - Item'Length >= 1 loop - Result.Data (Indx - (Item'Length - 1) .. Indx) := Item; - Indx := Indx - Item'Length; - end loop; - - Result.Data (1 .. Indx) := - Item (Item'Last - Indx + 1 .. Item'Last); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Replicate; - - function Replicate - (Count : in Natural; - Item : in Bounded_String; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_String - is begin ! return Replicate (Count, Item.Data (1 .. Item.Length), Drop); end Replicate; - ----------- - -- Slice -- - ----------- - - function Slice - (Source : Bounded_String; - Low : Positive; - High : Natural) - return String - is - begin - -- Note: test of High > Length is in accordance with AI95-00128 - - if Low > Source.Length + 1 or else High > Source.Length then - raise Index_Error; - else - return Source.Data (Low .. High); - end if; - end Slice; - - ---------- - -- Tail -- - ---------- - - function Tail - (Source : in Bounded_String; - Count : in Natural; - Pad : in Character := Space; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_String - is - Result : Bounded_String; - Slen : constant Natural := Source.Length; - Npad : constant Integer := Count - Slen; - - begin - if Npad <= 0 then - Result.Length := Count; - Result.Data (1 .. Count) := - Source.Data (Slen - (Count - 1) .. Slen); - - elsif Count <= Max_Length then - Result.Length := Count; - Result.Data (1 .. Npad) := (others => Pad); - Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen); - - else - Result.Length := Max_Length; - - case Drop is - when Strings.Right => - if Npad >= Max_Length then - Result.Data := (others => Pad); - - else - Result.Data (1 .. Npad) := (others => Pad); - Result.Data (Npad + 1 .. Max_Length) := - Source.Data (1 .. Max_Length - Npad); - end if; - - when Strings.Left => - Result.Data (1 .. Max_Length - Slen) := (others => Pad); - Result.Data (Max_Length - Slen + 1 .. Max_Length) := - Source.Data (1 .. Slen); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Tail; - - procedure Tail - (Source : in out Bounded_String; - Count : in Natural; - Pad : in Character := Space; - Drop : in Truncation := Error) - is - Slen : constant Natural := Source.Length; - Npad : constant Integer := Count - Slen; - Temp : String (1 .. Max_Length) := Source.Data; - - begin - if Npad <= 0 then - Source.Length := Count; - Source.Data (1 .. Count) := - Temp (Slen - (Count - 1) .. Slen); - - elsif Count <= Max_Length then - Source.Length := Count; - Source.Data (1 .. Npad) := (others => Pad); - Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen); - - else - Source.Length := Max_Length; - - case Drop is - when Strings.Right => - if Npad >= Max_Length then - Source.Data := (others => Pad); - - else - Source.Data (1 .. Npad) := (others => Pad); - Source.Data (Npad + 1 .. Max_Length) := - Temp (1 .. Max_Length - Npad); - end if; - - when Strings.Left => - for J in 1 .. Max_Length - Slen loop - Source.Data (J) := Pad; - end loop; - - Source.Data (Max_Length - Slen + 1 .. Max_Length) := - Temp (1 .. Slen); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - end Tail; ----------------------- -- To_Bounded_String -- --- 77,86 ---- Drop : in Strings.Truncation := Strings.Error) return Bounded_String is begin ! return Super_Replicate (Count, Item, Drop, Max_Length); end Replicate; ----------------------- -- To_Bounded_String -- *************** package body Ada.Strings.Bounded is *** 1556,1776 **** Drop : in Strings.Truncation := Strings.Error) return Bounded_String is - Slen : constant Natural := Source'Length; - Result : Bounded_String; - begin ! if Slen <= Max_Length then ! Result.Length := Slen; ! Result.Data (1 .. Slen) := Source; ! ! else ! case Drop is ! when Strings.Right => ! Result.Length := Max_Length; ! Result.Data (1 .. Max_Length) := ! Source (Source'First .. Source'First - 1 + Max_Length); ! ! when Strings.Left => ! Result.Length := Max_Length; ! Result.Data (1 .. Max_Length) := ! Source (Source'Last - (Max_Length - 1) .. Source'Last); ! ! when Strings.Error => ! raise Ada.Strings.Length_Error; ! end case; ! end if; ! ! return Result; end To_Bounded_String; - --------------- - -- To_String -- - --------------- - - function To_String (Source : in Bounded_String) return String is - begin - return Source.Data (1 .. Source.Length); - end To_String; - - --------------- - -- Translate -- - --------------- - - function Translate - (Source : in Bounded_String; - Mapping : in Maps.Character_Mapping) - return Bounded_String - is - Result : Bounded_String; - - begin - Result.Length := Source.Length; - - for J in 1 .. Source.Length loop - Result.Data (J) := Value (Mapping, Source.Data (J)); - end loop; - - return Result; - end Translate; - - procedure Translate - (Source : in out Bounded_String; - Mapping : in Maps.Character_Mapping) - is - begin - for J in 1 .. Source.Length loop - Source.Data (J) := Value (Mapping, Source.Data (J)); - end loop; - end Translate; - - function Translate - (Source : in Bounded_String; - Mapping : in Maps.Character_Mapping_Function) - return Bounded_String - is - Result : Bounded_String; - - begin - Result.Length := Source.Length; - - for J in 1 .. Source.Length loop - Result.Data (J) := Mapping.all (Source.Data (J)); - end loop; - - return Result; - end Translate; - - procedure Translate - (Source : in out Bounded_String; - Mapping : in Maps.Character_Mapping_Function) - is - begin - for J in 1 .. Source.Length loop - Source.Data (J) := Mapping.all (Source.Data (J)); - end loop; - end Translate; - - ---------- - -- Trim -- - ---------- - - function Trim (Source : in Bounded_String; Side : in Trim_End) - return Bounded_String - is - Result : Bounded_String; - Last : Natural := Source.Length; - First : Positive := 1; - - begin - if Side = Left or else Side = Both then - while First <= Last and then Source.Data (First) = ' ' loop - First := First + 1; - end loop; - end if; - - if Side = Right or else Side = Both then - while Last >= First and then Source.Data (Last) = ' ' loop - Last := Last - 1; - end loop; - end if; - - Result.Length := Last - First + 1; - Result.Data (1 .. Result.Length) := Source.Data (First .. Last); - return Result; - - end Trim; - - procedure Trim - (Source : in out Bounded_String; - Side : in Trim_End) - is - Last : Length_Range := Source.Length; - First : Positive := 1; - Temp : String (1 .. Max_Length); - - begin - Temp (1 .. Last) := Source.Data (1 .. Last); - - if Side = Left or else Side = Both then - while First <= Last and then Temp (First) = ' ' loop - First := First + 1; - end loop; - end if; - - if Side = Right or else Side = Both then - while Last >= First and then Temp (Last) = ' ' loop - Last := Last - 1; - end loop; - end if; - - Source := Null_Bounded_String; - Source.Length := Last - First + 1; - Source.Data (1 .. Source.Length) := Temp (First .. Last); - - end Trim; - - function Trim - (Source : in Bounded_String; - Left : in Maps.Character_Set; - Right : in Maps.Character_Set) - return Bounded_String - is - Result : Bounded_String; - - begin - for First in 1 .. Source.Length loop - if not Is_In (Source.Data (First), Left) then - for Last in reverse First .. Source.Length loop - if not Is_In (Source.Data (Last), Right) then - Result.Length := Last - First + 1; - Result.Data (1 .. Result.Length) := - Source.Data (First .. Last); - return Result; - end if; - end loop; - end if; - end loop; - - Result.Length := 0; - return Result; - end Trim; - - procedure Trim - (Source : in out Bounded_String; - Left : in Maps.Character_Set; - Right : in Maps.Character_Set) - is - begin - for First in 1 .. Source.Length loop - if not Is_In (Source.Data (First), Left) then - for Last in reverse First .. Source.Length loop - if not Is_In (Source.Data (Last), Right) then - if First = 1 then - Source.Length := Last; - return; - else - Source.Length := Last - First + 1; - Source.Data (1 .. Source.Length) := - Source.Data (First .. Last); - - for J in Source.Length + 1 .. Max_Length loop - Source.Data (J) := ASCII.NUL; - end loop; - - return; - end if; - end if; - end loop; - - Source.Length := 0; - return; - end if; - end loop; - - Source.Length := 0; - end Trim; - end Generic_Bounded_Length; end Ada.Strings.Bounded; --- 91,100 ---- Drop : in Strings.Truncation := Strings.Error) return Bounded_String is begin ! return To_Super_String (Source, Max_Length, Drop); end To_Bounded_String; end Generic_Bounded_Length; end Ada.Strings.Bounded; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-strbou.ads gcc-3.4.0/gcc/ada/a-strbou.ads *** gcc-3.3.3/gcc/ada/a-strbou.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-strbou.ads 2003-10-21 13:41:54.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1992-2000 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 -- --- 6,12 ---- -- -- -- 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 -- *************** *** 37,42 **** --- 36,42 ---- ------------------------------------------------------------------------------ with Ada.Strings.Maps; + with Ada.Strings.Superbounded; package Ada.Strings.Bounded is pragma Preelaborate (Bounded); *************** pragma Preelaborate (Bounded); *** 433,465 **** private ! type Bounded_String is record ! Length : Length_Range := 0; ! Data : String (1 .. Max_Length) := (1 .. Max_Length => ASCII.NUL); ! end record; Null_Bounded_String : constant Bounded_String := ! (Length => 0, Data => (1 .. Max_Length => ASCII.NUL)); ! -- Pragma Inline declarations (GNAT specific additions) ! pragma Inline ("="); ! pragma Inline ("<"); ! pragma Inline ("<="); ! pragma Inline (">"); ! pragma Inline (">="); ! pragma Inline ("&"); ! pragma Inline (Count); ! pragma Inline (Element); ! pragma Inline (Find_Token); ! pragma Inline (Index); ! pragma Inline (Index_Non_Blank); ! pragma Inline (Length); ! pragma Inline (Replace_Element); ! pragma Inline (Slice); ! pragma Inline (To_Bounded_String); ! pragma Inline (To_String); end Generic_Bounded_Length; --- 433,840 ---- private ! -- Most of the implementation is in the non generic package ! -- Ada.Strings.Superbounded. Type Bounded_String is derived from type ! -- Superbounded.Super_String with the maximum length constraint. ! -- Except for five, all subprograms are renames of subprograms that ! -- are inherited from Superbounded.Super_String. ! ! type Bounded_String is new Superbounded.Super_String (Max_Length); Null_Bounded_String : constant Bounded_String := ! (Max_Length => Max_Length, ! Current_Length => 0, ! Data => (1 .. Max_Length => ASCII.NUL)); + pragma Inline (To_Bounded_String); ! function Length (Source : in Bounded_String) return Length_Range ! renames Super_Length; ! function To_String (Source : in Bounded_String) return String ! renames Super_To_String; ! ! function Append ! (Left, Right : in Bounded_String; ! Drop : in Truncation := Error) ! return Bounded_String ! renames Super_Append; ! ! function Append ! (Left : in Bounded_String; ! Right : in String; ! Drop : in Truncation := Error) ! return Bounded_String ! renames Super_Append; ! ! function Append ! (Left : in String; ! Right : in Bounded_String; ! Drop : in Truncation := Error) ! return Bounded_String ! renames Super_Append; ! ! function Append ! (Left : in Bounded_String; ! Right : in Character; ! Drop : in Truncation := Error) ! return Bounded_String ! renames Super_Append; ! ! function Append ! (Left : in Character; ! Right : in Bounded_String; ! Drop : in Truncation := Error) ! return Bounded_String ! renames Super_Append; ! ! procedure Append ! (Source : in out Bounded_String; ! New_Item : in Bounded_String; ! Drop : in Truncation := Error) ! renames Super_Append; ! ! procedure Append ! (Source : in out Bounded_String; ! New_Item : in String; ! Drop : in Truncation := Error) ! renames Super_Append; ! ! procedure Append ! (Source : in out Bounded_String; ! New_Item : in Character; ! Drop : in Truncation := Error) ! renames Super_Append; ! ! function "&" ! (Left, Right : in Bounded_String) ! return Bounded_String ! renames Concat; ! ! function "&" ! (Left : in Bounded_String; ! Right : in String) ! return Bounded_String ! renames Concat; ! ! function "&" ! (Left : in String; ! Right : in Bounded_String) ! return Bounded_String ! renames Concat; ! ! function "&" ! (Left : in Bounded_String; ! Right : in Character) ! return Bounded_String ! renames Concat; ! ! function "&" ! (Left : in Character; ! Right : in Bounded_String) ! return Bounded_String ! renames Concat; ! ! function Element ! (Source : in Bounded_String; ! Index : in Positive) ! return Character ! renames Super_Element; ! ! procedure Replace_Element ! (Source : in out Bounded_String; ! Index : in Positive; ! By : in Character) ! renames Super_Replace_Element; ! ! function Slice ! (Source : in Bounded_String; ! Low : in Positive; ! High : in Natural) ! return String ! renames Super_Slice; ! ! function "=" (Left, Right : in Bounded_String) return Boolean ! renames Equal; ! ! function "=" ! (Left : in Bounded_String; ! Right : in String) ! return Boolean ! renames Equal; ! ! function "=" ! (Left : in String; ! Right : in Bounded_String) ! return Boolean ! renames Equal; ! ! function "<" (Left, Right : in Bounded_String) return Boolean ! renames Less; ! ! function "<" ! (Left : in Bounded_String; ! Right : in String) ! return Boolean ! renames Less; ! ! function "<" ! (Left : in String; ! Right : in Bounded_String) ! return Boolean ! renames Less; ! ! function "<=" (Left, Right : in Bounded_String) return Boolean ! renames Less_Or_Equal; ! ! function "<=" ! (Left : in Bounded_String; ! Right : in String) ! return Boolean ! renames Less_Or_Equal; ! ! function "<=" ! (Left : in String; ! Right : in Bounded_String) ! return Boolean ! renames Less_Or_Equal; ! ! function ">" (Left, Right : in Bounded_String) return Boolean ! renames Greater; ! ! function ">" ! (Left : in Bounded_String; ! Right : in String) ! return Boolean ! renames Greater; ! ! function ">" ! (Left : in String; ! Right : in Bounded_String) ! return Boolean ! renames Greater; ! ! function ">=" (Left, Right : in Bounded_String) return Boolean ! renames Greater_Or_Equal; ! ! function ">=" ! (Left : in Bounded_String; ! Right : in String) ! return Boolean ! renames Greater_Or_Equal; ! ! function ">=" ! (Left : in String; ! Right : in Bounded_String) ! return Boolean ! renames Greater_Or_Equal; ! ! function Index ! (Source : in Bounded_String; ! Pattern : in String; ! Going : in Direction := Forward; ! Mapping : in Maps.Character_Mapping := Maps.Identity) ! return Natural ! renames Super_Index; ! ! function Index ! (Source : in Bounded_String; ! Pattern : in String; ! Going : in Direction := Forward; ! Mapping : in Maps.Character_Mapping_Function) ! return Natural ! renames Super_Index; ! ! function Index ! (Source : in Bounded_String; ! Set : in Maps.Character_Set; ! Test : in Membership := Inside; ! Going : in Direction := Forward) ! return Natural ! renames Super_Index; ! ! function Index_Non_Blank ! (Source : in Bounded_String; ! Going : in Direction := Forward) ! return Natural ! renames Super_Index_Non_Blank; ! ! function Count ! (Source : in Bounded_String; ! Pattern : in String; ! Mapping : in Maps.Character_Mapping := Maps.Identity) ! return Natural ! renames Super_Count; ! ! function Count ! (Source : in Bounded_String; ! Pattern : in String; ! Mapping : in Maps.Character_Mapping_Function) ! return Natural ! renames Super_Count; ! ! function Count ! (Source : in Bounded_String; ! Set : in Maps.Character_Set) ! return Natural ! renames Super_Count; ! ! procedure Find_Token ! (Source : in Bounded_String; ! Set : in Maps.Character_Set; ! Test : in Membership; ! First : out Positive; ! Last : out Natural) ! renames Super_Find_Token; ! ! function Translate ! (Source : in Bounded_String; ! Mapping : in Maps.Character_Mapping) ! return Bounded_String ! renames Super_Translate; ! ! procedure Translate ! (Source : in out Bounded_String; ! Mapping : in Maps.Character_Mapping) ! renames Super_Translate; ! ! function Translate ! (Source : in Bounded_String; ! Mapping : in Maps.Character_Mapping_Function) ! return Bounded_String ! renames Super_Translate; ! ! procedure Translate ! (Source : in out Bounded_String; ! Mapping : in Maps.Character_Mapping_Function) ! renames Super_Translate; ! ! function Replace_Slice ! (Source : in Bounded_String; ! Low : in Positive; ! High : in Natural; ! By : in String; ! Drop : in Truncation := Error) ! return Bounded_String ! renames Super_Replace_Slice; ! ! procedure Replace_Slice ! (Source : in out Bounded_String; ! Low : in Positive; ! High : in Natural; ! By : in String; ! Drop : in Truncation := Error) ! renames Super_Replace_Slice; ! ! function Insert ! (Source : in Bounded_String; ! Before : in Positive; ! New_Item : in String; ! Drop : in Truncation := Error) ! return Bounded_String ! renames Super_Insert; ! ! procedure Insert ! (Source : in out Bounded_String; ! Before : in Positive; ! New_Item : in String; ! Drop : in Truncation := Error) ! renames Super_Insert; ! ! function Overwrite ! (Source : in Bounded_String; ! Position : in Positive; ! New_Item : in String; ! Drop : in Truncation := Error) ! return Bounded_String ! renames Super_Overwrite; ! ! procedure Overwrite ! (Source : in out Bounded_String; ! Position : in Positive; ! New_Item : in String; ! Drop : in Truncation := Error) ! renames Super_Overwrite; ! ! function Delete ! (Source : in Bounded_String; ! From : in Positive; ! Through : in Natural) ! return Bounded_String ! renames Super_Delete; ! ! procedure Delete ! (Source : in out Bounded_String; ! From : in Positive; ! Through : in Natural) ! renames Super_Delete; ! ! function Trim ! (Source : in Bounded_String; ! Side : in Trim_End) ! return Bounded_String ! renames Super_Trim; ! ! procedure Trim ! (Source : in out Bounded_String; ! Side : in Trim_End) ! renames Super_Trim; ! ! function Trim ! (Source : in Bounded_String; ! Left : in Maps.Character_Set; ! Right : in Maps.Character_Set) ! return Bounded_String ! renames Super_Trim; ! ! procedure Trim ! (Source : in out Bounded_String; ! Left : in Maps.Character_Set; ! Right : in Maps.Character_Set) ! renames Super_Trim; ! ! function Head ! (Source : in Bounded_String; ! Count : in Natural; ! Pad : in Character := Space; ! Drop : in Truncation := Error) ! return Bounded_String ! renames Super_Head; ! ! procedure Head ! (Source : in out Bounded_String; ! Count : in Natural; ! Pad : in Character := Space; ! Drop : in Truncation := Error) ! renames Super_Head; ! ! function Tail ! (Source : in Bounded_String; ! Count : in Natural; ! Pad : in Character := Space; ! Drop : in Truncation := Error) ! return Bounded_String ! renames Super_Tail; ! ! procedure Tail ! (Source : in out Bounded_String; ! Count : in Natural; ! Pad : in Character := Space; ! Drop : in Truncation := Error) ! renames Super_Tail; ! ! function "*" ! (Left : in Natural; ! Right : in Bounded_String) ! return Bounded_String ! renames Times; ! ! function Replicate ! (Count : in Natural; ! Item : in Bounded_String; ! Drop : in Truncation := Error) ! return Bounded_String ! renames Super_Replicate; end Generic_Bounded_Length; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-stream.ads gcc-3.4.0/gcc/ada/a-stream.ads *** gcc-3.3.3/gcc/ada/a-stream.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-stream.ads 2003-04-24 17:53:54.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/a-strfix.adb gcc-3.4.0/gcc/ada/a-strfix.adb *** gcc-3.3.3/gcc/ada/a-strfix.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-strfix.adb 2003-10-21 13:41:54.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-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.Strings.Fixed is *** 410,418 **** end if; declare ! Result_Length : Natural := ! Integer'Max ! (Source'Length, Position - Source'First + New_Item'Length); Result : String (1 .. Result_Length); Front : constant Integer := Position - Source'First; --- 409,418 ---- end if; declare ! Result_Length : constant Natural := ! Integer'Max ! (Source'Length, ! Position - Source'First + New_Item'Length); Result : String (1 .. Result_Length); Front : constant Integer := Position - Source'First; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-strfix.ads gcc-3.4.0/gcc/ada/a-strfix.ads *** gcc-3.3.3/gcc/ada/a-strfix.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-strfix.ads 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-string.ads gcc-3.4.0/gcc/ada/a-string.ads *** gcc-3.3.3/gcc/ada/a-string.ads 2002-03-14 10:58:53.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-string.ads 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-strmap.adb gcc-3.4.0/gcc/ada/a-strmap.adb *** gcc-3.3.3/gcc/ada/a-strmap.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-strmap.adb 2003-10-21 13:41:54.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-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.Strings.Maps is *** 231,237 **** loop exit when not Set (C) or else C = Character'Last; ! C := Character' Succ (C); end loop; if Set (C) then --- 230,236 ---- loop exit when not Set (C) or else C = Character'Last; ! C := Character'Succ (C); end loop; if Set (C) then diff -Nrc3pad gcc-3.3.3/gcc/ada/a-strmap.ads gcc-3.4.0/gcc/ada/a-strmap.ads *** gcc-3.3.3/gcc/ada/a-strmap.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-strmap.ads 2003-04-24 17:53:54.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/a-strsea.adb gcc-3.4.0/gcc/ada/a-strsea.adb *** gcc-3.3.3/gcc/ada/a-strsea.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-strsea.adb 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992,1993,1994,1995,1996 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/a-strsea.ads gcc-3.4.0/gcc/ada/a-strsea.ads *** gcc-3.3.3/gcc/ada/a-strsea.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-strsea.ads 2003-10-21 13:41:54.000000000 +0000 *************** *** 6,14 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1992-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) 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- -- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-strsup.adb gcc-3.4.0/gcc/ada/a-strsup.adb *** gcc-3.3.3/gcc/ada/a-strsup.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-strsup.adb 2003-10-21 13:41:54.000000000 +0000 *************** *** 0 **** --- 1,1807 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUNTIME COMPONENTS -- + -- -- + -- A D A . S T R I N G S . S U P E R B O U N D E D -- + -- -- + -- 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. -- + -- -- + ------------------------------------------------------------------------------ + + with Ada.Strings.Maps; use Ada.Strings.Maps; + with Ada.Strings.Search; + + package body Ada.Strings.Superbounded is + + ------------ + -- Concat -- + ------------ + + function Concat + (Left : Super_String; + Right : Super_String) + return Super_String + is + Result : Super_String (Left.Max_Length); + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen > Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end if; + + return Result; + end Concat; + + function Concat + (Left : Super_String; + Right : String) + return Super_String + is + Result : Super_String (Left.Max_Length); + Llen : constant Natural := Left.Current_Length; + + Nlen : constant Natural := Llen + Right'Length; + + begin + if Nlen > Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right; + end if; + return Result; + end Concat; + + function Concat + (Left : String; + Right : Super_String) + return Super_String + is + Result : Super_String (Right.Max_Length); + Llen : constant Natural := Left'Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen > Right.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end if; + + return Result; + end Concat; + + function Concat + (Left : Super_String; + Right : Character) + return Super_String + is + Result : Super_String (Left.Max_Length); + Llen : constant Natural := Left.Current_Length; + + begin + if Llen = Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Llen + 1; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Result.Current_Length) := Right; + end if; + + return Result; + end Concat; + + function Concat + (Left : Character; + Right : Super_String) + return Super_String + is + Result : Super_String (Right.Max_Length); + Rlen : constant Natural := Right.Current_Length; + + begin + if Rlen = Right.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Rlen + 1; + Result.Data (1) := Left; + Result.Data (2 .. Result.Current_Length) := Right.Data (1 .. Rlen); + end if; + + return Result; + end Concat; + + ----------- + -- Equal -- + ----------- + + function "=" (Left, Right : Super_String) return Boolean is + begin + return Left.Current_Length = Right.Current_Length + and then Left.Data (1 .. Left.Current_Length) = + Right.Data (1 .. Right.Current_Length); + end "="; + + function Equal (Left : Super_String; Right : String) + return Boolean is + begin + return Left.Current_Length = Right'Length + and then Left.Data (1 .. Left.Current_Length) = Right; + end Equal; + + function Equal (Left : String; Right : Super_String) + return Boolean is + begin + return Left'Length = Right.Current_Length + and then Left = Right.Data (1 .. Right.Current_Length); + end Equal; + + ------------- + -- Greater -- + ------------- + + function Greater (Left, Right : Super_String) return Boolean is + begin + return Left.Data (1 .. Left.Current_Length) > + Right.Data (1 .. Right.Current_Length); + end Greater; + + function Greater + (Left : Super_String; + Right : String) + return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) > Right; + end Greater; + + function Greater + (Left : String; + Right : Super_String) + return Boolean + is + begin + return Left > Right.Data (1 .. Right.Current_Length); + end Greater; + + ---------------------- + -- Greater_Or_Equal -- + ---------------------- + + function Greater_Or_Equal (Left, Right : Super_String) return Boolean is + begin + return Left.Data (1 .. Left.Current_Length) >= + Right.Data (1 .. Right.Current_Length); + end Greater_Or_Equal; + + function Greater_Or_Equal + (Left : Super_String; + Right : String) + return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) >= Right; + end Greater_Or_Equal; + + function Greater_Or_Equal + (Left : String; + Right : Super_String) + return Boolean + is + begin + return Left >= Right.Data (1 .. Right.Current_Length); + end Greater_Or_Equal; + + ---------- + -- Less -- + ---------- + + function Less (Left, Right : Super_String) return Boolean is + begin + return Left.Data (1 .. Left.Current_Length) < + Right.Data (1 .. Right.Current_Length); + end Less; + + function Less + (Left : Super_String; + Right : String) + return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) < Right; + end Less; + + function Less + (Left : String; + Right : Super_String) + return Boolean + is + begin + return Left < Right.Data (1 .. Right.Current_Length); + end Less; + + ------------------- + -- Less_Or_Equal -- + ------------------- + + function Less_Or_Equal (Left, Right : Super_String) return Boolean is + begin + return Left.Data (1 .. Left.Current_Length) <= + Right.Data (1 .. Right.Current_Length); + end Less_Or_Equal; + + function Less_Or_Equal + (Left : Super_String; + Right : String) + return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) <= Right; + end Less_Or_Equal; + + function Less_Or_Equal + (Left : String; + Right : Super_String) + return Boolean + is + begin + return Left <= Right.Data (1 .. Right.Current_Length); + end Less_Or_Equal; + + ------------------ + -- Super_Append -- + ------------------ + + -- Case of Super_String and Super_String + + function Super_Append + (Left, Right : Super_String; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Left.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen >= Max_Length then -- only case is Llen = Max_Length + Result.Data := Left.Data; + + else + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Max_Length) := + Right.Data (1 .. Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then -- only case is Rlen = Max_Length + Result.Data := Right.Data; + + else + Result.Data (1 .. Max_Length - Rlen) := + Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Result.Data (Max_Length - Rlen + 1 .. Max_Length) := + Right.Data (1 .. Rlen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Append; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Super_String; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Llen : constant Natural := Source.Current_Length; + Rlen : constant Natural := New_Item.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Source.Current_Length := Nlen; + Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen); + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen < Max_Length then + Source.Data (Llen + 1 .. Max_Length) := + New_Item.Data (1 .. Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then -- only case is Rlen = Max_Length + Source.Data := New_Item.Data; + + else + Source.Data (1 .. Max_Length - Rlen) := + Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Source.Data (Max_Length - Rlen + 1 .. Max_Length) := + New_Item.Data (1 .. Rlen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + end Super_Append; + + -- Case of Super_String and String + + function Super_Append + (Left : Super_String; + Right : String; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Left.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right'Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right; + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen >= Max_Length then -- only case is Llen = Max_Length + Result.Data := Left.Data; + + else + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Max_Length) := + Right (Right'First .. Right'First - 1 + + Max_Length - Llen); + + end if; + + when Strings.Left => + if Rlen >= Max_Length then + Result.Data (1 .. Max_Length) := + Right (Right'Last - (Max_Length - 1) .. Right'Last); + + else + Result.Data (1 .. Max_Length - Rlen) := + Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Result.Data (Max_Length - Rlen + 1 .. Max_Length) := + Right; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Append; + + procedure Super_Append + (Source : in out Super_String; + New_Item : String; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Llen : constant Natural := Source.Current_Length; + Rlen : constant Natural := New_Item'Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Source.Current_Length := Nlen; + Source.Data (Llen + 1 .. Nlen) := New_Item; + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen < Max_Length then + Source.Data (Llen + 1 .. Max_Length) := + New_Item (New_Item'First .. + New_Item'First - 1 + Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then + Source.Data (1 .. Max_Length) := + New_Item (New_Item'Last - (Max_Length - 1) .. + New_Item'Last); + + else + Source.Data (1 .. Max_Length - Rlen) := + Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Source.Data (Max_Length - Rlen + 1 .. Max_Length) := + New_Item; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + end Super_Append; + + -- Case of String and Super_String + + function Super_Append + (Left : String; + Right : Super_String; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Right.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left'Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen >= Max_Length then + Result.Data (1 .. Max_Length) := + Left (Left'First .. Left'First + (Max_Length - 1)); + + else + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Max_Length) := + Right.Data (1 .. Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then + Result.Data (1 .. Max_Length) := + Right.Data (Rlen - (Max_Length - 1) .. Rlen); + + else + Result.Data (1 .. Max_Length - Rlen) := + Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last); + Result.Data (Max_Length - Rlen + 1 .. Max_Length) := + Right.Data (1 .. Rlen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Append; + + -- Case of Super_String and Character + + function Super_Append + (Left : Super_String; + Right : Character; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Left.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left.Current_Length; + + begin + if Llen < Max_Length then + Result.Current_Length := Llen + 1; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1) := Right; + return Result; + + else + case Drop is + when Strings.Right => + return Left; + + when Strings.Left => + Result.Current_Length := Max_Length; + Result.Data (1 .. Max_Length - 1) := + Left.Data (2 .. Max_Length); + Result.Data (Max_Length) := Right; + return Result; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Append; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Character; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Llen : constant Natural := Source.Current_Length; + + begin + if Llen < Max_Length then + Source.Current_Length := Llen + 1; + Source.Data (Llen + 1) := New_Item; + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + null; + + when Strings.Left => + Source.Data (1 .. Max_Length - 1) := + Source.Data (2 .. Max_Length); + Source.Data (Max_Length) := New_Item; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + end Super_Append; + + -- Case of Character and Super_String + + function Super_Append + (Left : Character; + Right : Super_String; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Right.Max_Length; + Result : Super_String (Max_Length); + Rlen : constant Natural := Right.Current_Length; + + begin + if Rlen < Max_Length then + Result.Current_Length := Rlen + 1; + Result.Data (1) := Left; + Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen); + return Result; + + else + case Drop is + when Strings.Right => + Result.Current_Length := Max_Length; + Result.Data (1) := Left; + Result.Data (2 .. Max_Length) := + Right.Data (1 .. Max_Length - 1); + return Result; + + when Strings.Left => + return Right; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Append; + + ----------------- + -- Super_Count -- + ----------------- + + function Super_Count + (Source : Super_String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) + return Natural + is + begin + return + Search.Count + (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); + end Super_Count; + + function Super_Count + (Source : Super_String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) + return Natural + is + begin + return + Search.Count + (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); + end Super_Count; + + function Super_Count + (Source : Super_String; + Set : Maps.Character_Set) + return Natural + is + begin + return Search.Count (Source.Data (1 .. Source.Current_Length), Set); + end Super_Count; + + ------------------ + -- Super_Delete -- + ------------------ + + function Super_Delete + (Source : Super_String; + From : Positive; + Through : Natural) + return Super_String + is + Result : Super_String (Source.Max_Length); + Slen : constant Natural := Source.Current_Length; + Num_Delete : constant Integer := Through - From + 1; + + begin + if Num_Delete <= 0 then + return Source; + + elsif From > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif Through >= Slen then + Result.Current_Length := From - 1; + Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); + return Result; + + else + Result.Current_Length := Slen - Num_Delete; + Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); + Result.Data (From .. Result.Current_Length) := + Source.Data (Through + 1 .. Slen); + return Result; + end if; + end Super_Delete; + + procedure Super_Delete + (Source : in out Super_String; + From : Positive; + Through : Natural) + is + Slen : constant Natural := Source.Current_Length; + Num_Delete : constant Integer := Through - From + 1; + + begin + if Num_Delete <= 0 then + return; + + elsif From > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif Through >= Slen then + Source.Current_Length := From - 1; + + else + Source.Current_Length := Slen - Num_Delete; + Source.Data (From .. Source.Current_Length) := + Source.Data (Through + 1 .. Slen); + end if; + end Super_Delete; + + ------------------- + -- Super_Element -- + ------------------- + + function Super_Element + (Source : Super_String; + Index : Positive) + return Character + is + begin + if Index in 1 .. Source.Current_Length then + return Source.Data (Index); + else + raise Strings.Index_Error; + end if; + end Super_Element; + + ---------------------- + -- Super_Find_Token -- + ---------------------- + + procedure Super_Find_Token + (Source : Super_String; + Set : Maps.Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + begin + Search.Find_Token + (Source.Data (1 .. Source.Current_Length), Set, Test, First, Last); + end Super_Find_Token; + + ---------------- + -- Super_Head -- + ---------------- + + function Super_Head + (Source : Super_String; + Count : Natural; + Pad : Character := Space; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + + begin + if Npad <= 0 then + Result.Current_Length := Count; + Result.Data (1 .. Count) := Source.Data (1 .. Count); + + elsif Count <= Max_Length then + Result.Current_Length := Count; + Result.Data (1 .. Slen) := Source.Data (1 .. Slen); + Result.Data (Slen + 1 .. Count) := (others => Pad); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Slen) := Source.Data (1 .. Slen); + Result.Data (Slen + 1 .. Max_Length) := (others => Pad); + + when Strings.Left => + if Npad >= Max_Length then + Result.Data := (others => Pad); + + else + Result.Data (1 .. Max_Length - Npad) := + Source.Data (Count - Max_Length + 1 .. Slen); + Result.Data (Max_Length - Npad + 1 .. Max_Length) := + (others => Pad); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Head; + + procedure Super_Head + (Source : in out Super_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + Temp : String (1 .. Max_Length); + + begin + if Npad <= 0 then + Source.Current_Length := Count; + + elsif Count <= Max_Length then + Source.Current_Length := Count; + Source.Data (Slen + 1 .. Count) := (others => Pad); + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Source.Data (Slen + 1 .. Max_Length) := (others => Pad); + + when Strings.Left => + if Npad > Max_Length then + Source.Data := (others => Pad); + + else + Temp := Source.Data; + Source.Data (1 .. Max_Length - Npad) := + Temp (Count - Max_Length + 1 .. Slen); + + for J in Max_Length - Npad + 1 .. Max_Length loop + Source.Data (J) := Pad; + end loop; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Head; + + ----------------- + -- Super_Index -- + ----------------- + + function Super_Index + (Source : Super_String; + Pattern : String; + Going : Strings.Direction := Strings.Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) + return Natural + is + begin + return Search.Index + (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) + return Natural + is + begin + return Search.Index + (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Set : Maps.Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) + return Natural + is + begin + return Search.Index + (Source.Data (1 .. Source.Current_Length), Set, Test, Going); + end Super_Index; + + --------------------------- + -- Super_Index_Non_Blank -- + --------------------------- + + function Super_Index_Non_Blank + (Source : Super_String; + Going : Strings.Direction := Strings.Forward) + return Natural + is + begin + return + Search.Index_Non_Blank + (Source.Data (1 .. Source.Current_Length), Going); + end Super_Index_Non_Blank; + + ------------------ + -- Super_Insert -- + ------------------ + + function Super_Insert + (Source : Super_String; + Before : Positive; + New_Item : String; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Slen : constant Natural := Source.Current_Length; + Nlen : constant Natural := New_Item'Length; + Tlen : constant Natural := Slen + Nlen; + Blen : constant Natural := Before - 1; + Alen : constant Integer := Slen - Blen; + Droplen : constant Integer := Tlen - Max_Length; + + -- Tlen is the length of the total string before possible truncation. + -- Blen, Alen are the lengths of the before and after pieces of the + -- source string. + + begin + if Alen < 0 then + raise Ada.Strings.Index_Error; + + elsif Droplen <= 0 then + Result.Current_Length := Tlen; + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + Result.Data (Before .. Before + Nlen - 1) := New_Item; + Result.Data (Before + Nlen .. Tlen) := + Source.Data (Before .. Slen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + + if Droplen > Alen then + Result.Data (Before .. Max_Length) := + New_Item (New_Item'First + .. New_Item'First + Max_Length - Before); + else + Result.Data (Before .. Before + Nlen - 1) := New_Item; + Result.Data (Before + Nlen .. Max_Length) := + Source.Data (Before .. Slen - Droplen); + end if; + + when Strings.Left => + Result.Data (Max_Length - (Alen - 1) .. Max_Length) := + Source.Data (Before .. Slen); + + if Droplen >= Blen then + Result.Data (1 .. Max_Length - Alen) := + New_Item (New_Item'Last - (Max_Length - Alen) + 1 + .. New_Item'Last); + else + Result.Data + (Blen - Droplen + 1 .. Max_Length - Alen) := + New_Item; + Result.Data (1 .. Blen - Droplen) := + Source.Data (Droplen + 1 .. Blen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Insert; + + procedure Super_Insert + (Source : in out Super_String; + Before : Positive; + New_Item : String; + Drop : Strings.Truncation := Strings.Error) + is + begin + -- We do a double copy here because this is one of the situations + -- in which we move data to the right, and at least at the moment, + -- GNAT is not handling such cases correctly ??? + + Source := Super_Insert (Source, Before, New_Item, Drop); + end Super_Insert; + + ------------------ + -- Super_Length -- + ------------------ + + function Super_Length (Source : Super_String) return Natural is + begin + return Source.Current_Length; + end Super_Length; + + --------------------- + -- Super_Overwrite -- + --------------------- + + function Super_Overwrite + (Source : Super_String; + Position : Positive; + New_Item : String; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Endpos : constant Natural := Position + New_Item'Length - 1; + Slen : constant Natural := Source.Current_Length; + Droplen : Natural; + + begin + if Position > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif New_Item'Length = 0 then + return Source; + + elsif Endpos <= Slen then + Result.Current_Length := Source.Current_Length; + Result.Data (1 .. Slen) := Source.Data (1 .. Slen); + Result.Data (Position .. Endpos) := New_Item; + return Result; + + elsif Endpos <= Max_Length then + Result.Current_Length := Endpos; + Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1); + Result.Data (Position .. Endpos) := New_Item; + return Result; + + else + Result.Current_Length := Max_Length; + Droplen := Endpos - Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Position - 1) := + Source.Data (1 .. Position - 1); + + Result.Data (Position .. Max_Length) := + New_Item (New_Item'First .. New_Item'Last - Droplen); + return Result; + + when Strings.Left => + if New_Item'Length >= Max_Length then + Result.Data (1 .. Max_Length) := + New_Item (New_Item'Last - Max_Length + 1 .. + New_Item'Last); + return Result; + + else + Result.Data (1 .. Max_Length - New_Item'Length) := + Source.Data (Droplen + 1 .. Position - 1); + Result.Data + (Max_Length - New_Item'Length + 1 .. Max_Length) := + New_Item; + return Result; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Overwrite; + + procedure Super_Overwrite + (Source : in out Super_String; + Position : Positive; + New_Item : String; + Drop : Strings.Truncation := Strings.Error) + is + Max_Length : constant Positive := Source.Max_Length; + Endpos : constant Positive := Position + New_Item'Length - 1; + Slen : constant Natural := Source.Current_Length; + Droplen : Natural; + + begin + if Position > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif Endpos <= Slen then + Source.Data (Position .. Endpos) := New_Item; + + elsif Endpos <= Max_Length then + Source.Data (Position .. Endpos) := New_Item; + Source.Current_Length := Endpos; + + else + Source.Current_Length := Max_Length; + Droplen := Endpos - Max_Length; + + case Drop is + when Strings.Right => + Source.Data (Position .. Max_Length) := + New_Item (New_Item'First .. New_Item'Last - Droplen); + + when Strings.Left => + if New_Item'Length > Max_Length then + Source.Data (1 .. Max_Length) := + New_Item (New_Item'Last - Max_Length + 1 .. + New_Item'Last); + + else + Source.Data (1 .. Max_Length - New_Item'Length) := + Source.Data (Droplen + 1 .. Position - 1); + + Source.Data + (Max_Length - New_Item'Length + 1 .. Max_Length) := + New_Item; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Overwrite; + + --------------------------- + -- Super_Replace_Element -- + --------------------------- + + procedure Super_Replace_Element + (Source : in out Super_String; + Index : Positive; + By : Character) + is + begin + if Index <= Source.Current_Length then + Source.Data (Index) := By; + else + raise Ada.Strings.Index_Error; + end if; + end Super_Replace_Element; + + ------------------------- + -- Super_Replace_Slice -- + ------------------------- + + function Super_Replace_Slice + (Source : Super_String; + Low : Positive; + High : Natural; + By : String; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Slen : constant Natural := Source.Current_Length; + + begin + if Low > Slen + 1 then + raise Strings.Index_Error; + + elsif High < Low then + return Super_Insert (Source, Low, By, Drop); + + else + declare + Blen : constant Natural := Natural'Max (0, Low - 1); + Alen : constant Natural := Natural'Max (0, Slen - High); + Tlen : constant Natural := Blen + By'Length + Alen; + Droplen : constant Integer := Tlen - Max_Length; + Result : Super_String (Max_Length); + + -- Tlen is the total length of the result string before any + -- truncation. Blen and Alen are the lengths of the pieces + -- of the original string that end up in the result string + -- before and after the replaced slice. + + begin + if Droplen <= 0 then + Result.Current_Length := Tlen; + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + Result.Data (Low .. Low + By'Length - 1) := By; + Result.Data (Low + By'Length .. Tlen) := + Source.Data (High + 1 .. Slen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + + if Droplen > Alen then + Result.Data (Low .. Max_Length) := + By (By'First .. By'First + Max_Length - Low); + else + Result.Data (Low .. Low + By'Length - 1) := By; + Result.Data (Low + By'Length .. Max_Length) := + Source.Data (High + 1 .. Slen - Droplen); + end if; + + when Strings.Left => + Result.Data (Max_Length - (Alen - 1) .. Max_Length) := + Source.Data (High + 1 .. Slen); + + if Droplen >= Blen then + Result.Data (1 .. Max_Length - Alen) := + By (By'Last - (Max_Length - Alen) + 1 .. By'Last); + else + Result.Data + (Blen - Droplen + 1 .. Max_Length - Alen) := By; + Result.Data (1 .. Blen - Droplen) := + Source.Data (Droplen + 1 .. Blen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end; + end if; + end Super_Replace_Slice; + + procedure Super_Replace_Slice + (Source : in out Super_String; + Low : Positive; + High : Natural; + By : String; + Drop : Strings.Truncation := Strings.Error) + is + begin + -- We do a double copy here because this is one of the situations + -- in which we move data to the right, and at least at the moment, + -- GNAT is not handling such cases correctly ??? + + Source := Super_Replace_Slice (Source, Low, High, By, Drop); + end Super_Replace_Slice; + + --------------------- + -- Super_Replicate -- + --------------------- + + function Super_Replicate + (Count : Natural; + Item : Character; + Drop : Truncation := Error; + Max_Length : Positive) + return Super_String + is + Result : Super_String (Max_Length); + + begin + if Count <= Max_Length then + Result.Current_Length := Count; + + elsif Drop = Strings.Error then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Max_Length; + end if; + + Result.Data (1 .. Result.Current_Length) := (others => Item); + return Result; + end Super_Replicate; + + function Super_Replicate + (Count : Natural; + Item : String; + Drop : Truncation := Error; + Max_Length : Positive) + return Super_String + is + Length : constant Integer := Count * Item'Length; + Result : Super_String (Max_Length); + Indx : Positive; + + begin + if Length <= Max_Length then + Result.Current_Length := Length; + + if Length > 0 then + Indx := 1; + + for J in 1 .. Count loop + Result.Data (Indx .. Indx + Item'Length - 1) := Item; + Indx := Indx + Item'Length; + end loop; + end if; + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Indx := 1; + + while Indx + Item'Length <= Max_Length + 1 loop + Result.Data (Indx .. Indx + Item'Length - 1) := Item; + Indx := Indx + Item'Length; + end loop; + + Result.Data (Indx .. Max_Length) := + Item (Item'First .. Item'First + Max_Length - Indx); + + when Strings.Left => + Indx := Max_Length; + + while Indx - Item'Length >= 1 loop + Result.Data (Indx - (Item'Length - 1) .. Indx) := Item; + Indx := Indx - Item'Length; + end loop; + + Result.Data (1 .. Indx) := + Item (Item'Last - Indx + 1 .. Item'Last); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Replicate; + + function Super_Replicate + (Count : Natural; + Item : Super_String; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + begin + return + Super_Replicate + (Count, + Item.Data (1 .. Item.Current_Length), + Drop, + Item.Max_Length); + end Super_Replicate; + + ----------------- + -- Super_Slice -- + ----------------- + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) + return String + is + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + else + return Source.Data (Low .. High); + end if; + end Super_Slice; + + ---------------- + -- Super_Tail -- + ---------------- + + function Super_Tail + (Source : Super_String; + Count : Natural; + Pad : Character := Space; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + + begin + if Npad <= 0 then + Result.Current_Length := Count; + Result.Data (1 .. Count) := + Source.Data (Slen - (Count - 1) .. Slen); + + elsif Count <= Max_Length then + Result.Current_Length := Count; + Result.Data (1 .. Npad) := (others => Pad); + Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Npad >= Max_Length then + Result.Data := (others => Pad); + + else + Result.Data (1 .. Npad) := (others => Pad); + Result.Data (Npad + 1 .. Max_Length) := + Source.Data (1 .. Max_Length - Npad); + end if; + + when Strings.Left => + Result.Data (1 .. Max_Length - Slen) := (others => Pad); + Result.Data (Max_Length - Slen + 1 .. Max_Length) := + Source.Data (1 .. Slen); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Tail; + + procedure Super_Tail + (Source : in out Super_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + + Temp : constant String (1 .. Max_Length) := Source.Data; + + begin + if Npad <= 0 then + Source.Current_Length := Count; + Source.Data (1 .. Count) := + Temp (Slen - (Count - 1) .. Slen); + + elsif Count <= Max_Length then + Source.Current_Length := Count; + Source.Data (1 .. Npad) := (others => Pad); + Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen); + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Npad >= Max_Length then + Source.Data := (others => Pad); + + else + Source.Data (1 .. Npad) := (others => Pad); + Source.Data (Npad + 1 .. Max_Length) := + Temp (1 .. Max_Length - Npad); + end if; + + when Strings.Left => + for J in 1 .. Max_Length - Slen loop + Source.Data (J) := Pad; + end loop; + + Source.Data (Max_Length - Slen + 1 .. Max_Length) := + Temp (1 .. Slen); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Tail; + + --------------------- + -- Super_To_String -- + --------------------- + + function Super_To_String (Source : in Super_String) return String is + begin + return Source.Data (1 .. Source.Current_Length); + end Super_To_String; + + --------------------- + -- Super_Translate -- + --------------------- + + function Super_Translate + (Source : Super_String; + Mapping : Maps.Character_Mapping) + return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + Result.Current_Length := Source.Current_Length; + + for J in 1 .. Source.Current_Length loop + Result.Data (J) := Value (Mapping, Source.Data (J)); + end loop; + + return Result; + end Super_Translate; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Maps.Character_Mapping) + is + begin + for J in 1 .. Source.Current_Length loop + Source.Data (J) := Value (Mapping, Source.Data (J)); + end loop; + end Super_Translate; + + function Super_Translate + (Source : Super_String; + Mapping : Maps.Character_Mapping_Function) + return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + Result.Current_Length := Source.Current_Length; + + for J in 1 .. Source.Current_Length loop + Result.Data (J) := Mapping.all (Source.Data (J)); + end loop; + + return Result; + end Super_Translate; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Maps.Character_Mapping_Function) + is + begin + for J in 1 .. Source.Current_Length loop + Source.Data (J) := Mapping.all (Source.Data (J)); + end loop; + end Super_Translate; + + ---------------- + -- Super_Trim -- + ---------------- + + function Super_Trim (Source : Super_String; Side : Trim_End) + return Super_String + is + Result : Super_String (Source.Max_Length); + Last : Natural := Source.Current_Length; + First : Positive := 1; + + begin + if Side = Left or else Side = Both then + while First <= Last and then Source.Data (First) = ' ' loop + First := First + 1; + end loop; + end if; + + if Side = Right or else Side = Both then + while Last >= First and then Source.Data (Last) = ' ' loop + Last := Last - 1; + end loop; + end if; + + Result.Current_Length := Last - First + 1; + Result.Data (1 .. Result.Current_Length) := Source.Data (First .. Last); + return Result; + end Super_Trim; + + procedure Super_Trim + (Source : in out Super_String; + Side : Trim_End) + is + Max_Length : constant Positive := Source.Max_Length; + Last : Natural := Source.Current_Length; + First : Positive := 1; + Temp : String (1 .. Max_Length); + + begin + Temp (1 .. Last) := Source.Data (1 .. Last); + + if Side = Left or else Side = Both then + while First <= Last and then Temp (First) = ' ' loop + First := First + 1; + end loop; + end if; + + if Side = Right or else Side = Both then + while Last >= First and then Temp (Last) = ' ' loop + Last := Last - 1; + end loop; + end if; + + Source.Data := (others => ASCII.NUL); + Source.Current_Length := Last - First + 1; + Source.Data (1 .. Source.Current_Length) := Temp (First .. Last); + end Super_Trim; + + function Super_Trim + (Source : Super_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) + return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + for First in 1 .. Source.Current_Length loop + if not Is_In (Source.Data (First), Left) then + for Last in reverse First .. Source.Current_Length loop + if not Is_In (Source.Data (Last), Right) then + Result.Current_Length := Last - First + 1; + Result.Data (1 .. Result.Current_Length) := + Source.Data (First .. Last); + return Result; + end if; + end loop; + end if; + end loop; + + Result.Current_Length := 0; + return Result; + end Super_Trim; + + procedure Super_Trim + (Source : in out Super_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) + is + begin + for First in 1 .. Source.Current_Length loop + if not Is_In (Source.Data (First), Left) then + for Last in reverse First .. Source.Current_Length loop + if not Is_In (Source.Data (Last), Right) then + if First = 1 then + Source.Current_Length := Last; + return; + else + Source.Current_Length := Last - First + 1; + Source.Data (1 .. Source.Current_Length) := + Source.Data (First .. Last); + + for J in Source.Current_Length + 1 .. + Source.Max_Length + loop + Source.Data (J) := ASCII.NUL; + end loop; + + return; + end if; + end if; + end loop; + + Source.Current_Length := 0; + return; + end if; + end loop; + + Source.Current_Length := 0; + end Super_Trim; + + ----------- + -- Times -- + ----------- + + function Times + (Left : Natural; + Right : Character; + Max_Length : Positive) + return Super_String + is + Result : Super_String (Max_Length); + + begin + if Left > Max_Length then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Left; + + for J in 1 .. Left loop + Result.Data (J) := Right; + end loop; + end if; + + return Result; + end Times; + + function Times + (Left : Natural; + Right : String; + Max_Length : Positive) + return Super_String + is + Result : Super_String (Max_Length); + Pos : Positive := 1; + Rlen : constant Natural := Right'Length; + Nlen : constant Natural := Left * Rlen; + + begin + if Nlen > Max_Length then + raise Ada.Strings.Index_Error; + + else + Result.Current_Length := Nlen; + + if Nlen > 0 then + for J in 1 .. Left loop + Result.Data (Pos .. Pos + Rlen - 1) := Right; + Pos := Pos + Rlen; + end loop; + end if; + end if; + + return Result; + end Times; + + function Times + (Left : Natural; + Right : Super_String) + return Super_String + is + Result : Super_String (Right.Max_Length); + Pos : Positive := 1; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Left * Rlen; + + begin + if Nlen > Right.Max_Length then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Nlen; + + if Nlen > 0 then + for J in 1 .. Left loop + Result.Data (Pos .. Pos + Rlen - 1) := + Right.Data (1 .. Rlen); + Pos := Pos + Rlen; + end loop; + end if; + end if; + + return Result; + end Times; + + --------------------- + -- To_Super_String -- + --------------------- + + function To_Super_String + (Source : String; + Max_Length : Natural; + Drop : Truncation := Error) + return Super_String + is + Result : Super_String (Max_Length); + Slen : constant Natural := Source'Length; + + begin + if Slen <= Max_Length then + Result.Current_Length := Slen; + Result.Data (1 .. Slen) := Source; + + else + case Drop is + when Strings.Right => + Result.Current_Length := Max_Length; + Result.Data (1 .. Max_Length) := + Source (Source'First .. Source'First - 1 + Max_Length); + + when Strings.Left => + Result.Current_Length := Max_Length; + Result.Data (1 .. Max_Length) := + Source (Source'Last - (Max_Length - 1) .. Source'Last); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end To_Super_String; + + end Ada.Strings.Superbounded; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-strsup.ads gcc-3.4.0/gcc/ada/a-strsup.ads *** gcc-3.3.3/gcc/ada/a-strsup.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-strsup.ads 2003-10-21 13:41:54.000000000 +0000 *************** *** 0 **** --- 1,473 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- A D A . S T R I N G S . S U P E R B O U N D E D -- + -- -- + -- S p e c -- + -- -- + -- 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 non generic package contains most of the implementation of the + -- generic package Ada.Strings.Bounded.Generic_Bounded_Length. + + -- It defines type Super_String as a discriminated record with the maximum + -- length as the discriminant. Individual instantiations of Strings.Bounded + -- use this type with an appropriate discriminant value set. + + with Ada.Strings.Maps; + + package Ada.Strings.Superbounded is + pragma Preelaborate (Superbounded); + + type Super_String (Max_Length : Positive) is record + Current_Length : Natural := 0; + Data : String (1 .. Max_Length) := (others => ASCII.NUL); + end record; + -- Type Bounded_String in Ada.Strings.Bounded.Generic_Bounded_Length is + -- derived from this type, with the constraint of the maximum length. + + -- The subprograms defined for Super_String are similar to those + -- defined for Bounded_String, except that they have different names, so + -- that they can be renamed in Ada.Strings.Bounded.Generic_Bounded_Length. + + function Super_Length (Source : Super_String) return Natural; + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Super_String + (Source : String; + Max_Length : Natural; + Drop : Truncation := Error) + return Super_String; + -- Note the additional parameter Max_Length, which specifies the maximum + -- length setting of the resulting Super_String value. + + -- The following procedures have declarations (and semantics) that are + -- exactly analogous to those declared in Ada.Strings.Bounded. + + function Super_To_String (Source : Super_String) return String; + + function Super_Append + (Left, Right : Super_String; + Drop : Truncation := Error) + return Super_String; + + function Super_Append + (Left : Super_String; + Right : String; + Drop : Truncation := Error) + return Super_String; + + function Super_Append + (Left : String; + Right : Super_String; + Drop : Truncation := Error) + return Super_String; + + function Super_Append + (Left : Super_String; + Right : Character; + Drop : Truncation := Error) + return Super_String; + + function Super_Append + (Left : Character; + Right : Super_String; + Drop : Truncation := Error) + return Super_String; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Super_String; + Drop : Truncation := Error); + + procedure Super_Append + (Source : in out Super_String; + New_Item : String; + Drop : Truncation := Error); + + procedure Super_Append + (Source : in out Super_String; + New_Item : Character; + Drop : Truncation := Error); + + function Concat + (Left, Right : Super_String) + return Super_String; + + function Concat + (Left : Super_String; + Right : String) + return Super_String; + + function Concat + (Left : String; + Right : Super_String) + return Super_String; + + function Concat + (Left : Super_String; + Right : Character) + return Super_String; + + function Concat + (Left : Character; + Right : Super_String) + return Super_String; + + function Super_Element + (Source : Super_String; + Index : Positive) + return Character; + + procedure Super_Replace_Element + (Source : in out Super_String; + Index : Positive; + By : Character); + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) + return String; + + function "=" (Left, Right : Super_String) return Boolean; + + function Equal (Left, Right : Super_String) return Boolean renames "="; + + function Equal + (Left : Super_String; + Right : String) + return Boolean; + + function Equal + (Left : String; + Right : Super_String) + return Boolean; + + function Less (Left, Right : Super_String) return Boolean; + + function Less + (Left : Super_String; + Right : String) + return Boolean; + + function Less + (Left : String; + Right : Super_String) + return Boolean; + + function Less_Or_Equal (Left, Right : Super_String) return Boolean; + + function Less_Or_Equal + (Left : Super_String; + Right : String) + return Boolean; + + function Less_Or_Equal + (Left : String; + Right : Super_String) + return Boolean; + + function Greater (Left, Right : Super_String) return Boolean; + + function Greater + (Left : Super_String; + Right : String) + return Boolean; + + function Greater + (Left : String; + Right : Super_String) + return Boolean; + + function Greater_Or_Equal (Left, Right : Super_String) return Boolean; + + function Greater_Or_Equal + (Left : Super_String; + Right : String) + return Boolean; + + function Greater_Or_Equal + (Left : String; + Right : Super_String) + return Boolean; + + ---------------------- + -- Search Functions -- + ---------------------- + + function Super_Index + (Source : Super_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) + return Natural; + + function Super_Index + (Source : Super_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) + return Natural; + + function Super_Index + (Source : Super_String; + Set : Maps.Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) + return Natural; + + function Super_Index_Non_Blank + (Source : Super_String; + Going : Direction := Forward) + return Natural; + + function Super_Count + (Source : Super_String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) + return Natural; + + function Super_Count + (Source : Super_String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) + return Natural; + + function Super_Count + (Source : Super_String; + Set : Maps.Character_Set) + return Natural; + + procedure Super_Find_Token + (Source : Super_String; + Set : Maps.Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Super_Translate + (Source : Super_String; + Mapping : Maps.Character_Mapping) + return Super_String; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Maps.Character_Mapping); + + function Super_Translate + (Source : Super_String; + Mapping : Maps.Character_Mapping_Function) + return Super_String; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Maps.Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Super_Replace_Slice + (Source : Super_String; + Low : Positive; + High : Natural; + By : String; + Drop : Truncation := Error) + return Super_String; + + procedure Super_Replace_Slice + (Source : in out Super_String; + Low : Positive; + High : Natural; + By : String; + Drop : Truncation := Error); + + function Super_Insert + (Source : Super_String; + Before : Positive; + New_Item : String; + Drop : Truncation := Error) + return Super_String; + + procedure Super_Insert + (Source : in out Super_String; + Before : Positive; + New_Item : String; + Drop : Truncation := Error); + + function Super_Overwrite + (Source : Super_String; + Position : Positive; + New_Item : String; + Drop : Truncation := Error) + return Super_String; + + procedure Super_Overwrite + (Source : in out Super_String; + Position : Positive; + New_Item : String; + Drop : Truncation := Error); + + function Super_Delete + (Source : Super_String; + From : Positive; + Through : Natural) + return Super_String; + + procedure Super_Delete + (Source : in out Super_String; + From : Positive; + Through : Natural); + + --------------------------------- + -- String Selector Subprograms -- + --------------------------------- + + function Super_Trim + (Source : Super_String; + Side : Trim_End) + return Super_String; + + procedure Super_Trim + (Source : in out Super_String; + Side : Trim_End); + + function Super_Trim + (Source : Super_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) + return Super_String; + + procedure Super_Trim + (Source : in out Super_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set); + + function Super_Head + (Source : Super_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error) + return Super_String; + + procedure Super_Head + (Source : in out Super_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error); + + function Super_Tail + (Source : Super_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error) + return Super_String; + + procedure Super_Tail + (Source : in out Super_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error); + + ------------------------------------ + -- String Constructor Subprograms -- + ------------------------------------ + + -- Note: in some of the following routines, there is an extra parameter + -- Max_Length which specifies the value of the maximum length for the + -- resulting Super_String value. + + function Times + (Left : Natural; + Right : Character; + Max_Length : Positive) + return Super_String; + -- Note the additional parameter Max_Length + + function Times + (Left : Natural; + Right : String; + Max_Length : Positive) + return Super_String; + -- Note the additional parameter Max_Length + + function Times + (Left : Natural; + Right : Super_String) + return Super_String; + + function Super_Replicate + (Count : Natural; + Item : Character; + Drop : Truncation := Error; + Max_Length : Positive) + return Super_String; + -- Note the additional parameter Max_Length + + function Super_Replicate + (Count : Natural; + Item : String; + Drop : Truncation := Error; + Max_Length : Positive) + return Super_String; + -- Note the additional parameter Max_Length + + function Super_Replicate + (Count : Natural; + Item : Super_String; + Drop : Truncation := Error) + return Super_String; + + private + + -- Pragma Inline declarations + + pragma Inline ("="); + pragma Inline (Less); + pragma Inline (Less_Or_Equal); + pragma Inline (Greater); + pragma Inline (Greater_Or_Equal); + pragma Inline (Concat); + pragma Inline (Super_Count); + pragma Inline (Super_Element); + pragma Inline (Super_Find_Token); + pragma Inline (Super_Index); + pragma Inline (Super_Index_Non_Blank); + pragma Inline (Super_Length); + pragma Inline (Super_Replace_Element); + pragma Inline (Super_Slice); + pragma Inline (Super_To_String); + + end Ada.Strings.Superbounded; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-strunb.adb gcc-3.4.0/gcc/ada/a-strunb.adb *** gcc-3.3.3/gcc/ada/a-strunb.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-strunb.adb 2003-10-21 13:41:54.000000000 +0000 *************** *** 1,13 **** ------------------------------------------------------------------------------ -- -- ! -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . S T R I N G S . U N B O U N D E D -- -- -- -- 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- -- --- 1,12 ---- ------------------------------------------------------------------------------ -- -- ! -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . S T R I N G S . U N B O U N D E D -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-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.Strings.Unbounded is *** 40,59 **** use Ada.Finalization; --------- -- "&" -- --------- function "&" (Left, Right : Unbounded_String) return Unbounded_String is ! L_Length : constant Integer := Left.Reference.all'Length; ! R_Length : constant Integer := Right.Reference.all'Length; ! Length : constant Integer := L_Length + R_Length; Result : Unbounded_String; begin ! Result.Reference := new String (1 .. Length); ! Result.Reference.all (1 .. L_Length) := Left.Reference.all; ! Result.Reference.all (L_Length + 1 .. Length) := Right.Reference.all; return Result; end "&"; --- 39,73 ---- use Ada.Finalization; + procedure Realloc_For_Chunk + (Source : in out Unbounded_String; + Chunk_Size : Natural); + pragma Inline (Realloc_For_Chunk); + -- Adjust the size allocated for the string. Add at least Chunk_Size so it + -- is safe to add a string of this size at the end of the current + -- content. The real size allocated for the string is Chunk_Size + x % + -- of the current string size. This buffered handling makes the Append + -- unbounded string routines very fast. + --------- -- "&" -- --------- function "&" (Left, Right : Unbounded_String) return Unbounded_String is ! L_Length : constant Natural := Left.Last; ! R_Length : constant Natural := Right.Last; Result : Unbounded_String; begin ! Result.Last := L_Length + R_Length; ! ! Result.Reference := new String (1 .. Result.Last); ! ! Result.Reference (1 .. L_Length) := ! Left.Reference (1 .. Left.Last); ! Result.Reference (L_Length + 1 .. Result.Last) := ! Right.Reference (1 .. Right.Last); ! return Result; end "&"; *************** package body Ada.Strings.Unbounded is *** 62,75 **** Right : String) return Unbounded_String is ! L_Length : constant Integer := Left.Reference.all'Length; ! Length : constant Integer := L_Length + Right'Length; Result : Unbounded_String; begin ! Result.Reference := new String (1 .. Length); ! Result.Reference.all (1 .. L_Length) := Left.Reference.all; ! Result.Reference.all (L_Length + 1 .. Length) := Right; return Result; end "&"; --- 76,92 ---- Right : String) return Unbounded_String is ! L_Length : constant Natural := Left.Last; Result : Unbounded_String; begin ! Result.Last := L_Length + Right'Length; ! ! Result.Reference := new String (1 .. Result.Last); ! ! Result.Reference (1 .. L_Length) := Left.Reference (1 .. Left.Last); ! Result.Reference (L_Length + 1 .. Result.Last) := Right; ! return Result; end "&"; *************** package body Ada.Strings.Unbounded is *** 78,91 **** Right : Unbounded_String) return Unbounded_String is ! R_Length : constant Integer := Right.Reference.all'Length; ! Length : constant Integer := Left'Length + R_Length; Result : Unbounded_String; begin ! Result.Reference := new String (1 .. Length); ! Result.Reference.all (1 .. Left'Length) := Left; ! Result.Reference.all (Left'Length + 1 .. Length) := Right.Reference.all; return Result; end "&"; --- 95,112 ---- Right : Unbounded_String) return Unbounded_String is ! R_Length : constant Natural := Right.Last; Result : Unbounded_String; begin ! Result.Last := Left'Length + R_Length; ! ! Result.Reference := new String (1 .. Result.Last); ! ! Result.Reference (1 .. Left'Length) := Left; ! Result.Reference (Left'Length + 1 .. Result.Last) := ! Right.Reference (1 .. Right.Last); ! return Result; end "&"; *************** package body Ada.Strings.Unbounded is *** 94,106 **** Right : Character) return Unbounded_String is - Length : constant Integer := Left.Reference.all'Length + 1; Result : Unbounded_String; begin ! Result.Reference := new String (1 .. Length); ! Result.Reference.all (1 .. Length - 1) := Left.Reference.all; ! Result.Reference.all (Length) := Right; return Result; end "&"; --- 115,131 ---- Right : Character) return Unbounded_String is Result : Unbounded_String; begin ! Result.Last := Left.Last + 1; ! ! Result.Reference := new String (1 .. Result.Last); ! ! Result.Reference (1 .. Result.Last - 1) := ! Left.Reference (1 .. Left.Last); ! Result.Reference (Result.Last) := Right; ! return Result; end "&"; *************** package body Ada.Strings.Unbounded is *** 109,121 **** Right : Unbounded_String) return Unbounded_String is - Length : constant Integer := Right.Reference.all'Length + 1; Result : Unbounded_String; begin ! Result.Reference := new String (1 .. Length); ! Result.Reference.all (1) := Left; ! Result.Reference.all (2 .. Length) := Right.Reference.all; return Result; end "&"; --- 134,148 ---- Right : Unbounded_String) return Unbounded_String is Result : Unbounded_String; begin ! Result.Last := Right.Last + 1; ! ! Result.Reference := new String (1 .. Result.Last); ! Result.Reference (1) := Left; ! Result.Reference (2 .. Result.Last) := ! Right.Reference (1 .. Right.Last); return Result; end "&"; *************** package body Ada.Strings.Unbounded is *** 131,136 **** --- 158,165 ---- Result : Unbounded_String; begin + Result.Last := Left; + Result.Reference := new String (1 .. Left); for J in Result.Reference'Range loop Result.Reference (J) := Right; *************** package body Ada.Strings.Unbounded is *** 144,156 **** Right : String) return Unbounded_String is ! Len : constant Integer := Right'Length; Result : Unbounded_String; begin ! Result.Reference := new String (1 .. Left * Len); for J in 1 .. Left loop ! Result.Reference.all (Len * J - Len + 1 .. Len * J) := Right; end loop; return Result; --- 173,191 ---- Right : String) return Unbounded_String is ! Len : constant Natural := Right'Length; ! K : Positive; Result : Unbounded_String; begin ! Result.Last := Left * Len; ! ! Result.Reference := new String (1 .. Result.Last); ! ! K := 1; for J in 1 .. Left loop ! Result.Reference (K .. K + Len - 1) := Right; ! K := K + Len; end loop; return Result; *************** package body Ada.Strings.Unbounded is *** 161,174 **** Right : Unbounded_String) return Unbounded_String is ! Len : constant Integer := Right.Reference.all'Length; Result : Unbounded_String; begin ! Result.Reference := new String (1 .. Left * Len); for I in 1 .. Left loop ! Result.Reference.all (Len * I - Len + 1 .. Len * I) := ! Right.Reference.all; end loop; return Result; --- 196,215 ---- Right : Unbounded_String) return Unbounded_String is ! Len : constant Natural := Right.Last; ! K : Positive; Result : Unbounded_String; begin ! Result.Last := Left * Len; ! ! Result.Reference := new String (1 .. Result.Last); ! ! K := 1; for I in 1 .. Left loop ! Result.Reference (K .. K + Len - 1) := ! Right.Reference (1 .. Right.Last); ! K := K + Len; end loop; return Result; *************** package body Ada.Strings.Unbounded is *** 178,312 **** -- "<" -- --------- ! function "<" (Left, Right : in Unbounded_String) return Boolean is begin ! return Left.Reference.all < Right.Reference.all; end "<"; function "<" ! (Left : in Unbounded_String; ! Right : in String) return Boolean is begin ! return Left.Reference.all < Right; end "<"; function "<" ! (Left : in String; ! Right : in Unbounded_String) return Boolean is begin ! return Left < Right.Reference.all; end "<"; ---------- -- "<=" -- ---------- ! function "<=" (Left, Right : in Unbounded_String) return Boolean is begin ! return Left.Reference.all <= Right.Reference.all; end "<="; function "<=" ! (Left : in Unbounded_String; ! Right : in String) return Boolean is begin ! return Left.Reference.all <= Right; end "<="; function "<=" ! (Left : in String; ! Right : in Unbounded_String) return Boolean is begin ! return Left <= Right.Reference.all; end "<="; --------- -- "=" -- --------- ! function "=" (Left, Right : in Unbounded_String) return Boolean is begin ! return Left.Reference.all = Right.Reference.all; end "="; function "=" ! (Left : in Unbounded_String; ! Right : in String) return Boolean is begin ! return Left.Reference.all = Right; end "="; function "=" ! (Left : in String; ! Right : in Unbounded_String) return Boolean is begin ! return Left = Right.Reference.all; end "="; --------- -- ">" -- --------- ! function ">" (Left, Right : in Unbounded_String) return Boolean is begin ! return Left.Reference.all > Right.Reference.all; end ">"; function ">" ! (Left : in Unbounded_String; ! Right : in String) return Boolean is begin ! return Left.Reference.all > Right; end ">"; function ">" ! (Left : in String; ! Right : in Unbounded_String) return Boolean is begin ! return Left > Right.Reference.all; end ">"; ---------- -- ">=" -- ---------- ! function ">=" (Left, Right : in Unbounded_String) return Boolean is begin ! return Left.Reference.all >= Right.Reference.all; end ">="; function ">=" ! (Left : in Unbounded_String; ! Right : in String) return Boolean is begin ! return Left.Reference.all >= Right; end ">="; function ">=" ! (Left : in String; ! Right : in Unbounded_String) return Boolean is begin ! return Left >= Right.Reference.all; end ">="; ------------ --- 219,358 ---- -- "<" -- --------- ! function "<" (Left, Right : Unbounded_String) return Boolean is begin ! return ! Left.Reference (1 .. Left.Last) < Right.Reference (1 .. Right.Last); end "<"; function "<" ! (Left : Unbounded_String; ! Right : String) return Boolean is begin ! return Left.Reference (1 .. Left.Last) < Right; end "<"; function "<" ! (Left : String; ! Right : Unbounded_String) return Boolean is begin ! return Left < Right.Reference (1 .. Right.Last); end "<"; ---------- -- "<=" -- ---------- ! function "<=" (Left, Right : Unbounded_String) return Boolean is begin ! return ! Left.Reference (1 .. Left.Last) <= Right.Reference (1 .. Right.Last); end "<="; function "<=" ! (Left : Unbounded_String; ! Right : String) return Boolean is begin ! return Left.Reference (1 .. Left.Last) <= Right; end "<="; function "<=" ! (Left : String; ! Right : Unbounded_String) return Boolean is begin ! return Left <= Right.Reference (1 .. Right.Last); end "<="; --------- -- "=" -- --------- ! function "=" (Left, Right : Unbounded_String) return Boolean is begin ! return ! Left.Reference (1 .. Left.Last) = Right.Reference (1 .. Right.Last); end "="; function "=" ! (Left : Unbounded_String; ! Right : String) return Boolean is begin ! return Left.Reference (1 .. Left.Last) = Right; end "="; function "=" ! (Left : String; ! Right : Unbounded_String) return Boolean is begin ! return Left = Right.Reference (1 .. Right.Last); end "="; --------- -- ">" -- --------- ! function ">" (Left, Right : Unbounded_String) return Boolean is begin ! return ! Left.Reference (1 .. Left.Last) > Right.Reference (1 .. Right.Last); end ">"; function ">" ! (Left : Unbounded_String; ! Right : String) return Boolean is begin ! return Left.Reference (1 .. Left.Last) > Right; end ">"; function ">" ! (Left : String; ! Right : Unbounded_String) return Boolean is begin ! return Left > Right.Reference (1 .. Right.Last); end ">"; ---------- -- ">=" -- ---------- ! function ">=" (Left, Right : Unbounded_String) return Boolean is begin ! return ! Left.Reference (1 .. Left.Last) >= Right.Reference (1 .. Right.Last); end ">="; function ">=" ! (Left : Unbounded_String; ! Right : String) return Boolean is begin ! return Left.Reference (1 .. Left.Last) >= Right; end ">="; function ">=" ! (Left : String; ! Right : Unbounded_String) return Boolean is begin ! return Left >= Right.Reference (1 .. Right.Last); end ">="; ------------ *************** package body Ada.Strings.Unbounded is *** 317,325 **** begin -- Copy string, except we do not copy the statically allocated null -- string, since it can never be deallocated. if Object.Reference /= Null_String'Access then ! Object.Reference := new String'(Object.Reference.all); end if; end Adjust; --- 363,373 ---- begin -- Copy string, except we do not copy the statically allocated null -- string, since it can never be deallocated. + -- Note that we do not copy extra string room here to avoid dragging + -- unused allocated memory. if Object.Reference /= Null_String'Access then ! Object.Reference := new String'(Object.Reference (1 .. Object.Last)); end if; end Adjust; *************** package body Ada.Strings.Unbounded is *** 329,378 **** procedure Append (Source : in out Unbounded_String; ! New_Item : in Unbounded_String) is - S_Length : constant Integer := Source.Reference.all'Length; - Length : constant Integer := S_Length + New_Item.Reference.all'Length; - Tmp : String_Access; - begin ! Tmp := new String (1 .. Length); ! Tmp (1 .. S_Length) := Source.Reference.all; ! Tmp (S_Length + 1 .. Length) := New_Item.Reference.all; ! Free (Source.Reference); ! Source.Reference := Tmp; end Append; procedure Append (Source : in out Unbounded_String; ! New_Item : in String) is - S_Length : constant Integer := Source.Reference.all'Length; - Length : constant Integer := S_Length + New_Item'Length; - Tmp : String_Access; - begin ! Tmp := new String (1 .. Length); ! Tmp (1 .. S_Length) := Source.Reference.all; ! Tmp (S_Length + 1 .. Length) := New_Item; ! Free (Source.Reference); ! Source.Reference := Tmp; end Append; procedure Append (Source : in out Unbounded_String; ! New_Item : in Character) is - S_Length : constant Integer := Source.Reference.all'Length; - Length : constant Integer := S_Length + 1; - Tmp : String_Access; - begin ! Tmp := new String (1 .. Length); ! Tmp (1 .. S_Length) := Source.Reference.all; ! Tmp (S_Length + 1) := New_Item; ! Free (Source.Reference); ! Source.Reference := Tmp; end Append; ----------- --- 377,410 ---- procedure Append (Source : in out Unbounded_String; ! New_Item : Unbounded_String) is begin ! Realloc_For_Chunk (Source, New_Item.Last); ! Source.Reference (Source.Last + 1 .. Source.Last + New_Item.Last) := ! New_Item.Reference (1 .. New_Item.Last); ! Source.Last := Source.Last + New_Item.Last; end Append; procedure Append (Source : in out Unbounded_String; ! New_Item : String) is begin ! Realloc_For_Chunk (Source, New_Item'Length); ! Source.Reference (Source.Last + 1 .. Source.Last + New_Item'Length) := ! New_Item; ! Source.Last := Source.Last + New_Item'Length; end Append; procedure Append (Source : in out Unbounded_String; ! New_Item : Character) is begin ! Realloc_For_Chunk (Source, 1); ! Source.Reference (Source.Last + 1) := New_Item; ! Source.Last := Source.Last + 1; end Append; ----------- *************** package body Ada.Strings.Unbounded is *** 386,402 **** return Natural is begin ! return Search.Count (Source.Reference.all, Pattern, Mapping); end Count; function Count ! (Source : in Unbounded_String; ! Pattern : in String; ! Mapping : in Maps.Character_Mapping_Function) return Natural is begin ! return Search.Count (Source.Reference.all, Pattern, Mapping); end Count; function Count --- 418,436 ---- return Natural is begin ! return ! Search.Count (Source.Reference (1 .. Source.Last), Pattern, Mapping); end Count; function Count ! (Source : Unbounded_String; ! Pattern : String; ! Mapping : Maps.Character_Mapping_Function) return Natural is begin ! return ! Search.Count (Source.Reference (1 .. Source.Last), Pattern, Mapping); end Count; function Count *************** package body Ada.Strings.Unbounded is *** 405,411 **** return Natural is begin ! return Search.Count (Source.Reference.all, Set); end Count; ------------ --- 439,445 ---- return Natural is begin ! return Search.Count (Source.Reference (1 .. Source.Last), Set); end Count; ------------ *************** package body Ada.Strings.Unbounded is *** 421,440 **** begin return To_Unbounded_String ! (Fixed.Delete (Source.Reference.all, From, Through)); end Delete; procedure Delete (Source : in out Unbounded_String; ! From : in Positive; ! Through : in Natural) is - Old : String_Access := Source.Reference; - begin ! Source.Reference := ! new String' (Fixed.Delete (Old.all, From, Through)); ! Free (Old); end Delete; ------------- --- 455,485 ---- begin return To_Unbounded_String ! (Fixed.Delete (Source.Reference (1 .. Source.Last), From, Through)); end Delete; procedure Delete (Source : in out Unbounded_String; ! From : Positive; ! Through : Natural) is begin ! if From > Through then ! null; ! ! elsif From < Source.Reference'First or else Through > Source.Last then ! raise Index_Error; ! ! else ! declare ! Len : constant Natural := Through - From + 1; ! ! begin ! Source.Reference (From .. Source.Last - Len) := ! Source.Reference (Through + 1 .. Source.Last); ! Source.Last := Source.Last - Len; ! end; ! end if; end Delete; ------------- *************** package body Ada.Strings.Unbounded is *** 447,454 **** return Character is begin ! if Index <= Source.Reference.all'Last then ! return Source.Reference.all (Index); else raise Strings.Index_Error; end if; --- 492,499 ---- return Character is begin ! if Index <= Source.Last then ! return Source.Reference (Index); else raise Strings.Index_Error; end if; *************** package body Ada.Strings.Unbounded is *** 468,473 **** --- 513,519 ---- if Object.Reference /= Null_String'Access then Deallocate (Object.Reference); Object.Reference := Null_Unbounded_String.Reference; + Object.Last := 0; end if; end Finalize; *************** package body Ada.Strings.Unbounded is *** 483,489 **** Last : out Natural) is begin ! Search.Find_Token (Source.Reference.all, Set, Test, First, Last); end Find_Token; ---------- --- 529,536 ---- Last : out Natural) is begin ! Search.Find_Token ! (Source.Reference (1 .. Source.Last), Set, Test, First, Last); end Find_Token; ---------- *************** package body Ada.Strings.Unbounded is *** 495,501 **** new Ada.Unchecked_Deallocation (String, String_Access); begin ! -- Note: Don't try to free statically allocated null string if X /= Null_Unbounded_String.Reference then Deallocate (X); --- 542,548 ---- new Ada.Unchecked_Deallocation (String, String_Access); begin ! -- Note: Do not try to free statically allocated null string if X /= Null_Unbounded_String.Reference then Deallocate (X); *************** package body Ada.Strings.Unbounded is *** 513,531 **** return Unbounded_String is begin ! return ! To_Unbounded_String (Fixed.Head (Source.Reference.all, Count, Pad)); end Head; procedure Head (Source : in out Unbounded_String; ! Count : in Natural; ! Pad : in Character := Space) is Old : String_Access := Source.Reference; begin ! Source.Reference := new String'(Fixed.Head (Old.all, Count, Pad)); Free (Old); end Head; --- 560,581 ---- return Unbounded_String is begin ! return To_Unbounded_String ! (Fixed.Head (Source.Reference (1 .. Source.Last), Count, Pad)); end Head; procedure Head (Source : in out Unbounded_String; ! Count : Natural; ! Pad : Character := Space) is Old : String_Access := Source.Reference; begin ! Source.Reference := ! new String'(Fixed.Head (Source.Reference (1 .. Source.Last), ! Count, Pad)); ! Source.Last := Source.Reference'Length; Free (Old); end Head; *************** package body Ada.Strings.Unbounded is *** 541,558 **** return Natural is begin ! return Search.Index (Source.Reference.all, Pattern, Going, Mapping); end Index; function Index ! (Source : in Unbounded_String; ! Pattern : in String; ! Going : in Direction := Forward; ! Mapping : in Maps.Character_Mapping_Function) ! return Natural is begin ! return Search.Index (Source.Reference.all, Pattern, Going, Mapping); end Index; function Index --- 591,610 ---- return Natural is begin ! return Search.Index ! (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping); end Index; function Index ! (Source : Unbounded_String; ! Pattern : String; ! Going : Direction := Forward; ! Mapping : Maps.Character_Mapping_Function) ! return Natural is begin ! return Search.Index ! (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping); end Index; function Index *************** package body Ada.Strings.Unbounded is *** 563,569 **** return Natural is begin ! return Search.Index (Source.Reference.all, Set, Test, Going); end Index; function Index_Non_Blank --- 615,622 ---- return Natural is begin ! return Search.Index ! (Source.Reference (1 .. Source.Last), Set, Test, Going); end Index; function Index_Non_Blank *************** package body Ada.Strings.Unbounded is *** 572,578 **** return Natural is begin ! return Search.Index_Non_Blank (Source.Reference.all, Going); end Index_Non_Blank; ---------------- --- 625,632 ---- return Natural is begin ! return ! Search.Index_Non_Blank (Source.Reference (1 .. Source.Last), Going); end Index_Non_Blank; ---------------- *************** package body Ada.Strings.Unbounded is *** 582,587 **** --- 636,642 ---- procedure Initialize (Object : in out Unbounded_String) is begin Object.Reference := Null_Unbounded_String.Reference; + Object.Last := 0; end Initialize; ------------ *************** package body Ada.Strings.Unbounded is *** 595,616 **** return Unbounded_String is begin ! return ! To_Unbounded_String ! (Fixed.Insert (Source.Reference.all, Before, New_Item)); end Insert; procedure Insert (Source : in out Unbounded_String; ! Before : in Positive; ! New_Item : in String) is - Old : String_Access := Source.Reference; - begin ! Source.Reference := ! new String' (Fixed.Insert (Source.Reference.all, Before, New_Item)); ! Free (Old); end Insert; ------------ --- 650,677 ---- return Unbounded_String is begin ! return To_Unbounded_String ! (Fixed.Insert (Source.Reference (1 .. Source.Last), Before, New_Item)); end Insert; procedure Insert (Source : in out Unbounded_String; ! Before : Positive; ! New_Item : String) is begin ! if Before not in Source.Reference'First .. Source.Last + 1 then ! raise Index_Error; ! end if; ! ! Realloc_For_Chunk (Source, New_Item'Size); ! ! Source.Reference ! (Before + New_Item'Length .. Source.Last + New_Item'Length) := ! Source.Reference (Before .. Source.Last); ! ! Source.Reference (Before .. Before + New_Item'Length - 1) := New_Item; ! Source.Last := Source.Last + New_Item'Length; end Insert; ------------ *************** package body Ada.Strings.Unbounded is *** 619,625 **** function Length (Source : Unbounded_String) return Natural is begin ! return Source.Reference.all'Length; end Length; --------------- --- 680,686 ---- function Length (Source : Unbounded_String) return Natural is begin ! return Source.Last; end Length; --------------- *************** package body Ada.Strings.Unbounded is *** 634,651 **** begin return To_Unbounded_String ! (Fixed.Overwrite (Source.Reference.all, Position, New_Item)); end Overwrite; procedure Overwrite (Source : in out Unbounded_String; ! Position : in Positive; ! New_Item : in String) is ! NL : constant Integer := New_Item'Length; begin ! if Position <= Source.Reference'Length - NL + 1 then Source.Reference (Position .. Position + NL - 1) := New_Item; else --- 695,713 ---- begin return To_Unbounded_String ! (Fixed.Overwrite ! (Source.Reference (1 .. Source.Last), Position, New_Item)); end Overwrite; procedure Overwrite (Source : in out Unbounded_String; ! Position : Positive; ! New_Item : String) is ! NL : constant Natural := New_Item'Length; begin ! if Position <= Source.Last - NL + 1 then Source.Reference (Position .. Position + NL - 1) := New_Item; else *************** package body Ada.Strings.Unbounded is *** 653,665 **** Old : String_Access := Source.Reference; begin ! Source.Reference := new ! String'(Fixed.Overwrite (Old.all, Position, New_Item)); Free (Old); end; end if; end Overwrite; --------------------- -- Replace_Element -- --------------------- --- 715,756 ---- Old : String_Access := Source.Reference; begin ! Source.Reference := new String' ! (Fixed.Overwrite ! (Source.Reference (1 .. Source.Last), Position, New_Item)); ! Source.Last := Source.Reference'Length; Free (Old); end; end if; end Overwrite; + ----------------------- + -- Realloc_For_Chunk -- + ----------------------- + + procedure Realloc_For_Chunk + (Source : in out Unbounded_String; + Chunk_Size : Natural) + is + Growth_Factor : constant := 50; + S_Length : constant Natural := Source.Reference'Length; + + begin + if Chunk_Size > S_Length - Source.Last then + declare + Alloc_Chunk_Size : constant Positive := + Chunk_Size + (S_Length / Growth_Factor); + Tmp : String_Access; + + begin + Tmp := new String (1 .. S_Length + Alloc_Chunk_Size); + Tmp (1 .. Source.Last) := Source.Reference (1 .. Source.Last); + Free (Source.Reference); + Source.Reference := Tmp; + end; + end if; + end Realloc_For_Chunk; + --------------------- -- Replace_Element -- --------------------- *************** package body Ada.Strings.Unbounded is *** 670,677 **** By : Character) is begin ! if Index <= Source.Reference.all'Last then ! Source.Reference.all (Index) := By; else raise Strings.Index_Error; end if; --- 761,768 ---- By : Character) is begin ! if Index <= Source.Last then ! Source.Reference (Index) := By; else raise Strings.Index_Error; end if; *************** package body Ada.Strings.Unbounded is *** 689,710 **** return Unbounded_String is begin ! return ! To_Unbounded_String ! (Fixed.Replace_Slice (Source.Reference.all, Low, High, By)); end Replace_Slice; procedure Replace_Slice (Source : in out Unbounded_String; ! Low : in Positive; ! High : in Natural; ! By : in String) is Old : String_Access := Source.Reference; begin ! Source.Reference := ! new String'(Fixed.Replace_Slice (Old.all, Low, High, By)); Free (Old); end Replace_Slice; --- 780,803 ---- return Unbounded_String is begin ! return To_Unbounded_String ! (Fixed.Replace_Slice ! (Source.Reference (1 .. Source.Last), Low, High, By)); end Replace_Slice; procedure Replace_Slice (Source : in out Unbounded_String; ! Low : Positive; ! High : Natural; ! By : String) is Old : String_Access := Source.Reference; begin ! Source.Reference := new String' ! (Fixed.Replace_Slice ! (Source.Reference (1 .. Source.Last), Low, High, By)); ! Source.Last := Source.Reference'Length; Free (Old); end Replace_Slice; *************** package body Ada.Strings.Unbounded is *** 718,732 **** High : Natural) return String is - Length : constant Natural := Source.Reference'Length; - begin -- Note: test of High > Length is in accordance with AI95-00128 ! if Low > Length + 1 or else High > Length then raise Index_Error; else ! return Source.Reference.all (Low .. High); end if; end Slice; --- 811,823 ---- High : Natural) return String is begin -- Note: test of High > Length is in accordance with AI95-00128 ! if Low > Source.Last + 1 or else High > Source.Last then raise Index_Error; else ! return Source.Reference (Low .. High); end if; end Slice; *************** package body Ada.Strings.Unbounded is *** 741,759 **** return Unbounded_String is begin ! return ! To_Unbounded_String (Fixed.Tail (Source.Reference.all, Count, Pad)); end Tail; procedure Tail (Source : in out Unbounded_String; ! Count : in Natural; ! Pad : in Character := Space) is Old : String_Access := Source.Reference; begin ! Source.Reference := new String'(Fixed.Tail (Old.all, Count, Pad)); Free (Old); end Tail; --- 832,852 ---- return Unbounded_String is begin ! return To_Unbounded_String ! (Fixed.Tail (Source.Reference (1 .. Source.Last), Count, Pad)); end Tail; procedure Tail (Source : in out Unbounded_String; ! Count : Natural; ! Pad : Character := Space) is Old : String_Access := Source.Reference; begin ! Source.Reference := new String' ! (Fixed.Tail (Source.Reference (1 .. Source.Last), Count, Pad)); ! Source.Last := Source.Reference'Length; Free (Old); end Tail; *************** package body Ada.Strings.Unbounded is *** 763,769 **** function To_String (Source : Unbounded_String) return String is begin ! return Source.Reference.all; end To_String; ------------------------- --- 856,862 ---- function To_String (Source : Unbounded_String) return String is begin ! return Source.Reference (1 .. Source.Last); end To_String; ------------------------- *************** package body Ada.Strings.Unbounded is *** 774,791 **** Result : Unbounded_String; begin ! Result.Reference := new String (1 .. Source'Length); Result.Reference.all := Source; return Result; end To_Unbounded_String; function To_Unbounded_String ! (Length : in Natural) return Unbounded_String is Result : Unbounded_String; begin Result.Reference := new String (1 .. Length); return Result; end To_Unbounded_String; --- 867,886 ---- Result : Unbounded_String; begin ! Result.Last := Source'Length; ! Result.Reference := new String (1 .. Source'Length); Result.Reference.all := Source; return Result; end To_Unbounded_String; function To_Unbounded_String ! (Length : Natural) return Unbounded_String is Result : Unbounded_String; begin + Result.Last := Length; Result.Reference := new String (1 .. Length); return Result; end To_Unbounded_String; *************** package body Ada.Strings.Unbounded is *** 800,807 **** return Unbounded_String is begin ! return ! To_Unbounded_String (Fixed.Translate (Source.Reference.all, Mapping)); end Translate; procedure Translate --- 895,902 ---- return Unbounded_String is begin ! return To_Unbounded_String ! (Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping)); end Translate; procedure Translate *************** package body Ada.Strings.Unbounded is *** 809,833 **** Mapping : Maps.Character_Mapping) is begin ! Fixed.Translate (Source.Reference.all, Mapping); end Translate; function Translate ! (Source : in Unbounded_String; ! Mapping : in Maps.Character_Mapping_Function) return Unbounded_String is begin ! return ! To_Unbounded_String (Fixed.Translate (Source.Reference.all, Mapping)); end Translate; procedure Translate (Source : in out Unbounded_String; ! Mapping : in Maps.Character_Mapping_Function) is begin ! Fixed.Translate (Source.Reference.all, Mapping); end Translate; ---------- --- 904,928 ---- Mapping : Maps.Character_Mapping) is begin ! Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping); end Translate; function Translate ! (Source : Unbounded_String; ! Mapping : Maps.Character_Mapping_Function) return Unbounded_String is begin ! return To_Unbounded_String ! (Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping)); end Translate; procedure Translate (Source : in out Unbounded_String; ! Mapping : Maps.Character_Mapping_Function) is begin ! Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping); end Translate; ---------- *************** package body Ada.Strings.Unbounded is *** 835,879 **** ---------- function Trim ! (Source : in Unbounded_String; ! Side : in Trim_End) return Unbounded_String is begin ! return To_Unbounded_String (Fixed.Trim (Source.Reference.all, Side)); end Trim; procedure Trim (Source : in out Unbounded_String; ! Side : in Trim_End) is Old : String_Access := Source.Reference; begin ! Source.Reference := new String'(Fixed.Trim (Old.all, Side)); Free (Old); end Trim; function Trim ! (Source : in Unbounded_String; ! Left : in Maps.Character_Set; ! Right : in Maps.Character_Set) return Unbounded_String is begin ! return ! To_Unbounded_String (Fixed.Trim (Source.Reference.all, Left, Right)); end Trim; procedure Trim (Source : in out Unbounded_String; ! Left : in Maps.Character_Set; ! Right : in Maps.Character_Set) is Old : String_Access := Source.Reference; begin ! Source.Reference := new String'(Fixed.Trim (Old.all, Left, Right)); Free (Old); end Trim; --- 930,979 ---- ---------- function Trim ! (Source : Unbounded_String; ! Side : Trim_End) return Unbounded_String is begin ! return To_Unbounded_String ! (Fixed.Trim (Source.Reference (1 .. Source.Last), Side)); end Trim; procedure Trim (Source : in out Unbounded_String; ! Side : Trim_End) is Old : String_Access := Source.Reference; begin ! Source.Reference := new String' ! (Fixed.Trim (Source.Reference (1 .. Source.Last), Side)); ! Source.Last := Source.Reference'Length; Free (Old); end Trim; function Trim ! (Source : Unbounded_String; ! Left : Maps.Character_Set; ! Right : Maps.Character_Set) return Unbounded_String is begin ! return To_Unbounded_String ! (Fixed.Trim (Source.Reference (1 .. Source.Last), Left, Right)); end Trim; procedure Trim (Source : in out Unbounded_String; ! Left : Maps.Character_Set; ! Right : Maps.Character_Set) is Old : String_Access := Source.Reference; begin ! Source.Reference := new String' ! (Fixed.Trim (Source.Reference (1 .. Source.Last), Left, Right)); ! Source.Last := Source.Reference'Length; Free (Old); end Trim; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-strunb.ads gcc-3.4.0/gcc/ada/a-strunb.ads *** gcc-3.3.3/gcc/ada/a-strunb.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-strunb.ads 2003-10-21 13:41:54.000000000 +0000 *************** *** 1,13 **** ------------------------------------------------------------------------------ -- -- ! -- GNAT RUN-TIME COMPONENTS -- -- -- -- A D A . S T R I N G S . U N B O U N D E D -- -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1992-1998 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 -- --- 1,12 ---- ------------------------------------------------------------------------------ -- -- ! -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . S T R I N G S . U N B O U N D E D -- -- -- -- 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 -- *************** private *** 366,373 **** --- 365,380 ---- type Unbounded_String is new AF.Controlled with record Reference : String_Access := Null_String'Access; + Last : Natural := 0; end record; + -- The Unbounded_String is using a buffered implementation to increase + -- speed of the Append/Delete/Insert procedures. The Reference string + -- pointer above contains the current string value and extra room at the + -- end to be used by the next Append routine. Last is the index of the + -- string ending character. So the current string value is really + -- Reference (1 .. Last). + pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String); pragma Finalize_Storage_Only (Unbounded_String); *************** private *** 376,382 **** procedure Adjust (Object : in out Unbounded_String); procedure Finalize (Object : in out Unbounded_String); Null_Unbounded_String : constant Unbounded_String := ! (AF.Controlled with Reference => Null_String'Access); end Ada.Strings.Unbounded; --- 383,395 ---- procedure Adjust (Object : in out Unbounded_String); procedure Finalize (Object : in out Unbounded_String); + -- Note: the following declaration is illegal since library level + -- controlled objects are not allowed in preelaborated units. See + -- AI-161 for a discussion of this issue and an attempt to address it. + -- Meanwhile, what happens in GNAT is that this check is omitted for + -- internal implementation units (see check in sem_cat.adb). + Null_Unbounded_String : constant Unbounded_String := ! (AF.Controlled with Reference => Null_String'Access, Last => 0); end Ada.Strings.Unbounded; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-ststio.adb gcc-3.4.0/gcc/ada/a-ststio.adb *** gcc-3.3.3/gcc/ada/a-ststio.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-ststio.adb 2003-12-15 11:51:00.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-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- -- *************** with Interfaces.C_Streams; use Inte *** 36,41 **** --- 35,41 ---- with System; use System; with System.File_IO; with System.Soft_Links; + with System.CRTL; with Unchecked_Conversion; with Unchecked_Deallocation; *************** package body Ada.Streams.Stream_IO is *** 115,125 **** Name : in String := ""; Form : in String := "") is ! File_Control_Block : Stream_AFCB; begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => File_Control_Block, Mode => To_FCB (Mode), Name => Name, Form => Form, --- 115,128 ---- Name : in String := ""; Form : in String := "") is ! Dummy_File_Control_Block : Stream_AFCB; ! pragma Warnings (Off, Dummy_File_Control_Block); ! -- Yes, we know this is never assigned a value, only the tag ! -- is used for dispatching purposes, so that's expected. begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => Dummy_File_Control_Block, Mode => To_FCB (Mode), Name => Name, Form => Form, *************** package body Ada.Streams.Stream_IO is *** 213,223 **** Name : in String; Form : in String := "") is ! File_Control_Block : Stream_AFCB; begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => File_Control_Block, Mode => To_FCB (Mode), Name => Name, Form => Form, --- 216,229 ---- Name : in String; Form : in String := "") is ! Dummy_File_Control_Block : Stream_AFCB; ! pragma Warnings (Off, Dummy_File_Control_Block); ! -- Yes, we know this is never assigned a value, only the tag ! -- is used for dispatching purposes, so that's expected. begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => Dummy_File_Control_Block, Mode => To_FCB (Mode), Name => Name, Form => Form, *************** package body Ada.Streams.Stream_IO is *** 229,235 **** Reset (File, Mode); ! File.Last_Op := Op_Read; end Open; ---------- --- 235,253 ---- Reset (File, Mode); ! -- Set last operation. The purpose here is to ensure proper handling ! -- of the initial operation. In general, a write after a read requires ! -- resetting and doing a seek, so we set the last operation as Read ! -- for an In_Out file, but for an Out file we set the last operation ! -- to Op_Write, since in this case it is not necessary to do a seek ! -- (and furthermore there are situations (such as the case of writing ! -- a sequential Posix FIFO file) where the lseek would cause problems. ! ! if Mode = Out_File then ! File.Last_Op := Op_Write; ! else ! File.Last_Op := Op_Read; ! end if; end Open; ---------- *************** package body Ada.Streams.Stream_IO is *** 365,372 **** ------------------ procedure Set_Position (File : in File_Type) is begin ! if fseek (File.Stream, long (File.Index) - 1, SEEK_SET) /= 0 then raise Use_Error; end if; end Set_Position; --- 383,393 ---- ------------------ procedure Set_Position (File : in File_Type) is + use type System.CRTL.long; begin ! if fseek (File.Stream, ! System.CRTL.long (File.Index) - 1, SEEK_SET) /= 0 ! then raise Use_Error; end if; end Set_Position; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-ststio.ads gcc-3.4.0/gcc/ada/a-ststio.ads *** gcc-3.3.3/gcc/ada/a-ststio.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-ststio.ads 2003-04-24 17:53:54.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/a-stunau.adb gcc-3.4.0/gcc/ada/a-stunau.adb *** gcc-3.3.3/gcc/ada/a-stunau.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-stunau.adb 2003-10-21 13:41:54.000000000 +0000 *************** *** 1,13 **** ------------------------------------------------------------------------------ -- -- ! -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . S T R I N G S . U N B O U N D E D . A U X -- -- -- -- B o d y -- -- -- ! -- -- ! -- 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- -- --- 1,12 ---- ------------------------------------------------------------------------------ -- -- ! -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . S T R I N G S . U N B O U N D E D . A U X -- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-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.Strings.Unbounded.Aux i *** 38,46 **** -- Get_String -- ---------------- ! function Get_String (U : Unbounded_String) return String_Access is begin ! return U.Reference; end Get_String; ---------------- --- 37,65 ---- -- Get_String -- ---------------- ! function Get_String (U : Unbounded_String) return String_Access is begin ! if U.Last = U.Reference'Length then ! return U.Reference; ! ! else ! declare ! type Unbounded_String_Access is access all Unbounded_String; ! ! U_Ptr : constant Unbounded_String_Access := U'Unrestricted_Access; ! -- Unbounded_String is a controlled type which is always passed ! -- by copy it is always safe to take the pointer to such object ! -- here. This pointer is used to set the U.Reference value which ! -- would not be possible otherwise as U is read-only. ! ! Old : String_Access := U.Reference; ! ! begin ! U_Ptr.Reference := new String'(U.Reference (1 .. U.Last)); ! Free (Old); ! return U.Reference; ! end; ! end if; end Get_String; ---------------- *************** package body Ada.Strings.Unbounded.Aux i *** 49,55 **** procedure Set_String (UP : in out Unbounded_String; S : String) is begin ! if UP.Reference'Length = S'Length then UP.Reference.all := S; else --- 68,74 ---- procedure Set_String (UP : in out Unbounded_String; S : String) is begin ! if UP.Last = S'Length then UP.Reference.all := S; else *************** package body Ada.Strings.Unbounded.Aux i *** 61,66 **** --- 80,86 ---- Tmp := new String'(String_1 (S)); Finalize (UP); UP.Reference := Tmp; + UP.Last := UP.Reference'Length; end; end if; end Set_String; *************** package body Ada.Strings.Unbounded.Aux i *** 69,74 **** --- 89,95 ---- begin Finalize (UP); UP.Reference := S; + UP.Last := UP.Reference'Length; end Set_String; end Ada.Strings.Unbounded.Aux; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-stunau.ads gcc-3.4.0/gcc/ada/a-stunau.ads *** gcc-3.3.3/gcc/ada/a-stunau.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-stunau.ads 2003-10-21 13:41:54.000000000 +0000 *************** *** 1,13 **** ------------------------------------------------------------------------------ -- -- ! -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . S T R I N G S . U N B O U N D E D . A U X -- -- -- -- S p e c -- -- -- ! -- -- ! -- 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- -- --- 1,12 ---- ------------------------------------------------------------------------------ -- -- ! -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . S T R I N G S . U N B O U N D E D . A U X -- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-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- -- *************** *** 40,46 **** package Ada.Strings.Unbounded.Aux is pragma Preelaborate (Aux); ! function Get_String (U : Unbounded_String) return String_Access; pragma Inline (Get_String); -- This function returns the internal string pointer used in the -- representation of an unbounded string. There is no copy involved, --- 39,45 ---- package Ada.Strings.Unbounded.Aux is pragma Preelaborate (Aux); ! function Get_String (U : Unbounded_String) return String_Access; pragma Inline (Get_String); -- This function returns the internal string pointer used in the -- representation of an unbounded string. There is no copy involved, diff -Nrc3pad gcc-3.3.3/gcc/ada/a-stwibo.adb gcc-3.4.0/gcc/ada/a-stwibo.adb *** gcc-3.3.3/gcc/ada/a-stwibo.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-stwibo.adb 2003-10-21 13:41:54.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-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,154 **** -- -- ------------------------------------------------------------------------------ - with Ada.Strings.Wide_Maps; use Ada.Strings.Wide_Maps; - with Ada.Strings.Wide_Search; - package body Ada.Strings.Wide_Bounded is package body Generic_Bounded_Length is --------- - -- "&" -- - --------- - - function "&" - (Left : in Bounded_Wide_String; - Right : in Bounded_Wide_String) - return Bounded_Wide_String - is - Result : Bounded_Wide_String; - Llen : constant Length_Range := Left.Length; - Rlen : constant Length_Range := Right.Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen > Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - end if; - - return Result; - end "&"; - - function "&" - (Left : in Bounded_Wide_String; - Right : in Wide_String) - return Bounded_Wide_String - is - Result : Bounded_Wide_String; - Llen : constant Length_Range := Left.Length; - - Nlen : constant Natural := Llen + Right'Length; - - begin - if Nlen > Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right; - end if; - return Result; - end "&"; - - function "&" - (Left : in Wide_String; - Right : in Bounded_Wide_String) - return Bounded_Wide_String - is - Result : Bounded_Wide_String; - Llen : constant Length_Range := Left'Length; - Rlen : constant Length_Range := Right.Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen > Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Length := Nlen; - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - end if; - - return Result; - end "&"; - - function "&" - (Left : in Bounded_Wide_String; - Right : in Wide_Character) - return Bounded_Wide_String - is - Result : Bounded_Wide_String; - Llen : constant Length_Range := Left.Length; - - begin - if Llen = Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Length := Llen + 1; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Result.Length) := Right; - end if; - - return Result; - end "&"; - - function "&" - (Left : in Wide_Character; - Right : in Bounded_Wide_String) - return Bounded_Wide_String - is - Result : Bounded_Wide_String; - Rlen : Length_Range := Right.Length; - - begin - if Rlen = Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Length := Rlen + 1; - Result.Data (1) := Left; - Result.Data (2 .. Result.Length) := Right.Data (1 .. Rlen); - end if; - - return Result; - end "&"; - - --------- -- "*" -- --------- --- 31,41 ---- *************** package body Ada.Strings.Wide_Bounded is *** 157,176 **** Right : in Wide_Character) return Bounded_Wide_String is - Result : Bounded_Wide_String; - begin ! if Left > Max_Length then ! raise Ada.Strings.Length_Error; ! else ! Result.Length := Left; ! ! for J in 1 .. Left loop ! Result.Data (J) := Right; ! end loop; ! end if; ! ! return Result; end "*"; function "*" --- 44,51 ---- Right : in Wide_Character) return Bounded_Wide_String is begin ! return Times (Left, Right, Max_Length); end "*"; function "*" *************** package body Ada.Strings.Wide_Bounded is *** 178,1364 **** Right : in Wide_String) return Bounded_Wide_String is - Result : Bounded_Wide_String; - Pos : Positive := 1; - Rlen : constant Natural := Right'Length; - Nlen : constant Natural := Left * Rlen; - - begin - if Nlen > Max_Length then - raise Ada.Strings.Index_Error; - else - Result.Length := Nlen; - - if Nlen > 0 then - for J in 1 .. Left loop - Result.Data (Pos .. Pos + Rlen - 1) := Right; - Pos := Pos + Rlen; - end loop; - end if; - end if; - - return Result; - end "*"; - - function "*" - (Left : in Natural; - Right : in Bounded_Wide_String) - return Bounded_Wide_String - is - Result : Bounded_Wide_String; - Pos : Positive := 1; - Rlen : constant Length_Range := Right.Length; - Nlen : constant Natural := Left * Rlen; - begin ! if Nlen > Max_Length then ! raise Ada.Strings.Length_Error; ! ! else ! Result.Length := Nlen; ! ! if Nlen > 0 then ! for J in 1 .. Left loop ! Result.Data (Pos .. Pos + Rlen - 1) := ! Right.Data (1 .. Rlen); ! Pos := Pos + Rlen; ! end loop; ! end if; ! end if; ! ! return Result; end "*"; - --------- - -- "<" -- - --------- - - function "<" - (Left : in Bounded_Wide_String; - Right : in Bounded_Wide_String) - return Boolean - is - begin - return Left.Data (1 .. Left.Length) < Right.Data (1 .. Right.Length); - end "<"; - - function "<" - (Left : in Bounded_Wide_String; - Right : in Wide_String) - return Boolean - is - begin - return Left.Data (1 .. Left.Length) < Right; - end "<"; - - function "<" - (Left : in Wide_String; - Right : in Bounded_Wide_String) - return Boolean - is - begin - return Left < Right.Data (1 .. Right.Length); - end "<"; - - ---------- - -- "<=" -- - ---------- - - function "<=" - (Left : in Bounded_Wide_String; - Right : in Bounded_Wide_String) - return Boolean - is - begin - return Left.Data (1 .. Left.Length) <= Right.Data (1 .. Right.Length); - end "<="; - - function "<=" - (Left : in Bounded_Wide_String; - Right : in Wide_String) - return Boolean - is - begin - return Left.Data (1 .. Left.Length) <= Right; - end "<="; - - function "<=" - (Left : in Wide_String; - Right : in Bounded_Wide_String) - return Boolean - is - begin - return Left <= Right.Data (1 .. Right.Length); - end "<="; - - --------- - -- "=" -- - --------- - - function "=" - (Left : in Bounded_Wide_String; - Right : in Bounded_Wide_String) - return Boolean - is - begin - return Left.Length = Right.Length - and then Left.Data (1 .. Left.Length) = - Right.Data (1 .. Right.Length); - end "="; - - function "=" - (Left : in Bounded_Wide_String; - Right : in Wide_String) - return Boolean - is - begin - return Left.Length = Right'Length - and then Left.Data (1 .. Left.Length) = Right; - end "="; - - function "=" - (Left : in Wide_String; - Right : in Bounded_Wide_String) - return Boolean - is - begin - return Left'Length = Right.Length - and then Left = Right.Data (1 .. Right.Length); - end "="; - - --------- - -- ">" -- - --------- - - function ">" - (Left : in Bounded_Wide_String; - Right : in Bounded_Wide_String) - return Boolean - is - begin - return Left.Data (1 .. Left.Length) > Right.Data (1 .. Right.Length); - end ">"; - - function ">" - (Left : in Bounded_Wide_String; - Right : in Wide_String) - return Boolean - is - begin - return Left.Data (1 .. Left.Length) > Right; - end ">"; - - function ">" - (Left : in Wide_String; - Right : in Bounded_Wide_String) - return Boolean - is - begin - return Left > Right.Data (1 .. Right.Length); - end ">"; - - ---------- - -- ">=" -- - ---------- - - function ">=" - (Left : in Bounded_Wide_String; - Right : in Bounded_Wide_String) - return Boolean - is - begin - return Left.Data (1 .. Left.Length) >= Right.Data (1 .. Right.Length); - end ">="; - - function ">=" - (Left : in Bounded_Wide_String; - Right : in Wide_String) - return Boolean - is - begin - return Left.Data (1 .. Left.Length) >= Right; - end ">="; - - function ">=" - (Left : in Wide_String; - Right : in Bounded_Wide_String) - return Boolean - is - begin - return Left >= Right.Data (1 .. Right.Length); - end ">="; - - ------------ - -- Append -- - ------------ - - -- Case of Bounded_Wide_String and Bounded_Wide_String - - function Append - (Left, Right : in Bounded_Wide_String; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_Wide_String - is - Result : Bounded_Wide_String; - Llen : constant Length_Range := Left.Length; - Rlen : constant Length_Range := Right.Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Result.Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - - else - Result.Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen >= Max_Length then -- only case is Llen = Max_Length - Result.Data := Right.Data; - - else - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Max_Length) := - Right.Data (1 .. Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then -- only case is Rlen = Max_Length - Result.Data := Right.Data; - - else - Result.Data (1 .. Max_Length - Rlen) := - Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Result.Data (Max_Length - Rlen + 1 .. Max_Length) := - Right.Data (1 .. Rlen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Append; - - procedure Append - (Source : in out Bounded_Wide_String; - New_Item : in Bounded_Wide_String; - Drop : in Truncation := Error) - is - Llen : constant Length_Range := Source.Length; - Rlen : constant Length_Range := New_Item.Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Source.Length := Nlen; - Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen); - - else - Source.Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen < Max_Length then - Source.Data (Llen + 1 .. Max_Length) := - New_Item.Data (1 .. Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then -- only case is Rlen = Max_Length - Source.Data := New_Item.Data; - - else - Source.Data (1 .. Max_Length - Rlen) := - Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Source.Data (Max_Length - Rlen + 1 .. Max_Length) := - New_Item.Data (1 .. Rlen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - end Append; - - -- Case of Bounded_Wide_String and Wide_String - - function Append - (Left : in Bounded_Wide_String; - Right : in Wide_String; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_Wide_String - is - Result : Bounded_Wide_String; - Llen : constant Length_Range := Left.Length; - Rlen : constant Length_Range := Right'Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Result.Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right; - - else - Result.Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen >= Max_Length then -- only case is Llen = Max_Length - Result.Data := Left.Data; - - else - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Max_Length) := - Right (Right'First .. Right'First - 1 + - Max_Length - Llen); - - end if; - - when Strings.Left => - if Rlen >= Max_Length then - Result.Data (1 .. Max_Length) := - Right (Right'Last - (Max_Length - 1) .. Right'Last); - - else - Result.Data (1 .. Max_Length - Rlen) := - Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Result.Data (Max_Length - Rlen + 1 .. Max_Length) := - Right; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Append; - - procedure Append - (Source : in out Bounded_Wide_String; - New_Item : in Wide_String; - Drop : in Truncation := Error) - is - Llen : constant Length_Range := Source.Length; - Rlen : constant Length_Range := New_Item'Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Source.Length := Nlen; - Source.Data (Llen + 1 .. Nlen) := New_Item; - - else - Source.Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen < Max_Length then - Source.Data (Llen + 1 .. Max_Length) := - New_Item (New_Item'First .. - New_Item'First - 1 + Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then - Source.Data (1 .. Max_Length) := - New_Item (New_Item'Last - (Max_Length - 1) .. - New_Item'Last); - - else - Source.Data (1 .. Max_Length - Rlen) := - Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Source.Data (Max_Length - Rlen + 1 .. Max_Length) := - New_Item; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - end Append; - - -- Case of Wide_String and Bounded_Wide_String - - function Append - (Left : in Wide_String; - Right : in Bounded_Wide_String; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_Wide_String - is - Result : Bounded_Wide_String; - Llen : constant Length_Range := Left'Length; - Rlen : constant Length_Range := Right.Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Result.Length := Nlen; - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen); - - else - Result.Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen >= Max_Length then - Result.Data (1 .. Max_Length) := - Left (Left'First .. Left'First + (Max_Length - 1)); - - else - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Max_Length) := - Right.Data (1 .. Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then - Result.Data (1 .. Max_Length) := - Right.Data (Rlen - (Max_Length - 1) .. Rlen); - - else - Result.Data (1 .. Max_Length - Rlen) := - Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last); - Result.Data (Max_Length - Rlen + 1 .. Max_Length) := - Right.Data (1 .. Rlen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Append; - - -- Case of Bounded_Wide_String and Wide_Character - - function Append - (Left : in Bounded_Wide_String; - Right : in Wide_Character; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_Wide_String - is - Result : Bounded_Wide_String; - Llen : constant Length_Range := Left.Length; - - begin - if Llen < Max_Length then - Result.Length := Llen + 1; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1) := Right; - return Result; - - else - case Drop is - when Strings.Right => - return Left; - - when Strings.Left => - Result.Length := Max_Length; - Result.Data (1 .. Max_Length - 1) := - Left.Data (2 .. Max_Length); - Result.Data (Max_Length) := Right; - return Result; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Append; - - procedure Append - (Source : in out Bounded_Wide_String; - New_Item : in Wide_Character; - Drop : in Truncation := Error) - is - Llen : constant Length_Range := Source.Length; - - begin - if Llen < Max_Length then - Source.Length := Llen + 1; - Source.Data (Llen + 1) := New_Item; - - else - Source.Length := Max_Length; - - case Drop is - when Strings.Right => - null; - - when Strings.Left => - Source.Data (1 .. Max_Length - 1) := - Source.Data (2 .. Max_Length); - Source.Data (Max_Length) := New_Item; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - end Append; - - -- Case of Wide_Character and Bounded_Wide_String - - function Append - (Left : in Wide_Character; - Right : in Bounded_Wide_String; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_Wide_String - is - Result : Bounded_Wide_String; - Rlen : constant Length_Range := Right.Length; - - begin - if Rlen < Max_Length then - Result.Length := Rlen + 1; - Result.Data (1) := Left; - Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen); - return Result; - - else - case Drop is - when Strings.Right => - Result.Length := Max_Length; - Result.Data (1) := Left; - Result.Data (2 .. Max_Length) := - Right.Data (1 .. Max_Length - 1); - return Result; - - when Strings.Left => - return Right; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Append; - - ----------- - -- Count -- - ----------- - - function Count - (Source : in Bounded_Wide_String; - Pattern : in Wide_String; - Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - is - begin - return - Wide_Search.Count - (Source.Data (1 .. Source.Length), Pattern, Mapping); - end Count; - - function Count - (Source : in Bounded_Wide_String; - Pattern : in Wide_String; - Mapping : in Wide_Maps.Wide_Character_Mapping_Function) - return Natural - is - begin - return - Wide_Search.Count - (Source.Data (1 .. Source.Length), Pattern, Mapping); - end Count; - - function Count - (Source : in Bounded_Wide_String; - Set : in Wide_Maps.Wide_Character_Set) - return Natural - is - begin - return Wide_Search.Count (Source.Data (1 .. Source.Length), Set); - end Count; - - ------------ - -- Delete -- - ------------ - - function Delete - (Source : in Bounded_Wide_String; - From : in Positive; - Through : in Natural) - return Bounded_Wide_String - is - Slen : constant Natural := Source.Length; - Num_Delete : constant Integer := Through - From + 1; - Result : Bounded_Wide_String; - - begin - if Num_Delete <= 0 then - return Source; - - elsif From > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif Through >= Slen then - Result.Length := From - 1; - Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); - return Result; - - else - Result.Length := Slen - Num_Delete; - Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); - Result.Data (From .. Result.Length) := - Source.Data (Through + 1 .. Slen); - return Result; - end if; - end Delete; - - procedure Delete - (Source : in out Bounded_Wide_String; - From : in Positive; - Through : in Natural) - is - Slen : constant Natural := Source.Length; - Num_Delete : constant Integer := Through - From + 1; - - begin - if Num_Delete <= 0 then - return; - - elsif From > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif Through >= Slen then - Source.Length := From - 1; - - else - Source.Length := Slen - Num_Delete; - Source.Data (From .. Source.Length) := - Source.Data (Through + 1 .. Slen); - end if; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element - (Source : in Bounded_Wide_String; - Index : in Positive) - return Wide_Character - is - begin - if Index in 1 .. Source.Length then - return Source.Data (Index); - else - raise Strings.Index_Error; - end if; - end Element; - - ---------------- - -- Find_Token -- - ---------------- - - procedure Find_Token - (Source : in Bounded_Wide_String; - Set : in Wide_Maps.Wide_Character_Set; - Test : in Strings.Membership; - First : out Positive; - Last : out Natural) - is - begin - Wide_Search.Find_Token - (Source.Data (1 .. Source.Length), Set, Test, First, Last); - end Find_Token; - - - ---------- - -- Head -- - ---------- - - function Head - (Source : in Bounded_Wide_String; - Count : in Natural; - Pad : in Wide_Character := Wide_Space; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_Wide_String - is - Result : Bounded_Wide_String; - Slen : constant Natural := Source.Length; - Npad : constant Integer := Count - Slen; - - begin - if Npad <= 0 then - Result.Length := Count; - Result.Data (1 .. Count) := Source.Data (1 .. Count); - - elsif Count <= Max_Length then - Result.Length := Count; - Result.Data (1 .. Slen) := Source.Data (1 .. Slen); - Result.Data (Slen + 1 .. Count) := (others => Pad); - - else - Result.Length := Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Slen) := Source.Data (1 .. Slen); - Result.Data (Slen + 1 .. Max_Length) := (others => Pad); - - when Strings.Left => - if Npad >= Max_Length then - Result.Data := (others => Pad); - - else - Result.Data (1 .. Max_Length - Npad) := - Source.Data (Count - Max_Length + 1 .. Slen); - Result.Data (Max_Length - Npad + 1 .. Max_Length) := - (others => Pad); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Head; - - procedure Head - (Source : in out Bounded_Wide_String; - Count : in Natural; - Pad : in Wide_Character := Wide_Space; - Drop : in Truncation := Error) - is - Slen : constant Natural := Source.Length; - Npad : constant Integer := Count - Slen; - Temp : Wide_String (1 .. Max_Length); - - begin - if Npad <= 0 then - Source.Length := Count; - - elsif Count <= Max_Length then - Source.Length := Count; - Source.Data (Slen + 1 .. Count) := (others => Pad); - - else - Source.Length := Max_Length; - - case Drop is - when Strings.Right => - Source.Data (Slen + 1 .. Max_Length) := (others => Pad); - - when Strings.Left => - if Npad > Max_Length then - Source.Data := (others => Pad); - - else - Temp := Source.Data; - Source.Data (1 .. Max_Length - Npad) := - Temp (Count - Max_Length + 1 .. Slen); - - for J in Max_Length - Npad + 1 .. Max_Length loop - Source.Data (J) := Pad; - end loop; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - end Head; - - ----------- - -- Index -- - ----------- - - function Index - (Source : in Bounded_Wide_String; - Pattern : in Wide_String; - Going : in Strings.Direction := Strings.Forward; - Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - is - begin - return Wide_Search.Index - (Source.Data (1 .. Source.Length), Pattern, Going, Mapping); - end Index; - - function Index - (Source : in Bounded_Wide_String; - Pattern : in Wide_String; - Going : in Direction := Forward; - Mapping : in Wide_Maps.Wide_Character_Mapping_Function) - return Natural - is - begin - return Wide_Search.Index - (Source.Data (1 .. Source.Length), Pattern, Going, Mapping); - end Index; - - function Index - (Source : in Bounded_Wide_String; - Set : in Wide_Maps.Wide_Character_Set; - Test : in Strings.Membership := Strings.Inside; - Going : in Strings.Direction := Strings.Forward) - return Natural - is - begin - return Wide_Search.Index - (Source.Data (1 .. Source.Length), Set, Test, Going); - end Index; - - --------------------- - -- Index_Non_Blank -- - --------------------- - - function Index_Non_Blank - (Source : in Bounded_Wide_String; - Going : in Strings.Direction := Strings.Forward) - return Natural - is - begin - return - Wide_Search.Index_Non_Blank - (Source.Data (1 .. Source.Length), Going); - end Index_Non_Blank; - - ------------ - -- Insert -- - ------------ - - function Insert - (Source : in Bounded_Wide_String; - Before : in Positive; - New_Item : in Wide_String; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_Wide_String - is - Slen : constant Natural := Source.Length; - Nlen : constant Natural := New_Item'Length; - Tlen : constant Natural := Slen + Nlen; - Blen : constant Natural := Before - 1; - Alen : constant Integer := Slen - Blen; - Droplen : constant Integer := Tlen - Max_Length; - Result : Bounded_Wide_String; - - -- Tlen is the length of the total string before possible truncation. - -- Blen, Alen are the lengths of the before and after pieces of the - -- source string. - - begin - if Alen < 0 then - raise Ada.Strings.Index_Error; - - elsif Droplen <= 0 then - Result.Length := Tlen; - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - Result.Data (Before .. Before + Nlen - 1) := New_Item; - Result.Data (Before + Nlen .. Tlen) := - Source.Data (Before .. Slen); - - else - Result.Length := Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - - if Droplen > Alen then - Result.Data (Before .. Max_Length) := - New_Item (New_Item'First - .. New_Item'First + Max_Length - Before); - else - Result.Data (Before .. Before + Nlen - 1) := New_Item; - Result.Data (Before + Nlen .. Max_Length) := - Source.Data (Before .. Slen - Droplen); - end if; - - when Strings.Left => - Result.Data (Max_Length - (Alen - 1) .. Max_Length) := - Source.Data (Before .. Slen); - - if Droplen >= Blen then - Result.Data (1 .. Max_Length - Alen) := - New_Item (New_Item'Last - (Max_Length - Alen) + 1 - .. New_Item'Last); - else - Result.Data - (Blen - Droplen + 1 .. Max_Length - Alen) := - New_Item; - Result.Data (1 .. Blen - Droplen) := - Source.Data (Droplen + 1 .. Blen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Insert; - - procedure Insert - (Source : in out Bounded_Wide_String; - Before : in Positive; - New_Item : in Wide_String; - Drop : in Strings.Truncation := Strings.Error) - is - begin - -- We do a double copy here because this is one of the situations - -- in which we move data to the right, and at least at the moment, - -- GNAT is not handling such cases correctly ??? - - Source := Insert (Source, Before, New_Item, Drop); - end Insert; - - ------------ - -- Length -- - ------------ - - function Length (Source : in Bounded_Wide_String) return Length_Range is - begin - return Source.Length; - end Length; - - --------------- - -- Overwrite -- - --------------- - - function Overwrite - (Source : in Bounded_Wide_String; - Position : in Positive; - New_Item : in Wide_String; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_Wide_String - is - Result : Bounded_Wide_String; - Endpos : constant Natural := Position + New_Item'Length - 1; - Slen : constant Natural := Source.Length; - Droplen : Natural; - - begin - if Position > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif New_Item'Length = 0 then - return Source; - - elsif Endpos <= Slen then - Result.Length := Source.Length; - Result.Data (1 .. Slen) := Source.Data (1 .. Slen); - Result.Data (Position .. Endpos) := New_Item; - return Result; - - elsif Endpos <= Max_Length then - Result.Length := Endpos; - Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1); - Result.Data (Position .. Endpos) := New_Item; - return Result; - - else - Result.Length := Max_Length; - Droplen := Endpos - Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Position - 1) := - Source.Data (1 .. Position - 1); - - Result.Data (Position .. Max_Length) := - New_Item (New_Item'First .. New_Item'Last - Droplen); - return Result; - - when Strings.Left => - if New_Item'Length >= Max_Length then - Result.Data (1 .. Max_Length) := - New_Item (New_Item'Last - Max_Length + 1 .. - New_Item'Last); - return Result; - - else - Result.Data (1 .. Max_Length - New_Item'Length) := - Source.Data (Droplen + 1 .. Position - 1); - Result.Data - (Max_Length - New_Item'Length + 1 .. Max_Length) := - New_Item; - return Result; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Overwrite; - - procedure Overwrite - (Source : in out Bounded_Wide_String; - Position : in Positive; - New_Item : in Wide_String; - Drop : in Strings.Truncation := Strings.Error) - is - Endpos : constant Positive := Position + New_Item'Length - 1; - Slen : constant Natural := Source.Length; - Droplen : Natural; - - begin - if Position > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif Endpos <= Slen then - Source.Data (Position .. Endpos) := New_Item; - - elsif Endpos <= Max_Length then - Source.Data (Position .. Endpos) := New_Item; - Source.Length := Endpos; - - else - Source.Length := Max_Length; - Droplen := Endpos - Max_Length; - - case Drop is - when Strings.Right => - Source.Data (Position .. Max_Length) := - New_Item (New_Item'First .. New_Item'Last - Droplen); - - when Strings.Left => - if New_Item'Length > Max_Length then - Source.Data (1 .. Max_Length) := - New_Item (New_Item'Last - Max_Length + 1 .. - New_Item'Last); - - else - Source.Data (1 .. Max_Length - New_Item'Length) := - Source.Data (Droplen + 1 .. Position - 1); - - Source.Data - (Max_Length - New_Item'Length + 1 .. Max_Length) := - New_Item; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Overwrite; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Source : in out Bounded_Wide_String; - Index : in Positive; - By : in Wide_Character) - is - begin - if Index <= Source.Length then - Source.Data (Index) := By; - else - raise Ada.Strings.Index_Error; - end if; - end Replace_Element; - - ------------------- - -- Replace_Slice -- - ------------------- - - function Replace_Slice - (Source : in Bounded_Wide_String; - Low : in Positive; - High : in Natural; - By : in Wide_String; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_Wide_String - is - Slen : constant Natural := Source.Length; - - begin - if Low > Slen + 1 then - raise Strings.Index_Error; - - elsif High < Low then - return Insert (Source, Low, By, Drop); - - else - declare - Blen : constant Natural := Natural'Max (0, Low - 1); - Alen : constant Natural := Natural'Max (0, Slen - High); - Tlen : constant Natural := Blen + By'Length + Alen; - Droplen : constant Integer := Tlen - Max_Length; - Result : Bounded_Wide_String; - - -- Tlen is the total length of the result string before any - -- truncation. Blen and Alen are the lengths of the pieces - -- of the original string that end up in the result string - -- before and after the replaced slice. - - begin - if Droplen <= 0 then - Result.Length := Tlen; - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - Result.Data (Low .. Low + By'Length - 1) := By; - Result.Data (Low + By'Length .. Tlen) := - Source.Data (High + 1 .. Slen); - - else - Result.Length := Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - - if Droplen > Alen then - Result.Data (Low .. Max_Length) := - By (By'First .. By'First + Max_Length - Low); - else - Result.Data (Low .. Low + By'Length - 1) := By; - Result.Data (Low + By'Length .. Max_Length) := - Source.Data (High + 1 .. Slen - Droplen); - end if; - - when Strings.Left => - Result.Data (Max_Length - (Alen - 1) .. Max_Length) := - Source.Data (High + 1 .. Slen); - - if Droplen >= Blen then - Result.Data (1 .. Max_Length - Alen) := - By (By'Last - (Max_Length - Alen) + 1 .. By'Last); - else - Result.Data - (Blen - Droplen + 1 .. Max_Length - Alen) := By; - Result.Data (1 .. Blen - Droplen) := - Source.Data (Droplen + 1 .. Blen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end; - end if; - end Replace_Slice; - - procedure Replace_Slice - (Source : in out Bounded_Wide_String; - Low : in Positive; - High : in Natural; - By : in Wide_String; - Drop : in Strings.Truncation := Strings.Error) - is - begin - -- We do a double copy here because this is one of the situations - -- in which we move data to the right, and at least at the moment, - -- GNAT is not handling such cases correctly ??? - - Source := Replace_Slice (Source, Low, High, By, Drop); - end Replace_Slice; - --------------- -- Replicate -- --------------- --- 53,62 ---- Right : in Wide_String) return Bounded_Wide_String is begin ! return Times (Left, Right, Max_Length); end "*"; --------------- -- Replicate -- --------------- *************** package body Ada.Strings.Wide_Bounded is *** 1369,1389 **** Drop : in Strings.Truncation := Strings.Error) return Bounded_Wide_String is - Result : Bounded_Wide_String; - begin ! if Count <= Max_Length then ! Result.Length := Count; ! ! elsif Drop = Strings.Error then ! raise Ada.Strings.Length_Error; ! ! else ! Result.Length := Max_Length; ! end if; ! ! Result.Data (1 .. Result.Length) := (others => Item); ! return Result; end Replicate; function Replicate --- 67,74 ---- Drop : in Strings.Truncation := Strings.Error) return Bounded_Wide_String is begin ! return Super_Replicate (Count, Item, Drop, Max_Length); end Replicate; function Replicate *************** package body Ada.Strings.Wide_Bounded is *** 1392,1811 **** Drop : in Strings.Truncation := Strings.Error) return Bounded_Wide_String is - Length : constant Integer := Count * Item'Length; - Result : Bounded_Wide_String; - Indx : Positive; - - begin - if Length <= Max_Length then - Result.Length := Length; - - if Length > 0 then - Indx := 1; - - for J in 1 .. Count loop - Result.Data (Indx .. Indx + Item'Length - 1) := Item; - Indx := Indx + Item'Length; - end loop; - end if; - - else - Result.Length := Max_Length; - - case Drop is - when Strings.Right => - Indx := 1; - - while Indx + Item'Length <= Max_Length + 1 loop - Result.Data (Indx .. Indx + Item'Length - 1) := Item; - Indx := Indx + Item'Length; - end loop; - - Result.Data (Indx .. Max_Length) := - Item (Item'First .. Item'First + Max_Length - Indx); - - when Strings.Left => - Indx := Max_Length; - - while Indx - Item'Length >= 1 loop - Result.Data (Indx - (Item'Length - 1) .. Indx) := Item; - Indx := Indx - Item'Length; - end loop; - - Result.Data (1 .. Indx) := - Item (Item'Last - Indx + 1 .. Item'Last); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Replicate; - - function Replicate - (Count : in Natural; - Item : in Bounded_Wide_String; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_Wide_String - is begin ! return Replicate (Count, Item.Data (1 .. Item.Length), Drop); end Replicate; - ----------- - -- Slice -- - ----------- - - function Slice - (Source : Bounded_Wide_String; - Low : Positive; - High : Natural) - return Wide_String - is - begin - -- Note: test of High > Length is in accordance with AI95-00128 - - if Low > Source.Length + 1 or else High > Source.Length then - raise Index_Error; - - else - declare - Result : Wide_String (1 .. High - Low + 1); - - begin - Result := Source.Data (Low .. High); - return Result; - end; - end if; - end Slice; - - ---------- - -- Tail -- - ---------- - - function Tail - (Source : in Bounded_Wide_String; - Count : in Natural; - Pad : in Wide_Character := Wide_Space; - Drop : in Strings.Truncation := Strings.Error) - return Bounded_Wide_String - is - Result : Bounded_Wide_String; - Slen : constant Natural := Source.Length; - Npad : constant Integer := Count - Slen; - - begin - if Npad <= 0 then - Result.Length := Count; - Result.Data (1 .. Count) := - Source.Data (Slen - (Count - 1) .. Slen); - - elsif Count <= Max_Length then - Result.Length := Count; - Result.Data (1 .. Npad) := (others => Pad); - Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen); - - else - Result.Length := Max_Length; - - case Drop is - when Strings.Right => - if Npad >= Max_Length then - Result.Data := (others => Pad); - - else - Result.Data (1 .. Npad) := (others => Pad); - Result.Data (Npad + 1 .. Max_Length) := - Source.Data (1 .. Max_Length - Npad); - end if; - - when Strings.Left => - Result.Data (1 .. Max_Length - Slen) := (others => Pad); - Result.Data (Max_Length - Slen + 1 .. Max_Length) := - Source.Data (1 .. Slen); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Tail; - - procedure Tail - (Source : in out Bounded_Wide_String; - Count : in Natural; - Pad : in Wide_Character := Wide_Space; - Drop : in Truncation := Error) - is - Slen : constant Natural := Source.Length; - Npad : constant Integer := Count - Slen; - Temp : Wide_String (1 .. Max_Length) := Source.Data; - - begin - if Npad <= 0 then - Source.Length := Count; - Source.Data (1 .. Count) := - Temp (Slen - (Count - 1) .. Slen); - - elsif Count <= Max_Length then - Source.Length := Count; - Source.Data (1 .. Npad) := (others => Pad); - Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen); - - else - Source.Length := Max_Length; - - case Drop is - when Strings.Right => - if Npad >= Max_Length then - Source.Data := (others => Pad); - - else - Source.Data (1 .. Npad) := (others => Pad); - Source.Data (Npad + 1 .. Max_Length) := - Temp (1 .. Max_Length - Npad); - end if; ! when Strings.Left => ! for J in 1 .. Max_Length - Slen loop ! Source.Data (J) := Pad; ! end loop; ! ! Source.Data (Max_Length - Slen + 1 .. Max_Length) := ! Temp (1 .. Slen); ! ! when Strings.Error => ! raise Ada.Strings.Length_Error; ! end case; ! end if; ! ! end Tail; ! ! ---------------------------- ! -- To_Bounded_Wide_String -- ! ---------------------------- function To_Bounded_Wide_String (Source : in Wide_String; Drop : in Strings.Truncation := Strings.Error) return Bounded_Wide_String is - Slen : constant Natural := Source'Length; - Result : Bounded_Wide_String; - begin ! if Slen <= Max_Length then ! Result.Length := Slen; ! Result.Data (1 .. Slen) := Source; ! ! else ! case Drop is ! when Strings.Right => ! Result.Length := Max_Length; ! Result.Data (1 .. Max_Length) := ! Source (Source'First .. Source'First - 1 + Max_Length); ! ! when Strings.Left => ! Result.Length := Max_Length; ! Result.Data (1 .. Max_Length) := ! Source (Source'Last - (Max_Length - 1) .. Source'Last); ! ! when Strings.Error => ! raise Ada.Strings.Length_Error; ! end case; ! end if; ! ! return Result; end To_Bounded_Wide_String; - -------------------- - -- To_Wide_String -- - -------------------- - - function To_Wide_String - (Source : in Bounded_Wide_String) - return Wide_String - is - begin - return Source.Data (1 .. Source.Length); - end To_Wide_String; - - --------------- - -- Translate -- - --------------- - - function Translate - (Source : in Bounded_Wide_String; - Mapping : in Wide_Maps.Wide_Character_Mapping) - return Bounded_Wide_String - is - Result : Bounded_Wide_String; - - begin - Result.Length := Source.Length; - - for J in 1 .. Source.Length loop - Result.Data (J) := Value (Mapping, Source.Data (J)); - end loop; - - return Result; - end Translate; - - procedure Translate - (Source : in out Bounded_Wide_String; - Mapping : in Wide_Maps.Wide_Character_Mapping) - is - begin - for J in 1 .. Source.Length loop - Source.Data (J) := Value (Mapping, Source.Data (J)); - end loop; - end Translate; - - function Translate - (Source : in Bounded_Wide_String; - Mapping : in Wide_Maps.Wide_Character_Mapping_Function) - return Bounded_Wide_String - is - Result : Bounded_Wide_String; - - begin - Result.Length := Source.Length; - - for J in 1 .. Source.Length loop - Result.Data (J) := Mapping.all (Source.Data (J)); - end loop; - - return Result; - end Translate; - - procedure Translate - (Source : in out Bounded_Wide_String; - Mapping : in Wide_Maps.Wide_Character_Mapping_Function) - is - begin - for J in 1 .. Source.Length loop - Source.Data (J) := Mapping.all (Source.Data (J)); - end loop; - end Translate; - - ---------- - -- Trim -- - ---------- - - function Trim - (Source : in Bounded_Wide_String; - Side : in Trim_End) - return Bounded_Wide_String - is - Result : Bounded_Wide_String; - Last : Natural := Source.Length; - First : Positive := 1; - - begin - if Side = Left or else Side = Both then - while First <= Last and then Source.Data (First) = ' ' loop - First := First + 1; - end loop; - end if; - - if Side = Right or else Side = Both then - while Last >= First and then Source.Data (Last) = ' ' loop - Last := Last - 1; - end loop; - end if; - - Result.Length := Last - First + 1; - Result.Data (1 .. Result.Length) := Source.Data (First .. Last); - return Result; - - end Trim; - - procedure Trim - (Source : in out Bounded_Wide_String; - Side : in Trim_End) - is - Last : Length_Range := Source.Length; - First : Positive := 1; - Temp : Wide_String (1 .. Max_Length); - - begin - Temp (1 .. Last) := Source.Data (1 .. Last); - - if Side = Left or else Side = Both then - while First <= Last and then Temp (First) = ' ' loop - First := First + 1; - end loop; - end if; - - if Side = Right or else Side = Both then - while Last >= First and then Temp (Last) = ' ' loop - Last := Last - 1; - end loop; - end if; - - Source.Length := Last - First + 1; - Source.Data (1 .. Source.Length) := Temp (First .. Last); - - end Trim; - - function Trim - (Source : in Bounded_Wide_String; - Left : in Wide_Maps.Wide_Character_Set; - Right : in Wide_Maps.Wide_Character_Set) - return Bounded_Wide_String - is - Result : Bounded_Wide_String; - - begin - for First in 1 .. Source.Length loop - if not Is_In (Source.Data (First), Left) then - for Last in reverse First .. Source.Length loop - if not Is_In (Source.Data (Last), Right) then - Result.Length := Last - First + 1; - Result.Data (1 .. Result.Length) := - Source.Data (First .. Last); - return Result; - end if; - end loop; - end if; - end loop; - - Result.Length := 0; - return Result; - end Trim; - - procedure Trim - (Source : in out Bounded_Wide_String; - Left : in Wide_Maps.Wide_Character_Set; - Right : in Wide_Maps.Wide_Character_Set) - is - begin - for First in 1 .. Source.Length loop - if not Is_In (Source.Data (First), Left) then - for Last in reverse First .. Source.Length loop - if not Is_In (Source.Data (Last), Right) then - if First = 1 then - Source.Length := Last; - return; - else - Source.Length := Last - First + 1; - Source.Data (1 .. Source.Length) := - Source.Data (First .. Last); - return; - end if; - end if; - end loop; - - Source.Length := 0; - return; - end if; - end loop; - - Source.Length := 0; - end Trim; - end Generic_Bounded_Length; end Ada.Strings.Wide_Bounded; --- 77,100 ---- Drop : in Strings.Truncation := Strings.Error) return Bounded_Wide_String is begin ! return Super_Replicate (Count, Item, Drop, Max_Length); end Replicate; ! ----------------------- ! -- To_Bounded_String -- ! ----------------------- function To_Bounded_Wide_String (Source : in Wide_String; Drop : in Strings.Truncation := Strings.Error) return Bounded_Wide_String is begin ! return To_Super_String (Source, Max_Length, Drop); end To_Bounded_Wide_String; end Generic_Bounded_Length; end Ada.Strings.Wide_Bounded; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-stwibo.ads gcc-3.4.0/gcc/ada/a-stwibo.ads *** gcc-3.3.3/gcc/ada/a-stwibo.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-stwibo.ads 2003-10-21 13:41:54.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1992-1997 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 -- --- 6,12 ---- -- -- -- 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 -- *************** *** 37,42 **** --- 36,42 ---- ------------------------------------------------------------------------------ with Ada.Strings.Wide_Maps; + with Ada.Strings.Wide_Superbounded; package Ada.Strings.Wide_Bounded is pragma Preelaborate (Wide_Bounded); *************** pragma Preelaborate (Wide_Bounded); *** 449,482 **** return Bounded_Wide_String; private - Wide_NUL : constant Wide_Character := Wide_Character'Val (0); ! type Bounded_Wide_String is record ! Length : Length_Range := 0; ! Data : Wide_String (1 .. Max_Length); ! end record; ! Null_Bounded_Wide_String : constant Bounded_Wide_String := ! (Length => 0, Data => (1 .. Max_Length => Wide_NUL)); ! -- Pragma Inline declarations (GNAT specific additions) - pragma Inline ("="); - pragma Inline ("<"); - pragma Inline ("<="); - pragma Inline (">"); - pragma Inline (">="); - pragma Inline ("&"); - pragma Inline (Count); - pragma Inline (Element); - pragma Inline (Find_Token); - pragma Inline (Index); - pragma Inline (Index_Non_Blank); - pragma Inline (Length); - pragma Inline (Replace_Element); - pragma Inline (Slice); pragma Inline (To_Bounded_Wide_String); ! pragma Inline (To_Wide_String); end Generic_Bounded_Length; --- 449,860 ---- return Bounded_Wide_String; private ! -- Most of the implementation is in the non generic package ! -- Ada.Strings.Superbounded. Type Bounded_Wide_String is derived from ! -- type Wide_Superbounded.Super_String with the maximum length ! -- constraint. Except for five, all subprograms are renames of ! -- subprograms that are inherited from Wide_Superbounded.Super_String. ! type Bounded_Wide_String is ! new Wide_Superbounded.Super_String (Max_Length); ! Null_Bounded_Wide_String : constant Bounded_Wide_String := ! (Max_Length => Max_Length, ! Current_Length => 0, ! Data => (1 .. Max_Length => Wide_Superbounded.Wide_NUL)); pragma Inline (To_Bounded_Wide_String); ! ! function Length (Source : in Bounded_Wide_String) return Length_Range ! renames Super_Length; ! ! function To_Wide_String ! (Source : in Bounded_Wide_String) ! return Wide_String ! renames Super_To_String; ! ! function Append ! (Left, Right : in Bounded_Wide_String; ! Drop : in Truncation := Error) ! return Bounded_Wide_String ! renames Super_Append; ! ! function Append ! (Left : in Bounded_Wide_String; ! Right : in Wide_String; ! Drop : in Truncation := Error) ! return Bounded_Wide_String ! renames Super_Append; ! ! function Append ! (Left : in Wide_String; ! Right : in Bounded_Wide_String; ! Drop : in Truncation := Error) ! return Bounded_Wide_String ! renames Super_Append; ! ! function Append ! (Left : in Bounded_Wide_String; ! Right : in Wide_Character; ! Drop : in Truncation := Error) ! return Bounded_Wide_String ! renames Super_Append; ! ! function Append ! (Left : in Wide_Character; ! Right : in Bounded_Wide_String; ! Drop : in Truncation := Error) ! return Bounded_Wide_String ! renames Super_Append; ! ! procedure Append ! (Source : in out Bounded_Wide_String; ! New_Item : in Bounded_Wide_String; ! Drop : in Truncation := Error) ! renames Super_Append; ! ! procedure Append ! (Source : in out Bounded_Wide_String; ! New_Item : in Wide_String; ! Drop : in Truncation := Error) ! renames Super_Append; ! ! procedure Append ! (Source : in out Bounded_Wide_String; ! New_Item : in Wide_Character; ! Drop : in Truncation := Error) ! renames Super_Append; ! ! function "&" ! (Left, Right : in Bounded_Wide_String) ! return Bounded_Wide_String ! renames Concat; ! ! function "&" ! (Left : in Bounded_Wide_String; ! Right : in Wide_String) ! return Bounded_Wide_String ! renames Concat; ! ! function "&" ! (Left : in Wide_String; ! Right : in Bounded_Wide_String) ! return Bounded_Wide_String ! renames Concat; ! ! function "&" ! (Left : in Bounded_Wide_String; ! Right : in Wide_Character) ! return Bounded_Wide_String ! renames Concat; ! ! function "&" ! (Left : in Wide_Character; ! Right : in Bounded_Wide_String) ! return Bounded_Wide_String ! renames Concat; ! ! function Element ! (Source : in Bounded_Wide_String; ! Index : in Positive) ! return Wide_Character ! renames Super_Element; ! ! procedure Replace_Element ! (Source : in out Bounded_Wide_String; ! Index : in Positive; ! By : in Wide_Character) ! renames Super_Replace_Element; ! ! function Slice ! (Source : in Bounded_Wide_String; ! Low : in Positive; ! High : in Natural) ! return Wide_String ! renames Super_Slice; ! ! function "=" (Left, Right : in Bounded_Wide_String) return Boolean ! renames Equal; ! ! function "=" ! (Left : in Bounded_Wide_String; ! Right : in Wide_String) ! return Boolean ! renames Equal; ! ! function "=" ! (Left : in Wide_String; ! Right : in Bounded_Wide_String) ! return Boolean ! renames Equal; ! ! function "<" (Left, Right : in Bounded_Wide_String) return Boolean ! renames Less; ! ! function "<" ! (Left : in Bounded_Wide_String; ! Right : in Wide_String) ! return Boolean ! renames Less; ! ! function "<" ! (Left : in Wide_String; ! Right : in Bounded_Wide_String) ! return Boolean ! renames Less; ! ! function "<=" (Left, Right : in Bounded_Wide_String) return Boolean ! renames Less_Or_Equal; ! ! function "<=" ! (Left : in Bounded_Wide_String; ! Right : in Wide_String) ! return Boolean ! renames Less_Or_Equal; ! ! function "<=" ! (Left : in Wide_String; ! Right : in Bounded_Wide_String) ! return Boolean ! renames Less_Or_Equal; ! ! function ">" (Left, Right : in Bounded_Wide_String) return Boolean ! renames Greater; ! ! function ">" ! (Left : in Bounded_Wide_String; ! Right : in Wide_String) ! return Boolean ! renames Greater; ! ! function ">" ! (Left : in Wide_String; ! Right : in Bounded_Wide_String) ! return Boolean ! renames Greater; ! ! function ">=" (Left, Right : in Bounded_Wide_String) return Boolean ! renames Greater_Or_Equal; ! ! function ">=" ! (Left : in Bounded_Wide_String; ! Right : in Wide_String) ! return Boolean ! renames Greater_Or_Equal; ! ! function ">=" ! (Left : in Wide_String; ! Right : in Bounded_Wide_String) ! return Boolean ! renames Greater_Or_Equal; ! ! function Index ! (Source : in Bounded_Wide_String; ! Pattern : in Wide_String; ! Going : in Direction := Forward; ! Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) ! return Natural ! renames Super_Index; ! ! function Index ! (Source : in Bounded_Wide_String; ! Pattern : in Wide_String; ! Going : in Direction := Forward; ! Mapping : in Wide_Maps.Wide_Character_Mapping_Function) ! return Natural ! renames Super_Index; ! ! function Index ! (Source : in Bounded_Wide_String; ! Set : in Wide_Maps.Wide_Character_Set; ! Test : in Membership := Inside; ! Going : in Direction := Forward) ! return Natural ! renames Super_Index; ! ! function Index_Non_Blank ! (Source : in Bounded_Wide_String; ! Going : in Direction := Forward) ! return Natural ! renames Super_Index_Non_Blank; ! ! function Count ! (Source : in Bounded_Wide_String; ! Pattern : in Wide_String; ! Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) ! return Natural ! renames Super_Count; ! ! function Count ! (Source : in Bounded_Wide_String; ! Pattern : in Wide_String; ! Mapping : in Wide_Maps.Wide_Character_Mapping_Function) ! return Natural ! renames Super_Count; ! ! function Count ! (Source : in Bounded_Wide_String; ! Set : in Wide_Maps.Wide_Character_Set) ! return Natural ! renames Super_Count; ! ! procedure Find_Token ! (Source : in Bounded_Wide_String; ! Set : in Wide_Maps.Wide_Character_Set; ! Test : in Membership; ! First : out Positive; ! Last : out Natural) ! renames Super_Find_Token; ! ! function Translate ! (Source : in Bounded_Wide_String; ! Mapping : in Wide_Maps.Wide_Character_Mapping) ! return Bounded_Wide_String ! renames Super_Translate; ! ! procedure Translate ! (Source : in out Bounded_Wide_String; ! Mapping : in Wide_Maps.Wide_Character_Mapping) ! renames Super_Translate; ! ! function Translate ! (Source : in Bounded_Wide_String; ! Mapping : in Wide_Maps.Wide_Character_Mapping_Function) ! return Bounded_Wide_String ! renames Super_Translate; ! ! procedure Translate ! (Source : in out Bounded_Wide_String; ! Mapping : in Wide_Maps.Wide_Character_Mapping_Function) ! renames Super_Translate; ! ! function Replace_Slice ! (Source : in Bounded_Wide_String; ! Low : in Positive; ! High : in Natural; ! By : in Wide_String; ! Drop : in Truncation := Error) ! return Bounded_Wide_String ! renames Super_Replace_Slice; ! ! procedure Replace_Slice ! (Source : in out Bounded_Wide_String; ! Low : in Positive; ! High : in Natural; ! By : in Wide_String; ! Drop : in Truncation := Error) ! renames Super_Replace_Slice; ! ! function Insert ! (Source : in Bounded_Wide_String; ! Before : in Positive; ! New_Item : in Wide_String; ! Drop : in Truncation := Error) ! return Bounded_Wide_String ! renames Super_Insert; ! ! procedure Insert ! (Source : in out Bounded_Wide_String; ! Before : in Positive; ! New_Item : in Wide_String; ! Drop : in Truncation := Error) ! renames Super_Insert; ! ! function Overwrite ! (Source : in Bounded_Wide_String; ! Position : in Positive; ! New_Item : in Wide_String; ! Drop : in Truncation := Error) ! return Bounded_Wide_String ! renames Super_Overwrite; ! ! procedure Overwrite ! (Source : in out Bounded_Wide_String; ! Position : in Positive; ! New_Item : in Wide_String; ! Drop : in Truncation := Error) ! renames Super_Overwrite; ! ! function Delete ! (Source : in Bounded_Wide_String; ! From : in Positive; ! Through : in Natural) ! return Bounded_Wide_String ! renames Super_Delete; ! ! procedure Delete ! (Source : in out Bounded_Wide_String; ! From : in Positive; ! Through : in Natural) ! renames Super_Delete; ! ! function Trim ! (Source : in Bounded_Wide_String; ! Side : in Trim_End) ! return Bounded_Wide_String ! renames Super_Trim; ! ! procedure Trim ! (Source : in out Bounded_Wide_String; ! Side : in Trim_End) ! renames Super_Trim; ! ! function Trim ! (Source : in Bounded_Wide_String; ! Left : in Wide_Maps.Wide_Character_Set; ! Right : in Wide_Maps.Wide_Character_Set) ! return Bounded_Wide_String ! renames Super_Trim; ! ! procedure Trim ! (Source : in out Bounded_Wide_String; ! Left : in Wide_Maps.Wide_Character_Set; ! Right : in Wide_Maps.Wide_Character_Set) ! renames Super_Trim; ! ! function Head ! (Source : in Bounded_Wide_String; ! Count : in Natural; ! Pad : in Wide_Character := Wide_Space; ! Drop : in Truncation := Error) ! return Bounded_Wide_String ! renames Super_Head; ! ! procedure Head ! (Source : in out Bounded_Wide_String; ! Count : in Natural; ! Pad : in Wide_Character := Wide_Space; ! Drop : in Truncation := Error) ! renames Super_Head; ! ! function Tail ! (Source : in Bounded_Wide_String; ! Count : in Natural; ! Pad : in Wide_Character := Wide_Space; ! Drop : in Truncation := Error) ! return Bounded_Wide_String ! renames Super_Tail; ! ! procedure Tail ! (Source : in out Bounded_Wide_String; ! Count : in Natural; ! Pad : in Wide_Character := Wide_Space; ! Drop : in Truncation := Error) ! renames Super_Tail; ! ! function "*" ! (Left : in Natural; ! Right : in Bounded_Wide_String) ! return Bounded_Wide_String ! renames Times; ! ! function Replicate ! (Count : in Natural; ! Item : in Bounded_Wide_String; ! Drop : in Truncation := Error) ! return Bounded_Wide_String ! renames Super_Replicate; end Generic_Bounded_Length; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-stwifi.adb gcc-3.4.0/gcc/ada/a-stwifi.adb *** gcc-3.3.3/gcc/ada/a-stwifi.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-stwifi.adb 2003-10-21 13:41:54.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-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.Strings.Wide_Fixed is *** 380,386 **** raise Index_Error; else declare ! Result_Length : Natural := Natural'Max (Source'Length, Position - Source'First + New_Item'Length); --- 379,385 ---- raise Index_Error; else declare ! Result_Length : constant Natural := Natural'Max (Source'Length, Position - Source'First + New_Item'Length); *************** package body Ada.Strings.Wide_Fixed is *** 589,595 **** else declare ! Result : Wide_String (1 .. High - Low + 1) := Source (Low .. High); begin return Result; --- 588,595 ---- else declare ! Result : constant Wide_String (1 .. High - Low + 1) := ! Source (Low .. High); begin return Result; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-stwifi.ads gcc-3.4.0/gcc/ada/a-stwifi.ads *** gcc-3.3.3/gcc/ada/a-stwifi.ads 2002-03-14 10:58:54.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-stwifi.ads 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-stwima.adb gcc-3.4.0/gcc/ada/a-stwima.adb *** gcc-3.3.3/gcc/ada/a-stwima.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-stwima.adb 2003-10-21 13:41:54.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-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.Strings.Wide_Maps is *** 708,714 **** begin return (AF.Controlled with ! Set => new Wide_Character_Ranges' (1 => (Singleton, Singleton))); end To_Set; ----------- --- 707,713 ---- begin return (AF.Controlled with ! Set => new Wide_Character_Ranges'(1 => (Singleton, Singleton))); end To_Set; ----------- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-stwima.ads gcc-3.4.0/gcc/ada/a-stwima.ads *** gcc-3.3.3/gcc/ada/a-stwima.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-stwima.ads 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1998 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/a-stwise.adb gcc-3.4.0/gcc/ada/a-stwise.adb *** gcc-3.3.3/gcc/ada/a-stwise.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-stwise.adb 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992,1993,1994 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/a-stwise.ads gcc-3.4.0/gcc/ada/a-stwise.ads *** gcc-3.3.3/gcc/ada/a-stwise.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-stwise.ads 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-stwisu.adb gcc-3.4.0/gcc/ada/a-stwisu.adb *** gcc-3.3.3/gcc/ada/a-stwisu.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-stwisu.adb 2003-10-21 13:41:54.000000000 +0000 *************** *** 0 **** --- 1,1809 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUNTIME COMPONENTS -- + -- -- + -- A D A . S T R I N G S . W I D E _ S U P E R B O U N D E D -- + -- -- + -- 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. -- + -- -- + ------------------------------------------------------------------------------ + + with Ada.Strings.Wide_Maps; use Ada.Strings.Wide_Maps; + with Ada.Strings.Wide_Search; + + package body Ada.Strings.Wide_Superbounded is + + ------------ + -- Concat -- + ------------ + + function Concat + (Left : Super_String; + Right : Super_String) + return Super_String + is + Result : Super_String (Left.Max_Length); + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen > Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end if; + + return Result; + end Concat; + + function Concat + (Left : Super_String; + Right : Wide_String) + return Super_String + is + Result : Super_String (Left.Max_Length); + Llen : constant Natural := Left.Current_Length; + + Nlen : constant Natural := Llen + Right'Length; + + begin + if Nlen > Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right; + end if; + return Result; + end Concat; + + function Concat + (Left : Wide_String; + Right : Super_String) + return Super_String + is + Result : Super_String (Right.Max_Length); + Llen : constant Natural := Left'Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen > Right.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end if; + + return Result; + end Concat; + + function Concat + (Left : Super_String; + Right : Wide_Character) + return Super_String + is + Result : Super_String (Left.Max_Length); + Llen : constant Natural := Left.Current_Length; + + begin + if Llen = Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Llen + 1; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Result.Current_Length) := Right; + end if; + + return Result; + end Concat; + + function Concat + (Left : Wide_Character; + Right : Super_String) + return Super_String + is + Result : Super_String (Right.Max_Length); + Rlen : constant Natural := Right.Current_Length; + + begin + if Rlen = Right.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Rlen + 1; + Result.Data (1) := Left; + Result.Data (2 .. Result.Current_Length) := Right.Data (1 .. Rlen); + end if; + + return Result; + end Concat; + + ----------- + -- Equal -- + ----------- + + function "=" (Left, Right : Super_String) return Boolean is + begin + return Left.Current_Length = Right.Current_Length + and then Left.Data (1 .. Left.Current_Length) = + Right.Data (1 .. Right.Current_Length); + end "="; + + function Equal (Left : Super_String; Right : Wide_String) + return Boolean is + begin + return Left.Current_Length = Right'Length + and then Left.Data (1 .. Left.Current_Length) = Right; + end Equal; + + function Equal (Left : Wide_String; Right : Super_String) + return Boolean is + begin + return Left'Length = Right.Current_Length + and then Left = Right.Data (1 .. Right.Current_Length); + end Equal; + + ------------- + -- Greater -- + ------------- + + function Greater (Left, Right : Super_String) return Boolean is + begin + return Left.Data (1 .. Left.Current_Length) > + Right.Data (1 .. Right.Current_Length); + end Greater; + + function Greater + (Left : Super_String; + Right : Wide_String) + return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) > Right; + end Greater; + + function Greater + (Left : Wide_String; + Right : Super_String) + return Boolean + is + begin + return Left > Right.Data (1 .. Right.Current_Length); + end Greater; + + ---------------------- + -- Greater_Or_Equal -- + ---------------------- + + function Greater_Or_Equal (Left, Right : Super_String) return Boolean is + begin + return Left.Data (1 .. Left.Current_Length) >= + Right.Data (1 .. Right.Current_Length); + end Greater_Or_Equal; + + function Greater_Or_Equal + (Left : Super_String; + Right : Wide_String) + return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) >= Right; + end Greater_Or_Equal; + + function Greater_Or_Equal + (Left : Wide_String; + Right : Super_String) + return Boolean + is + begin + return Left >= Right.Data (1 .. Right.Current_Length); + end Greater_Or_Equal; + + ---------- + -- Less -- + ---------- + + function Less (Left, Right : Super_String) return Boolean is + begin + return Left.Data (1 .. Left.Current_Length) < + Right.Data (1 .. Right.Current_Length); + end Less; + + function Less + (Left : Super_String; + Right : Wide_String) + return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) < Right; + end Less; + + function Less + (Left : Wide_String; + Right : Super_String) + return Boolean + is + begin + return Left < Right.Data (1 .. Right.Current_Length); + end Less; + + ------------------- + -- Less_Or_Equal -- + ------------------- + + function Less_Or_Equal (Left, Right : Super_String) return Boolean is + begin + return Left.Data (1 .. Left.Current_Length) <= + Right.Data (1 .. Right.Current_Length); + end Less_Or_Equal; + + function Less_Or_Equal + (Left : Super_String; + Right : Wide_String) + return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) <= Right; + end Less_Or_Equal; + + function Less_Or_Equal + (Left : Wide_String; + Right : Super_String) + return Boolean + is + begin + return Left <= Right.Data (1 .. Right.Current_Length); + end Less_Or_Equal; + + ------------------ + -- Super_Append -- + ------------------ + + -- Case of Super_String and Super_String + + function Super_Append + (Left, Right : Super_String; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Left.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen >= Max_Length then -- only case is Llen = Max_Length + Result.Data := Left.Data; + + else + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Max_Length) := + Right.Data (1 .. Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then -- only case is Rlen = Max_Length + Result.Data := Right.Data; + + else + Result.Data (1 .. Max_Length - Rlen) := + Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Result.Data (Max_Length - Rlen + 1 .. Max_Length) := + Right.Data (1 .. Rlen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Append; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Super_String; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Llen : constant Natural := Source.Current_Length; + Rlen : constant Natural := New_Item.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Source.Current_Length := Nlen; + Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen); + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen < Max_Length then + Source.Data (Llen + 1 .. Max_Length) := + New_Item.Data (1 .. Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then -- only case is Rlen = Max_Length + Source.Data := New_Item.Data; + + else + Source.Data (1 .. Max_Length - Rlen) := + Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Source.Data (Max_Length - Rlen + 1 .. Max_Length) := + New_Item.Data (1 .. Rlen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + end Super_Append; + + -- Case of Super_String and Wide_String + + function Super_Append + (Left : Super_String; + Right : Wide_String; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Left.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right'Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right; + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen >= Max_Length then -- only case is Llen = Max_Length + Result.Data := Left.Data; + + else + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Max_Length) := + Right (Right'First .. Right'First - 1 + + Max_Length - Llen); + + end if; + + when Strings.Left => + if Rlen >= Max_Length then + Result.Data (1 .. Max_Length) := + Right (Right'Last - (Max_Length - 1) .. Right'Last); + + else + Result.Data (1 .. Max_Length - Rlen) := + Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Result.Data (Max_Length - Rlen + 1 .. Max_Length) := + Right; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Append; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Wide_String; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Llen : constant Natural := Source.Current_Length; + Rlen : constant Natural := New_Item'Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Source.Current_Length := Nlen; + Source.Data (Llen + 1 .. Nlen) := New_Item; + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen < Max_Length then + Source.Data (Llen + 1 .. Max_Length) := + New_Item (New_Item'First .. + New_Item'First - 1 + Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then + Source.Data (1 .. Max_Length) := + New_Item (New_Item'Last - (Max_Length - 1) .. + New_Item'Last); + + else + Source.Data (1 .. Max_Length - Rlen) := + Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Source.Data (Max_Length - Rlen + 1 .. Max_Length) := + New_Item; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + end Super_Append; + + -- Case of Wide_String and Super_String + + function Super_Append + (Left : Wide_String; + Right : Super_String; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Right.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left'Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen >= Max_Length then + Result.Data (1 .. Max_Length) := + Left (Left'First .. Left'First + (Max_Length - 1)); + + else + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Max_Length) := + Right.Data (1 .. Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then + Result.Data (1 .. Max_Length) := + Right.Data (Rlen - (Max_Length - 1) .. Rlen); + + else + Result.Data (1 .. Max_Length - Rlen) := + Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last); + Result.Data (Max_Length - Rlen + 1 .. Max_Length) := + Right.Data (1 .. Rlen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Append; + + -- Case of Super_String and Wide_Character + + function Super_Append + (Left : Super_String; + Right : Wide_Character; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Left.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left.Current_Length; + + begin + if Llen < Max_Length then + Result.Current_Length := Llen + 1; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1) := Right; + return Result; + + else + case Drop is + when Strings.Right => + return Left; + + when Strings.Left => + Result.Current_Length := Max_Length; + Result.Data (1 .. Max_Length - 1) := + Left.Data (2 .. Max_Length); + Result.Data (Max_Length) := Right; + return Result; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Append; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Wide_Character; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Llen : constant Natural := Source.Current_Length; + + begin + if Llen < Max_Length then + Source.Current_Length := Llen + 1; + Source.Data (Llen + 1) := New_Item; + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + null; + + when Strings.Left => + Source.Data (1 .. Max_Length - 1) := + Source.Data (2 .. Max_Length); + Source.Data (Max_Length) := New_Item; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + end Super_Append; + + -- Case of Wide_Character and Super_String + + function Super_Append + (Left : Wide_Character; + Right : Super_String; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Right.Max_Length; + Result : Super_String (Max_Length); + Rlen : constant Natural := Right.Current_Length; + + begin + if Rlen < Max_Length then + Result.Current_Length := Rlen + 1; + Result.Data (1) := Left; + Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen); + return Result; + + else + case Drop is + when Strings.Right => + Result.Current_Length := Max_Length; + Result.Data (1) := Left; + Result.Data (2 .. Max_Length) := + Right.Data (1 .. Max_Length - 1); + return Result; + + when Strings.Left => + return Right; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Append; + + ----------------- + -- Super_Count -- + ----------------- + + function Super_Count + (Source : Super_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + begin + return + Wide_Search.Count + (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); + end Super_Count; + + function Super_Count + (Source : Super_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Natural + is + begin + return + Wide_Search.Count + (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); + end Super_Count; + + function Super_Count + (Source : Super_String; + Set : Wide_Maps.Wide_Character_Set) + return Natural + is + begin + return Wide_Search.Count (Source.Data (1 .. Source.Current_Length), Set); + end Super_Count; + + ------------------ + -- Super_Delete -- + ------------------ + + function Super_Delete + (Source : Super_String; + From : Positive; + Through : Natural) + return Super_String + is + Result : Super_String (Source.Max_Length); + Slen : constant Natural := Source.Current_Length; + Num_Delete : constant Integer := Through - From + 1; + + begin + if Num_Delete <= 0 then + return Source; + + elsif From > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif Through >= Slen then + Result.Current_Length := From - 1; + Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); + return Result; + + else + Result.Current_Length := Slen - Num_Delete; + Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); + Result.Data (From .. Result.Current_Length) := + Source.Data (Through + 1 .. Slen); + return Result; + end if; + end Super_Delete; + + procedure Super_Delete + (Source : in out Super_String; + From : Positive; + Through : Natural) + is + Slen : constant Natural := Source.Current_Length; + Num_Delete : constant Integer := Through - From + 1; + + begin + if Num_Delete <= 0 then + return; + + elsif From > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif Through >= Slen then + Source.Current_Length := From - 1; + + else + Source.Current_Length := Slen - Num_Delete; + Source.Data (From .. Source.Current_Length) := + Source.Data (Through + 1 .. Slen); + end if; + end Super_Delete; + + ------------------- + -- Super_Element -- + ------------------- + + function Super_Element + (Source : Super_String; + Index : Positive) + return Wide_Character + is + begin + if Index in 1 .. Source.Current_Length then + return Source.Data (Index); + else + raise Strings.Index_Error; + end if; + end Super_Element; + + ---------------------- + -- Super_Find_Token -- + ---------------------- + + procedure Super_Find_Token + (Source : Super_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + begin + Wide_Search.Find_Token + (Source.Data (1 .. Source.Current_Length), Set, Test, First, Last); + end Super_Find_Token; + + ---------------- + -- Super_Head -- + ---------------- + + function Super_Head + (Source : Super_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + + begin + if Npad <= 0 then + Result.Current_Length := Count; + Result.Data (1 .. Count) := Source.Data (1 .. Count); + + elsif Count <= Max_Length then + Result.Current_Length := Count; + Result.Data (1 .. Slen) := Source.Data (1 .. Slen); + Result.Data (Slen + 1 .. Count) := (others => Pad); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Slen) := Source.Data (1 .. Slen); + Result.Data (Slen + 1 .. Max_Length) := (others => Pad); + + when Strings.Left => + if Npad >= Max_Length then + Result.Data := (others => Pad); + + else + Result.Data (1 .. Max_Length - Npad) := + Source.Data (Count - Max_Length + 1 .. Slen); + Result.Data (Max_Length - Npad + 1 .. Max_Length) := + (others => Pad); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Head; + + procedure Super_Head + (Source : in out Super_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + Temp : Wide_String (1 .. Max_Length); + + begin + if Npad <= 0 then + Source.Current_Length := Count; + + elsif Count <= Max_Length then + Source.Current_Length := Count; + Source.Data (Slen + 1 .. Count) := (others => Pad); + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Source.Data (Slen + 1 .. Max_Length) := (others => Pad); + + when Strings.Left => + if Npad > Max_Length then + Source.Data := (others => Pad); + + else + Temp := Source.Data; + Source.Data (1 .. Max_Length - Npad) := + Temp (Count - Max_Length + 1 .. Slen); + + for J in Max_Length - Npad + 1 .. Max_Length loop + Source.Data (J) := Pad; + end loop; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Head; + + ----------------- + -- Super_Index -- + ----------------- + + function Super_Index + (Source : Super_String; + Pattern : Wide_String; + Going : Strings.Direction := Strings.Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + begin + return Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Natural + is + begin + return Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) + return Natural + is + begin + return Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), Set, Test, Going); + end Super_Index; + + --------------------------- + -- Super_Index_Non_Blank -- + --------------------------- + + function Super_Index_Non_Blank + (Source : Super_String; + Going : Strings.Direction := Strings.Forward) + return Natural + is + begin + return + Wide_Search.Index_Non_Blank + (Source.Data (1 .. Source.Current_Length), Going); + end Super_Index_Non_Blank; + + ------------------ + -- Super_Insert -- + ------------------ + + function Super_Insert + (Source : Super_String; + Before : Positive; + New_Item : Wide_String; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Slen : constant Natural := Source.Current_Length; + Nlen : constant Natural := New_Item'Length; + Tlen : constant Natural := Slen + Nlen; + Blen : constant Natural := Before - 1; + Alen : constant Integer := Slen - Blen; + Droplen : constant Integer := Tlen - Max_Length; + + -- Tlen is the length of the total Wide_String before possible + -- truncation. Blen, Alen are the lengths of the before and after + -- pieces of the source Wide_String. + + begin + if Alen < 0 then + raise Ada.Strings.Index_Error; + + elsif Droplen <= 0 then + Result.Current_Length := Tlen; + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + Result.Data (Before .. Before + Nlen - 1) := New_Item; + Result.Data (Before + Nlen .. Tlen) := + Source.Data (Before .. Slen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + + if Droplen > Alen then + Result.Data (Before .. Max_Length) := + New_Item (New_Item'First + .. New_Item'First + Max_Length - Before); + else + Result.Data (Before .. Before + Nlen - 1) := New_Item; + Result.Data (Before + Nlen .. Max_Length) := + Source.Data (Before .. Slen - Droplen); + end if; + + when Strings.Left => + Result.Data (Max_Length - (Alen - 1) .. Max_Length) := + Source.Data (Before .. Slen); + + if Droplen >= Blen then + Result.Data (1 .. Max_Length - Alen) := + New_Item (New_Item'Last - (Max_Length - Alen) + 1 + .. New_Item'Last); + else + Result.Data + (Blen - Droplen + 1 .. Max_Length - Alen) := + New_Item; + Result.Data (1 .. Blen - Droplen) := + Source.Data (Droplen + 1 .. Blen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Insert; + + procedure Super_Insert + (Source : in out Super_String; + Before : Positive; + New_Item : Wide_String; + Drop : Strings.Truncation := Strings.Error) + is + begin + -- We do a double copy here because this is one of the situations + -- in which we move data to the right, and at least at the moment, + -- GNAT is not handling such cases correctly ??? + + Source := Super_Insert (Source, Before, New_Item, Drop); + end Super_Insert; + + ------------------ + -- Super_Length -- + ------------------ + + function Super_Length (Source : Super_String) return Natural is + begin + return Source.Current_Length; + end Super_Length; + + --------------------- + -- Super_Overwrite -- + --------------------- + + function Super_Overwrite + (Source : Super_String; + Position : Positive; + New_Item : Wide_String; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Endpos : constant Natural := Position + New_Item'Length - 1; + Slen : constant Natural := Source.Current_Length; + Droplen : Natural; + + begin + if Position > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif New_Item'Length = 0 then + return Source; + + elsif Endpos <= Slen then + Result.Current_Length := Source.Current_Length; + Result.Data (1 .. Slen) := Source.Data (1 .. Slen); + Result.Data (Position .. Endpos) := New_Item; + return Result; + + elsif Endpos <= Max_Length then + Result.Current_Length := Endpos; + Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1); + Result.Data (Position .. Endpos) := New_Item; + return Result; + + else + Result.Current_Length := Max_Length; + Droplen := Endpos - Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Position - 1) := + Source.Data (1 .. Position - 1); + + Result.Data (Position .. Max_Length) := + New_Item (New_Item'First .. New_Item'Last - Droplen); + return Result; + + when Strings.Left => + if New_Item'Length >= Max_Length then + Result.Data (1 .. Max_Length) := + New_Item (New_Item'Last - Max_Length + 1 .. + New_Item'Last); + return Result; + + else + Result.Data (1 .. Max_Length - New_Item'Length) := + Source.Data (Droplen + 1 .. Position - 1); + Result.Data + (Max_Length - New_Item'Length + 1 .. Max_Length) := + New_Item; + return Result; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Overwrite; + + procedure Super_Overwrite + (Source : in out Super_String; + Position : Positive; + New_Item : Wide_String; + Drop : Strings.Truncation := Strings.Error) + is + Max_Length : constant Positive := Source.Max_Length; + Endpos : constant Positive := Position + New_Item'Length - 1; + Slen : constant Natural := Source.Current_Length; + Droplen : Natural; + + begin + if Position > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif Endpos <= Slen then + Source.Data (Position .. Endpos) := New_Item; + + elsif Endpos <= Max_Length then + Source.Data (Position .. Endpos) := New_Item; + Source.Current_Length := Endpos; + + else + Source.Current_Length := Max_Length; + Droplen := Endpos - Max_Length; + + case Drop is + when Strings.Right => + Source.Data (Position .. Max_Length) := + New_Item (New_Item'First .. New_Item'Last - Droplen); + + when Strings.Left => + if New_Item'Length > Max_Length then + Source.Data (1 .. Max_Length) := + New_Item (New_Item'Last - Max_Length + 1 .. + New_Item'Last); + + else + Source.Data (1 .. Max_Length - New_Item'Length) := + Source.Data (Droplen + 1 .. Position - 1); + + Source.Data + (Max_Length - New_Item'Length + 1 .. Max_Length) := + New_Item; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Overwrite; + + --------------------------- + -- Super_Replace_Element -- + --------------------------- + + procedure Super_Replace_Element + (Source : in out Super_String; + Index : Positive; + By : Wide_Character) + is + begin + if Index <= Source.Current_Length then + Source.Data (Index) := By; + else + raise Ada.Strings.Index_Error; + end if; + end Super_Replace_Element; + + ------------------------- + -- Super_Replace_Slice -- + ------------------------- + + function Super_Replace_Slice + (Source : Super_String; + Low : Positive; + High : Natural; + By : Wide_String; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Slen : constant Natural := Source.Current_Length; + + begin + if Low > Slen + 1 then + raise Strings.Index_Error; + + elsif High < Low then + return Super_Insert (Source, Low, By, Drop); + + else + declare + Blen : constant Natural := Natural'Max (0, Low - 1); + Alen : constant Natural := Natural'Max (0, Slen - High); + Tlen : constant Natural := Blen + By'Length + Alen; + Droplen : constant Integer := Tlen - Max_Length; + Result : Super_String (Max_Length); + + -- Tlen is the total length of the result Wide_String before any + -- truncation. Blen and Alen are the lengths of the pieces + -- of the original Wide_String that end up in the result + -- Wide_String before and after the replaced slice. + + begin + if Droplen <= 0 then + Result.Current_Length := Tlen; + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + Result.Data (Low .. Low + By'Length - 1) := By; + Result.Data (Low + By'Length .. Tlen) := + Source.Data (High + 1 .. Slen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + + if Droplen > Alen then + Result.Data (Low .. Max_Length) := + By (By'First .. By'First + Max_Length - Low); + else + Result.Data (Low .. Low + By'Length - 1) := By; + Result.Data (Low + By'Length .. Max_Length) := + Source.Data (High + 1 .. Slen - Droplen); + end if; + + when Strings.Left => + Result.Data (Max_Length - (Alen - 1) .. Max_Length) := + Source.Data (High + 1 .. Slen); + + if Droplen >= Blen then + Result.Data (1 .. Max_Length - Alen) := + By (By'Last - (Max_Length - Alen) + 1 .. By'Last); + else + Result.Data + (Blen - Droplen + 1 .. Max_Length - Alen) := By; + Result.Data (1 .. Blen - Droplen) := + Source.Data (Droplen + 1 .. Blen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end; + end if; + end Super_Replace_Slice; + + procedure Super_Replace_Slice + (Source : in out Super_String; + Low : Positive; + High : Natural; + By : Wide_String; + Drop : Strings.Truncation := Strings.Error) + is + begin + -- We do a double copy here because this is one of the situations + -- in which we move data to the right, and at least at the moment, + -- GNAT is not handling such cases correctly ??? + + Source := Super_Replace_Slice (Source, Low, High, By, Drop); + end Super_Replace_Slice; + + --------------------- + -- Super_Replicate -- + --------------------- + + function Super_Replicate + (Count : Natural; + Item : Wide_Character; + Drop : Truncation := Error; + Max_Length : Positive) + return Super_String + is + Result : Super_String (Max_Length); + + begin + if Count <= Max_Length then + Result.Current_Length := Count; + + elsif Drop = Strings.Error then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Max_Length; + end if; + + Result.Data (1 .. Result.Current_Length) := (others => Item); + return Result; + end Super_Replicate; + + function Super_Replicate + (Count : Natural; + Item : Wide_String; + Drop : Truncation := Error; + Max_Length : Positive) + return Super_String + is + Length : constant Integer := Count * Item'Length; + Result : Super_String (Max_Length); + Indx : Positive; + + begin + if Length <= Max_Length then + Result.Current_Length := Length; + + if Length > 0 then + Indx := 1; + + for J in 1 .. Count loop + Result.Data (Indx .. Indx + Item'Length - 1) := Item; + Indx := Indx + Item'Length; + end loop; + end if; + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Indx := 1; + + while Indx + Item'Length <= Max_Length + 1 loop + Result.Data (Indx .. Indx + Item'Length - 1) := Item; + Indx := Indx + Item'Length; + end loop; + + Result.Data (Indx .. Max_Length) := + Item (Item'First .. Item'First + Max_Length - Indx); + + when Strings.Left => + Indx := Max_Length; + + while Indx - Item'Length >= 1 loop + Result.Data (Indx - (Item'Length - 1) .. Indx) := Item; + Indx := Indx - Item'Length; + end loop; + + Result.Data (1 .. Indx) := + Item (Item'Last - Indx + 1 .. Item'Last); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Replicate; + + function Super_Replicate + (Count : Natural; + Item : Super_String; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + begin + return + Super_Replicate + (Count, + Item.Data (1 .. Item.Current_Length), + Drop, + Item.Max_Length); + end Super_Replicate; + + ----------------- + -- Super_Slice -- + ----------------- + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) + return Wide_String + is + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + else + return Source.Data (Low .. High); + end if; + end Super_Slice; + + ---------------- + -- Super_Tail -- + ---------------- + + function Super_Tail + (Source : Super_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Strings.Truncation := Strings.Error) + return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + + begin + if Npad <= 0 then + Result.Current_Length := Count; + Result.Data (1 .. Count) := + Source.Data (Slen - (Count - 1) .. Slen); + + elsif Count <= Max_Length then + Result.Current_Length := Count; + Result.Data (1 .. Npad) := (others => Pad); + Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Npad >= Max_Length then + Result.Data := (others => Pad); + + else + Result.Data (1 .. Npad) := (others => Pad); + Result.Data (Npad + 1 .. Max_Length) := + Source.Data (1 .. Max_Length - Npad); + end if; + + when Strings.Left => + Result.Data (1 .. Max_Length - Slen) := (others => Pad); + Result.Data (Max_Length - Slen + 1 .. Max_Length) := + Source.Data (1 .. Slen); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Tail; + + procedure Super_Tail + (Source : in out Super_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + + Temp : constant Wide_String (1 .. Max_Length) := Source.Data; + + begin + if Npad <= 0 then + Source.Current_Length := Count; + Source.Data (1 .. Count) := + Temp (Slen - (Count - 1) .. Slen); + + elsif Count <= Max_Length then + Source.Current_Length := Count; + Source.Data (1 .. Npad) := (others => Pad); + Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen); + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Npad >= Max_Length then + Source.Data := (others => Pad); + + else + Source.Data (1 .. Npad) := (others => Pad); + Source.Data (Npad + 1 .. Max_Length) := + Temp (1 .. Max_Length - Npad); + end if; + + when Strings.Left => + for J in 1 .. Max_Length - Slen loop + Source.Data (J) := Pad; + end loop; + + Source.Data (Max_Length - Slen + 1 .. Max_Length) := + Temp (1 .. Slen); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Tail; + + --------------------- + -- Super_To_String -- + --------------------- + + function Super_To_String (Source : in Super_String) return Wide_String is + begin + return Source.Data (1 .. Source.Current_Length); + end Super_To_String; + + --------------------- + -- Super_Translate -- + --------------------- + + function Super_Translate + (Source : Super_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + Result.Current_Length := Source.Current_Length; + + for J in 1 .. Source.Current_Length loop + Result.Data (J) := Value (Mapping, Source.Data (J)); + end loop; + + return Result; + end Super_Translate; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + is + begin + for J in 1 .. Source.Current_Length loop + Source.Data (J) := Value (Mapping, Source.Data (J)); + end loop; + end Super_Translate; + + function Super_Translate + (Source : Super_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + Result.Current_Length := Source.Current_Length; + + for J in 1 .. Source.Current_Length loop + Result.Data (J) := Mapping.all (Source.Data (J)); + end loop; + + return Result; + end Super_Translate; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + is + begin + for J in 1 .. Source.Current_Length loop + Source.Data (J) := Mapping.all (Source.Data (J)); + end loop; + end Super_Translate; + + ---------------- + -- Super_Trim -- + ---------------- + + function Super_Trim + (Source : Super_String; + Side : Trim_End) + return Super_String + is + Result : Super_String (Source.Max_Length); + Last : Natural := Source.Current_Length; + First : Positive := 1; + + begin + if Side = Left or else Side = Both then + while First <= Last and then Source.Data (First) = ' ' loop + First := First + 1; + end loop; + end if; + + if Side = Right or else Side = Both then + while Last >= First and then Source.Data (Last) = ' ' loop + Last := Last - 1; + end loop; + end if; + + Result.Current_Length := Last - First + 1; + Result.Data (1 .. Result.Current_Length) := Source.Data (First .. Last); + return Result; + end Super_Trim; + + procedure Super_Trim + (Source : in out Super_String; + Side : Trim_End) + is + Max_Length : constant Positive := Source.Max_Length; + Last : Natural := Source.Current_Length; + First : Positive := 1; + Temp : Wide_String (1 .. Max_Length); + + begin + Temp (1 .. Last) := Source.Data (1 .. Last); + + if Side = Left or else Side = Both then + while First <= Last and then Temp (First) = ' ' loop + First := First + 1; + end loop; + end if; + + if Side = Right or else Side = Both then + while Last >= First and then Temp (Last) = ' ' loop + Last := Last - 1; + end loop; + end if; + + Source.Data := (others => Wide_NUL); + Source.Current_Length := Last - First + 1; + Source.Data (1 .. Source.Current_Length) := Temp (First .. Last); + end Super_Trim; + + function Super_Trim + (Source : Super_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) + return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + for First in 1 .. Source.Current_Length loop + if not Is_In (Source.Data (First), Left) then + for Last in reverse First .. Source.Current_Length loop + if not Is_In (Source.Data (Last), Right) then + Result.Current_Length := Last - First + 1; + Result.Data (1 .. Result.Current_Length) := + Source.Data (First .. Last); + return Result; + end if; + end loop; + end if; + end loop; + + Result.Current_Length := 0; + return Result; + end Super_Trim; + + procedure Super_Trim + (Source : in out Super_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) + is + begin + for First in 1 .. Source.Current_Length loop + if not Is_In (Source.Data (First), Left) then + for Last in reverse First .. Source.Current_Length loop + if not Is_In (Source.Data (Last), Right) then + if First = 1 then + Source.Current_Length := Last; + return; + else + Source.Current_Length := Last - First + 1; + Source.Data (1 .. Source.Current_Length) := + Source.Data (First .. Last); + + for J in Source.Current_Length + 1 .. + Source.Max_Length + loop + Source.Data (J) := Wide_NUL; + end loop; + + return; + end if; + end if; + end loop; + + Source.Current_Length := 0; + return; + end if; + end loop; + + Source.Current_Length := 0; + end Super_Trim; + + ----------- + -- Times -- + ----------- + + function Times + (Left : Natural; + Right : Wide_Character; + Max_Length : Positive) + return Super_String + is + Result : Super_String (Max_Length); + + begin + if Left > Max_Length then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Left; + + for J in 1 .. Left loop + Result.Data (J) := Right; + end loop; + end if; + + return Result; + end Times; + + function Times + (Left : Natural; + Right : Wide_String; + Max_Length : Positive) + return Super_String + is + Result : Super_String (Max_Length); + Pos : Positive := 1; + Rlen : constant Natural := Right'Length; + Nlen : constant Natural := Left * Rlen; + + begin + if Nlen > Max_Length then + raise Ada.Strings.Index_Error; + + else + Result.Current_Length := Nlen; + + if Nlen > 0 then + for J in 1 .. Left loop + Result.Data (Pos .. Pos + Rlen - 1) := Right; + Pos := Pos + Rlen; + end loop; + end if; + end if; + + return Result; + end Times; + + function Times + (Left : Natural; + Right : Super_String) + return Super_String + is + Result : Super_String (Right.Max_Length); + Pos : Positive := 1; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Left * Rlen; + + begin + if Nlen > Right.Max_Length then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Nlen; + + if Nlen > 0 then + for J in 1 .. Left loop + Result.Data (Pos .. Pos + Rlen - 1) := + Right.Data (1 .. Rlen); + Pos := Pos + Rlen; + end loop; + end if; + end if; + + return Result; + end Times; + + --------------------- + -- To_Super_String -- + --------------------- + + function To_Super_String + (Source : Wide_String; + Max_Length : Natural; + Drop : Truncation := Error) + return Super_String + is + Result : Super_String (Max_Length); + Slen : constant Natural := Source'Length; + + begin + if Slen <= Max_Length then + Result.Current_Length := Slen; + Result.Data (1 .. Slen) := Source; + + else + case Drop is + when Strings.Right => + Result.Current_Length := Max_Length; + Result.Data (1 .. Max_Length) := + Source (Source'First .. Source'First - 1 + Max_Length); + + when Strings.Left => + Result.Current_Length := Max_Length; + Result.Data (1 .. Max_Length) := + Source (Source'Last - (Max_Length - 1) .. Source'Last); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end To_Super_String; + + end Ada.Strings.Wide_Superbounded; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-stwisu.ads gcc-3.4.0/gcc/ada/a-stwisu.ads *** gcc-3.3.3/gcc/ada/a-stwisu.ads 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-stwisu.ads 2003-10-21 13:41:54.000000000 +0000 *************** *** 0 **** --- 1,478 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- A D A . S T R I N G S . W I D E _ S U P E R B O U N D E D -- + -- -- + -- S p e c -- + -- -- + -- 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 non generic package contains most of the implementation of the + -- generic package Ada.Strings.Wide_Bounded.Generic_Bounded_Length. + + -- It defines type Super_String as a discriminated record with the maximum + -- length as the discriminant. Individual instantiations of + -- Strings.Wide_Bounded.Generic_Bounded_Length use this type with + -- an appropriate discriminant value set. + + with Ada.Strings.Wide_Maps; + + package Ada.Strings.Wide_Superbounded is + pragma Preelaborate (Wide_Superbounded); + + Wide_NUL : constant Wide_Character := Wide_Character'Val (0); + + type Super_String (Max_Length : Positive) is record + Current_Length : Natural := 0; + Data : Wide_String (1 .. Max_Length) := (others => Wide_NUL); + end record; + -- Type Wide_Bounded_String in + -- Ada.Strings.Wide_Bounded.Generic_Bounded_Length is derived from this + -- type, with the constraint of the maximum length. + + -- The subprograms defined for Super_String are similar to those + -- defined for Wide_Bounded_String, except that they have different names, + -- so that they can be renamed in + -- Ada.Strings.Wide_Bounded.Generic_Bounded_Length. + + function Super_Length (Source : Super_String) return Natural; + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Super_String + (Source : Wide_String; + Max_Length : Natural; + Drop : Truncation := Error) + return Super_String; + -- Note the additional parameter Max_Length, which specifies the maximum + -- length setting of the resulting Super_String value. + + -- The following procedures have declarations (and semantics) that are + -- exactly analogous to those declared in Ada.Strings.Bounded. + + function Super_To_String (Source : Super_String) return Wide_String; + + function Super_Append + (Left, Right : Super_String; + Drop : Truncation := Error) + return Super_String; + + function Super_Append + (Left : Super_String; + Right : Wide_String; + Drop : Truncation := Error) + return Super_String; + + function Super_Append + (Left : Wide_String; + Right : Super_String; + Drop : Truncation := Error) + return Super_String; + + function Super_Append + (Left : Super_String; + Right : Wide_Character; + Drop : Truncation := Error) + return Super_String; + + function Super_Append + (Left : Wide_Character; + Right : Super_String; + Drop : Truncation := Error) + return Super_String; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Super_String; + Drop : Truncation := Error); + + procedure Super_Append + (Source : in out Super_String; + New_Item : Wide_String; + Drop : Truncation := Error); + + procedure Super_Append + (Source : in out Super_String; + New_Item : Wide_Character; + Drop : Truncation := Error); + + function Concat + (Left, Right : Super_String) + return Super_String; + + function Concat + (Left : Super_String; + Right : Wide_String) + return Super_String; + + function Concat + (Left : Wide_String; + Right : Super_String) + return Super_String; + + function Concat + (Left : Super_String; + Right : Wide_Character) + return Super_String; + + function Concat + (Left : Wide_Character; + Right : Super_String) + return Super_String; + + function Super_Element + (Source : Super_String; + Index : Positive) + return Wide_Character; + + procedure Super_Replace_Element + (Source : in out Super_String; + Index : Positive; + By : Wide_Character); + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) + return Wide_String; + + function "=" (Left, Right : Super_String) return Boolean; + + function Equal (Left, Right : Super_String) return Boolean renames "="; + + function Equal + (Left : Super_String; + Right : Wide_String) + return Boolean; + + function Equal + (Left : Wide_String; + Right : Super_String) + return Boolean; + + function Less (Left, Right : Super_String) return Boolean; + + function Less + (Left : Super_String; + Right : Wide_String) + return Boolean; + + function Less + (Left : Wide_String; + Right : Super_String) + return Boolean; + + function Less_Or_Equal (Left, Right : Super_String) return Boolean; + + function Less_Or_Equal + (Left : Super_String; + Right : Wide_String) + return Boolean; + + function Less_Or_Equal + (Left : Wide_String; + Right : Super_String) + return Boolean; + + function Greater (Left, Right : Super_String) return Boolean; + + function Greater + (Left : Super_String; + Right : Wide_String) + return Boolean; + + function Greater + (Left : Wide_String; + Right : Super_String) + return Boolean; + + function Greater_Or_Equal (Left, Right : Super_String) return Boolean; + + function Greater_Or_Equal + (Left : Super_String; + Right : Wide_String) + return Boolean; + + function Greater_Or_Equal + (Left : Wide_String; + Right : Super_String) + return Boolean; + + ---------------------- + -- Search Functions -- + ---------------------- + + function Super_Index + (Source : Super_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Super_Index + (Source : Super_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Natural; + + function Super_Index + (Source : Super_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) + return Natural; + + function Super_Index_Non_Blank + (Source : Super_String; + Going : Direction := Forward) + return Natural; + + function Super_Count + (Source : Super_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Super_Count + (Source : Super_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Natural; + + function Super_Count + (Source : Super_String; + Set : Wide_Maps.Wide_Character_Set) + return Natural; + + procedure Super_Find_Token + (Source : Super_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ----------------------------------------- + -- Wide_String Translation Subprograms -- + ----------------------------------------- + + function Super_Translate + (Source : Super_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + return Super_String; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Wide_Maps.Wide_Character_Mapping); + + function Super_Translate + (Source : Super_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Super_String; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function); + + -------------------------------------------- + -- Wide_String Transformation Subprograms -- + -------------------------------------------- + + function Super_Replace_Slice + (Source : Super_String; + Low : Positive; + High : Natural; + By : Wide_String; + Drop : Truncation := Error) + return Super_String; + + procedure Super_Replace_Slice + (Source : in out Super_String; + Low : Positive; + High : Natural; + By : Wide_String; + Drop : Truncation := Error); + + function Super_Insert + (Source : Super_String; + Before : Positive; + New_Item : Wide_String; + Drop : Truncation := Error) + return Super_String; + + procedure Super_Insert + (Source : in out Super_String; + Before : Positive; + New_Item : Wide_String; + Drop : Truncation := Error); + + function Super_Overwrite + (Source : Super_String; + Position : Positive; + New_Item : Wide_String; + Drop : Truncation := Error) + return Super_String; + + procedure Super_Overwrite + (Source : in out Super_String; + Position : Positive; + New_Item : Wide_String; + Drop : Truncation := Error); + + function Super_Delete + (Source : Super_String; + From : Positive; + Through : Natural) + return Super_String; + + procedure Super_Delete + (Source : in out Super_String; + From : Positive; + Through : Natural); + + -------------------------------------- + -- Wide_String Selector Subprograms -- + -------------------------------------- + + function Super_Trim + (Source : Super_String; + Side : Trim_End) + return Super_String; + + procedure Super_Trim + (Source : in out Super_String; + Side : Trim_End); + + function Super_Trim + (Source : Super_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) + return Super_String; + + procedure Super_Trim + (Source : in out Super_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set); + + function Super_Head + (Source : Super_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error) + return Super_String; + + procedure Super_Head + (Source : in out Super_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error); + + function Super_Tail + (Source : Super_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error) + return Super_String; + + procedure Super_Tail + (Source : in out Super_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error); + + ------------------------------------ + -- Wide_String Constructor Subprograms -- + ------------------------------------ + + -- Note: in some of the following routines, there is an extra parameter + -- Max_Length which specifies the value of the maximum length for the + -- resulting Super_String value. + + function Times + (Left : Natural; + Right : Wide_Character; + Max_Length : Positive) + return Super_String; + -- Note the additional parameter Max_Length + + function Times + (Left : Natural; + Right : Wide_String; + Max_Length : Positive) + return Super_String; + -- Note the additional parameter Max_Length + + function Times + (Left : Natural; + Right : Super_String) + return Super_String; + + function Super_Replicate + (Count : Natural; + Item : Wide_Character; + Drop : Truncation := Error; + Max_Length : Positive) + return Super_String; + -- Note the additional parameter Max_Length + + function Super_Replicate + (Count : Natural; + Item : Wide_String; + Drop : Truncation := Error; + Max_Length : Positive) + return Super_String; + -- Note the additional parameter Max_Length + + function Super_Replicate + (Count : Natural; + Item : Super_String; + Drop : Truncation := Error) + return Super_String; + + private + + -- Pragma Inline declarations + + pragma Inline ("="); + pragma Inline (Less); + pragma Inline (Less_Or_Equal); + pragma Inline (Greater); + pragma Inline (Greater_Or_Equal); + pragma Inline (Concat); + pragma Inline (Super_Count); + pragma Inline (Super_Element); + pragma Inline (Super_Find_Token); + pragma Inline (Super_Index); + pragma Inline (Super_Index_Non_Blank); + pragma Inline (Super_Length); + pragma Inline (Super_Replace_Element); + pragma Inline (Super_Slice); + pragma Inline (Super_To_String); + + end Ada.Strings.Wide_Superbounded; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-stwiun.adb gcc-3.4.0/gcc/ada/a-stwiun.adb *** gcc-3.3.3/gcc/ada/a-stwiun.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-stwiun.adb 2003-10-21 13:41:54.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-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.Strings.Wide_Unbounded *** 40,45 **** --- 39,54 ---- use Ada.Finalization; + procedure Realloc_For_Chunk + (Source : in out Unbounded_Wide_String; + Chunk_Size : Natural); + pragma Inline (Realloc_For_Chunk); + -- Adjust the size allocated for the string. Add at least Chunk_Size so it + -- is safe to add a string of this size at the end of the current + -- content. The real size allocated for the string is Chunk_Size + x % + -- of the current string size. This buffered handling makes the Append + -- unbounded wide string routines very fast. + --------- -- "&" -- --------- *************** package body Ada.Strings.Wide_Unbounded *** 49,63 **** Right : Unbounded_Wide_String) return Unbounded_Wide_String is ! L_Length : constant Integer := Left.Reference.all'Length; ! R_Length : constant Integer := Right.Reference.all'Length; ! Length : constant Integer := L_Length + R_Length; Result : Unbounded_Wide_String; begin ! Result.Reference := new Wide_String (1 .. Length); ! Result.Reference.all (1 .. L_Length) := Left.Reference.all; ! Result.Reference.all (L_Length + 1 .. Length) := Right.Reference.all; return Result; end "&"; --- 58,77 ---- Right : Unbounded_Wide_String) return Unbounded_Wide_String is ! L_Length : constant Natural := Left.Last; ! R_Length : constant Natural := Right.Last; Result : Unbounded_Wide_String; begin ! Result.Last := L_Length + R_Length; ! ! Result.Reference := new Wide_String (1 .. Result.Last); ! ! Result.Reference (1 .. L_Length) := ! Left.Reference (1 .. Left.Last); ! Result.Reference (L_Length + 1 .. Result.Last) := ! Right.Reference (1 .. Right.Last); ! return Result; end "&"; *************** package body Ada.Strings.Wide_Unbounded *** 66,79 **** Right : Wide_String) return Unbounded_Wide_String is ! L_Length : constant Integer := Left.Reference.all'Length; ! Length : constant Integer := L_Length + Right'Length; Result : Unbounded_Wide_String; begin ! Result.Reference := new Wide_String (1 .. Length); ! Result.Reference.all (1 .. L_Length) := Left.Reference.all; ! Result.Reference.all (L_Length + 1 .. Length) := Right; return Result; end "&"; --- 80,96 ---- Right : Wide_String) return Unbounded_Wide_String is ! L_Length : constant Natural := Left.Last; Result : Unbounded_Wide_String; begin ! Result.Last := L_Length + Right'Length; ! ! Result.Reference := new Wide_String (1 .. Result.Last); ! ! Result.Reference (1 .. L_Length) := Left.Reference (1 .. Left.Last); ! Result.Reference (L_Length + 1 .. Result.Last) := Right; ! return Result; end "&"; *************** package body Ada.Strings.Wide_Unbounded *** 82,95 **** Right : Unbounded_Wide_String) return Unbounded_Wide_String is ! R_Length : constant Integer := Right.Reference.all'Length; ! Length : constant Integer := Left'Length + R_Length; Result : Unbounded_Wide_String; begin ! Result.Reference := new Wide_String (1 .. Length); ! Result.Reference.all (1 .. Left'Length) := Left; ! Result.Reference.all (Left'Length + 1 .. Length) := Right.Reference.all; return Result; end "&"; --- 99,116 ---- Right : Unbounded_Wide_String) return Unbounded_Wide_String is ! R_Length : constant Natural := Right.Last; Result : Unbounded_Wide_String; begin ! Result.Last := Left'Length + R_Length; ! ! Result.Reference := new Wide_String (1 .. Result.Last); ! ! Result.Reference (1 .. Left'Length) := Left; ! Result.Reference (Left'Length + 1 .. Result.Last) := ! Right.Reference (1 .. Right.Last); ! return Result; end "&"; *************** package body Ada.Strings.Wide_Unbounded *** 98,110 **** Right : Wide_Character) return Unbounded_Wide_String is - Length : constant Integer := Left.Reference.all'Length + 1; Result : Unbounded_Wide_String; begin ! Result.Reference := new Wide_String (1 .. Length); ! Result.Reference.all (1 .. Length - 1) := Left.Reference.all; ! Result.Reference.all (Length) := Right; return Result; end "&"; --- 119,135 ---- Right : Wide_Character) return Unbounded_Wide_String is Result : Unbounded_Wide_String; begin ! Result.Last := Left.Last + 1; ! ! Result.Reference := new Wide_String (1 .. Result.Last); ! ! Result.Reference (1 .. Result.Last - 1) := ! Left.Reference (1 .. Left.Last); ! Result.Reference (Result.Last) := Right; ! return Result; end "&"; *************** package body Ada.Strings.Wide_Unbounded *** 113,125 **** Right : Unbounded_Wide_String) return Unbounded_Wide_String is - Length : constant Integer := Right.Reference.all'Length + 1; Result : Unbounded_Wide_String; begin ! Result.Reference := new Wide_String (1 .. Length); ! Result.Reference.all (1) := Left; ! Result.Reference.all (2 .. Length) := Right.Reference.all; return Result; end "&"; --- 138,153 ---- Right : Unbounded_Wide_String) return Unbounded_Wide_String is Result : Unbounded_Wide_String; begin ! Result.Last := Right.Last + 1; ! ! Result.Reference := new Wide_String (1 .. Result.Last); ! Result.Reference (1) := Left; ! Result.Reference (2 .. Result.Last) := ! Right.Reference (1 .. Right.Last); ! return Result; end "&"; *************** package body Ada.Strings.Wide_Unbounded *** 135,140 **** --- 163,170 ---- Result : Unbounded_Wide_String; begin + Result.Last := Left; + Result.Reference := new Wide_String (1 .. Left); for J in Result.Reference'Range loop Result.Reference (J) := Right; *************** package body Ada.Strings.Wide_Unbounded *** 148,161 **** Right : Wide_String) return Unbounded_Wide_String is Result : Unbounded_Wide_String; begin ! Result.Reference := new Wide_String (1 .. Left * Right'Length); for J in 1 .. Left loop ! Result.Reference.all ! (Right'Length * J - Right'Length + 1 .. Right'Length * J) := Right; end loop; return Result; --- 178,196 ---- Right : Wide_String) return Unbounded_Wide_String is + Len : constant Natural := Right'Length; + K : Positive; Result : Unbounded_Wide_String; begin ! Result.Last := Left * Len; + Result.Reference := new Wide_String (1 .. Result.Last); + + K := 1; for J in 1 .. Left loop ! Result.Reference (K .. K + Len - 1) := Right; ! K := K + Len; end loop; return Result; *************** package body Ada.Strings.Wide_Unbounded *** 166,180 **** Right : Unbounded_Wide_String) return Unbounded_Wide_String is ! R_Length : constant Integer := Right.Reference.all'Length; Result : Unbounded_Wide_String; begin ! Result.Reference := new Wide_String (1 .. Left * R_Length); for I in 1 .. Left loop ! Result.Reference.all (R_Length * I - R_Length + 1 .. R_Length * I) := ! Right.Reference.all; end loop; return Result; --- 201,220 ---- Right : Unbounded_Wide_String) return Unbounded_Wide_String is ! Len : constant Natural := Right.Last; ! K : Positive; Result : Unbounded_Wide_String; begin ! Result.Last := Left * Len; ! ! Result.Reference := new Wide_String (1 .. Result.Last); + K := 1; for I in 1 .. Left loop ! Result.Reference (K .. K + Len - 1) := ! Right.Reference (1 .. Right.Last); ! K := K + Len; end loop; return Result; *************** package body Ada.Strings.Wide_Unbounded *** 185,214 **** --------- function "<" ! (Left : in Unbounded_Wide_String; ! Right : in Unbounded_Wide_String) return Boolean is begin ! return Left.Reference.all < Right.Reference.all; end "<"; function "<" ! (Left : in Unbounded_Wide_String; ! Right : in Wide_String) return Boolean is begin ! return Left.Reference.all < Right; end "<"; function "<" ! (Left : in Wide_String; ! Right : in Unbounded_Wide_String) return Boolean is begin ! return Left < Right.Reference.all; end "<"; ---------- --- 225,255 ---- --------- function "<" ! (Left : Unbounded_Wide_String; ! Right : Unbounded_Wide_String) return Boolean is begin ! return ! Left.Reference (1 .. Left.Last) < Right.Reference (1 .. Right.Last); end "<"; function "<" ! (Left : Unbounded_Wide_String; ! Right : Wide_String) return Boolean is begin ! return Left.Reference (1 .. Left.Last) < Right; end "<"; function "<" ! (Left : Wide_String; ! Right : Unbounded_Wide_String) return Boolean is begin ! return Left < Right.Reference (1 .. Right.Last); end "<"; ---------- *************** package body Ada.Strings.Wide_Unbounded *** 216,245 **** ---------- function "<=" ! (Left : in Unbounded_Wide_String; ! Right : in Unbounded_Wide_String) return Boolean is begin ! return Left.Reference.all <= Right.Reference.all; end "<="; function "<=" ! (Left : in Unbounded_Wide_String; ! Right : in Wide_String) return Boolean is begin ! return Left.Reference.all <= Right; end "<="; function "<=" ! (Left : in Wide_String; ! Right : in Unbounded_Wide_String) return Boolean is begin ! return Left <= Right.Reference.all; end "<="; --------- --- 257,287 ---- ---------- function "<=" ! (Left : Unbounded_Wide_String; ! Right : Unbounded_Wide_String) return Boolean is begin ! return ! Left.Reference (1 .. Left.Last) <= Right.Reference (1 .. Right.Last); end "<="; function "<=" ! (Left : Unbounded_Wide_String; ! Right : Wide_String) return Boolean is begin ! return Left.Reference (1 .. Left.Last) <= Right; end "<="; function "<=" ! (Left : Wide_String; ! Right : Unbounded_Wide_String) return Boolean is begin ! return Left <= Right.Reference (1 .. Right.Last); end "<="; --------- *************** package body Ada.Strings.Wide_Unbounded *** 247,276 **** --------- function "=" ! (Left : in Unbounded_Wide_String; ! Right : in Unbounded_Wide_String) return Boolean is begin ! return Left.Reference.all = Right.Reference.all; end "="; function "=" ! (Left : in Unbounded_Wide_String; ! Right : in Wide_String) return Boolean is begin ! return Left.Reference.all = Right; end "="; function "=" ! (Left : in Wide_String; ! Right : in Unbounded_Wide_String) return Boolean is begin ! return Left = Right.Reference.all; end "="; --------- --- 289,319 ---- --------- function "=" ! (Left : Unbounded_Wide_String; ! Right : Unbounded_Wide_String) return Boolean is begin ! return ! Left.Reference (1 .. Left.Last) = Right.Reference (1 .. Right.Last); end "="; function "=" ! (Left : Unbounded_Wide_String; ! Right : Wide_String) return Boolean is begin ! return Left.Reference (1 .. Left.Last) = Right; end "="; function "=" ! (Left : Wide_String; ! Right : Unbounded_Wide_String) return Boolean is begin ! return Left = Right.Reference (1 .. Right.Last); end "="; --------- *************** package body Ada.Strings.Wide_Unbounded *** 278,307 **** --------- function ">" ! (Left : in Unbounded_Wide_String; ! Right : in Unbounded_Wide_String) return Boolean is begin ! return Left.Reference.all > Right.Reference.all; end ">"; function ">" ! (Left : in Unbounded_Wide_String; ! Right : in Wide_String) return Boolean is begin ! return Left.Reference.all > Right; end ">"; function ">" ! (Left : in Wide_String; ! Right : in Unbounded_Wide_String) return Boolean is begin ! return Left > Right.Reference.all; end ">"; ---------- --- 321,351 ---- --------- function ">" ! (Left : Unbounded_Wide_String; ! Right : Unbounded_Wide_String) return Boolean is begin ! return ! Left.Reference (1 .. Left.Last) > Right.Reference (1 .. Right.Last); end ">"; function ">" ! (Left : Unbounded_Wide_String; ! Right : Wide_String) return Boolean is begin ! return Left.Reference (1 .. Left.Last) > Right; end ">"; function ">" ! (Left : Wide_String; ! Right : Unbounded_Wide_String) return Boolean is begin ! return Left > Right.Reference (1 .. Right.Last); end ">"; ---------- *************** package body Ada.Strings.Wide_Unbounded *** 309,338 **** ---------- function ">=" ! (Left : in Unbounded_Wide_String; ! Right : in Unbounded_Wide_String) return Boolean is begin ! return Left.Reference.all >= Right.Reference.all; end ">="; function ">=" ! (Left : in Unbounded_Wide_String; ! Right : in Wide_String) return Boolean is begin ! return Left.Reference.all >= Right; end ">="; function ">=" ! (Left : in Wide_String; ! Right : in Unbounded_Wide_String) return Boolean is begin ! return Left >= Right.Reference.all; end ">="; ------------ --- 353,383 ---- ---------- function ">=" ! (Left : Unbounded_Wide_String; ! Right : Unbounded_Wide_String) return Boolean is begin ! return ! Left.Reference (1 .. Left.Last) >= Right.Reference (1 .. Right.Last); end ">="; function ">=" ! (Left : Unbounded_Wide_String; ! Right : Wide_String) return Boolean is begin ! return Left.Reference (1 .. Left.Last) >= Right; end ">="; function ">=" ! (Left : Wide_String; ! Right : Unbounded_Wide_String) return Boolean is begin ! return Left >= Right.Reference (1 .. Right.Last); end ">="; ------------ *************** package body Ada.Strings.Wide_Unbounded *** 343,351 **** begin -- Copy string, except we do not copy the statically allocated -- null string, since it can never be deallocated. if Object.Reference /= Null_Wide_String'Access then ! Object.Reference := new Wide_String'(Object.Reference.all); end if; end Adjust; --- 388,399 ---- begin -- Copy string, except we do not copy the statically allocated -- null string, since it can never be deallocated. + -- Note that we do not copy extra string room here to avoid dragging + -- unused allocated memory. if Object.Reference /= Null_Wide_String'Access then ! Object.Reference := ! new Wide_String'(Object.Reference (1 .. Object.Last)); end if; end Adjust; *************** package body Ada.Strings.Wide_Unbounded *** 355,417 **** procedure Append (Source : in out Unbounded_Wide_String; ! New_Item : in Unbounded_Wide_String) is - S_Length : constant Integer := Source.Reference.all'Length; - Length : constant Integer := S_Length + New_Item.Reference.all'Length; - Temp : Wide_String_Access := Source.Reference; - begin ! if Source.Reference = Null_Wide_String'Access then ! Source := To_Unbounded_Wide_String (New_Item.Reference.all); ! return; ! end if; ! ! Source.Reference := new Wide_String (1 .. Length); ! ! Source.Reference.all (1 .. S_Length) := Temp.all; ! Source.Reference.all (S_Length + 1 .. Length) := New_Item.Reference.all; ! Free (Temp); end Append; procedure Append (Source : in out Unbounded_Wide_String; ! New_Item : in Wide_String) is - S_Length : constant Integer := Source.Reference.all'Length; - Length : constant Integer := S_Length + New_Item'Length; - Temp : Wide_String_Access := Source.Reference; - begin ! if Source.Reference = Null_Wide_String'Access then ! Source := To_Unbounded_Wide_String (New_Item); ! return; ! end if; ! ! Source.Reference := new Wide_String (1 .. Length); ! Source.Reference.all (1 .. S_Length) := Temp.all; ! Source.Reference.all (S_Length + 1 .. Length) := New_Item; ! Free (Temp); end Append; procedure Append (Source : in out Unbounded_Wide_String; ! New_Item : in Wide_Character) is - S_Length : constant Integer := Source.Reference.all'Length; - Length : constant Integer := S_Length + 1; - Temp : Wide_String_Access := Source.Reference; - begin ! if Source.Reference = Null_Wide_String'Access then ! Source := To_Unbounded_Wide_String ("" & New_Item); ! return; ! end if; ! ! Source.Reference := new Wide_String (1 .. Length); ! Source.Reference.all (1 .. S_Length) := Temp.all; ! Source.Reference.all (S_Length + 1) := New_Item; ! Free (Temp); end Append; ----------- --- 403,436 ---- procedure Append (Source : in out Unbounded_Wide_String; ! New_Item : Unbounded_Wide_String) is begin ! Realloc_For_Chunk (Source, New_Item.Last); ! Source.Reference (Source.Last + 1 .. Source.Last + New_Item.Last) := ! New_Item.Reference (1 .. New_Item.Last); ! Source.Last := Source.Last + New_Item.Last; end Append; procedure Append (Source : in out Unbounded_Wide_String; ! New_Item : Wide_String) is begin ! Realloc_For_Chunk (Source, New_Item'Length); ! Source.Reference (Source.Last + 1 .. Source.Last + New_Item'Length) := ! New_Item; ! Source.Last := Source.Last + New_Item'Length; end Append; procedure Append (Source : in out Unbounded_Wide_String; ! New_Item : Wide_Character) is begin ! Realloc_For_Chunk (Source, 1); ! Source.Reference (Source.Last + 1) := New_Item; ! Source.Last := Source.Last + 1; end Append; ----------- *************** package body Ada.Strings.Wide_Unbounded *** 426,442 **** return Natural is begin ! return Wide_Search.Count (Source.Reference.all, Pattern, Mapping); end Count; function Count ! (Source : in Unbounded_Wide_String; ! Pattern : in Wide_String; ! Mapping : in Wide_Maps.Wide_Character_Mapping_Function) return Natural is begin ! return Wide_Search.Count (Source.Reference.all, Pattern, Mapping); end Count; function Count --- 445,463 ---- return Natural is begin ! return Wide_Search.Count ! (Source.Reference (1 .. Source.Last), Pattern, Mapping); end Count; function Count ! (Source : Unbounded_Wide_String; ! Pattern : Wide_String; ! Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural is begin ! return Wide_Search.Count ! (Source.Reference (1 .. Source.Last), Pattern, Mapping); end Count; function Count *************** package body Ada.Strings.Wide_Unbounded *** 445,451 **** return Natural is begin ! return Wide_Search.Count (Source.Reference.all, Set); end Count; ------------ --- 466,472 ---- return Natural is begin ! return Wide_Search.Count (Source.Reference (1 .. Source.Last), Set); end Count; ------------ *************** package body Ada.Strings.Wide_Unbounded *** 459,478 **** return Unbounded_Wide_String is begin ! return ! To_Unbounded_Wide_String ! (Wide_Fixed.Delete (Source.Reference.all, From, Through)); end Delete; procedure Delete (Source : in out Unbounded_Wide_String; ! From : in Positive; ! Through : in Natural) is - Temp : Wide_String_Access := Source.Reference; begin ! Source := To_Unbounded_Wide_String ! (Wide_Fixed.Delete (Temp.all, From, Through)); end Delete; ------------- --- 480,512 ---- return Unbounded_Wide_String is begin ! return To_Unbounded_Wide_String ! (Wide_Fixed.Delete ! (Source.Reference (1 .. Source.Last), From, Through)); end Delete; procedure Delete (Source : in out Unbounded_Wide_String; ! From : Positive; ! Through : Natural) is begin ! if From > Through then ! null; ! ! elsif From < Source.Reference'First or else Through > Source.Last then ! raise Index_Error; ! ! else ! declare ! Len : constant Natural := Through - From + 1; ! ! begin ! Source.Reference (From .. Source.Last - Len) := ! Source.Reference (Through + 1 .. Source.Last); ! Source.Last := Source.Last - Len; ! end; ! end if; end Delete; ------------- *************** package body Ada.Strings.Wide_Unbounded *** 485,492 **** return Wide_Character is begin ! if Index <= Source.Reference.all'Last then ! return Source.Reference.all (Index); else raise Strings.Index_Error; end if; --- 519,526 ---- return Wide_Character is begin ! if Index <= Source.Last then ! return Source.Reference (Index); else raise Strings.Index_Error; end if; *************** package body Ada.Strings.Wide_Unbounded *** 521,527 **** Last : out Natural) is begin ! Wide_Search.Find_Token (Source.Reference.all, Set, Test, First, Last); end Find_Token; ---------- --- 555,562 ---- Last : out Natural) is begin ! Wide_Search.Find_Token ! (Source.Reference (1 .. Source.Last), Set, Test, First, Last); end Find_Token; ---------- *************** package body Ada.Strings.Wide_Unbounded *** 532,538 **** procedure Deallocate is new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access); begin ! Deallocate (X); end Free; ---------- --- 567,577 ---- procedure Deallocate is new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access); begin ! -- Note: Do not try to free statically allocated null string ! ! if X /= Null_Unbounded_Wide_String.Reference then ! Deallocate (X); ! end if; end Free; ---------- *************** package body Ada.Strings.Wide_Unbounded *** 548,564 **** begin return To_Unbounded_Wide_String ! (Wide_Fixed.Head (Source.Reference.all, Count, Pad)); end Head; procedure Head (Source : in out Unbounded_Wide_String; ! Count : in Natural; ! Pad : in Wide_Character := Wide_Space) is begin ! Source := To_Unbounded_Wide_String ! (Wide_Fixed.Head (Source.Reference.all, Count, Pad)); end Head; ----------- --- 587,607 ---- begin return To_Unbounded_Wide_String ! (Wide_Fixed.Head (Source.Reference (1 .. Source.Last), Count, Pad)); end Head; procedure Head (Source : in out Unbounded_Wide_String; ! Count : Natural; ! Pad : Wide_Character := Wide_Space) is + Old : Wide_String_Access := Source.Reference; + begin ! Source.Reference := new Wide_String' ! (Wide_Fixed.Head (Source.Reference (1 .. Source.Last), Count, Pad)); ! Source.Last := Source.Reference'Length; ! Free (Old); end Head; ----------- *************** package body Ada.Strings.Wide_Unbounded *** 574,593 **** return Natural is begin ! return ! Wide_Search.Index (Source.Reference.all, Pattern, Going, Mapping); end Index; function Index ! (Source : in Unbounded_Wide_String; ! Pattern : in Wide_String; ! Going : in Direction := Forward; ! Mapping : in Wide_Maps.Wide_Character_Mapping_Function) return Natural is begin ! return ! Wide_Search.Index (Source.Reference.all, Pattern, Going, Mapping); end Index; function Index --- 617,636 ---- return Natural is begin ! return Wide_Search.Index ! (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping); end Index; function Index ! (Source : Unbounded_Wide_String; ! Pattern : Wide_String; ! Going : Direction := Forward; ! Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural is begin ! return Wide_Search.Index ! (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping); end Index; function Index *************** package body Ada.Strings.Wide_Unbounded *** 598,604 **** return Natural is begin ! return Wide_Search.Index (Source.Reference.all, Set, Test, Going); end Index; function Index_Non_Blank --- 641,648 ---- return Natural is begin ! return Wide_Search.Index ! (Source.Reference (1 .. Source.Last), Set, Test, Going); end Index; function Index_Non_Blank *************** package body Ada.Strings.Wide_Unbounded *** 607,613 **** return Natural is begin ! return Wide_Search.Index_Non_Blank (Source.Reference.all, Going); end Index_Non_Blank; ---------------- --- 651,658 ---- return Natural is begin ! return Wide_Search.Index_Non_Blank ! (Source.Reference (1 .. Source.Last), Going); end Index_Non_Blank; ---------------- *************** package body Ada.Strings.Wide_Unbounded *** 617,622 **** --- 662,668 ---- procedure Initialize (Object : in out Unbounded_Wide_String) is begin Object.Reference := Null_Unbounded_Wide_String.Reference; + Object.Last := 0; end Initialize; ------------ *************** package body Ada.Strings.Wide_Unbounded *** 630,648 **** return Unbounded_Wide_String is begin ! return ! To_Unbounded_Wide_String ! (Wide_Fixed.Insert (Source.Reference.all, Before, New_Item)); end Insert; procedure Insert (Source : in out Unbounded_Wide_String; ! Before : in Positive; ! New_Item : in Wide_String) is begin ! Source := To_Unbounded_Wide_String ! (Wide_Fixed.Insert (Source.Reference.all, Before, New_Item)); end Insert; ------------ --- 676,704 ---- return Unbounded_Wide_String is begin ! return To_Unbounded_Wide_String ! (Wide_Fixed.Insert ! (Source.Reference (1 .. Source.Last), Before, New_Item)); end Insert; procedure Insert (Source : in out Unbounded_Wide_String; ! Before : Positive; ! New_Item : Wide_String) is begin ! if Before not in Source.Reference'First .. Source.Last + 1 then ! raise Index_Error; ! end if; ! ! Realloc_For_Chunk (Source, New_Item'Size); ! ! Source.Reference ! (Before + New_Item'Length .. Source.Last + New_Item'Length) := ! Source.Reference (Before .. Source.Last); ! ! Source.Reference (Before .. Before + New_Item'Length - 1) := New_Item; ! Source.Last := Source.Last + New_Item'Length; end Insert; ------------ *************** package body Ada.Strings.Wide_Unbounded *** 651,657 **** function Length (Source : Unbounded_Wide_String) return Natural is begin ! return Source.Reference.all'Length; end Length; --------------- --- 707,713 ---- function Length (Source : Unbounded_Wide_String) return Natural is begin ! return Source.Last; end Length; --------------- *************** package body Ada.Strings.Wide_Unbounded *** 666,685 **** begin return To_Unbounded_Wide_String ! (Wide_Fixed.Overwrite (Source.Reference.all, Position, New_Item)); end Overwrite; procedure Overwrite (Source : in out Unbounded_Wide_String; ! Position : in Positive; ! New_Item : in Wide_String) is ! Temp : Wide_String_Access := Source.Reference; begin ! Source := To_Unbounded_Wide_String ! (Wide_Fixed.Overwrite (Temp.all, Position, New_Item)); end Overwrite; --------------------- -- Replace_Element -- --------------------- --- 722,783 ---- begin return To_Unbounded_Wide_String ! (Wide_Fixed.Overwrite ! (Source.Reference (1 .. Source.Last), Position, New_Item)); end Overwrite; procedure Overwrite (Source : in out Unbounded_Wide_String; ! Position : Positive; ! New_Item : Wide_String) is ! NL : constant Natural := New_Item'Length; ! begin ! if Position <= Source.Last - NL + 1 then ! Source.Reference (Position .. Position + NL - 1) := New_Item; ! ! else ! declare ! Old : Wide_String_Access := Source.Reference; ! ! begin ! Source.Reference := new Wide_String' ! (Wide_Fixed.Overwrite ! (Source.Reference (1 .. Source.Last), Position, New_Item)); ! Source.Last := Source.Reference'Length; ! Free (Old); ! end; ! end if; end Overwrite; + ----------------------- + -- Realloc_For_Chunk -- + ----------------------- + + procedure Realloc_For_Chunk + (Source : in out Unbounded_Wide_String; + Chunk_Size : Natural) + is + Growth_Factor : constant := 50; + S_Length : constant Natural := Source.Reference'Length; + + begin + if Chunk_Size > S_Length - Source.Last then + declare + Alloc_Chunk_Size : constant Positive := + Chunk_Size + (S_Length / Growth_Factor); + Tmp : Wide_String_Access; + + begin + Tmp := new Wide_String (1 .. S_Length + Alloc_Chunk_Size); + Tmp (1 .. Source.Last) := Source.Reference (1 .. Source.Last); + Free (Source.Reference); + Source.Reference := Tmp; + end; + end if; + end Realloc_For_Chunk; + --------------------- -- Replace_Element -- --------------------- *************** package body Ada.Strings.Wide_Unbounded *** 690,697 **** By : Wide_Character) is begin ! if Index <= Source.Reference.all'Last then ! Source.Reference.all (Index) := By; else raise Strings.Index_Error; end if; --- 788,795 ---- By : Wide_Character) is begin ! if Index <= Source.Last then ! Source.Reference (Index) := By; else raise Strings.Index_Error; end if; *************** package body Ada.Strings.Wide_Unbounded *** 711,729 **** begin return To_Unbounded_Wide_String ! (Wide_Fixed.Replace_Slice (Source.Reference.all, Low, High, By)); end Replace_Slice; procedure Replace_Slice (Source : in out Unbounded_Wide_String; ! Low : in Positive; ! High : in Natural; ! By : in Wide_String) is ! Temp : Wide_String_Access := Source.Reference; begin ! Source := To_Unbounded_Wide_String ! (Wide_Fixed.Replace_Slice (Temp.all, Low, High, By)); end Replace_Slice; ----------- --- 809,832 ---- begin return To_Unbounded_Wide_String ! (Wide_Fixed.Replace_Slice ! (Source.Reference (1 .. Source.Last), Low, High, By)); end Replace_Slice; procedure Replace_Slice (Source : in out Unbounded_Wide_String; ! Low : Positive; ! High : Natural; ! By : Wide_String) is ! Old : Wide_String_Access := Source.Reference; ! begin ! Source.Reference := new Wide_String' ! (Wide_Fixed.Replace_Slice ! (Source.Reference (1 .. Source.Last), Low, High, By)); ! Source.Last := Source.Reference'Length; ! Free (Old); end Replace_Slice; ----------- *************** package body Ada.Strings.Wide_Unbounded *** 736,757 **** High : Natural) return Wide_String is - Length : constant Natural := Source.Reference'Length; - begin -- Note: test of High > Length is in accordance with AI95-00128 ! if Low > Length + 1 or else High > Length then raise Index_Error; else ! declare ! Result : Wide_String (1 .. High - Low + 1); ! ! begin ! Result := Source.Reference.all (Low .. High); ! return Result; ! end; end if; end Slice; --- 839,852 ---- High : Natural) return Wide_String is begin -- Note: test of High > Length is in accordance with AI95-00128 ! if Low > Source.Last + 1 or else High > Source.Last then raise Index_Error; else ! return Source.Reference (Low .. High); end if; end Slice; *************** package body Ada.Strings.Wide_Unbounded *** 766,786 **** return Unbounded_Wide_String is begin ! return ! To_Unbounded_Wide_String ! (Wide_Fixed.Tail (Source.Reference.all, Count, Pad)); end Tail; procedure Tail (Source : in out Unbounded_Wide_String; ! Count : in Natural; ! Pad : in Wide_Character := Wide_Space) is ! Temp : Wide_String_Access := Source.Reference; begin ! Source := To_Unbounded_Wide_String ! (Wide_Fixed.Tail (Temp.all, Count, Pad)); end Tail; ------------------------------ --- 861,882 ---- return Unbounded_Wide_String is begin ! return To_Unbounded_Wide_String ! (Wide_Fixed.Tail (Source.Reference (1 .. Source.Last), Count, Pad)); end Tail; procedure Tail (Source : in out Unbounded_Wide_String; ! Count : Natural; ! Pad : Wide_Character := Wide_Space) is ! Old : Wide_String_Access := Source.Reference; begin ! Source.Reference := new Wide_String' ! (Wide_Fixed.Tail (Source.Reference (1 .. Source.Last), Count, Pad)); ! Source.Last := Source.Reference'Length; ! Free (Old); end Tail; ------------------------------ *************** package body Ada.Strings.Wide_Unbounded *** 794,810 **** Result : Unbounded_Wide_String; begin ! Result.Reference := new Wide_String (1 .. Source'Length); Result.Reference.all := Source; return Result; end To_Unbounded_Wide_String; ! function To_Unbounded_Wide_String (Length : in Natural) return Unbounded_Wide_String is Result : Unbounded_Wide_String; begin Result.Reference := new Wide_String (1 .. Length); return Result; end To_Unbounded_Wide_String; --- 890,908 ---- Result : Unbounded_Wide_String; begin ! Result.Last := Source'Length; ! Result.Reference := new Wide_String (1 .. Source'Length); Result.Reference.all := Source; return Result; end To_Unbounded_Wide_String; ! function To_Unbounded_Wide_String (Length : Natural) return Unbounded_Wide_String is Result : Unbounded_Wide_String; begin + Result.Last := Length; Result.Reference := new Wide_String (1 .. Length); return Result; end To_Unbounded_Wide_String; *************** package body Ada.Strings.Wide_Unbounded *** 818,824 **** return Wide_String is begin ! return Source.Reference.all; end To_Wide_String; --------------- --- 916,922 ---- return Wide_String is begin ! return Source.Reference (1 .. Source.Last); end To_Wide_String; --------------- *************** package body Ada.Strings.Wide_Unbounded *** 831,839 **** return Unbounded_Wide_String is begin ! return ! To_Unbounded_Wide_String ! (Wide_Fixed.Translate (Source.Reference.all, Mapping)); end Translate; procedure Translate --- 929,936 ---- return Unbounded_Wide_String is begin ! return To_Unbounded_Wide_String ! (Wide_Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping)); end Translate; procedure Translate *************** package body Ada.Strings.Wide_Unbounded *** 841,866 **** Mapping : Wide_Maps.Wide_Character_Mapping) is begin ! Wide_Fixed.Translate (Source.Reference.all, Mapping); end Translate; function Translate ! (Source : in Unbounded_Wide_String; ! Mapping : in Wide_Maps.Wide_Character_Mapping_Function) return Unbounded_Wide_String is begin ! return ! To_Unbounded_Wide_String ! (Wide_Fixed.Translate (Source.Reference.all, Mapping)); end Translate; procedure Translate (Source : in out Unbounded_Wide_String; ! Mapping : in Wide_Maps.Wide_Character_Mapping_Function) is begin ! Wide_Fixed.Translate (Source.Reference.all, Mapping); end Translate; ---------- --- 938,962 ---- Mapping : Wide_Maps.Wide_Character_Mapping) is begin ! Wide_Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping); end Translate; function Translate ! (Source : Unbounded_Wide_String; ! Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Unbounded_Wide_String is begin ! return To_Unbounded_Wide_String ! (Wide_Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping)); end Translate; procedure Translate (Source : in out Unbounded_Wide_String; ! Mapping : Wide_Maps.Wide_Character_Mapping_Function) is begin ! Wide_Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping); end Translate; ---------- *************** package body Ada.Strings.Wide_Unbounded *** 868,915 **** ---------- function Trim ! (Source : in Unbounded_Wide_String; ! Side : in Trim_End) return Unbounded_Wide_String is begin ! return ! To_Unbounded_Wide_String ! (Wide_Fixed.Trim (Source.Reference.all, Side)); end Trim; procedure Trim (Source : in out Unbounded_Wide_String; ! Side : in Trim_End) is Old : Wide_String_Access := Source.Reference; begin ! Source.Reference := new Wide_String'(Wide_Fixed.Trim (Old.all, Side)); Free (Old); end Trim; function Trim ! (Source : in Unbounded_Wide_String; ! Left : in Wide_Maps.Wide_Character_Set; ! Right : in Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String is begin ! return ! To_Unbounded_Wide_String ! (Wide_Fixed.Trim (Source.Reference.all, Left, Right)); end Trim; procedure Trim (Source : in out Unbounded_Wide_String; ! Left : in Wide_Maps.Wide_Character_Set; ! Right : in Wide_Maps.Wide_Character_Set) is Old : Wide_String_Access := Source.Reference; begin ! Source.Reference := ! new Wide_String'(Wide_Fixed.Trim (Old.all, Left, Right)); Free (Old); end Trim; --- 964,1012 ---- ---------- function Trim ! (Source : Unbounded_Wide_String; ! Side : Trim_End) return Unbounded_Wide_String is begin ! return To_Unbounded_Wide_String ! (Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Side)); end Trim; procedure Trim (Source : in out Unbounded_Wide_String; ! Side : Trim_End) is Old : Wide_String_Access := Source.Reference; begin ! Source.Reference := new Wide_String' ! (Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Side)); ! Source.Last := Source.Reference'Length; Free (Old); end Trim; function Trim ! (Source : Unbounded_Wide_String; ! Left : Wide_Maps.Wide_Character_Set; ! Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String is begin ! return To_Unbounded_Wide_String ! (Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Left, Right)); end Trim; procedure Trim (Source : in out Unbounded_Wide_String; ! Left : Wide_Maps.Wide_Character_Set; ! Right : Wide_Maps.Wide_Character_Set) is Old : Wide_String_Access := Source.Reference; begin ! Source.Reference := new Wide_String' ! (Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Left, Right)); ! Source.Last := Source.Reference'Length; Free (Old); end Trim; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-stwiun.ads gcc-3.4.0/gcc/ada/a-stwiun.ads *** gcc-3.3.3/gcc/ada/a-stwiun.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-stwiun.ads 2003-10-21 13:41:54.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1992-2000 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 -- --- 6,12 ---- -- -- -- 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 -- *************** private *** 390,397 **** --- 389,404 ---- type Unbounded_Wide_String is new AF.Controlled with record Reference : Wide_String_Access := Null_Wide_String'Access; + Last : Natural := 0; end record; + -- The Unbounded_Wide_String is using a buffered implementation to increase + -- speed of the Append/Delete/Insert procedures. The Reference string + -- pointer above contains the current string value and extra room at the + -- end to be used by the next Append routine. Last is the index of the + -- string ending character. So the current string value is really + -- Reference (1 .. Last). + pragma Stream_Convert (Unbounded_Wide_String, To_Unbounded_Wide, To_Wide_String); *************** private *** 402,407 **** procedure Finalize (Object : in out Unbounded_Wide_String); Null_Unbounded_Wide_String : constant Unbounded_Wide_String := ! (AF.Controlled with Reference => Null_Wide_String'Access); end Ada.Strings.Wide_Unbounded; --- 409,414 ---- procedure Finalize (Object : in out Unbounded_Wide_String); Null_Unbounded_Wide_String : constant Unbounded_Wide_String := ! (AF.Controlled with Reference => Null_Wide_String'Access, Last => 0); end Ada.Strings.Wide_Unbounded; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-suteio.adb gcc-3.4.0/gcc/ada/a-suteio.adb *** gcc-3.3.3/gcc/ada/a-suteio.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-suteio.adb 2003-04-24 17:53:54.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/a-suteio.ads gcc-3.4.0/gcc/ada/a-suteio.ads *** gcc-3.3.3/gcc/ada/a-suteio.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-suteio.ads 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- 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/a-swmwco.ads gcc-3.4.0/gcc/ada/a-swmwco.ads *** gcc-3.3.3/gcc/ada/a-swmwco.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-swmwco.ads 2003-04-24 17:53:54.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/a-swuwti.adb gcc-3.4.0/gcc/ada/a-swuwti.adb *** gcc-3.3.3/gcc/ada/a-swuwti.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-swuwti.adb 2003-04-24 17:53:54.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/a-swuwti.ads gcc-3.4.0/gcc/ada/a-swuwti.ads *** gcc-3.3.3/gcc/ada/a-swuwti.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-swuwti.ads 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- 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/a-sytaco.adb gcc-3.4.0/gcc/ada/a-sytaco.adb *** gcc-3.3.3/gcc/ada/a-sytaco.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-sytaco.adb 2003-04-24 17:53:54.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/a-sytaco.ads gcc-3.4.0/gcc/ada/a-sytaco.ads *** gcc-3.3.3/gcc/ada/a-sytaco.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-sytaco.ads 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1998 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/a-tags.adb gcc-3.4.0/gcc/ada/a-tags.adb *** gcc-3.3.3/gcc/ada/a-tags.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tags.adb 2003-10-21 13:41:54.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- --- 6,11 ---- *************** *** 33,42 **** ------------------------------------------------------------------------------ with Ada.Exceptions; with Unchecked_Conversion; - with GNAT.HTable; ! pragma Elaborate_All (GNAT.HTable); package body Ada.Tags is --- 32,43 ---- ------------------------------------------------------------------------------ with Ada.Exceptions; + + with System.HTable; + with Unchecked_Conversion; ! pragma Elaborate_All (System.HTable); package body Ada.Tags is *************** package body Ada.Tags is *** 67,74 **** type Tag_Table is array (Natural range <>) of Tag; pragma Suppress_Initialization (Tag_Table); ! type Wide_Boolean is (False, True); ! for Wide_Boolean'Size use Standard'Address_Size; type Type_Specific_Data is record Idepth : Natural; --- 68,76 ---- type Tag_Table is array (Natural range <>) of Tag; pragma Suppress_Initialization (Tag_Table); ! type Wide_Boolean is new Boolean; ! -- This name should probably be changed sometime ??? and indeed ! -- probably this field could simply be of type Standard.Boolean. type Type_Specific_Data is record Idepth : Natural; *************** package body Ada.Tags is *** 120,126 **** type HTable_Headers is range 1 .. 64; -- The following internal package defines the routines used for ! -- the instantiation of a new GNAT.HTable.Static_HTable (see -- below). See spec in g-htable.ads for details of usage. package HTable_Subprograms is --- 122,128 ---- type HTable_Headers is range 1 .. 64; -- The following internal package defines the routines used for ! -- the instantiation of a new System.HTable.Static_HTable (see -- below). See spec in g-htable.ads for details of usage. package HTable_Subprograms is *************** package body Ada.Tags is *** 130,136 **** function Equal (A, B : S.Address) return Boolean; end HTable_Subprograms; ! package External_Tag_HTable is new GNAT.HTable.Static_HTable ( Header_Num => HTable_Headers, Element => Dispatch_Table, Elmt_Ptr => Tag, --- 132,138 ---- function Equal (A, B : S.Address) return Boolean; end HTable_Subprograms; ! package External_Tag_HTable is new System.HTable.Static_HTable ( Header_Num => HTable_Headers, Element => Dispatch_Table, Elmt_Ptr => Tag, *************** package body Ada.Tags is *** 155,162 **** ----------- function Equal (A, B : S.Address) return Boolean is ! Str1 : Cstring_Ptr := To_Cstring_Ptr (A); ! Str2 : Cstring_Ptr := To_Cstring_Ptr (B); J : Integer := 1; begin --- 157,164 ---- ----------- function Equal (A, B : S.Address) return Boolean is ! Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A); ! Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B); J : Integer := 1; begin *************** package body Ada.Tags is *** 187,194 **** ---------- function Hash (F : S.Address) return HTable_Headers is ! function H is new GNAT.HTable.Hash (HTable_Headers); ! Str : Cstring_Ptr := To_Cstring_Ptr (F); Res : constant HTable_Headers := H (Str (1 .. Length (Str))); begin --- 189,196 ---- ---------- function Hash (F : S.Address) return HTable_Headers is ! function H is new System.HTable.Hash (HTable_Headers); ! Str : constant Cstring_Ptr := To_Cstring_Ptr (F); Res : constant HTable_Headers := H (Str (1 .. Length (Str))); begin *************** package body Ada.Tags is *** 237,243 **** ------------------- function Expanded_Name (T : Tag) return String is ! Result : Cstring_Ptr := T.TSD.Expanded_Name; begin return Result (1 .. Length (Result)); --- 239,245 ---- ------------------- function Expanded_Name (T : Tag) return String is ! Result : constant Cstring_Ptr := T.TSD.Expanded_Name; begin return Result (1 .. Length (Result)); *************** package body Ada.Tags is *** 248,254 **** ------------------ function External_Tag (T : Tag) return String is ! Result : Cstring_Ptr := T.TSD.External_Tag; begin return Result (1 .. Length (Result)); --- 250,256 ---- ------------------ function External_Tag (T : Tag) return String is ! Result : constant Cstring_Ptr := T.TSD.External_Tag; begin return Result (1 .. Length (Result)); *************** package body Ada.Tags is *** 409,444 **** -- Parent_Size -- ----------------- - -- Fake type with a tag as first component. Should match the - -- layout of all tagged types. - - type T is record - A : Tag; - end record; - - type T_Ptr is access all T; - - function To_T_Ptr is new Unchecked_Conversion (S.Address, T_Ptr); - - -- The profile of the implicitly defined _size primitive - type Acc_Size is access function (A : S.Address) return Long_Long_Integer; function To_Acc_Size is new Unchecked_Conversion (S.Address, Acc_Size); ! function Parent_Size (Obj : S.Address) return SSE.Storage_Count is ! ! -- Get the tag of the object ! ! Obj_Tag : constant Tag := To_T_Ptr (Obj).A; ! ! -- Get the tag of the parent type through the dispatch table ! ! Parent_Tag : constant Tag := Obj_Tag.TSD.Ancestor_Tags (1); ! -- Get an access to the _size primitive of the parent. We assume that ! -- it is always in the first slot of the distatch table F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1)); begin -- Here we compute the size of the _parent field of the object --- 411,431 ---- -- Parent_Size -- ----------------- type Acc_Size is access function (A : S.Address) return Long_Long_Integer; function To_Acc_Size is new Unchecked_Conversion (S.Address, Acc_Size); + -- The profile of the implicitly defined _size primitive ! function Parent_Size ! (Obj : S.Address; ! T : Tag) ! return SSE.Storage_Count is ! Parent_Tag : constant Tag := T.TSD.Ancestor_Tags (1); ! -- The tag of the parent type through the dispatch table F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1)); + -- Access to the _size primitive of the parent. We assume that + -- it is always in the first slot of the distatch table begin -- Here we compute the size of the _parent field of the object *************** package body Ada.Tags is *** 446,451 **** --- 433,447 ---- return SSE.Storage_Count (F.all (Obj)); end Parent_Size; + ---------------- + -- Parent_Tag -- + ---------------- + + function Parent_Tag (T : Tag) return Tag is + begin + return T.TSD.Ancestor_Tags (1); + end Parent_Tag; + ------------------ -- Register_Tag -- ------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/a-tags.ads gcc-3.4.0/gcc/ada/a-tags.ads *** gcc-3.3.3/gcc/ada/a-tags.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tags.ads 2003-10-21 13:41:54.000000000 +0000 *************** *** 6,13 **** -- -- -- 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 -- --- 6,12 ---- -- -- -- 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 -- *************** private *** 60,66 **** ---------------------------------------------------------------- -- GNAT's Dispatch Table format is customizable in order to match the ! -- format used in another language. GNAT supports programs that use -- two different dispatch table format at the same time: the native -- format that supports Ada 95 tagged types and which is described in -- Ada.Tags and a foreign format for types that are imported from some --- 59,65 ---- ---------------------------------------------------------------- -- GNAT's Dispatch Table format is customizable in order to match the ! -- format used in another langauge. GNAT supports programs that use -- two different dispatch table format at the same time: the native -- format that supports Ada 95 tagged types and which is described in -- Ada.Tags and a foreign format for types that are imported from some *************** private *** 134,148 **** -- Entry point used to initialize the TSD of a type knowing the -- TSD of the direct ancestor. ! function Parent_Size (Obj : S.Address) return SSE.Storage_Count; ! -- Computes the size of field _Parent of a tagged extension object -- whose address is 'obj' by calling the indirectly _size function of ! -- the parent. This function assumes that _size is always in slot 1 of -- the dispatch table. pragma Export (Ada, Parent_Size, "ada__tags__parent_size"); -- This procedure is used in s-finimp and is thus exported manually procedure Register_Tag (T : Tag); -- Insert the Tag and its associated external_tag in a table for the -- sake of Internal_Tag --- 133,158 ---- -- Entry point used to initialize the TSD of a type knowing the -- TSD of the direct ancestor. ! function Parent_Size ! (Obj : S.Address; ! T : Tag) ! return SSE.Storage_Count; ! -- Computes the size the ancestor part of a tagged extension object -- whose address is 'obj' by calling the indirectly _size function of ! -- the ancestor. The ancestor is the parent of the type represented by ! -- tag T. This function assumes that _size is always in slot 1 of -- the dispatch table. pragma Export (Ada, Parent_Size, "ada__tags__parent_size"); -- This procedure is used in s-finimp and is thus exported manually + function Parent_Tag (T : Tag) return Tag; + -- Obj is the address of a tagged object. Parent_Tag fetch the tag of the + -- immediate ancestor (parent) of the type associated with Obj. + + pragma Export (Ada, Parent_Tag, "ada__tags__parent_tag"); + -- This procedure is used in s-finimp and is thus exported manually + procedure Register_Tag (T : Tag); -- Insert the Tag and its associated external_tag in a table for the -- sake of Internal_Tag *************** private *** 226,229 **** --- 236,240 ---- pragma Inline_Always (Set_RC_Offset); pragma Inline_Always (Set_Remotely_Callable); pragma Inline_Always (Set_TSD); + end Ada.Tags; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-tasatt.adb gcc-3.4.0/gcc/ada/a-tasatt.adb *** gcc-3.3.3/gcc/ada/a-tasatt.adb 2002-03-14 10:58:55.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tasatt.adb 2003-10-21 13:41:54.000000000 +0000 *************** *** 6,13 **** -- -- -- 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- -- --- 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,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). -- -- -- ------------------------------------------------------------------------------ --- 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. -- -- -- ------------------------------------------------------------------------------ *************** *** 121,127 **** -- finalization for that type of attribute. On task termination, the -- runtime system uses the pointer to call the appropriate deallocator. ! -- While this gets around the limitation that instantiations be at -- the library level, it relies on an implementation feature that -- may not always be safe, i.e. that it is safe to call the -- Deallocate procedure for an instantiation of Ada.Task_Attributes --- 121,127 ---- -- finalization for that type of attribute. On task termination, the -- runtime system uses the pointer to call the appropriate deallocator. ! -- While this gets around the limitation that instantations be at -- the library level, it relies on an implementation feature that -- may not always be safe, i.e. that it is safe to call the -- Deallocate procedure for an instantiation of Ada.Task_Attributes *************** package body Ada.Task_Attributes is *** 287,297 **** -- Unchecked Conversions -- --------------------------- - pragma Warnings (Off); - -- These unchecked conversions can give warnings when alignments - -- are incorrect, but they will not be used in such cases anyway, - -- so the warnings can be safely ignored. - -- The following type corresponds to Dummy_Wrapper, -- declared in System.Tasking.Task_Attributes. --- 287,292 ---- *************** package body Ada.Task_Attributes is *** 307,313 **** -- they will not actually be used. function To_Attribute_Handle is new Unchecked_Conversion ! (Access_Address, Attribute_Handle); -- For reference to directly addressed task attributes type Access_Integer_Address is access all --- 302,310 ---- -- they will not actually be used. function To_Attribute_Handle is new Unchecked_Conversion ! (System.Address, Attribute_Handle); ! function To_Direct_Attribute_Element is new Unchecked_Conversion ! (System.Address, Direct_Attribute_Element); -- For reference to directly addressed task attributes type Access_Integer_Address is access all *************** package body Ada.Task_Attributes is *** 347,357 **** (Task_Identification.Task_Id, Task_ID); -- To access TCB of identified task ! Null_ID : constant Task_ID := To_Task_ID (Task_Identification.Null_Task_Id); ! -- ??? need comments on use and purpose ! ! type Local_Deallocator is ! access procedure (P : in out Access_Node); function To_Lib_Level_Deallocator is new Unchecked_Conversion (Local_Deallocator, Deallocator); --- 344,350 ---- (Task_Identification.Task_Id, Task_ID); -- To access TCB of identified task ! type Local_Deallocator is access procedure (P : in out Access_Node); function To_Lib_Level_Deallocator is new Unchecked_Conversion (Local_Deallocator, Deallocator); *************** package body Ada.Task_Attributes is *** 381,386 **** --- 374,385 ---- -- The generic formal type, may be controlled end record; + -- A number of unchecked conversions involving Wrapper_Access sources + -- are performed in this unit. We have to ensure that the designated + -- object is always strictly enough aligned. + + for Wrapper'Alignment use Standard'Maximum_Alignment; + procedure Free is new Unchecked_Deallocation (Wrapper, Access_Wrapper); *************** package body Ada.Task_Attributes is *** 389,398 **** begin Free (T); - - exception - when others => - pragma Assert (Shutdown ("Exception in Deallocate")); null; end Deallocate; --------------- --- 388,393 ---- *************** package body Ada.Task_Attributes is *** 404,415 **** return Attribute_Handle is TT : Task_ID := To_Task_ID (T); ! Error_Message : constant String := "Trying to get the reference of a"; begin ! if TT = Null_ID then ! Raise_Exception (Program_Error'Identity, ! Error_Message & "null task"); end if; if TT.Common.State = Terminated then --- 399,409 ---- return Attribute_Handle is TT : Task_ID := To_Task_ID (T); ! Error_Message : constant String := "Trying to get the reference of a "; begin ! if TT = null then ! Raise_Exception (Program_Error'Identity, Error_Message & "null task"); end if; if TT.Common.State = Terminated then *************** package body Ada.Task_Attributes is *** 417,487 **** Error_Message & "terminated task"); end if; ! begin ! Defer_Abortion; ! POP.Lock_RTS; ! -- Directly addressed case ! if Local.Index /= 0 then ! POP.Unlock_RTS; ! Undefer_Abortion; ! -- Return the attribute handle. Warnings off because this return ! -- statement generates alignment warnings for large attributes ! -- (but will never be executed in this case anyway). ! pragma Warnings (Off); ! return ! To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Access); ! pragma Warnings (On); ! -- Not directly addressed ! else ! declare ! P : Access_Node := To_Access_Node (TT.Indirect_Attributes); ! W : Access_Wrapper; ! begin ! while P /= null loop ! if P.Instance = Access_Instance'(Local'Unchecked_Access) then ! POP.Unlock_RTS; ! Undefer_Abortion; ! return To_Access_Wrapper (P.Wrapper).Value'Access; ! end if; ! P := P.Next; ! end loop; ! -- Unlock the RTS here to follow the lock ordering rule ! -- that prevent us from using new (i.e the Global_Lock) while ! -- holding any other lock. ! POP.Unlock_RTS; ! W := new Wrapper' ! ((null, Local'Unchecked_Access, null), Initial_Value); ! POP.Lock_RTS; ! P := W.Noed'Unchecked_Access; ! P.Wrapper := To_Access_Dummy_Wrapper (W); ! P.Next := To_Access_Node (TT.Indirect_Attributes); ! TT.Indirect_Attributes := To_Access_Address (P); POP.Unlock_RTS; Undefer_Abortion; ! return W.Value'Access; ! end; ! end if; ! ! pragma Assert (Shutdown ("Should never get here in Reference")); ! return null; ! exception ! when others => ! POP.Unlock_RTS; ! Undefer_Abortion; ! raise; ! end; exception when Tasking_Error | Program_Error => --- 411,477 ---- Error_Message & "terminated task"); end if; ! -- Directly addressed case ! if Local.Index /= 0 then ! -- Return the attribute handle. Warnings off because this return ! -- statement generates alignment warnings for large attributes ! -- (but will never be executed in this case anyway). ! pragma Warnings (Off); ! return ! To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Address); ! pragma Warnings (On); ! -- Not directly addressed ! else ! declare ! P : Access_Node := To_Access_Node (TT.Indirect_Attributes); ! W : Access_Wrapper; ! begin ! Defer_Abortion; ! POP.Lock_RTS; ! while P /= null loop ! if P.Instance = Access_Instance'(Local'Unchecked_Access) then ! POP.Unlock_RTS; ! Undefer_Abortion; ! return To_Access_Wrapper (P.Wrapper).Value'Access; ! end if; ! P := P.Next; ! end loop; ! -- Unlock the RTS here to follow the lock ordering rule ! -- that prevent us from using new (i.e the Global_Lock) while ! -- holding any other lock. ! POP.Unlock_RTS; ! W := new Wrapper' ! ((null, Local'Unchecked_Access, null), Initial_Value); ! POP.Lock_RTS; ! P := W.Noed'Unchecked_Access; ! P.Wrapper := To_Access_Dummy_Wrapper (W); ! P.Next := To_Access_Node (TT.Indirect_Attributes); ! TT.Indirect_Attributes := To_Access_Address (P); ! POP.Unlock_RTS; ! Undefer_Abortion; ! return W.Value'Access; ! ! exception ! when others => POP.Unlock_RTS; Undefer_Abortion; ! raise; ! end; ! end if; ! pragma Assert (Shutdown ("Should never get here in Reference")); ! return null; exception when Tasking_Error | Program_Error => *************** package body Ada.Task_Attributes is *** 499,510 **** (T : Task_Identification.Task_Id := Task_Identification.Current_Task) is TT : Task_ID := To_Task_ID (T); ! Error_Message : constant String := "Trying to Reinitialize a"; begin ! if TT = Null_ID then ! Raise_Exception (Program_Error'Identity, ! Error_Message & "null task"); end if; if TT.Common.State = Terminated then --- 489,499 ---- (T : Task_Identification.Task_Id := Task_Identification.Current_Task) is TT : Task_ID := To_Task_ID (T); ! Error_Message : constant String := "Trying to Reinitialize a "; begin ! if TT = null then ! Raise_Exception (Program_Error'Identity, Error_Message & "null task"); end if; if TT.Common.State = Terminated then *************** package body Ada.Task_Attributes is *** 512,522 **** Error_Message & "terminated task"); end if; ! if Local.Index = 0 then declare P, Q : Access_Node; W : Access_Wrapper; - begin Defer_Abortion; POP.Lock_RTS; --- 501,512 ---- Error_Message & "terminated task"); end if; ! if Local.Index /= 0 then ! Set_Value (Initial_Value, T); ! else declare P, Q : Access_Node; W : Access_Wrapper; begin Defer_Abortion; POP.Lock_RTS; *************** package body Ada.Task_Attributes is *** 548,557 **** when others => POP.Unlock_RTS; Undefer_Abortion; end; - - else - Set_Value (Initial_Value, T); end if; exception --- 538,545 ---- when others => POP.Unlock_RTS; Undefer_Abortion; + raise; end; end if; exception *************** package body Ada.Task_Attributes is *** 570,582 **** (Val : Attribute; T : Task_Identification.Task_Id := Task_Identification.Current_Task) is ! TT : Task_ID := To_Task_ID (T); ! Error_Message : constant String := "Trying to Set the Value of a"; begin ! if TT = Null_ID then ! Raise_Exception (Program_Error'Identity, ! Error_Message & "null task"); end if; if TT.Common.State = Terminated then --- 558,569 ---- (Val : Attribute; T : Task_Identification.Task_Id := Task_Identification.Current_Task) is ! TT : Task_ID := To_Task_ID (T); ! Error_Message : constant String := "Trying to Set the Value of a "; begin ! if TT = null then ! Raise_Exception (Program_Error'Identity, Error_Message & "null task"); end if; if TT.Common.State = Terminated then *************** package body Ada.Task_Attributes is *** 584,644 **** Error_Message & "terminated task"); end if; ! begin ! Defer_Abortion; ! POP.Lock_RTS; ! -- Directly addressed case ! if Local.Index /= 0 then ! -- Set attribute handle, warnings off, because this code can ! -- generate alignment warnings with large attributes (but of ! -- course wil not be executed in this case, since we never ! -- have direct addressing in such cases). ! pragma Warnings (Off); ! To_Attribute_Handle ! (TT.Direct_Attributes (Local.Index)'Access).all := Val; ! pragma Warnings (On); ! POP.Unlock_RTS; ! Undefer_Abortion; ! return; ! -- Not directly addressed ! else ! declare ! P : Access_Node := To_Access_Node (TT.Indirect_Attributes); ! W : Access_Wrapper; ! begin ! while P /= null loop ! if P.Instance = Access_Instance'(Local'Unchecked_Access) then ! To_Access_Wrapper (P.Wrapper).Value := Val; ! POP.Unlock_RTS; ! Undefer_Abortion; ! return; ! end if; ! P := P.Next; ! end loop; ! -- Unlock RTS here to follow the lock ordering rule that ! -- prevent us from using new (i.e the Global_Lock) while ! -- holding any other lock. ! POP.Unlock_RTS; ! W := new Wrapper' ! ((null, Local'Unchecked_Access, null), Val); ! POP.Lock_RTS; ! P := W.Noed'Unchecked_Access; ! P.Wrapper := To_Access_Dummy_Wrapper (W); ! P.Next := To_Access_Node (TT.Indirect_Attributes); ! TT.Indirect_Attributes := To_Access_Address (P); ! end; ! end if; POP.Unlock_RTS; Undefer_Abortion; --- 571,625 ---- Error_Message & "terminated task"); end if; ! -- Directly addressed case ! if Local.Index /= 0 then ! -- Set attribute handle, warnings off, because this code can generate ! -- alignment warnings with large attributes (but of course will not ! -- be executed in this case, since we never have direct addressing in ! -- such cases). ! pragma Warnings (Off); ! To_Attribute_Handle ! (TT.Direct_Attributes (Local.Index)'Address).all := Val; ! pragma Warnings (On); ! return; ! end if; ! -- Not directly addressed ! declare ! P : Access_Node := To_Access_Node (TT.Indirect_Attributes); ! W : Access_Wrapper; ! begin ! Defer_Abortion; ! POP.Lock_RTS; ! while P /= null loop ! if P.Instance = Access_Instance'(Local'Unchecked_Access) then ! To_Access_Wrapper (P.Wrapper).Value := Val; ! POP.Unlock_RTS; ! Undefer_Abortion; ! return; ! end if; ! P := P.Next; ! end loop; ! -- Unlock RTS here to follow the lock ordering rule that ! -- prevent us from using new (i.e the Global_Lock) while ! -- holding any other lock. ! POP.Unlock_RTS; ! W := new Wrapper'((null, Local'Unchecked_Access, null), Val); ! POP.Lock_RTS; ! P := W.Noed'Unchecked_Access; ! P.Wrapper := To_Access_Dummy_Wrapper (W); ! P.Next := To_Access_Node (TT.Indirect_Attributes); ! TT.Indirect_Attributes := To_Access_Address (P); POP.Unlock_RTS; Undefer_Abortion; *************** package body Ada.Task_Attributes is *** 650,664 **** raise; end; - return; - exception when Tasking_Error | Program_Error => raise; when others => raise Program_Error; - end Set_Value; ----------- --- 631,642 ---- *************** package body Ada.Task_Attributes is *** 669,682 **** (T : Task_Identification.Task_Id := Task_Identification.Current_Task) return Attribute is - Result : Attribute; TT : Task_ID := To_Task_ID (T); ! Error_Message : constant String := "Trying to get the Value of a"; begin ! if TT = Null_ID then ! Raise_Exception ! (Program_Error'Identity, Error_Message & "null task"); end if; if TT.Common.State = Terminated then --- 647,658 ---- (T : Task_Identification.Task_Id := Task_Identification.Current_Task) return Attribute is TT : Task_ID := To_Task_ID (T); ! Error_Message : constant String := "Trying to get the Value of a "; begin ! if TT = null then ! Raise_Exception (Program_Error'Identity, Error_Message & "null task"); end if; if TT.Common.State = Terminated then *************** package body Ada.Task_Attributes is *** 684,739 **** (Program_Error'Identity, Error_Message & "terminated task"); end if; ! begin ! -- Directly addressed case ! ! if Local.Index /= 0 then ! ! -- Get value of attribute. Warnings off, because for large ! -- attributes, this code can generate alignment warnings. ! -- But of course large attributes are never directly addressed ! -- so in fact we will never execute the code in this case. ! pragma Warnings (Off); ! Result := ! To_Attribute_Handle ! (TT.Direct_Attributes (Local.Index)'Access).all; ! pragma Warnings (On); ! -- Not directly addressed ! else ! declare ! P : Access_Node; ! begin ! Defer_Abortion; ! POP.Lock_RTS; ! P := To_Access_Node (TT.Indirect_Attributes); ! while P /= null loop ! if P.Instance = Access_Instance'(Local'Unchecked_Access) then ! POP.Unlock_RTS; ! Undefer_Abortion; ! return To_Access_Wrapper (P.Wrapper).Value; ! end if; ! P := P.Next; ! end loop; ! Result := Initial_Value; POP.Unlock_RTS; Undefer_Abortion; ! exception ! when others => ! POP.Unlock_RTS; ! Undefer_Abortion; ! raise; ! end; ! end if; ! return Result; end; exception --- 660,711 ---- (Program_Error'Identity, Error_Message & "terminated task"); end if; ! -- Directly addressed case ! if Local.Index /= 0 then ! -- Get value of attribute. Warnings off, because for large ! -- attributes, this code can generate alignment warnings. ! -- But of course large attributes are never directly addressed ! -- so in fact we will never execute the code in this case. ! pragma Warnings (Off); ! return To_Attribute_Handle ! (TT.Direct_Attributes (Local.Index)'Address).all; ! pragma Warnings (On); ! end if; ! -- Not directly addressed ! declare ! P : Access_Node; ! Result : Attribute; ! begin ! Defer_Abortion; ! POP.Lock_RTS; ! P := To_Access_Node (TT.Indirect_Attributes); ! while P /= null loop ! if P.Instance = Access_Instance'(Local'Unchecked_Access) then ! Result := To_Access_Wrapper (P.Wrapper).Value; POP.Unlock_RTS; Undefer_Abortion; + return Result; + end if; ! P := P.Next; ! end loop; ! POP.Unlock_RTS; ! Undefer_Abortion; ! return Initial_Value; ! ! exception ! when others => ! POP.Unlock_RTS; ! Undefer_Abortion; ! raise; end; exception *************** begin *** 775,785 **** -- Try to find space for the attribute in the TCB. Local.Index := 0; ! Two_To_J := 2 ** Direct_Index'First; if Attribute'Size <= System.Address'Size then ! for J in Direct_Index loop ! if (Two_To_J and In_Use) /= 0 then -- Reserve location J for this attribute --- 747,757 ---- -- Try to find space for the attribute in the TCB. Local.Index := 0; ! Two_To_J := 1; if Attribute'Size <= System.Address'Size then ! for J in Direct_Index_Range loop ! if (Two_To_J and In_Use) = 0 then -- Reserve location J for this attribute *************** begin *** 805,811 **** -- Attribute goes directly in the TCB if Local.Index /= 0 then - -- Replace stub for initialization routine -- that is called at task creation. --- 777,782 ---- *************** begin *** 816,828 **** declare C : System.Tasking.Task_ID := System.Tasking.All_Tasks_List; - begin while C /= null loop - POP.Write_Lock (C); C.Direct_Attributes (Local.Index) := ! System.Storage_Elements.To_Address (Local.Initial_Value); ! POP.Unlock (C); C := C.Common.All_Tasks_Link; end loop; end; --- 787,797 ---- declare C : System.Tasking.Task_ID := System.Tasking.All_Tasks_List; begin while C /= null loop C.Direct_Attributes (Local.Index) := ! To_Direct_Attribute_Element ! (System.Storage_Elements.To_Address (Local.Initial_Value)); C := C.Common.All_Tasks_Link; end loop; end; *************** begin *** 835,853 **** Initialization.Finalize_Attributes_Link := System.Tasking.Task_Attributes.Finalize_Attributes'Access; - end if; POP.Unlock_RTS; Undefer_Abortion; - - exception - when others => null; - pragma Assert (Shutdown ("Exception in task attribute initializer")); - - -- If we later decide to allow exceptions to propagate, we need to - -- not only release locks and undefer abortion, we also need to undo - -- any initializations that succeeded up to this point, or we will - -- risk a dangling reference when the task terminates. end; end Ada.Task_Attributes; --- 804,812 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-tasatt.ads gcc-3.4.0/gcc/ada/a-tasatt.ads *** gcc-3.3.3/gcc/ada/a-tasatt.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tasatt.ads 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-taside.adb gcc-3.4.0/gcc/ada/a-taside.adb *** gcc-3.3.3/gcc/ada/a-taside.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-taside.adb 2003-10-21 13:41:54.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-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- -- *************** with System.Tasking.Rendezvous; *** 48,56 **** with System.Task_Primitives.Operations; -- used for Self - with System.Task_Info; - use type System.Task_Info.Task_Image_Type; - with Unchecked_Conversion; package body Ada.Task_Identification is --- 47,52 ---- *************** package body Ada.Task_Identification is *** 115,121 **** ----------- function Image (T : Task_Id) return String is - use System.Task_Info; function To_Address is new Unchecked_Conversion (Task_Id, System.Address); --- 111,116 ---- *************** package body Ada.Task_Identification is *** 123,133 **** if T = Null_Task_Id then return ""; ! elsif T.Common.Task_Image = null then return System.Address_Image (To_Address (T)); else ! return T.Common.Task_Image.all & "_" & System.Address_Image (To_Address (T)); end if; end Image; --- 118,128 ---- if T = Null_Task_Id then return ""; ! elsif T.Common.Task_Image_Len = 0 then return System.Address_Image (To_Address (T)); else ! return T.Common.Task_Image (1 .. T.Common.Task_Image_Len) & "_" & System.Address_Image (To_Address (T)); end if; end Image; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-taside.ads gcc-3.4.0/gcc/ada/a-taside.ads *** gcc-3.3.3/gcc/ada/a-taside.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-taside.ads 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-2000 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/a-teioed.adb gcc-3.4.0/gcc/ada/a-teioed.adb *** gcc-3.3.3/gcc/ada/a-teioed.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-teioed.adb 2003-10-21 13:41:54.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-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.Text_IO.Editing is *** 113,119 **** exception when others => raise Picture_Error; - end Expand; ------------------- --- 112,117 ---- *************** package body Ada.Text_IO.Editing is *** 138,143 **** --- 136,142 ---- Answer : String (1 .. Pic.Picture.Length) := Pic.Picture.Expanded; Last : Integer; Currency_Pos : Integer := Pic.Start_Currency; + In_Currency : Boolean := False; Dollar : Boolean := False; -- Overridden immediately if necessary. *************** package body Ada.Text_IO.Editing is *** 299,305 **** if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 > Pic.Max_Leading_Digits then ! raise Layout_Error; end if; if Pic.Radix_Position = Invalid_Position then --- 298,304 ---- if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 > Pic.Max_Leading_Digits then ! raise Ada.Text_IO.Layout_Error; end if; if Pic.Radix_Position = Invalid_Position then *************** package body Ada.Text_IO.Editing is *** 434,439 **** --- 433,439 ---- else if Pic.Floater = '#' then Currency_Pos := Currency_Symbol'Length; + In_Currency := True; end if; for J in reverse Pic.Start_Float .. Position loop *************** package body Ada.Text_IO.Editing is *** 442,448 **** when '*' => Answer (J) := Fill_Character; ! when 'Z' | 'b' | '/' | '0' => Answer (J) := ' '; when '9' => --- 442,456 ---- when '*' => Answer (J) := Fill_Character; ! when 'b' | '/' => ! if In_Currency and then Currency_Pos > 0 then ! Answer (J) := Currency_Symbol (Currency_Pos); ! Currency_Pos := Currency_Pos - 1; ! else ! Answer (J) := ' '; ! end if; ! ! when 'Z' | '0' => Answer (J) := ' '; when '9' => *************** package body Ada.Text_IO.Editing is *** 490,496 **** end loop; if Pic.Floater = '#' and then Currency_Pos /= 0 then ! raise Layout_Error; end if; end if; --- 498,504 ---- end loop; if Pic.Floater = '#' and then Currency_Pos /= 0 then ! raise Ada.Text_IO.Layout_Error; end if; end if; *************** package body Ada.Text_IO.Editing is *** 498,504 **** if Sign_Position = Invalid_Position then if Attrs.Negative then ! raise Layout_Error; end if; else --- 506,512 ---- if Sign_Position = Invalid_Position then if Attrs.Negative then ! raise Ada.Text_IO.Layout_Error; end if; else *************** package body Ada.Text_IO.Editing is *** 605,611 **** else if Pic.Floater = '#' and then Currency_Pos /= 0 then ! raise Layout_Error; end if; -- No trailing digits, but now J may need to stick in a currency --- 613,619 ---- else if Pic.Floater = '#' and then Currency_Pos /= 0 then ! raise Ada.Text_IO.Layout_Error; end if; -- No trailing digits, but now J may need to stick in a currency *************** package body Ada.Text_IO.Editing is *** 625,653 **** Currency_Pos := 1; end if; - -- Note: There are some weird cases J can imagine with 'b' or '#' - -- in currency strings where the following code will cause - -- glitches. The trick is to tell when the character in the - -- answer should be checked, and when to look at the original - -- string. Some other time. RIE 11/26/96 ??? - case Answer (J) is when '*' => Answer (J) := Fill_Character; when 'b' => ! Answer (J) := ' '; when '#' => if Currency_Pos > Currency_Symbol'Length then Answer (J) := ' '; else Answer (J) := Currency_Symbol (Currency_Pos); Currency_Pos := Currency_Pos + 1; end if; when '_' => case Pic.Floater is --- 633,669 ---- Currency_Pos := 1; end if; case Answer (J) is when '*' => Answer (J) := Fill_Character; when 'b' => ! if In_Currency then ! Answer (J) := Currency_Symbol (Currency_Pos); ! Currency_Pos := Currency_Pos + 1; ! ! if Currency_Pos > Currency_Symbol'Length then ! In_Currency := False; ! end if; ! end if; when '#' => if Currency_Pos > Currency_Symbol'Length then Answer (J) := ' '; else + In_Currency := True; Answer (J) := Currency_Symbol (Currency_Pos); Currency_Pos := Currency_Pos + 1; + + if Currency_Pos > Currency_Symbol'Length then + In_Currency := False; + end if; end if; when '_' => + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos + 1; case Pic.Floater is *************** package body Ada.Text_IO.Editing is *** 693,699 **** Last := Last - 1; end if; ! return String' (1 .. Last => ' '); elsif Zero and Pic.Star_Fill then Last := Answer'Last; --- 709,715 ---- Last := Last - 1; end if; ! return String'(1 .. Last => ' '); elsif Zero and Pic.Star_Fill then Last := Answer'Last; *************** package body Ada.Text_IO.Editing is *** 709,717 **** elsif Dollar then if Pic.Radix_Position > Pic.Start_Currency then ! return String' (1 .. Pic.Radix_Position - 1 => '*') & Radix_Point & ! String' (Pic.Radix_Position + 1 .. Last => '*'); else return --- 725,733 ---- elsif Dollar then if Pic.Radix_Position > Pic.Start_Currency then ! return String'(1 .. Pic.Radix_Position - 1 => '*') & Radix_Point & ! String'(Pic.Radix_Position + 1 .. Last => '*'); else return *************** package body Ada.Text_IO.Editing is *** 725,737 **** end if; else ! return String' (1 .. Pic.Radix_Position - 1 => '*') & Radix_Point & ! String' (Pic.Radix_Position + 1 .. Last => '*'); end if; end if; ! return String' (1 .. Last => '*'); end if; -- This was once a simple return statement, now there are nine --- 741,753 ---- end if; else ! return String'(1 .. Pic.Radix_Position - 1 => '*') & Radix_Point & ! String'(Pic.Radix_Position + 1 .. Last => '*'); end if; end if; ! return String'(1 .. Last => '*'); end if; -- This was once a simple return statement, now there are nine *************** package body Ada.Text_IO.Editing is *** 740,746 **** -- Processing the radix and sign expansion separately -- would require lots of copying--the string and some of its ! -- indices--without really simplifying the logic. The cases are: -- 1) Expand $, replace '.' with Radix_Point -- 2) No currency expansion, replace '.' with Radix_Point --- 756,762 ---- -- Processing the radix and sign expansion separately -- would require lots of copying--the string and some of its ! -- indicies--without really simplifying the logic. The cases are: -- 1) Expand $, replace '.' with Radix_Point -- 2) No currency expansion, replace '.' with Radix_Point *************** package body Ada.Text_IO.Editing is *** 824,830 **** return Answer; end if; - end Format_Number; ------------------------- --- 840,845 ---- *************** package body Ada.Text_IO.Editing is *** 905,911 **** -- No significant (intger) digits needs a null range. return Answer; - end Parse_Number_String; ---------------- --- 920,925 ---- *************** package body Ada.Text_IO.Editing is *** 931,941 **** ------------------ procedure Precalculate (Pic : in out Format_Record) is Computed_BWZ : Boolean := True; - Debug : Boolean := False; type Legality is (Okay, Reject); State : Legality := Reject; -- Start in reject, which will reject null strings. --- 945,957 ---- ------------------ procedure Precalculate (Pic : in out Format_Record) is + Debug : constant Boolean := False; + -- Set True to generate debug output Computed_BWZ : Boolean := True; type Legality is (Okay, Reject); + State : Legality := Reject; -- Start in reject, which will reject null strings. *************** package body Ada.Text_IO.Editing is *** 985,990 **** --- 1001,1007 ---- procedure Number; procedure Optional_RHS_Sign; procedure Picture_String; + procedure Set_Debug; ------------ -- At_End -- *************** package body Ada.Text_IO.Editing is *** 992,1000 **** --- 1009,1033 ---- function At_End return Boolean is begin + Debug_Start ("At_End"); return Index > Pic.Picture.Length; end At_End; + -------------- + -- Set_Debug-- + -------------- + + -- Needed to have a procedure to pass to pragma Debug + + procedure Set_Debug is + begin + -- Uncomment this line and make Debug a variable to enable debug + + -- Debug := True; + + null; + end Set_Debug; + ------------------- -- Debug_Integer -- ------------------- *************** package body Ada.Text_IO.Editing is *** 1033,1039 **** procedure Floating_Bracket is begin Debug_Start ("Floating_Bracket"); ! Pic.Floater := '<'; Pic.End_Float := Index; Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; --- 1066,1081 ---- procedure Floating_Bracket is begin Debug_Start ("Floating_Bracket"); ! ! -- Two different floats not allowed. ! ! if Pic.Floater /= '!' and then Pic.Floater /= '<' then ! raise Picture_Error; ! ! else ! Pic.Floater := '<'; ! end if; ! Pic.End_Float := Index; Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; *************** package body Ada.Text_IO.Editing is *** 1083,1089 **** end loop; end Floating_Bracket; - -------------------- -- Floating_Minus -- -------------------- --- 1125,1130 ---- *************** package body Ada.Text_IO.Editing is *** 1289,1297 **** begin Debug_Start ("Leading_Dollar"); ! -- Treat as a floating dollar, and unwind otherwise. - Pic.Floater := '$'; Pic.Start_Currency := Index; Pic.End_Currency := Index; Pic.Start_Float := Index; --- 1330,1347 ---- begin Debug_Start ("Leading_Dollar"); ! -- Treat as a floating dollar, and unwind otherwise ! ! if Pic.Floater /= '!' and then Pic.Floater /= '$' then ! ! -- Two floats not allowed ! ! raise Picture_Error; ! ! else ! Pic.Floater := '$'; ! end if; Pic.Start_Currency := Index; Pic.End_Currency := Index; Pic.Start_Float := Index; *************** package body Ada.Text_IO.Editing is *** 1331,1338 **** if State = Okay then raise Picture_Error; else ! -- Will overwrite Floater and Start_Float Zero_Suppression; end if; --- 1381,1390 ---- if State = Okay then raise Picture_Error; else ! -- Overwrite Floater and Start_Float + Pic.Floater := 'Z'; + Pic.Start_Float := Index; Zero_Suppression; end if; *************** package body Ada.Text_IO.Editing is *** 1340,1347 **** if State = Okay then raise Picture_Error; else ! -- Will overwrite Floater and Start_Float ! Star_Suppression; end if; --- 1392,1400 ---- if State = Okay then raise Picture_Error; else ! -- Overwrite Floater and Start_Float ! Pic.Floater := '*'; ! Pic.Start_Float := Index; Star_Suppression; end if; *************** package body Ada.Text_IO.Editing is *** 1414,1420 **** -- Treat as a floating currency. If it isn't, this will be -- overwritten later. ! Pic.Floater := '#'; Pic.Start_Currency := Index; Pic.End_Currency := Index; --- 1467,1481 ---- -- Treat as a floating currency. If it isn't, this will be -- overwritten later. ! if Pic.Floater /= '!' and then Pic.Floater /= '#' then ! ! -- Two floats not allowed ! ! raise Picture_Error; ! ! else ! Pic.Floater := '#'; ! end if; Pic.Start_Currency := Index; Pic.End_Currency := Index; *************** package body Ada.Text_IO.Editing is *** 1454,1461 **** else Pic.Max_Leading_Digits := 0; ! -- Will overwrite Floater and Start_Float Zero_Suppression; end if; --- 1515,1524 ---- else Pic.Max_Leading_Digits := 0; ! -- Overwrite Floater and Start_Float + Pic.Floater := 'Z'; + Pic.Start_Float := Index; Zero_Suppression; end if; *************** package body Ada.Text_IO.Editing is *** 1465,1472 **** else Pic.Max_Leading_Digits := 0; ! -- Will overwrite Floater and Start_Float ! Star_Suppression; end if; --- 1528,1536 ---- else Pic.Max_Leading_Digits := 0; ! -- Overwrite Floater and Start_Float ! Pic.Floater := '*'; ! Pic.Start_Float := Index; Star_Suppression; end if; *************** package body Ada.Text_IO.Editing is *** 2285,2290 **** --- 2349,2359 ---- Set_State (Okay); + -- Overwrite Floater and Start_Float + + Pic.Floater := 'Z'; + Pic.Start_Float := Index; + Zero_Suppression; Trailing_Currency; Optional_RHS_Sign; *************** package body Ada.Text_IO.Editing is *** 2407,2413 **** procedure Star_Suppression is begin Debug_Start ("Star_Suppression"); ! Pic.Floater := '*'; Pic.Start_Float := Index; Pic.End_Float := Index; Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; --- 2476,2492 ---- procedure Star_Suppression is begin Debug_Start ("Star_Suppression"); ! ! if Pic.Floater /= '!' and then Pic.Floater /= '*' then ! ! -- Two floats not allowed ! ! raise Picture_Error; ! ! else ! Pic.Floater := '*'; ! end if; ! Pic.Start_Float := Index; Pic.End_Float := Index; Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; *************** package body Ada.Text_IO.Editing is *** 2451,2456 **** --- 2530,2541 ---- return; when '#' | '$' => + if Pic.Max_Currency_Digits > 0 then + raise Picture_Error; + end if; + + -- Cannot have leading and trailing currency + Trailing_Currency; Set_State (Okay); return; *************** package body Ada.Text_IO.Editing is *** 2588,2593 **** --- 2673,2680 ---- -- Start of processing for Precalculate begin + pragma Debug (Set_Debug); + Picture_String; if Debug then *************** package body Ada.Text_IO.Editing is *** 2622,2628 **** -- To deal with special cases like null strings. raise Picture_Error; - end Precalculate; ---------------- --- 2709,2714 ---- *************** package body Ada.Text_IO.Editing is *** 2651,2657 **** exception when others => raise Picture_Error; - end To_Picture; ----------- --- 2737,2742 ---- *************** package body Ada.Text_IO.Editing is *** 2676,2682 **** Format_Rec.Original_BWZ := Blank_When_Zero; Precalculate (Format_Rec); ! -- False only if Blank_When_0 is True but the pic string has a '*' return not Blank_When_Zero or Strings_Fixed.Index (Expanded_Pic, "*") = 0; --- 2761,2767 ---- Format_Rec.Original_BWZ := Blank_When_Zero; Precalculate (Format_Rec); ! -- False only if Blank_When_Zero is True but the pic string has a '*' return not Blank_When_Zero or Strings_Fixed.Index (Expanded_Pic, "*") = 0; *************** package body Ada.Text_IO.Editing is *** 2684,2690 **** exception when others => return False; - end Valid; -------------------- --- 2769,2774 ---- *************** package body Ada.Text_IO.Editing is *** 2791,2797 **** begin if Result'Length > To'Length then ! raise Text_IO.Layout_Error; else Strings_Fixed.Move (Source => Result, Target => To, Justify => Strings.Right); --- 2875,2881 ---- begin if Result'Length > To'Length then ! raise Ada.Text_IO.Layout_Error; else Strings_Fixed.Move (Source => Result, Target => To, Justify => Strings.Right); *************** package body Ada.Text_IO.Editing is *** 2817,2826 **** end; exception ! when Layout_Error => return False; end Valid; - end Decimal_Output; end Ada.Text_IO.Editing; --- 2901,2909 ---- end; exception ! when Ada.Text_IO.Layout_Error => return False; end Valid; end Decimal_Output; end Ada.Text_IO.Editing; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-teioed.ads gcc-3.4.0/gcc/ada/a-teioed.ads *** gcc-3.3.3/gcc/ada/a-teioed.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-teioed.ads 2003-04-24 17:53:54.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-textio.adb gcc-3.4.0/gcc/ada/a-textio.adb *** gcc-3.3.3/gcc/ada/a-textio.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-textio.adb 2003-12-15 11:51:00.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-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- -- *************** with Ada.Streams; use Ada.Strea *** 36,41 **** --- 35,41 ---- with Interfaces.C_Streams; use Interfaces.C_Streams; with System; with System.File_IO; + with System.CRTL; with Unchecked_Conversion; with Unchecked_Deallocation; *************** package body Ada.Text_IO is *** 52,63 **** function To_TIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode); use type FCB.File_Mode; ------------------- -- AFCB_Allocate -- ------------------- function AFCB_Allocate (Control_Block : Text_AFCB) return FCB.AFCB_Ptr is ! pragma Warnings (Off, Control_Block); begin return new Text_AFCB; --- 52,65 ---- function To_TIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode); use type FCB.File_Mode; + use type System.CRTL.size_t; + ------------------- -- AFCB_Allocate -- ------------------- function AFCB_Allocate (Control_Block : Text_AFCB) return FCB.AFCB_Ptr is ! pragma Unreferenced (Control_Block); begin return new Text_AFCB; *************** package body Ada.Text_IO is *** 137,147 **** Name : in String := ""; Form : in String := "") is ! File_Control_Block : Text_AFCB; begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => File_Control_Block, Mode => To_FCB (Mode), Name => Name, Form => Form, --- 139,152 ---- Name : in String := ""; Form : in String := "") is ! Dummy_File_Control_Block : Text_AFCB; ! pragma Warnings (Off, Dummy_File_Control_Block); ! -- Yes, we know this is never assigned a value, only the tag ! -- is used for dispatching purposes, so that's expected. begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => Dummy_File_Control_Block, Mode => To_FCB (Mode), Name => Name, Form => Form, *************** package body Ada.Text_IO is *** 339,344 **** --- 344,358 ---- return End_Of_Page (Current_In); end End_Of_Page; + -------------- + -- EOF_Char -- + -------------- + + function EOF_Char return Integer is + begin + return EOF; + end EOF_Char; + ----------- -- Flush -- ----------- *************** package body Ada.Text_IO is *** 482,488 **** end_of_file : int; procedure getc_immediate ! (stream : FILEs; ch : out int; end_of_file : out int); pragma Import (C, getc_immediate, "getc_immediate"); begin --- 496,504 ---- end_of_file : int; procedure getc_immediate ! (stream : FILEs; ! ch : out int; ! end_of_file : out int); pragma Import (C, getc_immediate, "getc_immediate"); begin *************** package body Ada.Text_IO is *** 504,510 **** end if; Item := Character'Val (ch); - end Get_Immediate; procedure Get_Immediate --- 520,525 ---- *************** package body Ada.Text_IO is *** 914,924 **** Name : in String; Form : in String := "") is ! File_Control_Block : Text_AFCB; begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => File_Control_Block, Mode => To_FCB (Mode), Name => Name, Form => Form, --- 929,942 ---- Name : in String; Form : in String := "") is ! Dummy_File_Control_Block : Text_AFCB; ! pragma Warnings (Off, Dummy_File_Control_Block); ! -- Yes, we know this is never assigned a value, only the tag ! -- is used for dispatching purposes, so that's expected. begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => Dummy_File_Control_Block, Mode => To_FCB (Mode), Name => Name, Form => Form, *************** package body Ada.Text_IO is *** 1047,1052 **** --- 1065,1073 ---- (File : in File_Type; Item : in String) is + Ilen : Natural := Item'Length; + Istart : Natural := Item'First; + begin FIO.Check_Write_Status (AP (File)); *************** package body Ada.Text_IO is *** 1066,1078 **** -- tasking programs, since often the OS will treat the entire put -- operation as an atomic operation. declare - Ilen : constant Natural := Item'Length; Buffer : String (1 .. Ilen + 2); Plen : size_t; begin ! Buffer (1 .. Ilen) := Item; Buffer (Ilen + 1) := Character'Val (LM); if File.Page_Length /= 0 --- 1087,1111 ---- -- tasking programs, since often the OS will treat the entire put -- operation as an atomic operation. + -- We only do this if the message is 512 characters or less in length, + -- since otherwise Put_Line would use an unbounded amount of stack + -- space and could cause undetected stack overflow. If we have a + -- longer string, then output the first part separately to avoid this. + + if Ilen > 512 then + FIO.Write_Buf (AP (File), Item'Address, size_t (Ilen - 512)); + Istart := Istart + Ilen - 512; + Ilen := 512; + end if; + + -- Now prepare the string with its terminator + declare Buffer : String (1 .. Ilen + 2); Plen : size_t; begin ! Buffer (1 .. Ilen) := Item (Istart .. Item'Last); Buffer (Ilen + 1) := Character'Val (LM); if File.Page_Length /= 0 *************** package body Ada.Text_IO is *** 1122,1128 **** Item : out Stream_Element_Array; Last : out Stream_Element_Offset) is ! ch : int; begin if File.Mode /= FCB.In_File then --- 1155,1162 ---- Item : out Stream_Element_Array; Last : out Stream_Element_Offset) is ! Discard_ch : int; ! pragma Warnings (Off, Discard_ch); begin if File.Mode /= FCB.In_File then *************** package body Ada.Text_IO is *** 1144,1150 **** -- be expected if stream and text input are mixed this way? if File.Before_LM_PM then ! ch := ungetc (PM, File.Stream); File.Before_LM_PM := False; end if; --- 1178,1184 ---- -- be expected if stream and text input are mixed this way? if File.Before_LM_PM then ! Discard_ch := ungetc (PM, File.Stream); File.Before_LM_PM := False; end if; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-textio.ads gcc-3.4.0/gcc/ada/a-textio.ads *** gcc-3.3.3/gcc/ada/a-textio.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-textio.ads 2003-10-21 13:41:54.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1992-2000 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 -- --- 6,12 ---- -- -- -- 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 -- *************** private *** 343,349 **** Self : aliased File_Type; -- Set to point to the containing Text_AFCB block. This is used to ! -- implement the Current_{Error,Input,Output} functions which return -- a File_Access, the file access value returned is a pointer to -- the Self field of the corresponding file. --- 342,348 ---- Self : aliased File_Type; -- Set to point to the containing Text_AFCB block. This is used to ! -- implement the Current_{Error,Input,Ouput} functions which return -- a File_Access, the file access value returned is a pointer to -- the Self field of the corresponding file. *************** private *** 412,417 **** --- 411,421 ---- -- this interfaces package with the spec of Ada.Text_IO, and we know that -- in fact these types are identical + function EOF_Char return Integer; + -- Returns the system-specific character indicating the end of a text file. + -- This is exported for use by child packages such as Enumeration_Aux to + -- eliminate their needing to depend directly on Interfaces.C_Streams. + function Getc (File : File_Type) return Integer; -- Gets next character from file, which has already been checked for -- being in read status, and returns the character read if no error diff -Nrc3pad gcc-3.3.3/gcc/ada/a-ticoau.adb gcc-3.4.0/gcc/ada/a-ticoau.adb *** gcc-3.3.3/gcc/ada/a-ticoau.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-ticoau.adb 2003-04-24 17:53:55.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992,1993,1994,1995,1996 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/a-ticoau.ads gcc-3.4.0/gcc/ada/a-ticoau.ads *** gcc-3.3.3/gcc/ada/a-ticoau.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-ticoau.ads 2003-04-24 17:53:55.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992,1993,1994,1995 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/a-ticoio.adb gcc-3.4.0/gcc/ada/a-ticoio.adb *** gcc-3.3.3/gcc/ada/a-ticoio.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-ticoio.adb 2003-04-24 17:53:55.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992,1993,1994,1995,1996 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/a-ticoio.ads gcc-3.4.0/gcc/ada/a-ticoio.ads *** gcc-3.3.3/gcc/ada/a-ticoio.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-ticoio.ads 2003-04-24 17:53:55.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-tideau.adb gcc-3.4.0/gcc/ada/a-tideau.adb *** gcc-3.3.3/gcc/ada/a-tideau.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tideau.adb 2003-04-24 17:53:55.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/a-tideau.ads gcc-3.4.0/gcc/ada/a-tideau.ads *** gcc-3.3.3/gcc/ada/a-tideau.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tideau.ads 2003-04-24 17:53:55.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-tideio.adb gcc-3.4.0/gcc/ada/a-tideio.adb *** gcc-3.3.3/gcc/ada/a-tideio.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tideio.adb 2003-04-24 17:53:55.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992-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/a-tideio.ads gcc-3.4.0/gcc/ada/a-tideio.ads *** gcc-3.3.3/gcc/ada/a-tideio.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tideio.ads 2003-04-24 17:53:55.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-tienau.adb gcc-3.4.0/gcc/ada/a-tienau.adb *** gcc-3.3.3/gcc/ada/a-tienau.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tienau.adb 2003-10-21 13:41:54.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-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,56 **** with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; with Ada.Characters.Handling; use Ada.Characters.Handling; - with Interfaces.C_Streams; use Interfaces.C_Streams; -- Note: this package does not yet deal properly with wide characters ??? package body Ada.Text_IO.Enumeration_Aux is - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- These definitions replace the ones in Ada.Characters.Handling, which - -- do not seem to work for some strange not understood reason ??? at - -- least in the OS/2 version. - - function To_Lower (C : Character) return Character; - function To_Upper (C : Character) return Character; - ------------------ -- Get_Enum_Lit -- ------------------ --- 33,43 ---- *************** package body Ada.Text_IO.Enumeration_Aux *** 60,66 **** Buf : out String; Buflen : out Natural) is ! ch : int; C : Character; begin --- 47,53 ---- Buf : out String; Buflen : out Natural) is ! ch : Integer; C : Character; begin *************** package body Ada.Text_IO.Enumeration_Aux *** 113,119 **** Store_Char (File, Character'Pos (To_Upper (C)), Buf, Buflen); ch := Getc (File); ! exit when ch = EOF; C := Character'Val (ch); exit when not Is_Letter (C) --- 100,106 ---- Store_Char (File, Character'Pos (To_Upper (C)), Buf, Buflen); ch := Getc (File); ! exit when ch = EOF_Char; C := Character'Val (ch); exit when not Is_Letter (C) *************** package body Ada.Text_IO.Enumeration_Aux *** 239,245 **** end if; end if; - Stop := Stop - 1; raise Data_Error; -- Similarly for identifiers, read as far as we can, in particular, --- 226,231 ---- *************** package body Ada.Text_IO.Enumeration_Aux *** 271,299 **** Stop := Stop + 1; end loop; end if; - end Scan_Enum_Lit; - -------------- - -- To_Lower -- - -------------- - - function To_Lower (C : Character) return Character is - begin - if C in 'A' .. 'Z' then - return Character'Val (Character'Pos (C) + 32); - else - return C; - end if; - end To_Lower; - - function To_Upper (C : Character) return Character is - begin - if C in 'a' .. 'z' then - return Character'Val (Character'Pos (C) - 32); - else - return C; - end if; - end To_Upper; - end Ada.Text_IO.Enumeration_Aux; --- 257,262 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-tienau.ads gcc-3.4.0/gcc/ada/a-tienau.ads *** gcc-3.3.3/gcc/ada/a-tienau.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tienau.ads 2003-04-24 17:53:55.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-tienio.adb gcc-3.4.0/gcc/ada/a-tienio.adb *** gcc-3.3.3/gcc/ada/a-tienio.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tienio.adb 2003-04-24 17:53:55.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992-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/a-tienio.ads gcc-3.4.0/gcc/ada/a-tienio.ads *** gcc-3.3.3/gcc/ada/a-tienio.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tienio.ads 2003-04-24 17:53:55.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-2000 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/a-tifiio.adb gcc-3.4.0/gcc/ada/a-tifiio.adb *** gcc-3.3.3/gcc/ada/a-tifiio.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tifiio.adb 2003-10-21 13:41:54.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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- -- *************** *** 32,50 **** -- -- ------------------------------------------------------------------------------ with Ada.Text_IO.Float_Aux; package body Ada.Text_IO.Fixed_IO is ! -- Note: we use the floating-point I/O routines for input/output of ! -- ordinary fixed-point. This works fine for fixed-point declarations ! -- whose mantissa is no longer than the mantissa of Long_Long_Float, ! -- and we simply consider that we have only partial support for fixed- ! -- point types with larger mantissas (this situation will not arise on ! -- the x86, but it will rise on machines only supporting IEEE long). package Aux renames Ada.Text_IO.Float_Aux; --------- -- Get -- --------- --- 31,314 ---- -- -- ------------------------------------------------------------------------------ + -- Fixed point I/O + -- --------------- + + -- The following documents implementation details of the fixed point + -- input/output routines in the GNAT run time. The first part describes + -- general properties of fixed point types as defined by the Ada 95 standard, + -- including the Information Systems Annex. + + -- Subsequently these are reduced to implementation constraints and the impact + -- of these constraints on a few possible approaches to I/O are given. + -- Based on this analysis, a specific implementation is selected for use in + -- the GNAT run time. Finally, the chosen algorithm is analyzed numerically in + -- order to provide user-level documentation on limits for range and precision + -- of fixed point types as well as accuracy of input/output conversions. + + -- ------------------------------------------- + -- - General Properties of Fixed Point Types - + -- ------------------------------------------- + + -- Operations on fixed point values, other than input and output, are not + -- important for the purposes of this document. Only the set of values that a + -- fixed point type can represent and the input and output operations are + -- significant. + + -- Values + -- ------ + + -- Set set of values of a fixed point type comprise the integral + -- multiples of a number called the small of the type. The small can + -- either be a power of ten, a power of two or (if the implementation + -- allows) an arbitrary strictly positive real value. + + -- Implementations need to support fixed-point types with a precision + -- of at least 24 bits, and (in order to comply with the Information + -- Systems Annex) decimal types need to support at least digits 18. + -- For the rest, however, no requirements exist for the minimal small + -- and range that need to be supported. + + -- Operations + -- ---------- + + -- 'Image and 'Wide_Image (see RM 3.5(34)) + + -- These attributes return a decimal real literal best approximating + -- the value (rounded away from zero if halfway between) with a + -- single leading character that is either a minus sign or a space, + -- one or more digits before the decimal point (with no redundant + -- leading zeros), a decimal point, and N digits after the decimal + -- point. For a subtype S, the value of N is S'Aft, the smallest + -- positive integer such that (10**N)*S'Delta is greater or equal to + -- one, see RM 3.5.10(5). + + -- For an arbitrary small, this means large number arithmetic needs + -- to be performed. + + -- Put (see RM A.10.9(22-26)) + + -- The requirements for Put add no extra constraints over the image + -- attributes, although it would be nice to be able to output more + -- than S'Aft digits after the decimal point for values of subtype S. + + -- 'Value and 'Wide_Value attribute (RM 3.5(40-55)) + + -- Since the input can be given in any base in the range 2..16, + -- accurate conversion to a fixed point number may require + -- arbitrary precision arithmetic if there is no limit on the + -- magnitude of the small of the fixed point type. + + -- Get (see RM A.10.9(12-21)) + + -- The requirements for Get are identical to those of the Value + -- attribute. + + -- ------------------------------ + -- - Implementation Constraints - + -- ------------------------------ + + -- The requirements listed above for the input/output operations lead to + -- significant complexity, if no constraints are put on supported smalls. + + -- Implementation Strategies + -- ------------------------- + + -- * Float arithmetic + -- * Arbitrary-precision integer arithmetic + -- * Fixed-precision integer arithmetic + + -- Although it seems convenient to convert fixed point numbers to floating- + -- point and then print them, this leads to a number of restrictions. + -- The first one is precision. The widest floating-point type generally + -- available has 53 bits of mantissa. This means that Fine_Delta cannot + -- be less than 2.0**(-53). + + -- In GNAT, Fine_Delta is 2.0**(-63), and Duration for example is a + -- 64-bit type. It would still be possible to use multi-precision + -- floating-point to perform calculations using longer mantissas, + -- but this is a much harder approach. + + -- The base conversions needed for input and output of (non-decimal) + -- fixed point types can be seen as pairs of integer multiplications + -- and divisions. + + -- Arbitrary-precision integer arithmetic would be suitable for the job + -- at hand, but has the draw-back that it is very heavy implementation-wise. + -- Especially in embedded systems, where fixed point types are often used, + -- it may not be desirable to require large amounts of storage and time + -- for fixed I/O operations. + + -- Fixed-precision integer arithmetic has the advantage of simplicity and + -- speed. For the most common fixed point types this would be a perfect + -- solution. The downside however may be a too limited set of acceptable + -- fixed point types. + + -- Extra Precision + -- --------------- + + -- Using a scaled divide which truncates and returns a remainder R, + -- another E trailing digits can be calculated by computing the value + -- (R * (10.0**E)) / Z using another scaled divide. This procedure + -- can be repeated to compute an arbitrary number of digits in linear + -- time and storage. The last scaled divide should be rounded, with + -- a possible carry propagating to the more significant digits, to + -- ensure correct rounding of the unit in the last place. + + -- An extension of this technique is to limit the value of Q to 9 decimal + -- digits, since 32-bit integers can be much more efficient than 64-bit + -- integers to output. + + with Interfaces; use Interfaces; + with System.Arith_64; use System.Arith_64; + with System.Img_Real; use System.Img_Real; + with Ada.Text_IO; use Ada.Text_IO; with Ada.Text_IO.Float_Aux; + with Ada.Text_IO.Generic_Aux; package body Ada.Text_IO.Fixed_IO is ! -- Note: we still use the floating-point I/O routines for input of ! -- ordinary fixed-point and output using exponent format. This will ! -- result in inaccuracies for fixed point types with a small that is ! -- not a power of two, and for types that require more precision than ! -- is available in Long_Long_Float. package Aux renames Ada.Text_IO.Float_Aux; + Extra_Layout_Space : constant Field := 5 + Num'Fore; + -- Extra space that may be needed for output of sign, decimal point, + -- exponent indication and mandatory decimals after and before the + -- decimal point. A string with length + + -- Fore + Aft + Exp + Extra_Layout_Space + + -- is always long enough for formatting any fixed point number. + + -- Implementation of Put routines + + -- The following section describes a specific implementation choice for + -- performing base conversions needed for output of values of a fixed + -- point type T with small T'Small. The goal is to be able to output + -- all values of types with a precision of 64 bits and a delta of at + -- least 2.0**(-63), as these are current GNAT limitations already. + + -- The chosen algorithm uses fixed precision integer arithmetic for + -- reasons of simplicity and efficiency. It is important to understand + -- in what ways the most simple and accurate approach to fixed point I/O + -- is limiting, before considering more complicated schemes. + + -- Without loss of generality assume T has a range (-2.0**63) * T'Small + -- .. (2.0**63 - 1) * T'Small, and is output with Aft digits after the + -- decimal point and T'Fore - 1 before. If T'Small is integer, or + -- 1.0 / T'Small is integer, let S = T'Small and E = 0. For other T'Small, + -- let S and E be integers such that S / 10**E best approximates T'Small + -- and S is in the range 10**17 .. 10**18 - 1. The extra decimal scaling + -- factor 10**E can be trivially handled during final output, by adjusting + -- the decimal point or exponent. + + -- Convert a value X * S of type T to a 64-bit integer value Q equal + -- to 10.0**D * (X * S) rounded to the nearest integer. + -- This conversion is a scaled integer divide of the form + + -- Q := (X * Y) / Z, + + -- where all variables are 64-bit signed integers using 2's complement, + -- and both the multiplication and division are done using full + -- intermediate precision. The final decimal value to be output is + + -- Q * 10**(E-D) + + -- This value can be written to the output file or to the result string + -- according to the format described in RM A.3.10. The details of this + -- operation are omitted here. + + -- A 64-bit value can contain all integers with 18 decimal digits, but + -- not all with 19 decimal digits. If the total number of requested output + -- digits (Fore - 1) + Aft is greater than 18, for purposes of the + -- conversion Aft is adjusted to 18 - (Fore - 1). In that case, or + -- when Fore > 19, trailing zeros can complete the output after writing + -- the first 18 significant digits, or the technique described in the + -- next section can be used. + + -- The final expression for D is + + -- D := Integer'Max (-18, Integer'Min (Aft, 18 - (Fore - 1))); + + -- For Y and Z the following expressions can be derived: + + -- Q / (10.0**D) = X * S + + -- Q = X * S * (10.0**D) = (X * Y) / Z + + -- S * 10.0**D = Y / Z; + + -- If S is an integer greater than or equal to one, then Fore must be at + -- least 20 in order to print T'First, which is at most -2.0**63. + -- This means D < 0, so use + + -- (1) Y = -S and Z = -10**(-D). + + -- If 1.0 / S is an integer greater than one, use + + -- (2) Y = -10**D and Z = -(1.0 / S), for D >= 0 + + -- or + + -- (3) Y = 1 and Z = (1.0 / S) * 10**(-D), for D < 0 + + -- Negative values are used for nominator Y and denominator Z, so that S + -- can have a maximum value of 2.0**63 and a minimum of 2.0**(-63). + -- For Z in -1 .. -9, Fore will still be 20, and D will be negative, as + -- (-2.0**63) / -9 is greater than 10**18. In these cases there is room + -- in the denominator for the extra decimal scaling required, so case (3) + -- will not overflow. + + pragma Assert (System.Fine_Delta >= 2.0**(-63)); + pragma Assert (Num'Small in 2.0**(-63) .. 2.0**63); + pragma Assert (Num'Fore <= 37); + -- These assertions need to be relaxed to allow for a Small of + -- 2.0**(-64) at least, since there is an ACATS test for this ??? + + Max_Digits : constant := 18; + -- Maximum number of decimal digits that can be represented in a + -- 64-bit signed number, see above + + -- The constants E0 .. E5 implement a binary search for the appropriate + -- power of ten to scale the small so that it has one digit before the + -- decimal point. + + subtype Int is Integer; + E0 : constant Int := -20 * Boolean'Pos (Num'Small >= 1.0E1); + E1 : constant Int := E0 + 10 * Boolean'Pos (Num'Small * 10.0**E0 < 1.0E-10); + E2 : constant Int := E1 + 5 * Boolean'Pos (Num'Small * 10.0**E1 < 1.0E-5); + E3 : constant Int := E2 + 3 * Boolean'Pos (Num'Small * 10.0**E2 < 1.0E-3); + E4 : constant Int := E3 + 2 * Boolean'Pos (Num'Small * 10.0**E3 < 1.0E-1); + E5 : constant Int := E4 + 1 * Boolean'Pos (Num'Small * 10.0**E4 < 1.0E-0); + + Scale : constant Integer := E5; + + pragma Assert (Num'Small * 10.0**Scale >= 1.0 + and then Num'Small * 10.0**Scale < 10.0); + + Exact : constant Boolean := + Float'Floor (Num'Small) = Float'Ceiling (Num'Small) + or Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small) + or Num'Small >= 10.0**Max_Digits; + -- True iff a numerator and denominator can be calculated such that + -- their ratio exactly represents the small of Num + + -- Local Subprograms + + procedure Put + (To : out String; + Last : out Natural; + Item : Num; + Fore : Field; + Aft : Field; + Exp : Field); + -- Actual output function, used internally by all other Put routines + --------- -- Get -- --------- *************** package body Ada.Text_IO.Fixed_IO is *** 101,108 **** Aft : in Field := Default_Aft; Exp : in Field := Default_Exp) is begin ! Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); end Put; procedure Put --- 365,375 ---- Aft : in Field := Default_Aft; Exp : in Field := Default_Exp) is + S : String (1 .. Fore + Aft + Exp + Extra_Layout_Space); + Last : Natural; begin ! Put (S, Last, Item, Fore, Aft, Exp); ! Generic_Aux.Put_Item (File, S (1 .. Last)); end Put; procedure Put *************** package body Ada.Text_IO.Fixed_IO is *** 111,118 **** Aft : in Field := Default_Aft; Exp : in Field := Default_Exp) is begin ! Aux.Put (Current_Out, Long_Long_Float (Item), Fore, Aft, Exp); end Put; procedure Put --- 378,388 ---- Aft : in Field := Default_Aft; Exp : in Field := Default_Exp) is + S : String (1 .. Fore + Aft + Exp + Extra_Layout_Space); + Last : Natural; begin ! Put (S, Last, Item, Fore, Aft, Exp); ! Generic_Aux.Put_Item (Text_IO.Current_Out, S (1 .. Last)); end Put; procedure Put *************** package body Ada.Text_IO.Fixed_IO is *** 121,128 **** Aft : in Field := Default_Aft; Exp : in Field := Default_Exp) is begin ! Aux.Puts (To, Long_Long_Float (Item), Aft, Exp); end Put; end Ada.Text_IO.Fixed_IO; --- 391,662 ---- Aft : in Field := Default_Aft; Exp : in Field := Default_Exp) is + Fore : constant Integer := To'Length + - 1 -- Decimal point + - Field'Max (1, Aft) -- Decimal part + - Boolean'Pos (Exp /= 0) -- Exponent indicator + - Exp; -- Exponent + Last : Natural; + begin ! if Fore not in Field'Range then ! raise Layout_Error; ! end if; ! ! Put (To, Last, Item, Fore, Aft, Exp); ! ! if Last /= To'Last then ! raise Layout_Error; ! end if; ! end Put; ! ! procedure Put ! (To : out String; ! Last : out Natural; ! Item : Num; ! Fore : Field; ! Aft : Field; ! Exp : Field) ! is ! subtype Digit is Int64 range 0 .. 9; ! X : constant Int64 := Int64'Integer_Value (Item); ! A : constant Field := Field'Max (Aft, 1); ! Neg : constant Boolean := (Item < 0.0); ! Pos : Integer; -- Next digit X has value X * 10.0**Pos; ! ! Y, Z : Int64; ! E : constant Integer := Boolean'Pos (not Exact) ! * (Max_Digits - 1 + Scale); ! D : constant Integer := Boolean'Pos (Exact) ! * Integer'Min (A, Max_Digits - (Num'Fore - 1)) ! + Boolean'Pos (not Exact) ! * (Scale - 1); ! ! ! procedure Put_Character (C : Character); ! pragma Inline (Put_Character); ! -- Add C to the output string To, updating Last ! ! procedure Put_Digit (X : Digit); ! -- Add digit X to the output string (going from left to right), ! -- updating Last and Pos, and inserting the sign, leading zeroes ! -- or a decimal point when necessary. After outputting the first ! -- digit, Pos must not be changed outside Put_Digit anymore ! ! procedure Put_Int64 (X : Int64; Scale : Integer); ! -- Output the decimal number X * 10**Scale ! ! procedure Put_Scaled ! (X, Y, Z : Int64; ! A : Field; ! E : Integer); ! -- Output the decimal number (X * Y / Z) * 10**E, producing A digits ! -- after the decimal point and rounding the final digit. The value ! -- X * Y / Z is computed with full precision, but must be in the ! -- range of Int64. ! ! ------------------- ! -- Put_Character -- ! ------------------- ! ! procedure Put_Character (C : Character) is ! begin ! Last := Last + 1; ! To (Last) := C; ! end Put_Character; ! ! --------------- ! -- Put_Digit -- ! --------------- ! ! procedure Put_Digit (X : Digit) is ! Digs : constant array (Digit) of Character := "0123456789"; ! begin ! if Last = 0 then ! if X /= 0 or Pos <= 0 then ! -- Before outputting first digit, include leading space, ! -- posible minus sign and, if the first digit is fractional, ! -- decimal seperator and leading zeros. ! ! -- The Fore part has Pos + 1 + Boolean'Pos (Neg) characters, ! -- if Pos >= 0 and otherwise has a single zero digit plus minus ! -- sign if negative. Add leading space if necessary. ! ! for J in Integer'Max (0, Pos) + 2 + Boolean'Pos (Neg) .. Fore ! loop ! Put_Character (' '); ! end loop; ! ! -- Output minus sign, if number is negative ! ! if Neg then ! Put_Character ('-'); ! end if; ! ! -- If starting with fractional digit, output leading zeros ! ! if Pos < 0 then ! Put_Character ('0'); ! Put_Character ('.'); ! ! for J in Pos .. -2 loop ! Put_Character ('0'); ! end loop; ! end if; ! ! Put_Character (Digs (X)); ! end if; ! ! else ! -- This is not the first digit to be output, so the only ! -- special handling is that for the decimal point ! ! if Pos = -1 then ! Put_Character ('.'); ! end if; ! ! Put_Character (Digs (X)); ! end if; ! ! Pos := Pos - 1; ! end Put_Digit; ! ! --------------- ! -- Put_Int64 -- ! --------------- ! ! procedure Put_Int64 (X : Int64; Scale : Integer) is ! begin ! if X = 0 then ! return; ! end if; ! ! Pos := Scale; ! ! if X not in -9 .. 9 then ! Put_Int64 (X / 10, Scale + 1); ! end if; ! ! Put_Digit (abs (X rem 10)); ! end Put_Int64; ! ! ---------------- ! -- Put_Scaled -- ! ---------------- ! ! procedure Put_Scaled ! (X, Y, Z : Int64; ! A : Field; ! E : Integer) ! is ! N : constant Natural := (A + Max_Digits - 1) / Max_Digits + 1; ! pragma Debug (Put_Line ("N =" & N'Img)); ! Q : array (1 .. N) of Int64 := (others => 0); ! ! XX : Int64 := X; ! YY : Int64 := Y; ! AA : Field := A; ! ! begin ! for J in Q'Range loop ! exit when XX = 0; ! ! Scaled_Divide (XX, YY, Z, Q (J), XX, Round => AA = 0); ! ! -- As the last block of digits is rounded, a carry may have to ! -- be propagated to the more significant digits. Since the last ! -- block may have less than Max_Digits, the test for this block ! -- is specialized. ! ! -- The absolute value of the left-most digit block may equal ! -- 10*Max_Digits, as no carry can be propagated from there. ! -- The final output routines need to be prepared to handle ! -- this specific case. ! ! if (Q (J) = YY or -Q (J) = YY) and then J > Q'First then ! if Q (J) < 0 then ! Q (J - 1) := Q (J - 1) + 1; ! else ! Q (J - 1) := Q (J - 1) - 1; ! end if; ! ! Q (J) := 0; ! ! Propagate_Carry : ! for J in reverse Q'First + 1 .. Q'Last loop ! if Q (J) >= 10**Max_Digits then ! Q (J - 1) := Q (J - 1) + 1; ! Q (J) := Q (J) - 10**Max_Digits; ! ! elsif Q (J) <= -10**Max_Digits then ! Q (J - 1) := Q (J - 1) - 1; ! Q (J) := Q (J) + 10**Max_Digits; ! end if; ! end loop Propagate_Carry; ! end if; ! ! YY := -10**Integer'Min (Max_Digits, AA); ! AA := AA - Integer'Min (Max_Digits, AA); ! end loop; ! ! for J in Q'First .. Q'Last - 1 loop ! Put_Int64 (Q (J), E - (J - Q'First) * Max_Digits); ! end loop; ! ! Put_Int64 (Q (Q'Last), E - A); ! end Put_Scaled; ! ! -- Start of processing for Put ! ! begin ! Last := To'First - 1; ! ! if Exp /= 0 then ! ! -- With the Exp format, it is not known how many output digits to ! -- generate, as leading zeros must be ignored. Computing too many ! -- digits and then truncating the output will not give the closest ! -- output, it is necessary to round at the correct digit. ! ! -- The general approach is as follows: as long as no digits have ! -- been generated, compute the Aft next digits (without rounding). ! -- Once a non-zero digit is generated, determine the exact number ! -- of digits remaining and compute them with rounding. ! -- Since a large number of iterations might be necessary in case ! -- of Aft = 1, the following optimization would be desirable. ! -- Count the number Z of leading zero bits in the integer ! -- representation of X, and start with producing ! -- Aft + Z * 1000 / 3322 digits in the first scaled division. ! ! -- However, the floating-point routines are still used now ??? ! ! System.Img_Real.Set_Image_Real (Long_Long_Float (Item), To, Last, ! Fore, Aft, Exp); ! return; ! end if; ! ! if Exact then ! Y := Int64'Min (Int64 (-Num'Small), -1) * 10**Integer'Max (0, D); ! Z := Int64'Min (Int64 (-1.0 / Num'Small), -1) ! * 10**Integer'Max (0, -D); ! else ! Y := Int64 (-Num'Small * 10.0**E); ! Z := -10**Max_Digits; ! end if; ! ! Put_Scaled (X, Y, Z, A - D, -D); ! ! -- If only zero digits encountered, unit digit has not been output yet ! ! if Last < To'First then ! Pos := 0; ! end if; ! ! -- Always output digits up to the first one after the decimal point ! ! while Pos >= -A loop ! Put_Digit (0); ! end loop; end Put; end Ada.Text_IO.Fixed_IO; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-tifiio.ads gcc-3.4.0/gcc/ada/a-tifiio.ads *** gcc-3.3.3/gcc/ada/a-tifiio.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tifiio.ads 2003-04-24 17:53:55.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-tiflau.adb gcc-3.4.0/gcc/ada/a-tiflau.adb *** gcc-3.3.3/gcc/ada/a-tiflau.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tiflau.adb 2003-10-21 13:41:54.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-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.Text_IO.Float_Aux is *** 83,89 **** exception when Constraint_Error => - Last := Pos - 1; raise Data_Error; end Gets; --- 82,87 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-tiflau.ads gcc-3.4.0/gcc/ada/a-tiflau.ads *** gcc-3.3.3/gcc/ada/a-tiflau.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tiflau.ads 2003-04-24 17:53:55.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-tiflio.adb gcc-3.4.0/gcc/ada/a-tiflio.adb *** gcc-3.3.3/gcc/ada/a-tiflio.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tiflio.adb 2003-10-21 13:41:54.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- 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.Text_IO.Float_IO is *** 52,57 **** --- 51,65 ---- begin Aux.Get (File, Long_Long_Float (Item), Width); + -- In the case where the type is unconstrained (e.g. Standard'Float), + -- the above conversion may result in an infinite value, which is + -- normally fine for a conversion, but in this case, we want to treat + -- that as a data error. + + if not Item'Valid then + raise Data_Error; + end if; + exception when Constraint_Error => raise Data_Error; end Get; *************** package body Ada.Text_IO.Float_IO is *** 65,70 **** --- 73,87 ---- begin Aux.Get (Current_In, Long_Long_Float (Item), Width); + -- In the case where the type is unconstrained (e.g. Standard'Float), + -- the above conversion may result in an infinite value, which is + -- normally fine for a conversion, but in this case, we want to treat + -- that as a data error. + + if not Item'Valid then + raise Data_Error; + end if; + exception when Constraint_Error => raise Data_Error; end Get; *************** package body Ada.Text_IO.Float_IO is *** 79,84 **** --- 96,110 ---- begin Aux.Gets (From, Long_Long_Float (Item), Last); + -- In the case where the type is unconstrained (e.g. Standard'Float), + -- the above conversion may result in an infinite value, which is + -- normally fine for a conversion, but in this case, we want to treat + -- that as a data error. + + if not Item'Valid then + raise Data_Error; + end if; + exception when Constraint_Error => raise Data_Error; end Get; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-tiflio.ads gcc-3.4.0/gcc/ada/a-tiflio.ads *** gcc-3.3.3/gcc/ada/a-tiflio.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tiflio.ads 2003-04-24 17:53:55.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-tigeau.adb gcc-3.4.0/gcc/ada/a-tigeau.adb *** gcc-3.3.3/gcc/ada/a-tigeau.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tigeau.adb 2003-10-21 13:41:54.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-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.Text_IO.Generic_Aux is *** 433,444 **** begin File.Col := File.Col + 1; ! if Ptr = Buf'Last then ! raise Data_Error; ! else Ptr := Ptr + 1; - Buf (Ptr) := Character'Val (ch); end if; end Store_Char; ----------------- --- 432,442 ---- begin File.Col := File.Col + 1; ! if Ptr < Buf'Last then Ptr := Ptr + 1; end if; + + Buf (Ptr) := Character'Val (ch); end Store_Char; ----------------- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-tigeau.ads gcc-3.4.0/gcc/ada/a-tigeau.ads *** gcc-3.3.3/gcc/ada/a-tigeau.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tigeau.ads 2003-10-21 13:41:54.000000000 +0000 *************** *** 1,4 **** ! ----------------------------------------------------------------------------- -- -- -- GNAT RUNTIME COMPONENTS -- -- -- --- 1,4 ---- ! ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- *************** *** 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- -- *************** private package Ada.Text_IO.Generic_Aux *** 169,175 **** Ptr : in out Integer); -- Store a single character in buffer, checking for overflow and -- adjusting the column number in the file to reflect the fact ! -- that a character has been acquired from the input stream. procedure String_Skip (Str : String; Ptr : out Integer); -- Used in the Get from string procedures to skip leading blanks in the --- 168,179 ---- Ptr : in out Integer); -- Store a single character in buffer, checking for overflow and -- adjusting the column number in the file to reflect the fact ! -- that a character has been acquired from the input stream. If ! -- the character will not fit in the buffer it is stored in the ! -- last character position of the buffer and Ptr is unchanged. ! -- No exception is raised in this case, it is the caller's job ! -- to raise Data_Error if the buffer fills up, so typically the ! -- caller will make the buffer one character longer than needed. procedure String_Skip (Str : String; Ptr : out Integer); -- Used in the Get from string procedures to skip leading blanks in the diff -Nrc3pad gcc-3.3.3/gcc/ada/a-tiinau.adb gcc-3.4.0/gcc/ada/a-tiinau.adb *** gcc-3.3.3/gcc/ada/a-tiinau.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tiinau.adb 2003-12-11 16:21:39.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-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.Text_IO.Integer_Aux is *** 125,131 **** exception when Constraint_Error => - Last := Pos - 1; raise Data_Error; end Gets_Int; --- 124,129 ---- *************** package body Ada.Text_IO.Integer_Aux is *** 147,153 **** exception when Constraint_Error => - Last := Pos - 1; raise Data_Error; end Gets_LLI; --- 145,150 ---- *************** package body Ada.Text_IO.Integer_Aux is *** 170,175 **** --- 167,175 ---- Load_Digits (File, Buf, Ptr, Loaded); if Loaded then + + -- Deal with based literal (note : is ok replacement for #) + Load (File, Buf, Ptr, '#', ':', Loaded); if Loaded then *************** package body Ada.Text_IO.Integer_Aux is *** 178,183 **** --- 178,185 ---- Load (File, Buf, Ptr, Buf (Hash_Loc)); end if; + -- Deal with exponent + Load (File, Buf, Ptr, 'E', 'e', Loaded); if Loaded then diff -Nrc3pad gcc-3.3.3/gcc/ada/a-tiinau.ads gcc-3.4.0/gcc/ada/a-tiinau.ads *** gcc-3.3.3/gcc/ada/a-tiinau.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tiinau.ads 2003-04-24 17:53:55.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-tiinio.adb gcc-3.4.0/gcc/ada/a-tiinio.adb *** gcc-3.3.3/gcc/ada/a-tiinio.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tiinio.adb 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992-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/a-tiinio.ads gcc-3.4.0/gcc/ada/a-tiinio.ads *** gcc-3.3.3/gcc/ada/a-tiinio.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tiinio.ads 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-timoau.adb gcc-3.4.0/gcc/ada/a-timoau.adb *** gcc-3.3.3/gcc/ada/a-timoau.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-timoau.adb 2003-10-21 13:41:54.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-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.Text_IO.Modular_Aux is *** 127,133 **** exception when Constraint_Error => - Last := Pos - 1; raise Data_Error; end Gets_LLU; --- 126,131 ---- *************** package body Ada.Text_IO.Modular_Aux is *** 149,155 **** exception when Constraint_Error => - Last := Pos - 1; raise Data_Error; end Gets_Uns; --- 147,152 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-timoau.ads gcc-3.4.0/gcc/ada/a-timoau.ads *** gcc-3.3.3/gcc/ada/a-timoau.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-timoau.ads 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-timoio.adb gcc-3.4.0/gcc/ada/a-timoio.adb *** gcc-3.3.3/gcc/ada/a-timoio.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-timoio.adb 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992,1993,1994,1995,1996 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/a-timoio.ads gcc-3.4.0/gcc/ada/a-timoio.ads *** gcc-3.3.3/gcc/ada/a-timoio.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-timoio.ads 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1993-2000 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/a-tiocst.adb gcc-3.4.0/gcc/ada/a-tiocst.adb *** gcc-3.3.3/gcc/ada/a-tiocst.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tiocst.adb 2003-10-21 13:41:54.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-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.Text_IO.C_Streams is *** 62,78 **** procedure Open (File : in out File_Type; ! Mode : in File_Mode; ! C_Stream : in FILEs; ! Form : in String := "") is ! File_Control_Block : Text_AFCB; begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => File_Control_Block, Mode => To_FCB (Mode), ! Name => "", Form => Form, Amethod => 'T', Creat => False, --- 61,81 ---- procedure Open (File : in out File_Type; ! Mode : File_Mode; ! C_Stream : FILEs; ! Form : String := ""; ! Name : String := "") is ! Dummy_File_Control_Block : Text_AFCB; ! pragma Warnings (Off, Dummy_File_Control_Block); ! -- Yes, we know this is never assigned a value, only the tag ! -- is used for dispatching purposes, so that's expected. begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => Dummy_File_Control_Block, Mode => To_FCB (Mode), ! Name => Name, Form => Form, Amethod => 'T', Creat => False, diff -Nrc3pad gcc-3.3.3/gcc/ada/a-tiocst.ads gcc-3.4.0/gcc/ada/a-tiocst.ads *** gcc-3.3.3/gcc/ada/a-tiocst.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-tiocst.ads 2003-10-21 13:41:54.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1992,1993,1994,1995 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-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 Ada.Text_IO.C_Streams is *** 47,55 **** procedure Open (File : in out File_Type; ! Mode : in File_Mode; ! C_Stream : in ICS.FILEs; ! Form : in String := ""); -- Create new file from existing stream end Ada.Text_IO.C_Streams; --- 46,55 ---- procedure Open (File : in out File_Type; ! Mode : File_Mode; ! C_Stream : ICS.FILEs; ! Form : String := ""; ! Name : String := ""); -- Create new file from existing stream end Ada.Text_IO.C_Streams; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-titest.adb gcc-3.4.0/gcc/ada/a-titest.adb *** gcc-3.3.3/gcc/ada/a-titest.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-titest.adb 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992,1993,1994,1995,1996 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/a-titest.ads gcc-3.4.0/gcc/ada/a-titest.ads *** gcc-3.3.3/gcc/ada/a-titest.ads 2002-03-14 10:58:59.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-titest.ads 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/atree.adb gcc-3.4.0/gcc/ada/atree.adb *** gcc-3.3.3/gcc/ada/atree.adb 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/atree.adb 2003-11-21 10:46:37.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-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 Atree is *** 348,353 **** --- 347,381 ---- Table_Increment => Alloc.Orig_Nodes_Increment, Table_Name => "Orig_Nodes"); + ---------------------------------------- + -- Global_Variables for New_Copy_Tree -- + ---------------------------------------- + + -- These global variables are used by New_Copy_Tree. See description + -- of the body of this subprogram for details. Global variables can be + -- safely used by New_Copy_Tree, since there is no case of a recursive + -- call from the processing inside New_Copy_Tree. + + NCT_Hash_Threshhold : constant := 20; + -- If there are more than this number of pairs of entries in the + -- map, then Hash_Tables_Used will be set, and the hash tables will + -- be initialized and used for the searches. + + NCT_Hash_Tables_Used : Boolean := False; + -- Set to True if hash tables are in use + + NCT_Table_Entries : Nat; + -- Count entries in table to see if threshhold is reached + + NCT_Hash_Table_Setup : Boolean := False; + -- Set to True if hash table contains data. We set this True if we + -- setup the hash table with data, and leave it set permanently + -- from then on, this is a signal that second and subsequent users + -- of the hash table must clear the old entries before reuse. + + subtype NCT_Header_Num is Int range 0 .. 511; + -- Defines range of headers in hash tables (512 headers) + ----------------------- -- Local Subprograms -- ----------------------- *************** package body Atree is *** 512,518 **** return NL; end if; - end Copy_List; ------------------- --- 540,545 ---- *************** package body Atree is *** 665,671 **** Delete_Field (Field3 (Node)); Delete_Field (Field4 (Node)); Delete_Field (Field5 (Node)); - end Delete_Tree; ----------- --- 692,697 ---- *************** package body Atree is *** 812,818 **** then Set_Parent (List_Id (Field), New_Node); end if; - end Fix_Parent; ----------------------------------- --- 838,843 ---- *************** package body Atree is *** 839,846 **** --- 864,876 ---- procedure Initialize is Dummy : Node_Id; + pragma Warnings (Off, Dummy); begin + Node_Count := 0; + Atree_Private_Part.Nodes.Init; + Orig_Nodes.Init; + -- Allocate Empty node Dummy := New_Node (N_Empty, No_Location); *************** package body Atree is *** 852,857 **** --- 882,892 ---- Dummy := New_Node (N_Error, No_Location); Set_Name1 (Error, Error_Name); Set_Error_Posted (Error, True); + + -- Set global variables for New_Copy_Tree: + NCT_Hash_Tables_Used := False; + NCT_Table_Entries := 0; + NCT_Hash_Table_Setup := False; end Initialize; -------------------------- *************** package body Atree is *** 958,986 **** -- (because setting up a hash table for only a few entries takes -- more time than it saves. - -- Global variables are safe for this purpose, since there is no case - -- of a recursive call from the processing inside New_Copy_Tree. - - NCT_Hash_Threshhold : constant := 20; - -- If there are more than this number of pairs of entries in the - -- map, then Hash_Tables_Used will be set, and the hash tables will - -- be initialized and used for the searches. - - NCT_Hash_Tables_Used : Boolean := False; - -- Set to True if hash tables are in use - - NCT_Table_Entries : Nat; - -- Count entries in table to see if threshhold is reached - - NCT_Hash_Table_Setup : Boolean := False; - -- Set to True if hash table contains data. We set this True if we - -- setup the hash table with data, and leave it set permanently - -- from then on, this is a signal that second and subsequent users - -- of the hash table must clear the old entries before reuse. - - subtype NCT_Header_Num is Int range 0 .. 511; - -- Defines range of headers in hash tables (512 headers) - function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num; -- Hash function used for hash operations --- 993,998 ---- *************** package body Atree is *** 1384,1390 **** else E := First_Elmt (Actual_Map); while Present (E) loop ! if Old_Node = Associated_Node_For_Itype (Node (E)) then Set_Associated_Node_For_Itype (Node (Next_Elmt (E)), New_Node); end if; --- 1396,1405 ---- else E := First_Elmt (Actual_Map); while Present (E) loop ! if Is_Itype (Node (E)) ! and then ! Old_Node = Associated_Node_For_Itype (Node (E)) ! then Set_Associated_Node_For_Itype (Node (Next_Elmt (E)), New_Node); end if; *************** package body Atree is *** 1591,1597 **** Set_Associated_Node_For_Itype (Ent, New_Itype); end if; ! -- Csae of hash tables not used else E := First_Elmt (Actual_Map); --- 1606,1612 ---- Set_Associated_Node_For_Itype (Ent, New_Itype); end if; ! -- Case of hash tables not used else E := First_Elmt (Actual_Map); *************** package body Atree is *** 1601,1607 **** (New_Itype, Node (Next_Elmt (E))); end if; ! if Old_Itype = Associated_Node_For_Itype (Node (E)) then Set_Associated_Node_For_Itype (Node (Next_Elmt (E)), New_Itype); end if; --- 1616,1625 ---- (New_Itype, Node (Next_Elmt (E))); end if; ! if Is_Type (Node (E)) ! and then ! Old_Itype = Associated_Node_For_Itype (Node (E)) ! then Set_Associated_Node_For_Itype (Node (Next_Elmt (E)), New_Itype); end if; *************** package body Atree is *** 1814,1822 **** --- 1832,1846 ---- New_Sloc : Source_Ptr) return Entity_Id is + Ent : Entity_Id; + procedure New_Entity_Debugging_Output; -- Debugging routine for debug flag N + --------------------------------- + -- New_Entity_Debugging_Output -- + --------------------------------- + procedure New_Entity_Debugging_Output is begin if Debug_Flag_N then *************** package body Atree is *** 1838,1844 **** pragma Assert (New_Node_Kind in N_Entity); Nodes.Increment_Last; ! Current_Error_Node := Nodes.Last; Nodes.Table (Nodes.Last) := Default_Node; Nodes.Table (Nodes.Last).Nkind := New_Node_Kind; Nodes.Table (Nodes.Last).Sloc := New_Sloc; --- 1862,1877 ---- pragma Assert (New_Node_Kind in N_Entity); Nodes.Increment_Last; ! Ent := Nodes.Last; ! ! -- If this is a node with a real location and we are generating ! -- source nodes, then reset Current_Error_Node. This is useful ! -- if we bomb during parsing to get a error location for the bomb. ! ! if Default_Node.Comes_From_Source and then New_Sloc > No_Location then ! Current_Error_Node := Ent; ! end if; ! Nodes.Table (Nodes.Last) := Default_Node; Nodes.Table (Nodes.Last).Nkind := New_Node_Kind; Nodes.Table (Nodes.Last).Sloc := New_Sloc; *************** package body Atree is *** 1859,1865 **** Orig_Nodes.Set_Last (Nodes.Last); Allocate_List_Tables (Nodes.Last); Node_Count := Node_Count + 1; ! return Current_Error_Node; end New_Entity; -------------- --- 1892,1898 ---- Orig_Nodes.Set_Last (Nodes.Last); Allocate_List_Tables (Nodes.Last); Node_Count := Node_Count + 1; ! return Ent; end New_Entity; -------------- *************** package body Atree is *** 1871,1879 **** --- 1904,1918 ---- New_Sloc : Source_Ptr) return Node_Id is + Nod : Node_Id; + procedure New_Node_Debugging_Output; -- Debugging routine for debug flag N + -------------------------- + -- New_Debugging_Output -- + -------------------------- + procedure New_Node_Debugging_Output is begin if Debug_Flag_N then *************** package body Atree is *** 1898,1910 **** Nodes.Table (Nodes.Last).Nkind := New_Node_Kind; Nodes.Table (Nodes.Last).Sloc := New_Sloc; pragma Debug (New_Node_Debugging_Output); ! Current_Error_Node := Nodes.Last; ! Node_Count := Node_Count + 1; Orig_Nodes.Increment_Last; Allocate_List_Tables (Nodes.Last); Orig_Nodes.Table (Nodes.Last) := Nodes.Last; ! return Nodes.Last; end New_Node; ----------- --- 1937,1957 ---- Nodes.Table (Nodes.Last).Nkind := New_Node_Kind; Nodes.Table (Nodes.Last).Sloc := New_Sloc; pragma Debug (New_Node_Debugging_Output); ! Nod := Nodes.Last; ! ! -- If this is a node with a real location and we are generating ! -- source nodes, then reset Current_Error_Node. This is useful ! -- if we bomb during parsing to get a error location for the bomb. ! ! if Default_Node.Comes_From_Source and then New_Sloc > No_Location then ! Current_Error_Node := Nod; ! end if; + Node_Count := Node_Count + 1; Orig_Nodes.Increment_Last; Allocate_List_Tables (Nodes.Last); Orig_Nodes.Table (Nodes.Last) := Nodes.Last; ! return Nod; end New_Node; ----------- *************** package body Atree is *** 2033,2038 **** --- 2080,2093 ---- -- not get set. Set_Parent (New_Node, Parent (Source)); + + -- If the node being relocated was a rewriting of some original + -- node, then the relocated node has the same original node. + + if Orig_Nodes.Table (Source) /= Source then + Orig_Nodes.Table (New_Node) := Orig_Nodes.Table (Source); + end if; + return New_Node; end Relocate_Node; *************** package body Atree is *** 2078,2084 **** -- Finally delete the source, since it is now copied Delete_Node (New_Node); - end Replace; ------------- --- 2133,2138 ---- *************** package body Atree is *** 2127,2133 **** Sav_Node := Nodes.Last; Nodes.Table (Sav_Node) := Nodes.Table (Old_Node); Nodes.Table (Sav_Node).In_List := False; ! Nodes.Table (Sav_Node).Link := Union_Id (Empty); Orig_Nodes.Increment_Last; Allocate_List_Tables (Nodes.Last); --- 2181,2187 ---- Sav_Node := Nodes.Last; Nodes.Table (Sav_Node) := Nodes.Table (Old_Node); Nodes.Table (Sav_Node).In_List := False; ! Nodes.Table (Sav_Node).Link := Union_Id (Parent (Old_Node)); Orig_Nodes.Increment_Last; Allocate_List_Tables (Nodes.Last); *************** package body Atree is *** 2153,2159 **** Fix_Parent (Field3 (Old_Node), New_Node, Old_Node); Fix_Parent (Field4 (Old_Node), New_Node, Old_Node); Fix_Parent (Field5 (Old_Node), New_Node, Old_Node); - end Rewrite; ------------------ --- 2207,2212 ---- *************** package body Atree is *** 2282,2288 **** -- Traverse descendent that is syntactic subtree node ! if Parent (Node_Id (Fld)) = Node then return Traverse_Func (Node_Id (Fld)); -- Node that is not a syntactic subtree --- 2335,2343 ---- -- Traverse descendent that is syntactic subtree node ! if Parent (Node_Id (Fld)) = Node ! or else Original_Node (Parent (Node_Id (Fld))) = Node ! then return Traverse_Func (Node_Id (Fld)); -- Node that is not a syntactic subtree *************** package body Atree is *** 2297,2304 **** -- Traverse descendent that is a syntactic subtree list ! if Parent (List_Id (Fld)) = Node then ! declare Elmt : Node_Id := First (List_Id (Fld)); begin --- 2352,2360 ---- -- Traverse descendent that is a syntactic subtree list ! if Parent (List_Id (Fld)) = Node ! or else Original_Node (Parent (List_Id (Fld))) = Node ! then declare Elmt : Node_Id := First (List_Id (Fld)); begin *************** package body Atree is *** 2375,2381 **** end if; end; end case; - end Traverse_Func; ------------------- --- 2431,2436 ---- *************** package body Atree is *** 2385,2390 **** --- 2440,2446 ---- procedure Traverse_Proc (Node : Node_Id) is function Traverse is new Traverse_Func (Process); Discard : Traverse_Result; + pragma Warnings (Off, Discard); begin Discard := Traverse (Node); diff -Nrc3pad gcc-3.3.3/gcc/ada/atree.ads gcc-3.4.0/gcc/ada/atree.ads *** gcc-3.3.3/gcc/ada/atree.ads 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/atree.ads 2003-10-21 13:41:58.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- -- *************** package Atree is *** 149,155 **** -- package in Atree allows for direct untyped accesses in such cases. -- Flag4 Fifteen Boolean flags (use depends on Nkind and ! -- Flag5 Ekind, as described for Fieldn). Again the access -- Flag6 is usually via subprograms in Sinfo and Einfo which -- Flag7 provide high-level synonyms for these flags, and -- Flag8 contain debugging code that checks that the values --- 148,154 ---- -- package in Atree allows for direct untyped accesses in such cases. -- Flag4 Fifteen Boolean flags (use depends on Nkind and ! -- Flag5 Ekind, as described for FieldN). Again the access -- Flag6 is usually via subprograms in Sinfo and Einfo which -- Flag7 provide high-level synonyms for these flags, and -- Flag8 contain debugging code that checks that the values *************** package Atree is *** 243,251 **** -- avoid posting related cascaded error messages, and to propagate -- the error node if necessary. ! ----------------------- -- Current_Error_Node -- ! ----------------------- -- The current error node is a global location indicating the current -- node that is being processed for the purposes of placing a compiler --- 242,250 ---- -- avoid posting related cascaded error messages, and to propagate -- the error node if necessary. ! ------------------------ -- Current_Error_Node -- ! ------------------------ -- The current error node is a global location indicating the current -- node that is being processed for the purposes of placing a compiler *************** package Atree is *** 253,259 **** -- just a reasonably accurate best guess. It is used to output the -- source location in the abort message by Comperr, and also to -- implement the d3 debugging flag. This is also used by Rtsfind ! -- to generate error messages for No_Run_Time mode. Current_Error_Node : Node_Id; -- Node to place error messages --- 252,266 ---- -- just a reasonably accurate best guess. It is used to output the -- source location in the abort message by Comperr, and also to -- implement the d3 debugging flag. This is also used by Rtsfind ! -- to generate error messages for high integrity mode. ! ! -- There are two ways this gets set. During parsing, when new source ! -- nodes are being constructed by calls to New_Node and New_Entity, ! -- either one of these calls sets Current_Error_Node to the newly ! -- created node. During semantic analysis, this mechanism is not ! -- used, and instead Current_Error_Node is set by the subprograms in ! -- Debug_A that mark the start and end of analysis/expansion of a ! -- node in the tree. Current_Error_Node : Node_Id; -- Node to place error messages *************** package Atree is *** 286,292 **** -- A subpackage Atree.Unchecked_Access provides routines for reading and -- writing the fields defined above (Field1-17, Node1-17, Flag1-88 etc). ! -- These unchecked access routines can be used for untyped traversals. In -- In addition they are used in the implementations of the Sinfo and -- Einfo packages. These packages both provide logical synonyms for -- the generic fields, together with an appropriate set of access routines. --- 293,299 ---- -- A subpackage Atree.Unchecked_Access provides routines for reading and -- writing the fields defined above (Field1-17, Node1-17, Flag1-88 etc). ! -- These unchecked access routines can be used for untyped traversals. -- In addition they are used in the implementations of the Sinfo and -- Einfo packages. These packages both provide logical synonyms for -- the generic fields, together with an appropriate set of access routines. *************** package Atree is *** 330,342 **** -- Allocates a completely new node with the given node type and source -- location values. All other fields are set to their standard defaults: -- ! -- Empty for all Fieldn fields ! -- False for all Flagn fields -- -- The usual approach is to build a new node using this function and -- then, using the value returned, use the Set_xxx functions to set -- fields of the node as required. New_Node can only be used for -- non-entity nodes, i.e. it never generates an extended node. function New_Entity (New_Node_Kind : Node_Kind; --- 337,353 ---- -- Allocates a completely new node with the given node type and source -- location values. All other fields are set to their standard defaults: -- ! -- Empty for all FieldN fields ! -- False for all FlagN fields -- -- The usual approach is to build a new node using this function and -- then, using the value returned, use the Set_xxx functions to set -- fields of the node as required. New_Node can only be used for -- non-entity nodes, i.e. it never generates an extended node. + -- + -- If we are currently parsing, as indicated by a previous call to + -- Set_Comes_From_Source_Default (True), then this call also resets + -- the value of Current_Error_Node. function New_Entity (New_Node_Kind : Node_Kind; *************** package Atree is *** 348,354 **** procedure Set_Comes_From_Source_Default (Default : Boolean); -- Sets value of Comes_From_Source flag to be used in all subsequent -- New_Node and New_Entity calls until another call to this procedure ! -- changes the default. function Get_Comes_From_Source_Default return Boolean; pragma Inline (Get_Comes_From_Source_Default); --- 359,367 ---- procedure Set_Comes_From_Source_Default (Default : Boolean); -- Sets value of Comes_From_Source flag to be used in all subsequent -- New_Node and New_Entity calls until another call to this procedure ! -- changes the default. This value is set True during parsing and ! -- False during semantic analysis. This is also used to determine ! -- if New_Node and New_Entity should set Current_Error_Node. function Get_Comes_From_Source_Default return Boolean; pragma Inline (Get_Comes_From_Source_Default); diff -Nrc3pad gcc-3.3.3/gcc/ada/atree.h gcc-3.4.0/gcc/ada/atree.h *** gcc-3.3.3/gcc/ada/atree.h 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/atree.h 2003-10-24 13:02:42.000000000 +0000 *************** *** 6,13 **** * * * C Header File * * * ! * * ! * 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 ---- * * * C Header File * * * ! * 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- * *************** struct Extended *** 236,242 **** Int field8; Int field9; Int field10; ! union { Int field11; struct Flag_Word3 fw3; --- 235,241 ---- Int field8; Int field9; Int field10; ! union { Int field11; struct Flag_Word3 fw3; *************** extern struct Node *Nodes_Ptr; *** 275,281 **** #define Parent atree__parent ! extern Node_Id Parent PARAMS((Node_Id)); /* Overloaded Functions: --- 274,280 ---- #define Parent atree__parent ! extern Node_Id Parent (Node_Id); /* Overloaded Functions: *************** typedef Int Tree_Id; *** 288,311 **** /* These two functions can only be used for Node_Id and List_Id values and they work in the C version because Empty = No_List = 0. */ ! static Boolean No PARAMS ((Tree_Id)); ! static Boolean Present PARAMS ((Tree_Id)); INLINE Boolean ! No (N) ! Tree_Id N; { return N == Empty; } INLINE Boolean ! Present (N) ! Tree_Id N; { return N != Empty; } ! extern Node_Id Parent PARAMS((Tree_Id)); #define Current_Error_Node atree__current_error_node extern Node_Id Current_Error_Node; --- 287,308 ---- /* These two functions can only be used for Node_Id and List_Id values and they work in the C version because Empty = No_List = 0. */ ! static Boolean No (Tree_Id); ! static Boolean Present (Tree_Id); INLINE Boolean ! No (Tree_Id N) { return N == Empty; } INLINE Boolean ! Present (Tree_Id N) { return N != Empty; } ! extern Node_Id Parent (Tree_Id); #define Current_Error_Node atree__current_error_node extern Node_Id Current_Error_Node; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-unccon.ads gcc-3.4.0/gcc/ada/a-unccon.ads *** gcc-3.3.3/gcc/ada/a-unccon.ads 2002-03-14 10:58:59.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-unccon.ads 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-uncdea.ads gcc-3.4.0/gcc/ada/a-uncdea.ads *** gcc-3.3.3/gcc/ada/a-uncdea.ads 2002-03-14 10:58:59.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-uncdea.ads 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/aux-io.c gcc-3.4.0/gcc/ada/aux-io.c *** gcc-3.3.3/gcc/ada/aux-io.c 2002-10-23 08:04:17.000000000 +0000 --- gcc-3.4.0/gcc/ada/aux-io.c 2003-11-04 12:51:45.000000000 +0000 *************** *** 6,13 **** * * * C Implementation File * * * ! * * ! * 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 ---- * * * C Implementation File * * * ! * 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- * *************** *** 44,72 **** /* Function wrappers are needed to access the values from Ada which are defined as C macros. */ ! FILE *c_stdin PARAMS ((void)); ! FILE *c_stdout PARAMS ((void)); ! FILE *c_stderr PARAMS ((void)); ! int seek_set_function PARAMS ((void)); ! int seek_end_function PARAMS ((void)); ! void *null_function PARAMS ((void)); ! int c_fileno PARAMS ((FILE *)); FILE * ! c_stdin () ! { ! return stdin; } FILE * ! c_stdout () ! { return stdout; } FILE * ! c_stderr () ! { return stderr; } --- 43,71 ---- /* Function wrappers are needed to access the values from Ada which are defined as C macros. */ ! FILE *c_stdin (void); ! FILE *c_stdout (void); ! FILE *c_stderr (void); ! int seek_set_function (void); ! int seek_end_function (void); ! void *null_function (void); ! int c_fileno (FILE *); FILE * ! c_stdin (void) ! { ! return stdin; } FILE * ! c_stdout (void) ! { return stdout; } FILE * ! c_stderr (void) ! { return stderr; } *************** c_stderr () *** 76,101 **** #define SEEK_END 2 /* Set file pointer to the size of the file plus offset */ #endif ! int ! seek_set_function () ! { ! return SEEK_SET; } ! int ! seek_end_function () ! { ! return SEEK_END; } ! void *null_function () ! { ! return NULL; } ! int ! c_fileno (s) ! FILE *s; ! { ! return fileno (s); } --- 75,99 ---- #define SEEK_END 2 /* Set file pointer to the size of the file plus offset */ #endif ! int ! seek_set_function (void) ! { ! return SEEK_SET; } ! int ! seek_end_function (void) ! { ! return SEEK_END; } ! void *null_function (void) ! { ! return NULL; } ! int ! c_fileno (FILE *s) ! { ! return fileno (s); } diff -Nrc3pad gcc-3.3.3/gcc/ada/a-witeio.adb gcc-3.4.0/gcc/ada/a-witeio.adb *** gcc-3.3.3/gcc/ada/a-witeio.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-witeio.adb 2003-12-15 11:51:00.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-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- -- *************** with Ada.Streams; use Ada.Strea *** 37,42 **** --- 36,42 ---- with Interfaces.C_Streams; use Interfaces.C_Streams; with System; + with System.CRTL; with System.File_IO; with System.WCh_Cnv; use System.WCh_Cnv; with System.WCh_Con; use System.WCh_Con; *************** package body Ada.Wide_Text_IO is *** 56,61 **** --- 56,63 ---- function To_TIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode); use type FCB.File_Mode; + use type System.CRTL.size_t; + WC_Encoding : Character; pragma Import (C, WC_Encoding, "__gl_wc_encoding"); *************** package body Ada.Wide_Text_IO is *** 87,93 **** (Control_Block : Wide_Text_AFCB) return FCB.AFCB_Ptr is ! pragma Warnings (Off, Control_Block); begin return new Wide_Text_AFCB; --- 89,95 ---- (Control_Block : Wide_Text_AFCB) return FCB.AFCB_Ptr is ! pragma Unreferenced (Control_Block); begin return new Wide_Text_AFCB; *************** package body Ada.Wide_Text_IO is *** 167,177 **** Name : in String := ""; Form : in String := "") is ! File_Control_Block : Wide_Text_AFCB; begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => File_Control_Block, Mode => To_FCB (Mode), Name => Name, Form => Form, --- 169,182 ---- Name : in String := ""; Form : in String := "") is ! Dummy_File_Control_Block : Wide_Text_AFCB; ! pragma Warnings (Off, Dummy_File_Control_Block); ! -- Yes, we know this is never assigned a value, only the tag ! -- is used for dispatching purposes, so that's expected. begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => Dummy_File_Control_Block, Mode => To_FCB (Mode), Name => Name, Form => Form, *************** package body Ada.Wide_Text_IO is *** 1008,1018 **** Name : in String; Form : in String := "") is ! File_Control_Block : Wide_Text_AFCB; begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => File_Control_Block, Mode => To_FCB (Mode), Name => Name, Form => Form, --- 1013,1026 ---- Name : in String; Form : in String := "") is ! Dummy_File_Control_Block : Wide_Text_AFCB; ! pragma Warnings (Off, Dummy_File_Control_Block); ! -- Yes, we know this is never assigned a value, only the tag ! -- is used for dispatching purposes, so that's expected. begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => Dummy_File_Control_Block, Mode => To_FCB (Mode), Name => Name, Form => Form, *************** package body Ada.Wide_Text_IO is *** 1145,1151 **** Item : out Stream_Element_Array; Last : out Stream_Element_Offset) is ! ch : int; begin -- Need to deal with Before_Wide_Character ??? --- 1153,1160 ---- Item : out Stream_Element_Array; Last : out Stream_Element_Offset) is ! Discard_ch : int; ! pragma Unreferenced (Discard_ch); begin -- Need to deal with Before_Wide_Character ??? *************** package body Ada.Wide_Text_IO is *** 1169,1175 **** -- be expected if stream and text input are mixed this way? if File.Before_LM_PM then ! ch := ungetc (PM, File.Stream); File.Before_LM_PM := False; end if; --- 1178,1184 ---- -- be expected if stream and text input are mixed this way? if File.Before_LM_PM then ! Discard_ch := ungetc (PM, File.Stream); File.Before_LM_PM := False; end if; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-witeio.ads gcc-3.4.0/gcc/ada/a-witeio.ads *** gcc-3.3.3/gcc/ada/a-witeio.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-witeio.ads 2003-10-21 13:41:55.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- --- 6,11 ---- *************** package Ada.Wide_Text_IO is *** 141,147 **** -- Buffer control -- -------------------- ! -- Note: The parameter file is in out in the RM, but as pointed out -- in <<95-5166.a Tucker Taft 95-6-23>> this is clearly an oversight. procedure Flush (File : in File_Type); --- 140,146 ---- -- Buffer control -- -------------------- ! -- Note: The paramter file is in out in the RM, but as pointed out -- in <<95-5166.a Tucker Taft 95-6-23>> this is clearly an oversight. procedure Flush (File : in File_Type); diff -Nrc3pad gcc-3.3.3/gcc/ada/a-wtcoau.adb gcc-3.4.0/gcc/ada/a-wtcoau.adb *** gcc-3.3.3/gcc/ada/a-wtcoau.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtcoau.adb 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992,1993,1994,1995,1996 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/a-wtcoau.ads gcc-3.4.0/gcc/ada/a-wtcoau.ads *** gcc-3.3.3/gcc/ada/a-wtcoau.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtcoau.ads 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992,1993,1994,1995,1996 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/a-wtcoio.adb gcc-3.4.0/gcc/ada/a-wtcoio.adb *** gcc-3.3.3/gcc/ada/a-wtcoio.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtcoio.adb 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992,1993,1994,1995,1996 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/a-wtcoio.ads gcc-3.4.0/gcc/ada/a-wtcoio.ads *** gcc-3.3.3/gcc/ada/a-wtcoio.ads 2002-03-14 10:58:59.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtcoio.ads 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-wtcstr.adb gcc-3.4.0/gcc/ada/a-wtcstr.adb *** gcc-3.3.3/gcc/ada/a-wtcstr.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtcstr.adb 2003-10-21 13:41:55.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-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.Wide_Text_IO.C_Streams *** 62,78 **** procedure Open (File : in out File_Type; ! Mode : in File_Mode; ! C_Stream : in FILEs; ! Form : in String := "") is ! File_Control_Block : Wide_Text_AFCB; begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => File_Control_Block, Mode => To_FCB (Mode), ! Name => "", Form => Form, Amethod => 'W', Creat => False, --- 61,81 ---- procedure Open (File : in out File_Type; ! Mode : File_Mode; ! C_Stream : FILEs; ! Form : String := ""; ! Name : String := "") is ! Dummy_File_Control_Block : Wide_Text_AFCB; ! pragma Warnings (Off, Dummy_File_Control_Block); ! -- Yes, we know this is never assigned a value, only the tag ! -- is used for dispatching purposes, so that's expected. begin FIO.Open (File_Ptr => AP (File), ! Dummy_FCB => Dummy_File_Control_Block, Mode => To_FCB (Mode), ! Name => Name, Form => Form, Amethod => 'W', Creat => False, diff -Nrc3pad gcc-3.3.3/gcc/ada/a-wtcstr.ads gcc-3.4.0/gcc/ada/a-wtcstr.ads *** gcc-3.3.3/gcc/ada/a-wtcstr.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtcstr.ads 2003-10-21 13:41:55.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- Copyright (C) 1992,1993,1994,1995,1996 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-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 Ada.Wide_Text_IO.C_Streams is *** 47,55 **** procedure Open (File : in out File_Type; ! Mode : in File_Mode; ! C_Stream : in ICS.FILEs; ! Form : in String := ""); -- Create new file from existing stream end Ada.Wide_Text_IO.C_Streams; --- 46,55 ---- procedure Open (File : in out File_Type; ! Mode : File_Mode; ! C_Stream : ICS.FILEs; ! Form : String := ""; ! Name : String := ""); -- Create new file from existing stream end Ada.Wide_Text_IO.C_Streams; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-wtdeau.adb gcc-3.4.0/gcc/ada/a-wtdeau.adb *** gcc-3.3.3/gcc/ada/a-wtdeau.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtdeau.adb 2003-04-24 17:53:56.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/a-wtdeau.ads gcc-3.4.0/gcc/ada/a-wtdeau.ads *** gcc-3.3.3/gcc/ada/a-wtdeau.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtdeau.ads 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-wtdeio.adb gcc-3.4.0/gcc/ada/a-wtdeio.adb *** gcc-3.3.3/gcc/ada/a-wtdeio.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtdeio.adb 2003-10-21 13:41:55.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.Wide_Text_IO.Decimal_IO *** 139,144 **** --- 138,145 ---- Aft : in Field := Default_Aft; Exp : in Field := Default_Exp) is + pragma Unreferenced (Fore); + -- ??? how come this is unreferenced, sounds wrong ??? begin Put (Current_Output, Item, Aft, Exp); end Put; diff -Nrc3pad gcc-3.3.3/gcc/ada/a-wtdeio.ads gcc-3.4.0/gcc/ada/a-wtdeio.ads *** gcc-3.3.3/gcc/ada/a-wtdeio.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtdeio.ads 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-wtedit.adb gcc-3.4.0/gcc/ada/a-wtedit.adb *** gcc-3.3.3/gcc/ada/a-wtedit.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtedit.adb 2003-10-21 13:41:55.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-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.Wide_Text_IO.Editing is *** 897,905 **** elsif Dollar then if Pic.Radix_Position > Pic.Start_Currency then ! return Wide_String' (1 .. Pic.Radix_Position - 1 => '*') & Radix_Point & ! Wide_String' (Pic.Radix_Position + 1 .. Last => '*'); else return --- 896,904 ---- elsif Dollar then if Pic.Radix_Position > Pic.Start_Currency then ! return Wide_String'(1 .. Pic.Radix_Position - 1 => '*') & Radix_Point & ! Wide_String'(Pic.Radix_Position + 1 .. Last => '*'); else return *************** package body Ada.Wide_Text_IO.Editing is *** 921,927 **** end if; end if; ! return Wide_String' (1 .. Last => '*'); end if; -- This was once a simple return statement, now there are nine --- 920,926 ---- end if; end if; ! return Wide_String'(1 .. Last => '*'); end if; -- This was once a simple return statement, now there are nine *************** package body Ada.Wide_Text_IO.Editing is *** 930,936 **** -- Processing the radix and sign expansion separately -- would require lots of copying--the string and some of its ! -- indices--without really simplifying the logic. The cases are: -- 1) Expand $, replace '.' with Radix_Point -- 2) No currency expansion, replace '.' with Radix_Point --- 929,935 ---- -- Processing the radix and sign expansion separately -- would require lots of copying--the string and some of its ! -- indicies--without really simplifying the logic. The cases are: -- 1) Expand $, replace '.' with Radix_Point -- 2) No currency expansion, replace '.' with Radix_Point diff -Nrc3pad gcc-3.3.3/gcc/ada/a-wtedit.ads gcc-3.4.0/gcc/ada/a-wtedit.ads *** gcc-3.3.3/gcc/ada/a-wtedit.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtedit.ads 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-wtenau.adb gcc-3.4.0/gcc/ada/a-wtenau.adb *** gcc-3.3.3/gcc/ada/a-wtenau.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtenau.adb 2003-10-21 13:41:56.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1992-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- -- --- 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.Wide_Text_IO.Enumeratio *** 136,143 **** null; else ! exit when Is_Letter (Character'Val (ch)) ! and then not Is_Digit (Character'Val (ch)); end if; end loop; end if; --- 135,143 ---- null; else ! exit when not Is_Letter (Character'Val (ch)) ! and then ! not Is_Digit (Character'Val (ch)); end if; end loop; end if; *************** package body Ada.Wide_Text_IO.Enumeratio *** 280,286 **** end if; end if; - Stop := Stop - 1; raise Data_Error; -- Similarly for identifiers, read as far as we can, in particular, --- 280,285 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-wtenau.ads gcc-3.4.0/gcc/ada/a-wtenau.ads *** gcc-3.3.3/gcc/ada/a-wtenau.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtenau.ads 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-wtenio.adb gcc-3.4.0/gcc/ada/a-wtenio.adb *** gcc-3.3.3/gcc/ada/a-wtenio.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtenio.adb 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-wtenio.ads gcc-3.4.0/gcc/ada/a-wtenio.ads *** gcc-3.3.3/gcc/ada/a-wtenio.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtenio.ads 2003-04-24 17:53:56.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-2000 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/a-wtfiio.adb gcc-3.4.0/gcc/ada/a-wtfiio.adb *** gcc-3.3.3/gcc/ada/a-wtfiio.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtfiio.adb 2003-04-24 17:53:57.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-wtfiio.ads gcc-3.4.0/gcc/ada/a-wtfiio.ads *** gcc-3.3.3/gcc/ada/a-wtfiio.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtfiio.ads 2003-04-24 17:53:57.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-wtflau.adb gcc-3.4.0/gcc/ada/a-wtflau.adb *** gcc-3.3.3/gcc/ada/a-wtflau.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtflau.adb 2003-10-21 13:41:56.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-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.Wide_Text_IO.Float_Aux *** 83,89 **** exception when Constraint_Error => - Last := Pos - 1; raise Data_Error; end Gets; --- 82,87 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-wtflau.ads gcc-3.4.0/gcc/ada/a-wtflau.ads *** gcc-3.3.3/gcc/ada/a-wtflau.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtflau.ads 2003-04-24 17:53:57.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-wtflio.adb gcc-3.4.0/gcc/ada/a-wtflio.adb *** gcc-3.3.3/gcc/ada/a-wtflio.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtflio.adb 2003-04-24 17:53:57.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-wtflio.ads gcc-3.4.0/gcc/ada/a-wtflio.ads *** gcc-3.3.3/gcc/ada/a-wtflio.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtflio.ads 2003-04-24 17:53:57.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-wtgeau.adb gcc-3.4.0/gcc/ada/a-wtgeau.adb *** gcc-3.3.3/gcc/ada/a-wtgeau.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtgeau.adb 2003-04-24 17:53:57.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/a-wtgeau.ads gcc-3.4.0/gcc/ada/a-wtgeau.ads *** gcc-3.3.3/gcc/ada/a-wtgeau.ads 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtgeau.ads 2003-04-24 17:53:57.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-wtinau.adb gcc-3.4.0/gcc/ada/a-wtinau.adb *** gcc-3.3.3/gcc/ada/a-wtinau.adb 2002-10-23 07:33:21.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtinau.adb 2003-10-21 13:41:57.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-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.Wide_Text_IO.Integer_Au *** 125,133 **** exception when Constraint_Error => - Last := Pos - 1; raise Data_Error; - end Gets_Int; -------------- --- 124,130 ---- *************** package body Ada.Wide_Text_IO.Integer_Au *** 148,156 **** exception when Constraint_Error => - Last := Pos - 1; raise Data_Error; - end Gets_LLI; ------------------ --- 145,151 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-wtinau.ads gcc-3.4.0/gcc/ada/a-wtinau.ads *** gcc-3.3.3/gcc/ada/a-wtinau.ads 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtinau.ads 2003-04-24 17:53:57.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-wtinio.adb gcc-3.4.0/gcc/ada/a-wtinio.adb *** gcc-3.3.3/gcc/ada/a-wtinio.adb 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtinio.adb 2003-04-24 17:53:57.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-wtinio.ads gcc-3.4.0/gcc/ada/a-wtinio.ads *** gcc-3.3.3/gcc/ada/a-wtinio.ads 2002-03-14 10:59:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtinio.ads 2003-04-24 17:53:57.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-wtmoau.adb gcc-3.4.0/gcc/ada/a-wtmoau.adb *** gcc-3.3.3/gcc/ada/a-wtmoau.adb 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtmoau.adb 2003-10-21 13:41:57.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-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.Wide_Text_IO.Modular_Au *** 127,135 **** exception when Constraint_Error => - Last := Pos - 1; raise Data_Error; - end Gets_LLU; -------------- --- 126,132 ---- *************** package body Ada.Wide_Text_IO.Modular_Au *** 150,158 **** exception when Constraint_Error => - Last := Pos - 1; raise Data_Error; - end Gets_Uns; ------------------ --- 147,153 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/a-wtmoau.ads gcc-3.4.0/gcc/ada/a-wtmoau.ads *** gcc-3.3.3/gcc/ada/a-wtmoau.ads 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtmoau.ads 2003-04-24 17:53:57.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-wtmoio.adb gcc-3.4.0/gcc/ada/a-wtmoio.adb *** gcc-3.3.3/gcc/ada/a-wtmoio.adb 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtmoio.adb 2003-04-24 17:53:57.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992,1993,1994,1995,1996 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/a-wtmoio.ads gcc-3.4.0/gcc/ada/a-wtmoio.ads *** gcc-3.3.3/gcc/ada/a-wtmoio.ads 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wtmoio.ads 2003-04-24 17:53:57.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/a-wttest.adb gcc-3.4.0/gcc/ada/a-wttest.adb *** gcc-3.3.3/gcc/ada/a-wttest.adb 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wttest.adb 2003-04-24 17:53:57.000000000 +0000 *************** *** 6,12 **** -- -- -- B o d y -- -- -- - -- -- -- Copyright (C) 1992,1993,1994,1995,1996 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/a-wttest.ads gcc-3.4.0/gcc/ada/a-wttest.ads *** gcc-3.3.3/gcc/ada/a-wttest.ads 2002-03-14 10:59:01.000000000 +0000 --- gcc-3.4.0/gcc/ada/a-wttest.ads 2003-04-24 17:53:57.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/back_end.adb gcc-3.4.0/gcc/ada/back_end.adb *** gcc-3.3.3/gcc/ada/back_end.adb 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/back_end.adb 2003-12-03 11:47:52.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-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 Back_End is *** 241,249 **** while Next_Arg < save_argc loop Look_At_Arg : declare ! Argv_Ptr : constant BSP := save_argv (Next_Arg); ! Argv_Len : constant Nat := Len_Arg (Next_Arg); ! Argv : String := Argv_Ptr (1 .. Natural (Argv_Len)); begin -- If the previous switch has set the Output_File_Name_Present --- 240,248 ---- while Next_Arg < save_argc loop Look_At_Arg : declare ! Argv_Ptr : constant BSP := save_argv (Next_Arg); ! Argv_Len : constant Nat := Len_Arg (Next_Arg); ! Argv : constant String := Argv_Ptr (1 .. Natural (Argv_Len)); begin -- If the previous switch has set the Output_File_Name_Present *************** package body Back_End is *** 271,276 **** --- 270,281 ---- Opt.No_Stdinc := True; Scan_Back_End_Switches (Argv); + -- We must recognize -nostdlib to suppress visibility on the + -- standard GNAT RTL objects. + + elsif Argv (Argv'First + 1 .. Argv'Last) = "nostdlib" then + Opt.No_Stdlib := True; + elsif Is_Front_End_Switch (Argv) then Scan_Front_End_Switches (Argv); diff -Nrc3pad gcc-3.3.3/gcc/ada/back_end.ads gcc-3.4.0/gcc/ada/back_end.ads *** gcc-3.3.3/gcc/ada/back_end.ads 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/back_end.ads 2003-04-24 17:53:58.000000000 +0000 *************** *** 6,12 **** -- -- -- 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 -- --- 6,11 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/bcheck.adb gcc-3.4.0/gcc/ada/bcheck.adb *** gcc-3.3.3/gcc/ada/bcheck.adb 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/bcheck.adb 2003-10-21 13:41:58.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1992-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- -- --- 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- -- *************** with Types; use Types; *** 40,57 **** package body Bcheck is ! -- Local subprograms ! -- The following checking subprograms make up the parts ! -- of the configuration consistency check. procedure Check_Consistent_Dynamic_Elaboration_Checking; procedure Check_Consistent_Floating_Point_Format; procedure Check_Consistent_Locking_Policy; procedure Check_Consistent_Normalize_Scalars; procedure Check_Consistent_Queuing_Policy; procedure Check_Consistent_Zero_Cost_Exception_Handling; - procedure Check_Partition_Restrictions; procedure Consistency_Error_Msg (Msg : String); -- Produce an error or a warning message, depending on whether --- 39,59 ---- package body Bcheck is ! ----------------------- ! -- Local Subprograms -- ! ----------------------- ! -- The following checking subprograms make up the parts of the ! -- configuration consistency check. procedure Check_Consistent_Dynamic_Elaboration_Checking; procedure Check_Consistent_Floating_Point_Format; + procedure Check_Consistent_Interrupt_States; procedure Check_Consistent_Locking_Policy; procedure Check_Consistent_Normalize_Scalars; + procedure Check_Consistent_Partition_Restrictions; procedure Check_Consistent_Queuing_Policy; procedure Check_Consistent_Zero_Cost_Exception_Handling; procedure Consistency_Error_Msg (Msg : String); -- Produce an error or a warning message, depending on whether *************** package body Bcheck is *** 82,88 **** Check_Consistent_Normalize_Scalars; Check_Consistent_Dynamic_Elaboration_Checking; ! Check_Partition_Restrictions; end Check_Configuration_Consistency; --------------------------------------------------- --- 84,91 ---- Check_Consistent_Normalize_Scalars; Check_Consistent_Dynamic_Elaboration_Checking; ! Check_Consistent_Partition_Restrictions; ! Check_Consistent_Interrupt_States; end Check_Configuration_Consistency; --------------------------------------------------- *************** package body Bcheck is *** 199,204 **** --- 202,283 ---- end loop Find_Format; end Check_Consistent_Floating_Point_Format; + --------------------------------------- + -- Check_Consistent_Interrupt_States -- + --------------------------------------- + + -- The rule is that if the state of a given interrupt is specified + -- in more than one unit, it must be specified with a consistent state. + + procedure Check_Consistent_Interrupt_States is + Max_Intrup : Nat; + + begin + -- If no Interrupt_State entries, nothing to do + + if Interrupt_States.Last < Interrupt_States.First then + return; + end if; + + -- First find out the maximum interrupt value + + Max_Intrup := 0; + for J in Interrupt_States.First .. Interrupt_States.Last loop + if Interrupt_States.Table (J).Interrupt_Id > Max_Intrup then + Max_Intrup := Interrupt_States.Table (J).Interrupt_Id; + end if; + end loop; + + -- Now establish tables to be used for consistency checking + + declare + Istate : array (0 .. Max_Intrup) of Character := (others => 'n'); + -- Interrupt state entries, 'u'/'s'/'r' or 'n' to indicate an + -- entry that has not been set. + + Afile : array (0 .. Max_Intrup) of ALI_Id; + -- ALI file that generated Istate entry for consistency message + + Loc : array (0 .. Max_Intrup) of Nat; + -- Line numbers from IS pragma generating Istate entry + + Inum : Nat; + -- Interrupt number from entry being tested + + Stat : Character; + -- Interrupt state from entry being tested + + Lnum : Nat; + -- Line number from entry being tested + + begin + for F in ALIs.First .. ALIs.Last loop + for K in ALIs.Table (F).First_Interrupt_State .. + ALIs.Table (F).Last_Interrupt_State + loop + Inum := Interrupt_States.Table (K).Interrupt_Id; + Stat := Interrupt_States.Table (K).Interrupt_State; + Lnum := Interrupt_States.Table (K).IS_Pragma_Line; + + if Istate (Inum) = 'n' then + Istate (Inum) := Stat; + Afile (Inum) := F; + Loc (Inum) := Lnum; + + elsif Istate (Inum) /= Stat then + Error_Msg_Name_1 := ALIs.Table (Afile (Inum)).Sfile; + Error_Msg_Name_2 := ALIs.Table (F).Sfile; + Error_Msg_Nat_1 := Loc (Inum); + Error_Msg_Nat_2 := Lnum; + + Consistency_Error_Msg + ("inconsistent interrupt states at %:# and %:#"); + end if; + end loop; + end loop; + end; + end Check_Consistent_Interrupt_States; + ------------------------------------- -- Check_Consistent_Locking_Policy -- ------------------------------------- *************** package body Bcheck is *** 283,351 **** end if; end Check_Consistent_Normalize_Scalars; ! ------------------------------------- ! -- Check_Consistent_Queuing_Policy -- ! ------------------------------------- ! ! -- The rule is that all files for which the queuing policy is ! -- significant must be compiled with the same setting. ! ! procedure Check_Consistent_Queuing_Policy is ! begin ! -- First search for a unit specifying a policy and then ! -- check all remaining units against it. ! ! Find_Policy : for A1 in ALIs.First .. ALIs.Last loop ! if ALIs.Table (A1).Queuing_Policy /= ' ' then ! Check_Policy : declare ! Policy : constant Character := ALIs.Table (A1).Queuing_Policy; ! begin ! for A2 in A1 + 1 .. ALIs.Last loop ! if ALIs.Table (A2).Queuing_Policy /= ' ' ! and then ! ALIs.Table (A2).Queuing_Policy /= Policy ! then ! Error_Msg_Name_1 := ALIs.Table (A1).Sfile; ! Error_Msg_Name_2 := ALIs.Table (A2).Sfile; ! ! Consistency_Error_Msg ! ("% and % compiled with different queuing policies"); ! exit Find_Policy; ! end if; ! end loop; ! end Check_Policy; ! ! exit Find_Policy; ! end if; ! end loop Find_Policy; ! end Check_Consistent_Queuing_Policy; ! ! --------------------------------------------------- ! -- Check_Consistent_Zero_Cost_Exception_Handling -- ! --------------------------------------------------- ! ! -- Check consistent zero cost exception handling. The rule is that ! -- all units must have the same exception handling mechanism. ! ! procedure Check_Consistent_Zero_Cost_Exception_Handling is ! begin ! Check_Mechanism : for A1 in ALIs.First + 1 .. ALIs.Last loop ! if ALIs.Table (A1).Zero_Cost_Exceptions /= ! ALIs.Table (ALIs.First).Zero_Cost_Exceptions ! ! then ! Error_Msg_Name_1 := ALIs.Table (A1).Sfile; ! Error_Msg_Name_2 := ALIs.Table (ALIs.First).Sfile; ! ! Consistency_Error_Msg ("% and % compiled with different " ! & "exception handling mechanisms"); ! end if; ! end loop Check_Mechanism; ! end Check_Consistent_Zero_Cost_Exception_Handling; ! ! ---------------------------------- ! -- Check_Partition_Restrictions -- ! ---------------------------------- -- The rule is that if a restriction is specified in any unit, -- then all units must obey the restriction. The check applies --- 362,370 ---- end if; end Check_Consistent_Normalize_Scalars; ! --------------------------------------------- ! -- Check_Consistent_Partition_Restrictions -- ! --------------------------------------------- -- The rule is that if a restriction is specified in any unit, -- then all units must obey the restriction. The check applies *************** package body Bcheck is *** 356,363 **** -- a unit specifying that restriction is found, if any. -- Second, all units are verified against the specified restrictions. ! procedure Check_Partition_Restrictions is ! No_Restriction_List : array (All_Restrictions) of Boolean := (No_Implicit_Conditionals => True, -- This could modify and pessimize generated code --- 375,382 ---- -- a unit specifying that restriction is found, if any. -- Second, all units are verified against the specified restrictions. ! procedure Check_Consistent_Partition_Restrictions is ! No_Restriction_List : constant array (All_Restrictions) of Boolean := (No_Implicit_Conditionals => True, -- This could modify and pessimize generated code *************** package body Bcheck is *** 471,477 **** declare S : constant String := Restriction_Id'Image (J); - begin Name_Len := S'Length; Name_Buffer (1 .. Name_Len) := S; --- 490,495 ---- *************** package body Bcheck is *** 484,490 **** end if; end loop; end if; ! end Check_Partition_Restrictions; ----------------------- -- Check_Consistency -- --- 502,568 ---- end if; end loop; end if; ! end Check_Consistent_Partition_Restrictions; ! ! ------------------------------------- ! -- Check_Consistent_Queuing_Policy -- ! ------------------------------------- ! ! -- The rule is that all files for which the queuing policy is ! -- significant must be compiled with the same setting. ! ! procedure Check_Consistent_Queuing_Policy is ! begin ! -- First search for a unit specifying a policy and then ! -- check all remaining units against it. ! ! Find_Policy : for A1 in ALIs.First .. ALIs.Last loop ! if ALIs.Table (A1).Queuing_Policy /= ' ' then ! Check_Policy : declare ! Policy : constant Character := ALIs.Table (A1).Queuing_Policy; ! begin ! for A2 in A1 + 1 .. ALIs.Last loop ! if ALIs.Table (A2).Queuing_Policy /= ' ' ! and then ! ALIs.Table (A2).Queuing_Policy /= Policy ! then ! Error_Msg_Name_1 := ALIs.Table (A1).Sfile; ! Error_Msg_Name_2 := ALIs.Table (A2).Sfile; ! ! Consistency_Error_Msg ! ("% and % compiled with different queuing policies"); ! exit Find_Policy; ! end if; ! end loop; ! end Check_Policy; ! ! exit Find_Policy; ! end if; ! end loop Find_Policy; ! end Check_Consistent_Queuing_Policy; ! ! --------------------------------------------------- ! -- Check_Consistent_Zero_Cost_Exception_Handling -- ! --------------------------------------------------- ! ! -- Check consistent zero cost exception handling. The rule is that ! -- all units must have the same exception handling mechanism. ! ! procedure Check_Consistent_Zero_Cost_Exception_Handling is ! begin ! Check_Mechanism : for A1 in ALIs.First + 1 .. ALIs.Last loop ! if ALIs.Table (A1).Zero_Cost_Exceptions /= ! ALIs.Table (ALIs.First).Zero_Cost_Exceptions ! ! then ! Error_Msg_Name_1 := ALIs.Table (A1).Sfile; ! Error_Msg_Name_2 := ALIs.Table (ALIs.First).Sfile; ! ! Consistency_Error_Msg ("% and % compiled with different " ! & "exception handling mechanisms"); ! end if; ! end loop Check_Mechanism; ! end Check_Consistent_Zero_Cost_Exception_Handling; ----------------------- -- Check_Consistency -- *************** package body Bcheck is *** 577,583 **** end if; else ! if Tolerate_Consistency_Errors then Error_Msg ("?% should be recompiled (% has been modified)"); --- 655,676 ---- end if; else ! if Osint.Is_Readonly_Library (ALIs.Table (A).Afile) then ! Error_Msg_Name_2 := ! Osint.Find_File ((ALIs.Table (A).Afile), Osint.Library); ! ! if Tolerate_Consistency_Errors then ! Error_Msg ("?% should be recompiled"); ! Error_Msg_Name_1 := Error_Msg_Name_2; ! Error_Msg ("?(% is obsolete and read-only)"); ! ! else ! Error_Msg ("% must be compiled"); ! Error_Msg_Name_1 := Error_Msg_Name_2; ! Error_Msg ("(% is obsolete and read-only)"); ! end if; ! ! elsif Tolerate_Consistency_Errors then Error_Msg ("?% should be recompiled (% has been modified)"); *************** package body Bcheck is *** 588,603 **** if (not Tolerate_Consistency_Errors) and Verbose_Mode then declare ! Msg : constant String := "file % has time stamp "; Buf : String (1 .. Msg'Length + Time_Stamp_Length); begin Buf (1 .. Msg'Length) := Msg; Buf (Msg'Length + 1 .. Buf'Length) := String (Source.Table (Src).Stamp); ! Error_Msg_Name_1 := ALIs.Table (A).Sfile; Error_Msg (Buf); Buf (Msg'Length + 1 .. Buf'Length) := String (Sdep.Table (D).Stamp); Error_Msg_Name_1 := Sdep.Table (D).Sfile; --- 681,703 ---- if (not Tolerate_Consistency_Errors) and Verbose_Mode then declare ! Msg : constant String := "% time stamp "; Buf : String (1 .. Msg'Length + Time_Stamp_Length); begin Buf (1 .. Msg'Length) := Msg; Buf (Msg'Length + 1 .. Buf'Length) := String (Source.Table (Src).Stamp); ! Error_Msg_Name_1 := Sdep.Table (D).Sfile; Error_Msg (Buf); + end; + declare + Msg : constant String := " conflicts with % timestamp "; + Buf : String (1 .. Msg'Length + Time_Stamp_Length); + + begin + Buf (1 .. Msg'Length) := Msg; Buf (Msg'Length + 1 .. Buf'Length) := String (Sdep.Table (D).Stamp); Error_Msg_Name_1 := Sdep.Table (D).Sfile; diff -Nrc3pad gcc-3.3.3/gcc/ada/bcheck.ads gcc-3.4.0/gcc/ada/bcheck.ads *** gcc-3.3.3/gcc/ada/bcheck.ads 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/bcheck.ads 2003-04-24 17:53:58.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-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/binde.adb gcc-3.4.0/gcc/ada/binde.adb *** gcc-3.3.3/gcc/ada/binde.adb 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/binde.adb 2003-10-21 13:41:58.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-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- -- *************** with Binderr; use Binderr; *** 29,34 **** --- 28,34 ---- with Butil; use Butil; with Debug; use Debug; with Fname; use Fname; + with Lib; use Lib; with Namet; use Namet; with Opt; use Opt; with Output; use Output; *************** package body Binde is *** 766,776 **** for W in Units.Table (Before).First_With .. Units.Table (Before).Last_With loop ! -- Skip if no ALI file for this with, happens with certain -- specialized generic files that do not get compiled. ! if Withs.Table (W).Afile /= No_File then ! Elab_All_Links (Unit_Id_Of (Withs.Table (W).Uname), After, --- 766,779 ---- for W in Units.Table (Before).First_With .. Units.Table (Before).Last_With loop ! -- Skip if this with is an interface to a stand-alone library. ! -- Skip also if no ALI file for this with, happens with certain -- specialized generic files that do not get compiled. ! if not Withs.Table (W).Interface ! and then Withs.Table (W).Afile /= No_File ! and then Generic_Separately_Compiled (Withs.Table (W).Sfile) ! then Elab_All_Links (Unit_Id_Of (Withs.Table (W).Uname), After, *************** package body Binde is *** 841,847 **** when Elab_Desirable => Error_Msg_Output ! (" reason: Elaborate_All probably needed in unit &", Info => True); Error_Msg_Output --- 844,850 ---- when Elab_Desirable => Error_Msg_Output ! (" reason: implicit Elaborate_All in unit &", Info => True); Error_Msg_Output *************** package body Binde is *** 1004,1103 **** for U in Units.First .. Units.Last loop Cur_Unit := U; ! -- If there is a body and a spec, then spec must be elaborated first -- Note that the corresponding spec immediately follows the body ! if Units.Table (U).Utype = Is_Body then Build_Link (Corresponding_Spec (U), U, Spec_First); end if; ! -- Process WITH references for this unit ignoring generic units ! ! for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop ! if Withs.Table (W).Sfile /= No_File then ! -- Check for special case of withing a unit that does not ! -- exist any more. If the unit was completely missing we would ! -- already have detected this, but a nasty case arises when we ! -- have a subprogram body with no spec, and some obsolete unit ! -- with's a previous (now disappeared) spec. ! if Get_Name_Table_Info (Withs.Table (W).Uname) = 0 then ! Error_Msg_Name_1 := Units.Table (U).Sfile; ! Error_Msg_Name_2 := Withs.Table (W).Uname; ! Error_Msg ("% depends on & which no longer exists"); ! goto Next_With; ! end if; ! Withed_Unit := ! Unit_Id (Unit_Id_Of (Withs.Table (W).Uname)); ! -- Pragma Elaborate_All case, for this we use the recursive ! -- Elab_All_Links procedure to establish the links. ! if Withs.Table (W).Elaborate_All then ! -- Reset flags used to stop multiple visits to a given node ! for Uref in UNR.First .. UNR.Last loop ! UNR.Table (Uref).Visited := False; ! end loop; ! -- Now establish all the links we need ! Elab_All_Links ! (Withed_Unit, U, Elab_All, ! Make_Elab_Entry ! (Withs.Table (W).Uname, No_Elab_All_Link)); ! -- Elaborate_All_Desirable case, for this we establish the ! -- same links as above, but with a different reason. ! elsif Withs.Table (W).Elab_All_Desirable then ! -- Reset flags used to stop multiple visits to a given node ! for Uref in UNR.First .. UNR.Last loop ! UNR.Table (Uref).Visited := False; ! end loop; ! -- Now establish all the links we need ! Elab_All_Links ! (Withed_Unit, U, Elab_Desirable, ! Make_Elab_Entry ! (Withs.Table (W).Uname, No_Elab_All_Link)); ! -- Pragma Elaborate case. We must build a link for the withed ! -- unit itself, and also the corresponding body if there is one ! -- However, skip this processing if there is no ALI file for ! -- the WITH entry, because this means it is a generic (even ! -- when we fix the generics so that an ALI file is present, ! -- we probably still will have no ALI file for unchecked ! -- and other special cases). ! elsif Withs.Table (W).Elaborate ! and then Withs.Table (W).Afile /= No_File ! then ! Build_Link (Withed_Unit, U, Withed); ! if Units.Table (Withed_Unit).Utype = Is_Spec then ! Build_Link ! (Corresponding_Body (Withed_Unit), U, Elab); ! end if; ! -- Case of normal WITH with no elaboration pragmas, just ! -- build the single link to the directly referenced unit ! else ! Build_Link (Withed_Unit, U, Withed); end if; - end if; ! <> null; ! end loop; end loop; end Gather_Dependencies; --- 1007,1119 ---- for U in Units.First .. Units.Last loop Cur_Unit := U; ! -- If this is not an interface to a stand-alone library and ! -- there is a body and a spec, then spec must be elaborated first -- Note that the corresponding spec immediately follows the body ! if not Units.Table (U).Interface ! and then Units.Table (U).Utype = Is_Body ! then Build_Link (Corresponding_Spec (U), U, Spec_First); end if; ! -- If this unit is not an interface to a stand-alone library, ! -- process WITH references for this unit ignoring generic units and ! -- interfaces to stand-alone libraries. ! if not Units.Table (U).Interface then ! for ! W in Units.Table (U).First_With .. Units.Table (U).Last_With ! loop ! if Withs.Table (W).Sfile /= No_File ! and then (not Withs.Table (W).Interface) ! then ! -- Check for special case of withing a unit that does not ! -- exist any more. If the unit was completely missing we ! -- would already have detected this, but a nasty case arises ! -- when we have a subprogram body with no spec, and some ! -- obsolete unit with's a previous (now disappeared) spec. ! if Get_Name_Table_Info (Withs.Table (W).Uname) = 0 then ! Error_Msg_Name_1 := Units.Table (U).Sfile; ! Error_Msg_Name_2 := Withs.Table (W).Uname; ! Error_Msg ("% depends on & which no longer exists"); ! goto Next_With; ! end if; ! Withed_Unit := ! Unit_Id (Unit_Id_Of (Withs.Table (W).Uname)); ! -- Pragma Elaborate_All case, for this we use the recursive ! -- Elab_All_Links procedure to establish the links. ! if Withs.Table (W).Elaborate_All then ! -- Reset flags used to stop multiple visits to a given ! -- node. ! for Uref in UNR.First .. UNR.Last loop ! UNR.Table (Uref).Visited := False; ! end loop; ! -- Now establish all the links we need ! Elab_All_Links ! (Withed_Unit, U, Elab_All, ! Make_Elab_Entry ! (Withs.Table (W).Uname, No_Elab_All_Link)); ! -- Elaborate_All_Desirable case, for this we establish ! -- the same links as above, but with a different reason. ! elsif Withs.Table (W).Elab_All_Desirable then ! -- Reset flags used to stop multiple visits to a given ! -- node. ! for Uref in UNR.First .. UNR.Last loop ! UNR.Table (Uref).Visited := False; ! end loop; ! -- Now establish all the links we need ! Elab_All_Links ! (Withed_Unit, U, Elab_Desirable, ! Make_Elab_Entry ! (Withs.Table (W).Uname, No_Elab_All_Link)); ! -- Pragma Elaborate case. We must build a link for the ! -- withed unit itself, and also the corresponding body ! -- if there is one. ! -- However, skip this processing if there is no ALI file ! -- for the WITH entry, because this means it is a ! -- generic (even when we fix the generics so that an ALI ! -- file is present, we probably still will have no ALI ! -- file for unchecked and other special cases). ! elsif Withs.Table (W).Elaborate ! and then Withs.Table (W).Afile /= No_File ! then ! Build_Link (Withed_Unit, U, Withed); ! if Units.Table (Withed_Unit).Utype = Is_Spec then ! Build_Link ! (Corresponding_Body (Withed_Unit), U, Elab); ! end if; ! -- Case of normal WITH with no elaboration pragmas, just ! -- build the single link to the directly referenced unit ! else ! Build_Link (Withed_Unit, U, Withed); ! end if; end if; ! <> null; ! end loop; ! end if; end loop; end Gather_Dependencies; diff -Nrc3pad gcc-3.3.3/gcc/ada/binde.ads gcc-3.4.0/gcc/ada/binde.ads *** gcc-3.3.3/gcc/ada/binde.ads 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/binde.ads 2003-04-24 17:53:58.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992-1997 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/binderr.adb gcc-3.4.0/gcc/ada/binderr.adb *** gcc-3.3.3/gcc/ada/binderr.adb 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/binderr.adb 2003-04-24 17:53:58.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-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 Binderr is *** 97,102 **** --- 96,102 ---- procedure Error_Msg_Output (Msg : String; Info : Boolean) is Use_Second_Name : Boolean := False; + Use_Second_Nat : Boolean := False; begin if Warnings_Detected + Errors_Detected > Maximum_Errors then *************** package body Binderr is *** 115,122 **** Write_Str ("error: "); end if; ! for I in Msg'Range loop ! if Msg (I) = '%' then if Use_Second_Name then Get_Name_String (Error_Msg_Name_2); --- 115,122 ---- Write_Str ("error: "); end if; ! for J in Msg'Range loop ! if Msg (J) = '%' then if Use_Second_Name then Get_Name_String (Error_Msg_Name_2); *************** package body Binderr is *** 129,135 **** Write_Str (Name_Buffer (1 .. Name_Len)); Write_Char ('"'); ! elsif Msg (I) = '&' then Write_Char ('"'); if Use_Second_Name then --- 129,135 ---- Write_Str (Name_Buffer (1 .. Name_Len)); Write_Char ('"'); ! elsif Msg (J) = '&' then Write_Char ('"'); if Use_Second_Name then *************** package body Binderr is *** 141,148 **** Write_Char ('"'); ! elsif Msg (I) /= '?' then ! Write_Char (Msg (I)); end if; end loop; --- 141,156 ---- Write_Char ('"'); ! elsif Msg (J) = '#' then ! if Use_Second_Nat then ! Write_Int (Error_Msg_Nat_2); ! else ! Use_Second_Nat := True; ! Write_Int (Error_Msg_Nat_1); ! end if; ! ! elsif Msg (J) /= '?' then ! Write_Char (Msg (J)); end if; end loop; diff -Nrc3pad gcc-3.3.3/gcc/ada/binderr.ads gcc-3.4.0/gcc/ada/binderr.ads *** gcc-3.3.3/gcc/ada/binderr.ads 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/binderr.ads 2003-04-24 17:53:58.000000000 +0000 *************** *** 6,13 **** -- -- -- S p e c -- -- -- ! -- -- ! -- 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 ---- -- -- -- 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- -- *************** package Binderr is *** 66,71 **** --- 65,76 ---- -- which case it is similarly replaced by the name which is specified -- by the Name_Id value stored in Error_Msg_Name_2. + -- Insertion character # (Pound: insert non-negative number in decimal) + -- The character # is replaced by the contents of Error_Msg_Nat_1 + -- converted into an unsigned decimal string. A second # may appear + -- in a single message, in which case it is similarly replaced by + -- the value stored in Error_Msg_Nat_2. + -- Insertion character ? (Question mark: warning message) -- The character ?, which must be the first character in the message -- string, signals a warning message instead of an error message. *************** package Binderr is *** 84,89 **** --- 89,98 ---- Error_Msg_Name_2 : Name_Id; -- Name_Id values for % insertion characters in message + Error_Msg_Nat_1 : Nat; + Error_Msg_Nat_2 : Nat; + -- Integer values for # insertion characters in message + ------------------------------ -- Error Output Subprograms -- ------------------------------ diff -Nrc3pad gcc-3.3.3/gcc/ada/bindgen.adb gcc-3.4.0/gcc/ada/bindgen.adb *** gcc-3.3.3/gcc/ada/bindgen.adb 2002-11-15 01:45:29.000000000 +0000 --- gcc-3.4.0/gcc/ada/bindgen.adb 2004-01-05 15:20:43.000000000 +0000 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- -- ! -- Copyright (C) 1992-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- -- --- 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- -- *************** with Opt; use Opt; *** 38,45 **** with Osint; use Osint; with Osint.B; use Osint.B; with Output; use Output; with Types; use Types; - with Sdefault; use Sdefault; with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; --- 37,46 ---- with Osint; use Osint; with Osint.B; use Osint.B; with Output; use Output; + with Rident; use Rident; + with Table; use Table; + with Targparm; use Targparm; with Types; use Types; with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; *************** package body Bindgen is *** 53,59 **** With_DECGNAT : Boolean := False; -- Flag which indicates whether the program uses the DECGNAT library ! -- (presence of the unit System.Aux_DEC.DECLIB) With_GNARL : Boolean := False; -- Flag which indicates whether the program uses the GNARL library --- 54,60 ---- With_DECGNAT : Boolean := False; -- Flag which indicates whether the program uses the DECGNAT library ! -- (presence of the unit DEC). With_GNARL : Boolean := False; -- Flag which indicates whether the program uses the GNARL library *************** package body Bindgen is *** 62,67 **** --- 63,85 ---- Num_Elab_Calls : Nat := 0; -- Number of generated calls to elaboration routines + ---------------------------------- + -- Interface_State Pragma Table -- + ---------------------------------- + + -- This table assembles the interface state pragma information from + -- all the units in the partition. Note that Bcheck has already checked + -- that the information is consistent across partitions. The entries + -- in this table are n/u/r/s for not set/user/runtime/system. + + package IS_Pragma_Settings is new Table.Table ( + Table_Component_Type => Character, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "IS_Pragma_Settings"); + ----------------------- -- Local Subprograms -- ----------------------- *************** package body Bindgen is *** 69,79 **** procedure WBI (Info : String) renames Osint.B.Write_Binder_Info; -- Convenient shorthand used throughout - procedure Resolve_Binder_Options; - -- Set the value of With_GNARL and With_DECGNAT. The latter only on VMS - -- since it tests for a package named "dec" which might cause a conflict - -- on non-VMS systems. - procedure Gen_Adainit_Ada; -- Generates the Adainit procedure (Ada code case) --- 87,92 ---- *************** package body Bindgen is *** 128,137 **** procedure Gen_Output_File_C (Filename : String); -- Generate output file (C code case) - procedure Gen_Scalar_Values; - -- Generates scalar initialization values for -Snn. A single procedure - -- handles both the Ada and C cases, since there is much common code. - procedure Gen_Versions_Ada; -- Output series of definitions for unit versions (Ada code case) --- 141,146 ---- *************** package body Bindgen is *** 147,155 **** function Get_Main_Name return String; -- This function is used in the Ada main output case to compute the ! -- correct external main program. It is "main" by default, except on ! -- VxWorks where it is the name of the Ada main name without the "_ada". ! -- the -Mname binder option overrides the default with name. function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean; -- Compare linker options, when sorting, first according to --- 156,165 ---- function Get_Main_Name return String; -- This function is used in the Ada main output case to compute the ! -- correct external main program. It is "main" by default, unless the ! -- flag Use_Ada_Main_Program_Name_On_Target is set, in which case it ! -- is the name of the Ada main name without the "_ada". This default ! -- can be overridden explicitly using the -Mname binder switch. function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean; -- Compare linker options, when sorting, first according to *************** package body Bindgen is *** 159,164 **** --- 169,183 ---- procedure Move_Linker_Option (From : Natural; To : Natural); -- Move routine for sorting linker options + procedure Public_Version_Warning; + -- Emit a warning concerning the use of the Public version under + -- certain circumstances. See details in body. + + procedure Resolve_Binder_Options; + -- Set the value of With_GNARL and With_DECGNAT. The latter only on VMS + -- since it tests for a package named "dec" which might cause a conflict + -- on non-VMS systems. + procedure Set_Char (C : Character); -- Set given character in Statement_Buffer at the Last + 1 position -- and increment Last by one to reflect the stored character. *************** package body Bindgen is *** 168,173 **** --- 187,195 ---- -- starting at the Last + 1 position, and updating Last past the value. -- A minus sign is output for a negative value. + procedure Set_IS_Pragma_Table; + -- Initializes contents of IS_Pragma_Settings table from ALI table + procedure Set_Main_Program_Name; -- Given the main program name in Name_Buffer (length in Name_Len) -- generate the name of the routine to be used in the call. The name *************** package body Bindgen is *** 257,263 **** U : Unit_Record renames Units.Table (Unum); begin ! if U.Set_Elab_Entity then Set_String (" "); Set_String ("E"); Set_Unit_Number (Unum); --- 279,285 ---- U : Unit_Record renames Units.Table (Unum); begin ! if U.Set_Elab_Entity and then not U.Interface then Set_String (" "); Set_String ("E"); Set_Unit_Number (Unum); *************** package body Bindgen is *** 302,312 **** Write_Statement_Buffer; ! -- Case of No_Run_Time mode. The only global variable that might ! -- be needed (by the Ravenscar profile) is the priority of the ! -- environment. Also no exception tables are needed. ! if No_Run_Time_Specified then if Main_Priority /= No_Main_Priority then WBI (" Main_Priority : Integer;"); WBI (" pragma Import (C, Main_Priority," & --- 324,334 ---- Write_Statement_Buffer; ! -- If the standard library is suppressed, then the only global variable ! -- that might be needed (by the Ravenscar profile) is the priority of ! -- the environment. Also no exception tables are needed. ! if Suppress_Standard_Library_On_Target then if Main_Priority /= No_Main_Priority then WBI (" Main_Priority : Integer;"); WBI (" pragma Import (C, Main_Priority," & *************** package body Bindgen is *** 326,332 **** WBI (" null;"); end if; ! -- Normal case (not No_Run_Time mode). The global values are -- assigned using the runtime routine Set_Globals (we have to use -- the routine call, rather than define the globals in the binder -- file to deal with cross-library calls in some systems. --- 348,354 ---- WBI (" null;"); end if; ! -- Normal case (standard library not suppressed). Global values are -- assigned using the runtime routine Set_Globals (we have to use -- the routine call, rather than define the globals in the binder -- file to deal with cross-library calls in some systems. *************** package body Bindgen is *** 346,351 **** --- 368,406 ---- Write_Statement_Buffer; WBI (""); + -- Generate Interrupt_State pragma string + + Set_String (" Interrupt_States : constant String :="); + Write_Statement_Buffer; + + declare + Col : Natural; + + begin + Set_String (" """); + Col := 9; + + for J in 0 .. IS_Pragma_Settings.Last loop + if Col > 72 then + Set_String (""" &"); + Write_Statement_Buffer; + Set_String (" """); + Col := 9; + + else + Col := Col + 1; + end if; + + Set_Char (IS_Pragma_Settings.Table (J)); + end loop; + end; + + Set_String (""";"); + Write_Statement_Buffer; + WBI (""); + + -- Generate spec for Set_Globals procedure + WBI (" procedure Set_Globals"); WBI (" (Main_Priority : Integer;"); WBI (" Time_Slice_Value : Integer;"); *************** package body Bindgen is *** 354,367 **** WBI (" Queuing_Policy : Character;"); WBI (" Task_Dispatching_Policy : Character;"); WBI (" Restrictions : System.Address;"); WBI (" Unreserve_All_Interrupts : Integer;"); WBI (" Exception_Tracebacks : Integer;"); WBI (" Zero_Cost_Exceptions : Integer);"); WBI (" pragma Import (C, Set_Globals, ""__gnat_set_globals"");"); -- Import entry point for elaboration time signal handler ! -- installation, and indication of whether it's been called ! -- previously WBI (""); WBI (" procedure Install_Handler;"); --- 409,423 ---- WBI (" Queuing_Policy : Character;"); WBI (" Task_Dispatching_Policy : Character;"); WBI (" Restrictions : System.Address;"); + WBI (" Interrupt_States : System.Address;"); + WBI (" Num_Interrupt_States : Integer;"); WBI (" Unreserve_All_Interrupts : Integer;"); WBI (" Exception_Tracebacks : Integer;"); WBI (" Zero_Cost_Exceptions : Integer);"); WBI (" pragma Import (C, Set_Globals, ""__gnat_set_globals"");"); -- Import entry point for elaboration time signal handler ! -- installation, and indication of if it's been called previously. WBI (""); WBI (" procedure Install_Handler;"); *************** package body Bindgen is *** 420,425 **** --- 476,489 ---- WBI (" Restrictions => Restrictions'Address,"); + WBI (" Interrupt_States => " & + "Interrupt_States'Address,"); + + Set_String (" Num_Interrupt_States => "); + Set_Int (IS_Pragma_Settings.Last + 1); + Set_Char (','); + Write_Statement_Buffer; + Set_String (" Unreserve_All_Interrupts => "); if Unreserve_All_Interrupts_Specified then *************** package body Bindgen is *** 428,434 **** Set_String ("0"); end if; ! Set_String (","); Write_Statement_Buffer; Set_String (" Exception_Tracebacks => "); --- 492,498 ---- Set_String ("0"); end if; ! Set_Char (','); Write_Statement_Buffer; Set_String (" Exception_Tracebacks => "); *************** package body Bindgen is *** 454,465 **** Write_Statement_Buffer; -- Generate call to Install_Handler WBI (""); WBI (" if Handler_Installed = 0 then"); ! WBI (" Install_Handler;"); WBI (" end if;"); end if; Gen_Elab_Calls_Ada; WBI (" end " & Ada_Init_Name.all & ";"); --- 518,556 ---- Write_Statement_Buffer; -- Generate call to Install_Handler + WBI (""); WBI (" if Handler_Installed = 0 then"); ! WBI (" Install_Handler;"); WBI (" end if;"); end if; + -- Generate call to set Initialize_Scalar values if active + + if Initialize_Scalars_Used then + WBI (""); + Set_String (" System.Scalar_Values.Initialize ('"); + Set_Char (Initialize_Scalars_Mode1); + Set_String ("', '"); + Set_Char (Initialize_Scalars_Mode2); + Set_String ("');"); + Write_Statement_Buffer; + end if; + + -- Generate assignment of default secondary stack size if set + + if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then + WBI (""); + Set_String (" System.Secondary_Stack."); + Set_String ("Default_Secondary_Stack_Size := "); + Set_Int (Opt.Default_Sec_Stack_Size); + Set_Char (';'); + Write_Statement_Buffer; + end if; + + -- Generate elaboration calls + + WBI (""); Gen_Elab_Calls_Ada; WBI (" end " & Ada_Init_Name.all & ";"); *************** package body Bindgen is *** 473,479 **** Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority; begin ! WBI ("void " & Ada_Init_Name.all & " ()"); WBI ("{"); -- Generate externals for elaboration entities --- 564,570 ---- Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority; begin ! WBI ("void " & Ada_Init_Name.all & " (void)"); WBI ("{"); -- Generate externals for elaboration entities *************** package body Bindgen is *** 482,490 **** declare Unum : constant Unit_Id := Elab_Order.Table (E); U : Unit_Record renames Units.Table (Unum); - begin ! if U.Set_Elab_Entity then Set_String (" extern char "); Get_Name_String (U.Uname); Set_Unit_Name; --- 573,580 ---- declare Unum : constant Unit_Id := Elab_Order.Table (E); U : Unit_Record renames Units.Table (Unum); begin ! if U.Set_Elab_Entity and then not U.Interface then Set_String (" extern char "); Get_Name_String (U.Uname); Set_Unit_Name; *************** package body Bindgen is *** 496,506 **** Write_Statement_Buffer; ! -- No run-time case ! if No_Run_Time_Specified then ! -- Case of No_Run_Time mode. Set __gl_main_priority if needed -- for the Ravenscar profile. if Main_Priority /= No_Main_Priority then --- 586,596 ---- Write_Statement_Buffer; ! -- Standard library suppressed ! if Suppress_Standard_Library_On_Target then ! -- Case of High_Integrity_Mode mode. Set __gl_main_priority if needed -- for the Ravenscar profile. if Main_Priority /= No_Main_Priority then *************** package body Bindgen is *** 510,516 **** Write_Statement_Buffer; end if; ! -- Normal case (run time present) else -- Generate definition for restrictions string --- 600,606 ---- Write_Statement_Buffer; end if; ! -- Normal case (standard library not suppressed) else -- Generate definition for restrictions string *************** package body Bindgen is *** 524,530 **** Set_String (""";"); Write_Statement_Buffer; ! -- Code for normal case (not in No_Run_Time mode) Gen_Exception_Table_C; --- 614,640 ---- Set_String (""";"); Write_Statement_Buffer; ! -- Generate definition for interrupt states string ! ! Set_String (" const char *interrupt_states = """); ! ! for J in 0 .. IS_Pragma_Settings.Last loop ! Set_Char (IS_Pragma_Settings.Table (J)); ! end loop; ! ! Set_String (""";"); ! Write_Statement_Buffer; ! ! -- Generate declaration for secondary stack default if needed ! ! if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then ! WBI (" extern int system__secondary_stack__" & ! "default_secondary_stack_size;"); ! end if; ! ! WBI (""); ! ! -- Code for normal case (standard library not suppressed) Gen_Exception_Table_C; *************** package body Bindgen is *** 541,547 **** Set_String (" "); Set_Int (Main_Priority); Set_Char (','); ! Tab_To (15); Set_String ("/* Main_Priority */"); Write_Statement_Buffer; --- 651,657 ---- Set_String (" "); Set_Int (Main_Priority); Set_Char (','); ! Tab_To (24); Set_String ("/* Main_Priority */"); Write_Statement_Buffer; *************** package body Bindgen is *** 556,620 **** end if; Set_Char (','); ! Tab_To (20); Set_String ("/* Time_Slice_Value */"); Write_Statement_Buffer; Set_String (" '"); Set_Char (ALIs.Table (ALIs.First).WC_Encoding); Set_String ("',"); ! Tab_To (20); Set_String ("/* WC_Encoding */"); Write_Statement_Buffer; Set_String (" '"); Set_Char (Locking_Policy_Specified); Set_String ("',"); ! Tab_To (20); Set_String ("/* Locking_Policy */"); Write_Statement_Buffer; Set_String (" '"); Set_Char (Queuing_Policy_Specified); Set_String ("',"); ! Tab_To (20); Set_String ("/* Queuing_Policy */"); Write_Statement_Buffer; Set_String (" '"); Set_Char (Task_Dispatching_Policy_Specified); Set_String ("',"); ! Tab_To (20); Set_String ("/* Tasking_Dispatching_Policy */"); Write_Statement_Buffer; Set_String (" "); Set_String ("restrictions"); Set_String (","); ! Tab_To (20); ! Set_String ("/* Restrictions */"); Write_Statement_Buffer; Set_String (" "); Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified)); Set_String (","); ! Tab_To (20); ! Set_String ("/* Unreserve_All_Interrupts */"); Write_Statement_Buffer; Set_String (" "); Set_Int (Boolean'Pos (Exception_Tracebacks)); Set_String (","); ! Tab_To (20); ! Set_String ("/* Exception_Tracebacks */"); Write_Statement_Buffer; Set_String (" "); Set_Int (Boolean'Pos (Zero_Cost_Exceptions_Specified)); Set_String (");"); ! Tab_To (20); ! Set_String ("/* Zero_Cost_Exceptions */"); Write_Statement_Buffer; -- Install elaboration time signal handler --- 666,745 ---- end if; Set_Char (','); ! Tab_To (24); Set_String ("/* Time_Slice_Value */"); Write_Statement_Buffer; Set_String (" '"); Set_Char (ALIs.Table (ALIs.First).WC_Encoding); Set_String ("',"); ! Tab_To (24); Set_String ("/* WC_Encoding */"); Write_Statement_Buffer; Set_String (" '"); Set_Char (Locking_Policy_Specified); Set_String ("',"); ! Tab_To (24); Set_String ("/* Locking_Policy */"); Write_Statement_Buffer; Set_String (" '"); Set_Char (Queuing_Policy_Specified); Set_String ("',"); ! Tab_To (24); Set_String ("/* Queuing_Policy */"); Write_Statement_Buffer; Set_String (" '"); Set_Char (Task_Dispatching_Policy_Specified); Set_String ("',"); ! Tab_To (24); Set_String ("/* Tasking_Dispatching_Policy */"); Write_Statement_Buffer; Set_String (" "); Set_String ("restrictions"); Set_String (","); ! Tab_To (24); ! Set_String ("/* Restrictions */"); ! Write_Statement_Buffer; ! ! Set_String (" "); ! Set_String ("interrupt_states"); ! Set_String (","); ! Tab_To (24); ! Set_String ("/* Interrupt_States */"); ! Write_Statement_Buffer; ! ! Set_String (" "); ! Set_Int (IS_Pragma_Settings.Last + 1); ! Set_String (","); ! Tab_To (24); ! Set_String ("/* Num_Interrupt_States */"); Write_Statement_Buffer; Set_String (" "); Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified)); Set_String (","); ! Tab_To (24); ! Set_String ("/* Unreserve_All_Interrupts */"); Write_Statement_Buffer; Set_String (" "); Set_Int (Boolean'Pos (Exception_Tracebacks)); Set_String (","); ! Tab_To (24); ! Set_String ("/* Exception_Tracebacks */"); Write_Statement_Buffer; Set_String (" "); Set_Int (Boolean'Pos (Zero_Cost_Exceptions_Specified)); Set_String (");"); ! Tab_To (24); ! Set_String ("/* Zero_Cost_Exceptions */"); Write_Statement_Buffer; + WBI (""); -- Install elaboration time signal handler *************** package body Bindgen is *** 624,629 **** --- 749,779 ---- WBI (" }"); end if; + -- Generate call to set Initialize_Scalar values if needed + + if Initialize_Scalars_Used then + WBI (""); + Set_String (" system__scalar_values__initialize('"); + Set_Char (Initialize_Scalars_Mode1); + Set_String ("', '"); + Set_Char (Initialize_Scalars_Mode2); + Set_String ("');"); + Write_Statement_Buffer; + end if; + + -- Generate assignment of default secondary stack size if set + + if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then + WBI (""); + Set_String (" system__secondary_stack__"); + Set_String ("default_secondary_stack_size = "); + Set_Int (Opt.Default_Sec_Stack_Size); + Set_Char (';'); + Write_Statement_Buffer; + end if; + + -- Generate elaboration calls + WBI (""); Gen_Elab_Calls_C; WBI ("}"); *************** package body Bindgen is *** 635,641 **** procedure Gen_Elab_Calls_Ada is begin - for E in Elab_Order.First .. Elab_Order.Last loop declare Unum : constant Unit_Id := Elab_Order.Table (E); --- 785,790 ---- *************** package body Bindgen is *** 666,672 **** -- to True, we do not need to test if this has already been -- done, since it is quicker to set the flag than to test it. ! if U.Utype = Is_Body and then Units.Table (Unum_Spec).Set_Elab_Entity then Set_String (" E"); --- 815,821 ---- -- to True, we do not need to test if this has already been -- done, since it is quicker to set the flag than to test it. ! if not U.Interface and then U.Utype = Is_Body and then Units.Table (Unum_Spec).Set_Elab_Entity then Set_String (" E"); *************** package body Bindgen is *** 675,697 **** Write_Statement_Buffer; end if; ! -- Here if elaboration code is present. We generate: -- if not uname_E then -- uname'elab_[spec|body]; -- uname_E := True; -- end if; -- The uname_E assignment is skipped if this is a separate spec, -- since the assignment will be done when we process the body. ! else ! Set_String (" if not E"); ! Set_Unit_Number (Unum_Spec); ! Set_String (" then"); ! Write_Statement_Buffer; ! Set_String (" "); Get_Decoded_Name_String_With_Brackets (U.Uname); if Name_Buffer (Name_Len) = 's' then --- 824,858 ---- Write_Statement_Buffer; end if; ! -- Here if elaboration code is present. If binding a library ! -- or if there is a non-Ada main subprogram then we generate: -- if not uname_E then -- uname'elab_[spec|body]; -- uname_E := True; -- end if; + -- Otherwise, elaboration routines are called unconditionally: + + -- uname'elab_[spec|body]; + -- uname_E := True; + -- The uname_E assignment is skipped if this is a separate spec, -- since the assignment will be done when we process the body. ! elsif not U.Interface then ! if Force_Checking_Of_Elaboration_Flags or ! Interface_Library_Unit or ! (not Bind_Main_Program) ! then ! Set_String (" if not E"); ! Set_Unit_Number (Unum_Spec); ! Set_String (" then"); ! Write_Statement_Buffer; ! Set_String (" "); ! end if; ! Set_String (" "); Get_Decoded_Name_String_With_Brackets (U.Uname); if Name_Buffer (Name_Len) = 's' then *************** package body Bindgen is *** 707,723 **** Write_Statement_Buffer; if U.Utype /= Is_Spec then ! Set_String (" E"); Set_Unit_Number (Unum_Spec); Set_String (" := True;"); Write_Statement_Buffer; end if; ! WBI (" end if;"); end if; end; end loop; - end Gen_Elab_Calls_Ada; ---------------------- --- 868,895 ---- Write_Statement_Buffer; if U.Utype /= Is_Spec then ! if Force_Checking_Of_Elaboration_Flags or ! Interface_Library_Unit or ! (not Bind_Main_Program) ! then ! Set_String (" "); ! end if; ! ! Set_String (" E"); Set_Unit_Number (Unum_Spec); Set_String (" := True;"); Write_Statement_Buffer; end if; ! if Force_Checking_Of_Elaboration_Flags or ! Interface_Library_Unit or ! (not Bind_Main_Program) ! then ! WBI (" end if;"); ! end if; end if; end; end loop; end Gen_Elab_Calls_Ada; ---------------------- *************** package body Bindgen is *** 757,763 **** -- to True, we do not need to test if this has already been -- done, since it is quicker to set the flag than to test it. ! if U.Utype = Is_Body and then Units.Table (Unum_Spec).Set_Elab_Entity then Set_String (" "); --- 929,935 ---- -- to True, we do not need to test if this has already been -- done, since it is quicker to set the flag than to test it. ! if not U.Interface and then U.Utype = Is_Body and then Units.Table (Unum_Spec).Set_Elab_Entity then Set_String (" "); *************** package body Bindgen is *** 767,773 **** Write_Statement_Buffer; end if; ! -- Here if elaboration code is present. We generate: -- if (uname_E == 0) { -- uname__elab[s|b] (); --- 939,946 ---- Write_Statement_Buffer; end if; ! -- Here if elaboration code is present. If binding a library ! -- or if there is a non-Ada main subprogram then we generate: -- if (uname_E == 0) { -- uname__elab[s|b] (); *************** package body Bindgen is *** 777,790 **** -- The uname_E assignment is skipped if this is a separate spec, -- since the assignment will be done when we process the body. ! else ! Set_String (" if ("); Get_Name_String (U.Uname); - Set_Unit_Name; - Set_String ("_E == 0) {"); - Write_Statement_Buffer; ! Set_String (" "); Set_Unit_Name; Set_String ("___elab"); Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body --- 950,970 ---- -- The uname_E assignment is skipped if this is a separate spec, -- since the assignment will be done when we process the body. ! elsif not U.Interface then Get_Name_String (U.Uname); ! if Force_Checking_Of_Elaboration_Flags or ! Interface_Library_Unit or ! (not Bind_Main_Program) ! then ! Set_String (" if ("); ! Set_Unit_Name; ! Set_String ("_E == 0) {"); ! Write_Statement_Buffer; ! Set_String (" "); ! end if; ! ! Set_String (" "); Set_Unit_Name; Set_String ("___elab"); Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body *************** package body Bindgen is *** 792,804 **** Write_Statement_Buffer; if U.Utype /= Is_Spec then ! Set_String (" "); Set_Unit_Name; Set_String ("_E++;"); Write_Statement_Buffer; end if; ! WBI (" }"); end if; end; end loop; --- 972,996 ---- Write_Statement_Buffer; if U.Utype /= Is_Spec then ! if Force_Checking_Of_Elaboration_Flags or ! Interface_Library_Unit or ! (not Bind_Main_Program) ! then ! Set_String (" "); ! end if; ! ! Set_String (" "); Set_Unit_Name; Set_String ("_E++;"); Write_Statement_Buffer; end if; ! if Force_Checking_Of_Elaboration_Flags or ! Interface_Library_Unit or ! (not Bind_Main_Program) ! then ! WBI (" }"); ! end if; end if; end; end loop; *************** package body Bindgen is *** 822,828 **** Set_Unit_Name; Set_String ("___elab"); Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body ! Set_String (" PARAMS ((void));"); Write_Statement_Buffer; end if; --- 1014,1020 ---- Set_Unit_Name; Set_String ("___elab"); Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body ! Set_String (" (void);"); Write_Statement_Buffer; end if; *************** package body Bindgen is *** 838,853 **** procedure Gen_Elab_Order_Ada is begin WBI (""); ! WBI (" -- BEGIN ELABORATION ORDER"); for J in Elab_Order.First .. Elab_Order.Last loop ! Set_String (" -- "); Get_Unit_Name_String (Units.Table (Elab_Order.Table (J)).Uname); Set_Name_Buffer; Write_Statement_Buffer; end loop; ! WBI (" -- END ELABORATION ORDER"); end Gen_Elab_Order_Ada; ---------------------- --- 1030,1045 ---- procedure Gen_Elab_Order_Ada is begin WBI (""); ! WBI (" -- BEGIN ELABORATION ORDER"); for J in Elab_Order.First .. Elab_Order.Last loop ! Set_String (" -- "); Get_Unit_Name_String (Units.Table (Elab_Order.Table (J)).Uname); Set_Name_Buffer; Write_Statement_Buffer; end loop; ! WBI (" -- END ELABORATION ORDER"); end Gen_Elab_Order_Ada; ---------------------- *************** package body Bindgen is *** 910,916 **** Num := 0; for A in ALIs.First .. ALIs.Last loop ! if ALIs.Table (A).Unit_Exception_Table then Num := Num + 1; Last := A; end if; --- 1102,1110 ---- Num := 0; for A in ALIs.First .. ALIs.Last loop ! if not ALIs.Table (A).Interface ! and then ALIs.Table (A).Unit_Exception_Table ! then Num := Num + 1; Last := A; end if; *************** package body Bindgen is *** 946,952 **** Write_Statement_Buffer; for A in ALIs.First .. ALIs.Last loop ! if ALIs.Table (A).Unit_Exception_Table then Get_Decoded_Name_String_With_Brackets (Units.Table (ALIs.Table (A).First_Unit).Uname); Set_Casing (Mixed_Case); --- 1140,1148 ---- Write_Statement_Buffer; for A in ALIs.First .. ALIs.Last loop ! if not ALIs.Table (A).Interface ! and then ALIs.Table (A).Unit_Exception_Table ! then Get_Decoded_Name_String_With_Brackets (Units.Table (ALIs.Table (A).First_Unit).Uname); Set_Casing (Mixed_Case); *************** package body Bindgen is *** 975,984 **** -- If compiling for the JVM, we directly reference Adafinal because -- we don't import it via Do_Finalize (see Gen_Output_File_Ada). ! if Hostparm.Java_VM then ! Set_String (" System.Standard_Library.Adafinal'Code_Address"); ! else ! Set_String (" Do_Finalize'Code_Address"); end if; for E in Elab_Order.First .. Elab_Order.Last loop --- 1171,1184 ---- -- If compiling for the JVM, we directly reference Adafinal because -- we don't import it via Do_Finalize (see Gen_Output_File_Ada). ! if not Restrictions_On_Target (No_Finalization) then ! if Hostparm.Java_VM then ! Set_String ! (" System.Standard_Library.Adafinal'Code_Address"); ! else ! Set_String ! (" Do_Finalize'Code_Address"); ! end if; end if; for E in Elab_Order.First .. Elab_Order.Last loop *************** package body Bindgen is *** 1062,1068 **** Num := 0; for A in ALIs.First .. ALIs.Last loop ! if ALIs.Table (A).Unit_Exception_Table then Num := Num + 1; Set_String (" extern void *__gnat_"); --- 1262,1270 ---- Num := 0; for A in ALIs.First .. ALIs.Last loop ! if not ALIs.Table (A).Interface ! and then ALIs.Table (A).Unit_Exception_Table ! then Num := Num + 1; Set_String (" extern void *__gnat_"); *************** package body Bindgen is *** 1090,1096 **** Num2 := 0; for A in ALIs.First .. ALIs.Last loop ! if ALIs.Table (A).Unit_Exception_Table then Num2 := Num2 + 1; Set_String (" &__gnat_"); --- 1292,1300 ---- Num2 := 0; for A in ALIs.First .. ALIs.Last loop ! if not ALIs.Table (A).Interface ! and then ALIs.Table (A).Unit_Exception_Table ! then Num2 := Num2 + 1; Set_String (" &__gnat_"); *************** package body Bindgen is *** 1132,1138 **** Write_Statement_Buffer; WBI (" " & Ada_Init_Name.all & ","); ! Set_String (" system__standard_library__adafinal"); for E in Elab_Order.First .. Elab_Order.Last loop Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); --- 1336,1345 ---- Write_Statement_Buffer; WBI (" " & Ada_Init_Name.all & ","); ! ! if not Restrictions_On_Target (No_Finalization) then ! Set_String (" system__standard_library__adafinal"); ! end if; for E in Elab_Order.First .. Elab_Order.Last loop Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); *************** package body Bindgen is *** 1168,1199 **** ------------------ procedure Gen_Main_Ada is - Target : constant String_Ptr := Target_Name; - VxWorks_Target : constant Boolean := - Target (Target'Last - 7 .. Target'Last) = "vxworks/" - or else Target (Target'Last - 9 .. Target'Last) = "vxworksae/"; - begin WBI (""); - Set_String (" function "); - Set_String (Get_Main_Name); - - if VxWorks_Target then - Set_String (" return Integer is"); - Write_Statement_Buffer; else Write_Statement_Buffer; WBI (" (argc : Integer;"); WBI (" argv : System.Address;"); WBI (" envp : System.Address)"); ! WBI (" return Integer"); WBI (" is"); end if; ! -- Initialize and Finalize are not used in No_Run_Time mode ! if not No_Run_Time_Specified then WBI (" procedure initialize;"); WBI (" pragma Import (C, initialize, ""__gnat_initialize"");"); WBI (""); --- 1375,1416 ---- ------------------ procedure Gen_Main_Ada is begin WBI (""); + if Exit_Status_Supported_On_Target then + Set_String (" function "); else + Set_String (" procedure "); + end if; + + Set_String (Get_Main_Name); + + if Command_Line_Args_On_Target then Write_Statement_Buffer; WBI (" (argc : Integer;"); WBI (" argv : System.Address;"); WBI (" envp : System.Address)"); ! ! if Exit_Status_Supported_On_Target then ! WBI (" return Integer"); ! end if; ! WBI (" is"); + + else + if Exit_Status_Supported_On_Target then + Set_String (" return Integer is"); + else + Set_String (" is"); + end if; + + Write_Statement_Buffer; end if; ! -- Initialize and Finalize ! if not Restrictions_On_Target (No_Finalization) then WBI (" procedure initialize;"); WBI (" pragma Import (C, initialize, ""__gnat_initialize"");"); WBI (""); *************** package body Bindgen is *** 1254,1276 **** WBI (" begin"); ! -- On VxWorks, there are no command line arguments ! ! if VxWorks_Target then ! WBI (" gnat_argc := 0;"); ! WBI (" gnat_argv := System.Null_Address;"); ! WBI (" gnat_envp := System.Null_Address;"); ! ! -- Normal case of command line arguments present ! else WBI (" gnat_argc := argc;"); WBI (" gnat_argv := argv;"); WBI (" gnat_envp := envp;"); WBI (""); end if; ! if not No_Run_Time_Specified then WBI (" Initialize;"); end if; --- 1471,1500 ---- WBI (" begin"); ! -- Acquire command line arguments if present on target ! if Command_Line_Args_On_Target then WBI (" gnat_argc := argc;"); WBI (" gnat_argv := argv;"); WBI (" gnat_envp := envp;"); WBI (""); + + -- If configurable run time and no command line args, then nothing + -- needs to be done since the gnat_argc/argv/envp variables are + -- suppressed in this case. + + elsif Configurable_Run_Time_On_Target then + null; + + -- Otherwise set dummy values (to be filled in by some other unit?) + + else + WBI (" gnat_argc := 0;"); + WBI (" gnat_argv := System.Null_Address;"); + WBI (" gnat_envp := System.Null_Address;"); end if; ! if not Restrictions_On_Target (No_Finalization) then WBI (" Initialize;"); end if; *************** package body Bindgen is *** 1286,1294 **** end if; end if; ! -- Adafinal is only called if we have a run time ! if not No_Run_Time_Specified then -- If compiling for the JVM, we directly call Adafinal because -- we don't import it via Do_Finalize (see Gen_Output_File_Ada). --- 1510,1518 ---- end if; end if; ! -- Adafinal call is skipped if no finalization ! if not Restrictions_On_Target (No_Finalization) then -- If compiling for the JVM, we directly call Adafinal because -- we don't import it via Do_Finalize (see Gen_Output_File_Ada). *************** package body Bindgen is *** 1302,1319 **** -- Finalize is only called if we have a run time ! if not No_Run_Time_Specified then WBI (" Finalize;"); end if; -- Return result ! if No_Main_Subprogram ! or else ALIs.Table (ALIs.First).Main_Program = Proc ! then ! WBI (" return (gnat_exit_status);"); ! else ! WBI (" return (Result);"); end if; WBI (" end;"); --- 1526,1545 ---- -- Finalize is only called if we have a run time ! if not Restrictions_On_Target (No_Finalization) then WBI (" Finalize;"); end if; -- Return result ! if Exit_Status_Supported_On_Target then ! if No_Main_Subprogram ! or else ALIs.Table (ALIs.First).Main_Program = Proc ! then ! WBI (" return (gnat_exit_status);"); ! else ! WBI (" return (Result);"); ! end if; end if; WBI (" end;"); *************** package body Bindgen is *** 1324,1392 **** ---------------- procedure Gen_Main_C is - Target : constant String_Ptr := Target_Name; - VxWorks_Target : constant Boolean := - Target (Target'Last - 7 .. Target'Last) = "vxworks/" - or else Target (Target'Last - 9 .. Target'Last) = "vxworksae/"; - begin ! Set_String ("int "); Set_String (Get_Main_Name); ! -- On VxWorks, there are no command line arguments ! if VxWorks_Target then ! Set_String (" ()"); ! -- Normal case with command line arguments present else ! Set_String (" (argc, argv, envp)"); end if; ! Write_Statement_Buffer; ! ! -- VxWorks doesn't have the notion of argc/argv ! ! if VxWorks_Target then ! WBI ("{"); ! WBI (" int result;"); ! WBI (" gnat_argc = 0;"); ! WBI (" gnat_argv = 0;"); ! WBI (" gnat_envp = 0;"); ! -- Normal case of arguments present ! else ! WBI (" int argc;"); ! WBI (" char **argv;"); ! WBI (" char **envp;"); ! WBI ("{"); ! -- Generate a reference to __gnat_ada_main_program_name. This symbol ! -- is not referenced elsewhere in the generated program, but is ! -- needed by the debugger (that's why it is generated in the first ! -- place). The reference stops Ada_Main_Program_Name from being ! -- optimized away by smart linkers, such as the AiX linker. ! if Bind_Main_Program then ! WBI (" char *ensure_reference = __gnat_ada_main_program_name;"); ! WBI (""); ! end if; ! if ALIs.Table (ALIs.First).Main_Program = Func then ! WBI (" int result;"); ! end if; WBI (" gnat_argc = argc;"); WBI (" gnat_argv = argv;"); WBI (" gnat_envp = envp;"); WBI (" "); end if; -- The __gnat_initialize routine is used only if we have a run-time ! if not No_Run_Time_Specified then WBI (" __gnat_initialize ();"); end if; --- 1550,1622 ---- ---------------- procedure Gen_Main_C is begin ! if Exit_Status_Supported_On_Target then ! Set_String ("int "); ! else ! Set_String ("void "); ! end if; ! Set_String (Get_Main_Name); ! -- Generate command line args in prototype if present on target ! if Command_Line_Args_On_Target then ! Write_Statement_Buffer (" (int argc, char **argv, char **envp)"); ! -- Case of no command line arguments on target else ! Write_Statement_Buffer (" ()"); end if; ! WBI ("{"); ! -- Generate a reference to __gnat_ada_main_program_name. This symbol ! -- is not referenced elsewhere in the generated program, but is ! -- needed by the debugger (that's why it is generated in the first ! -- place). The reference stops Ada_Main_Program_Name from being ! -- optimized away by smart linkers, such as the AiX linker. ! if Bind_Main_Program then ! WBI (" char *ensure_reference __attribute__ ((__unused__)) = " & ! "__gnat_ada_main_program_name;"); ! WBI (""); ! end if; ! -- If main program is a function, generate result variable ! if ALIs.Table (ALIs.First).Main_Program = Func then ! WBI (" int result;"); ! end if; ! -- Set command line argument values from parameters if command line ! -- arguments are present on target + if Command_Line_Args_On_Target then WBI (" gnat_argc = argc;"); WBI (" gnat_argv = argv;"); WBI (" gnat_envp = envp;"); WBI (" "); + + -- If configurable run-time, then nothing to do, since in this case + -- the gnat_argc/argv/envp variables are entirely suppressed. + + elsif Configurable_Run_Time_On_Target then + null; + + -- if no command line arguments on target, set dummy values + + else + WBI (" int result;"); + WBI (" gnat_argc = 0;"); + WBI (" gnat_argv = 0;"); + WBI (" gnat_envp = 0;"); end if; -- The __gnat_initialize routine is used only if we have a run-time ! if not Suppress_Standard_Library_On_Target then WBI (" __gnat_initialize ();"); end if; *************** package body Bindgen is *** 1394,1400 **** WBI (" " & Ada_Init_Name.all & " ();"); if not No_Main_Subprogram then - WBI (" __gnat_break_start ();"); WBI (" "); --- 1624,1629 ---- *************** package body Bindgen is *** 1421,1460 **** end if; ! -- Adafinal is called only when we have a run-time ! if not No_Run_Time_Specified then WBI (" "); WBI (" system__standard_library__adafinal ();"); end if; -- The finalize routine is used only if we have a run-time ! if not No_Run_Time_Specified then WBI (" __gnat_finalize ();"); end if; ! if ALIs.Table (ALIs.First).Main_Program = Func then ! ! if Hostparm.OpenVMS then ! -- VMS must use the Posix exit routine in order to get an ! -- Unix compatible exit status. ! WBI (" __posix_exit (result);"); ! else ! WBI (" exit (result);"); end if; else ! if Hostparm.OpenVMS then ! -- VMS must use the Posix exit routine in order to get an ! -- Unix compatible exit status. ! WBI (" __posix_exit (gnat_exit_status);"); ! else ! WBI (" exit (gnat_exit_status);"); end if; end if; --- 1650,1700 ---- end if; ! -- Call adafinal if finalization active ! if not Restrictions_On_Target (No_Finalization) then WBI (" "); WBI (" system__standard_library__adafinal ();"); end if; -- The finalize routine is used only if we have a run-time ! if not Suppress_Standard_Library_On_Target then WBI (" __gnat_finalize ();"); end if; ! -- Case of main program is a function, so the value it returns ! -- is the exit status in this case. ! if ALIs.Table (ALIs.First).Main_Program = Func then ! if Exit_Status_Supported_On_Target then ! -- VMS must use Posix exit routine in order to get the effect ! -- of a Unix compatible setting of the program exit status. ! -- For all other systems, we use the standard exit routine. ! if OpenVMS_On_Target then ! WBI (" __posix_exit (result);"); ! else ! WBI (" exit (result);"); ! end if; end if; + -- Case of main program is a procedure, in which case the exit + -- status is whatever was set by a Set_Exit call most recently + else + if Exit_Status_Supported_On_Target then ! -- VMS must use Posix exit routine in order to get the effect ! -- of a Unix compatible setting of the program exit status. ! -- For all other systems, we use the standard exit routine. ! ! if OpenVMS_On_Target then ! WBI (" __posix_exit (gnat_exit_status);"); ! else ! WBI (" exit (gnat_exit_status);"); ! end if; end if; end if; *************** package body Bindgen is *** 1515,1528 **** begin WBI (""); ! Write_Info_Ada_C ("--", "/*", " BEGIN Object file/option list"); for E in Elab_Order.First .. Elab_Order.Last loop -- If not spec that has an associated body, then generate a -- comment giving the name of the corresponding object file. ! if Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec then Get_Name_String (ALIs.Table (Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name); --- 1755,1770 ---- begin WBI (""); ! Write_Info_Ada_C ("-- ", "/* ", " BEGIN Object file/option list"); for E in Elab_Order.First .. Elab_Order.Last loop -- If not spec that has an associated body, then generate a -- comment giving the name of the corresponding object file. ! if (not Units.Table (Elab_Order.Table (E)).Interface) ! and then Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec ! then Get_Name_String (ALIs.Table (Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name); *************** package body Bindgen is *** 1531,1538 **** -- exists, then use it. if not Hostparm.Exclude_Missing_Objects ! or else ! GNAT.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len)); if Output_Object_List then --- 1773,1779 ---- -- exists, then use it. if not Hostparm.Exclude_Missing_Objects ! or else GNAT.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len)); if Output_Object_List then *************** package body Bindgen is *** 1549,1578 **** (ALIs.Table (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile) then ! Opt.Shared_Libgnat := False; ! end if; end if; end if; end loop; ! -- Add a "-Ldir" for each directory in the object path. We skip this ! -- in No_Run_Time mode, where we want more precise control of exactly ! -- what goes into the resulting object file ! ! if not No_Run_Time_Specified then ! for J in 1 .. Nb_Dir_In_Obj_Search_Path loop ! declare ! Dir : String_Ptr := Dir_In_Obj_Search_Path (J); ! begin ! Name_Len := 0; ! Add_Str_To_Name_Buffer ("-L"); ! Add_Str_To_Name_Buffer (Dir.all); ! Write_Linker_Option; ! end; ! end loop; ! end if; -- Sort linker options --- 1790,1821 ---- (ALIs.Table (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile) then ! -- Special case for g-trasym.obj, which is not included ! -- in libgnat. + Get_Name_String (ALIs.Table + (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile); + + if Name_Buffer (1 .. 8) /= "g-trasym" then + Opt.Shared_Libgnat := False; + end if; + end if; end if; end if; end loop; ! -- Add a "-Ldir" for each directory in the object path ! for J in 1 .. Nb_Dir_In_Obj_Search_Path loop ! declare ! Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J); ! begin ! Name_Len := 0; ! Add_Str_To_Name_Buffer ("-L"); ! Add_Str_To_Name_Buffer (Dir.all); ! Write_Linker_Option; ! end; ! end loop; -- Sort linker options *************** package body Bindgen is *** 1628,1634 **** -- files. The reason for this decision is that libraries referenced -- by internal routines may reference these standard library entries. ! if not (No_Run_Time_Specified or else Opt.No_Stdlib) then Name_Len := 0; if Opt.Shared_Libgnat then --- 1871,1877 ---- -- files. The reason for this decision is that libraries referenced -- by internal routines may reference these standard library entries. ! if not Opt.No_Stdlib then Name_Len := 0; if Opt.Shared_Libgnat then *************** package body Bindgen is *** 1649,1660 **** if With_GNARL then Name_Len := 0; ! Add_Str_To_Name_Buffer ("-lgnarl"); Write_Linker_Option; end if; Name_Len := 0; ! Add_Str_To_Name_Buffer ("-lgnat"); Write_Linker_Option; end if; --- 1892,1915 ---- if With_GNARL then Name_Len := 0; ! ! if Opt.Shared_Libgnat then ! Add_Str_To_Name_Buffer (Shared_Lib ("gnarl")); ! else ! Add_Str_To_Name_Buffer ("-lgnarl"); ! end if; ! Write_Linker_Option; end if; Name_Len := 0; ! ! if Opt.Shared_Libgnat then ! Add_Str_To_Name_Buffer (Shared_Lib ("gnat")); ! else ! Add_Str_To_Name_Buffer ("-lgnat"); ! end if; ! Write_Linker_Option; end if; *************** package body Bindgen is *** 1666,1676 **** end loop; if Ada_Bind_File then ! WBI ("-- END Object file/option list "); else ! WBI (" END Object file/option list */"); end if; - end Gen_Object_Files_Options; --------------------- --- 1921,1930 ---- end loop; if Ada_Bind_File then ! WBI ("-- END Object file/option list "); else ! WBI (" END Object file/option list */"); end if; end Gen_Object_Files_Options; --------------------- *************** package body Bindgen is *** 1678,1685 **** --- 1932,1944 ---- --------------------- procedure Gen_Output_File (Filename : String) is + Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public; begin + -- Acquire settings for Interrupt_State pragmas + + Set_IS_Pragma_Table; + -- Override Ada_Bind_File and Bind_Main_Program for Java since -- JGNAT only supports Ada code, and the main program is already -- generated by the compiler. *************** package body Bindgen is *** 1705,1710 **** --- 1964,1975 ---- end if; end loop; + -- Get the time stamp of the former bind for public version warning + + if Is_Public_Version then + Record_Time_From_Last_Bind; + end if; + -- Generate output file in appropriate language if Ada_Bind_File then *************** package body Bindgen is *** 1713,1718 **** --- 1978,1989 ---- Gen_Output_File_C (Filename); end if; + -- Periodically issue a warning when the public version is used on + -- big projects + + if Is_Public_Version then + Public_Version_Warning; + end if; end Gen_Output_File; ------------------------- *************** package body Bindgen is *** 1731,1754 **** -- Name to be used for generated Ada main program. See the body of -- function Get_Ada_Main_Name for details on the form of the name. - Target : constant String_Ptr := Target_Name; - VxWorks_Target : constant Boolean := - Target (Target'Last - 7 .. Target'Last) = "vxworks/" - or else Target (Target'Last - 9 .. Target'Last) = "vxworksae/"; - begin -- Create spec first Create_Binder_Output (Filename, 's', Bfiles); ! if No_Run_Time_Specified then ! WBI ("pragma No_Run_Time;"); end if; ! -- Generate with of System so we can reference System.Address, note ! -- that such a reference is safe even in No_Run_Time mode, since we ! -- do not need any run-time code for such a reference, and we output ! -- a pragma No_Run_Time for this compilation above. WBI ("with System;"); --- 2002,2021 ---- -- Name to be used for generated Ada main program. See the body of -- function Get_Ada_Main_Name for details on the form of the name. begin -- Create spec first Create_Binder_Output (Filename, 's', Bfiles); ! -- If we are operating in Restrictions (No_Exception_Handlers) mode, ! -- then we need to make sure that the binder program is compiled with ! -- the same restriction, so that no exception tables are generated. ! ! if Restrictions_On_Target (No_Exception_Handlers) then ! WBI ("pragma Restrictions (No_Exception_Handlers);"); end if; ! -- Generate with of System so we can reference System.Address WBI ("with System;"); *************** package body Bindgen is *** 1758,1766 **** WBI ("with System.Scalar_Values;"); end if; Resolve_Binder_Options; ! if not No_Run_Time_Specified then -- Usually, adafinal is called using a pragma Import C. Since -- Import C doesn't have the same semantics for JGNAT, we use --- 2025,2039 ---- WBI ("with System.Scalar_Values;"); end if; + -- Generate with of System.Secondary_Stack if active + + if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then + WBI ("with System.Secondary_Stack;"); + end if; + Resolve_Binder_Options; ! if not Suppress_Standard_Library_On_Target then -- Usually, adafinal is called using a pragma Import C. Since -- Import C doesn't have the same semantics for JGNAT, we use *************** package body Bindgen is *** 1772,1807 **** end if; WBI ("package " & Ada_Main & " is"); -- Main program case if Bind_Main_Program then ! -- Generate argc/argv stuff ! WBI (""); ! WBI (" gnat_argc : Integer;"); ! WBI (" gnat_argv : System.Address;"); ! WBI (" gnat_envp : System.Address;"); ! -- If we have a run time present, these variables are in the ! -- runtime data area for easy access from the runtime ! if not No_Run_Time_Specified then ! WBI (""); ! WBI (" pragma Import (C, gnat_argc);"); ! WBI (" pragma Import (C, gnat_argv);"); ! WBI (" pragma Import (C, gnat_envp);"); end if; -- Define exit status. Again in normal mode, this is in the ! -- run-time library, and is initialized there, but in the no ! -- run time case, the variable is here and initialized here. WBI (""); ! if No_Run_Time_Specified then ! WBI (" gnat_exit_status : Integer := 0;"); else WBI (" gnat_exit_status : Integer;"); WBI (" pragma Import (C, gnat_exit_status);"); --- 2045,2088 ---- end if; WBI ("package " & Ada_Main & " is"); + WBI (" pragma Warnings (Off);"); -- Main program case if Bind_Main_Program then ! -- Generate argc/argv stuff unless suppressed ! if Command_Line_Args_On_Target ! or not Configurable_Run_Time_On_Target ! then ! WBI (""); ! WBI (" gnat_argc : Integer;"); ! WBI (" gnat_argv : System.Address;"); ! WBI (" gnat_envp : System.Address;"); ! -- If the standard library is not suppressed, these variables are ! -- in the runtime data area for easy access from the runtime ! if not Suppress_Standard_Library_On_Target then ! WBI (""); ! WBI (" pragma Import (C, gnat_argc);"); ! WBI (" pragma Import (C, gnat_argv);"); ! WBI (" pragma Import (C, gnat_envp);"); ! end if; end if; -- Define exit status. Again in normal mode, this is in the ! -- run-time library, and is initialized there, but in the ! -- configurable runtime case, the variable is declared and ! -- initialized in this file. WBI (""); ! if Configurable_Run_Time_Mode then ! if Exit_Status_Supported_On_Target then ! WBI (" gnat_exit_status : Integer := 0;"); ! end if; else WBI (" gnat_exit_status : Integer;"); WBI (" pragma Import (C, gnat_exit_status);"); *************** package body Bindgen is *** 1832,1841 **** """__gnat_ada_main_program_name"");"); end if; ! -- No need to generate a finalization routine if there is no ! -- runtime, since there is nothing to do in this case. ! if not No_Run_Time_Specified then WBI (""); WBI (" procedure " & Ada_Final_Name.all & ";"); WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ & --- 2113,2122 ---- """__gnat_ada_main_program_name"");"); end if; ! -- No need to generate a finalization routine if finalization ! -- is restricted, since there is nothing to do in this case. ! if not Restrictions_On_Target (No_Finalization) then WBI (""); WBI (" procedure " & Ada_Final_Name.all & ";"); WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ & *************** package body Bindgen is *** 1849,1886 **** if Bind_Main_Program then ! -- If we have a run time, then Break_Start is defined there, but ! -- if there is no run-time, Break_Start is defined in this file. WBI (""); WBI (" procedure Break_Start;"); ! if No_Run_Time_Specified then WBI (" pragma Export (C, Break_Start, ""__gnat_break_start"");"); else WBI (" pragma Import (C, Break_Start, ""__gnat_break_start"");"); end if; WBI (""); - WBI (" function " & Get_Main_Name); ! -- Generate argument list (except on VxWorks, where none is present) ! if not VxWorks_Target then WBI (" (argc : Integer;"); WBI (" argv : System.Address;"); ! WBI (" envp : System.Address)"); end if; - WBI (" return Integer;"); WBI (" pragma Export (C, " & Get_Main_Name & ", """ & Get_Main_Name & """);"); end if; - if Initialize_Scalars_Used then - Gen_Scalar_Values; - end if; - Gen_Versions_Ada; Gen_Elab_Order_Ada; --- 2130,2186 ---- if Bind_Main_Program then ! -- If we have the standard library, then Break_Start is defined ! -- there, but when the standard library is suppressed, Break_Start ! -- is defined here. WBI (""); WBI (" procedure Break_Start;"); ! if Suppress_Standard_Library_On_Target then WBI (" pragma Export (C, Break_Start, ""__gnat_break_start"");"); else WBI (" pragma Import (C, Break_Start, ""__gnat_break_start"");"); end if; WBI (""); ! if Exit_Status_Supported_On_Target then ! Set_String (" function "); ! else ! Set_String (" procedure "); ! end if; ! Set_String (Get_Main_Name); ! ! -- Generate argument list if present ! ! if Command_Line_Args_On_Target then ! Write_Statement_Buffer; WBI (" (argc : Integer;"); WBI (" argv : System.Address;"); ! Set_String ! (" envp : System.Address)"); ! ! if Exit_Status_Supported_On_Target then ! Write_Statement_Buffer; ! WBI (" return Integer;"); ! else ! Write_Statement_Buffer (";"); ! end if; ! ! else ! if Exit_Status_Supported_On_Target then ! Write_Statement_Buffer (" return Integer;"); ! else ! Write_Statement_Buffer (";"); ! end if; end if; WBI (" pragma Export (C, " & Get_Main_Name & ", """ & Get_Main_Name & """);"); end if; Gen_Versions_Ada; Gen_Elab_Order_Ada; *************** package body Bindgen is *** 1919,1928 **** WBI (""); WBI ("package body " & Ada_Main & " is"); ! -- Import the finalization procedure only if there is a runtime. ! if not No_Run_Time_Specified then -- In the Java case, pragma Import C cannot be used, so the -- standard Ada constructs will be used instead. --- 2219,2229 ---- WBI (""); WBI ("package body " & Ada_Main & " is"); + WBI (" pragma Warnings (Off);"); ! -- Import the finalization procedure only if finalization active ! if not Restrictions_On_Target (No_Finalization) then -- In the Java case, pragma Import C cannot be used, so the -- standard Ada constructs will be used instead. *************** package body Bindgen is *** 1939,1956 **** Gen_Adainit_Ada; ! -- No need to generate a finalization routine if there is no ! -- runtime, since there is nothing to do in this case. ! if not No_Run_Time_Specified then Gen_Adafinal_Ada; end if; if Bind_Main_Program then ! -- In No_Run_Time mode, generate dummy body for Break_Start ! if No_Run_Time_Specified then WBI (""); WBI (" procedure Break_Start is"); WBI (" begin"); --- 2240,2257 ---- Gen_Adainit_Ada; ! -- No need to generate a finalization routine if no finalization ! if not Restrictions_On_Target (No_Finalization) then Gen_Adafinal_Ada; end if; if Bind_Main_Program then ! -- When suppressing the standard library then generate dummy body ! -- for Break_Start ! if Suppress_Standard_Library_On_Target then WBI (""); WBI (" procedure Break_Start is"); WBI (" begin"); *************** package body Bindgen is *** 1985,2014 **** Resolve_Binder_Options; ! WBI ("#ifdef __STDC__"); ! WBI ("#define PARAMS(paramlist) paramlist"); ! WBI ("#else"); ! WBI ("#define PARAMS(paramlist) ()"); ! WBI ("#endif"); ! WBI (""); ! WBI ("extern void __gnat_set_globals "); ! WBI (" PARAMS ((int, int, int, int, int, int, const char *,"); ! WBI (" int, int, int));"); ! WBI ("extern void " & Ada_Final_Name.all & " PARAMS ((void));"); ! WBI ("extern void " & Ada_Init_Name.all & " PARAMS ((void));"); ! WBI ("extern void system__standard_library__adafinal PARAMS ((void));"); ! if not No_Main_Subprogram then ! WBI ("extern int main PARAMS ((int, char **, char **));"); ! if Hostparm.OpenVMS then ! WBI ("extern void __posix_exit PARAMS ((int));"); else ! WBI ("extern void exit PARAMS ((int));"); end if; ! WBI ("extern void __gnat_break_start PARAMS ((void));"); Set_String ("extern "); if ALIs.Table (ALIs.First).Main_Program = Proc then --- 2286,2323 ---- Resolve_Binder_Options; ! WBI ("extern void __gnat_set_globals"); ! WBI (" (int, int, char, char, char, char,"); ! WBI (" const char *, const char *,"); ! WBI (" int, int, int, int);"); ! WBI ("extern void " & Ada_Final_Name.all & " (void);"); ! WBI ("extern void " & Ada_Init_Name.all & " (void);"); ! WBI ("extern void system__standard_library__adafinal (void);"); ! if not No_Main_Subprogram then ! Set_String ("extern "); ! if Exit_Status_Supported_On_Target then ! Set_String ("int"); ! else ! Set_String ("void"); ! end if; ! Set_String (" main "); ! ! if Command_Line_Args_On_Target then ! Write_Statement_Buffer ("(int, char **, char **);"); else ! Write_Statement_Buffer ("(void);"); end if; ! if OpenVMS_On_Target then ! WBI ("extern void __posix_exit (int);"); ! else ! WBI ("extern void exit (int);"); ! end if; ! ! WBI ("extern void __gnat_break_start (void);"); Set_String ("extern "); if ALIs.Table (ALIs.First).Main_Program = Proc then *************** package body Bindgen is *** 2019,2032 **** Get_Name_String (Units.Table (First_Unit_Entry).Uname); Set_Main_Program_Name; ! Set_String (" PARAMS ((void));"); Write_Statement_Buffer; end if; ! if not No_Run_Time_Specified then ! WBI ("extern void __gnat_initialize PARAMS ((void));"); ! WBI ("extern void __gnat_finalize PARAMS ((void));"); ! WBI ("extern void __gnat_install_handler PARAMS ((void));"); end if; WBI (""); --- 2328,2341 ---- Get_Name_String (Units.Table (First_Unit_Entry).Uname); Set_Main_Program_Name; ! Set_String (" (void);"); Write_Statement_Buffer; end if; ! if not Suppress_Standard_Library_On_Target then ! WBI ("extern void __gnat_initialize (void);"); ! WBI ("extern void __gnat_finalize (void);"); ! WBI ("extern void __gnat_install_handler (void);"); end if; WBI (""); *************** package body Bindgen is *** 2036,2060 **** -- Imported variable used to track elaboration/finalization phase. -- Used only when we have a runtime. ! if not No_Run_Time_Specified then WBI ("extern int __gnat_handler_installed;"); WBI (""); end if; ! -- Write argv/argc stuff if main program case if Bind_Main_Program then ! -- In the normal case, these are in the runtime library ! if not No_Run_Time_Specified then WBI ("extern int gnat_argc;"); WBI ("extern char **gnat_argv;"); WBI ("extern char **gnat_envp;"); WBI ("extern int gnat_exit_status;"); ! -- In the No_Run_Time case, they are right in the binder file ! -- and we initialize gnat_exit_status in the declaration. else WBI ("int gnat_argc;"); --- 2345,2376 ---- -- Imported variable used to track elaboration/finalization phase. -- Used only when we have a runtime. ! if not Suppress_Standard_Library_On_Target then WBI ("extern int __gnat_handler_installed;"); WBI (""); end if; ! -- Write argv/argc exit status stuff if main program case if Bind_Main_Program then ! -- First deal with argc/argv/envp. In the normal case they ! -- are in the run-time library. ! if not Configurable_Run_Time_On_Target then WBI ("extern int gnat_argc;"); WBI ("extern char **gnat_argv;"); WBI ("extern char **gnat_envp;"); WBI ("extern int gnat_exit_status;"); ! -- If configurable run time and no command line args, then the ! -- generation of these variables is entirely suppressed. ! ! elsif not Command_Line_Args_On_Target then ! null; ! ! -- Otherwise, in the configurable run-time case they are right in ! -- the binder file. else WBI ("int gnat_argc;"); *************** package body Bindgen is *** 2063,2075 **** WBI ("int gnat_exit_status = 0;"); end if; WBI (""); end if; ! -- In no run-time mode, the __gnat_break_start routine (for the ! -- debugger to get initial control) is defined in this file. ! if No_Run_Time_Specified then WBI (""); WBI ("void __gnat_break_start () {}"); end if; --- 2379,2411 ---- WBI ("int gnat_exit_status = 0;"); end if; + -- Similarly deal with exit status + -- are in the run-time library. + + if not Configurable_Run_Time_On_Target then + WBI ("extern int gnat_exit_status;"); + + -- If configurable run time and no exit status on target, then + -- the generation of this variables is entirely suppressed. + + elsif not Exit_Status_Supported_On_Target then + null; + + -- Otherwise, in the configurable run-time case this variable is + -- right in the binder file, and initialized to zero there. + + else + WBI ("int gnat_exit_status = 0;"); + end if; + WBI (""); end if; ! -- When suppressing the standard library, the __gnat_break_start ! -- routine (for the debugger to get initial control) is defined in ! -- this file. ! if Suppress_Standard_Library_On_Target then WBI (""); WBI ("void __gnat_break_start () {}"); end if; *************** package body Bindgen is *** 2094,2100 **** -- Generate the adafinal routine. In no runtime mode, this is -- not needed, since there is no finalization to do. ! if not No_Run_Time_Specified then Gen_Adafinal_C; end if; --- 2430,2436 ---- -- Generate the adafinal routine. In no runtime mode, this is -- not needed, since there is no finalization to do. ! if not Restrictions_On_Target (No_Finalization) then Gen_Adafinal_C; end if; *************** package body Bindgen is *** 2106,2116 **** Gen_Main_C; end if; ! -- Scalar values, versions and object files needed in both cases ! ! if Initialize_Scalars_Used then ! Gen_Scalar_Values; ! end if; Gen_Versions_C; Gen_Elab_Order_C; --- 2442,2448 ---- Gen_Main_C; end if; ! -- Generate versions, elaboration order, list of object files Gen_Versions_C; Gen_Elab_Order_C; *************** package body Bindgen is *** 2121,2421 **** Close_Binder_Output; end Gen_Output_File_C; - ----------------------- - -- Gen_Scalar_Values -- - ----------------------- - - procedure Gen_Scalar_Values is - - -- Strings to hold hex values of initialization constants. Note that - -- we store these strings in big endian order, but they are actually - -- used to initialize integer values, so the actual generated data - -- will automaticaly have the right endianess. - - IS_Is1 : String (1 .. 2); - IS_Is2 : String (1 .. 4); - IS_Is4 : String (1 .. 8); - IS_Is8 : String (1 .. 16); - IS_Iu1 : String (1 .. 2); - IS_Iu2 : String (1 .. 4); - IS_Iu4 : String (1 .. 8); - IS_Iu8 : String (1 .. 16); - IS_Isf : String (1 .. 8); - IS_Ifl : String (1 .. 8); - IS_Ilf : String (1 .. 16); - - -- The string for Long_Long_Float is special. This is used only on the - -- ia32 with 80-bit extended float (stored in 96 bits by gcc). The - -- value here is represented little-endian, since that's the only way - -- it is ever generated (this is not used on big-endian machines. - - IS_Ill : String (1 .. 24); - - begin - -- -Sin (invalid values) - - if Opt.Initialize_Scalars_Mode = 'I' then - IS_Is1 := "80"; - IS_Is2 := "8000"; - IS_Is4 := "80000000"; - IS_Is8 := "8000000000000000"; - IS_Iu1 := "FF"; - IS_Iu2 := "FFFF"; - IS_Iu4 := "FFFFFFFF"; - IS_Iu8 := "FFFFFFFFFFFFFFFF"; - IS_Isf := IS_Iu4; - IS_Ifl := IS_Iu4; - IS_Ilf := IS_Iu8; - IS_Ill := "00000000000000C0FFFF0000"; - - -- -Slo (low values) - - elsif Opt.Initialize_Scalars_Mode = 'L' then - IS_Is1 := "80"; - IS_Is2 := "8000"; - IS_Is4 := "80000000"; - IS_Is8 := "8000000000000000"; - IS_Iu1 := "00"; - IS_Iu2 := "0000"; - IS_Iu4 := "00000000"; - IS_Iu8 := "0000000000000000"; - IS_Isf := "FF800000"; - IS_Ifl := IS_Isf; - IS_Ilf := "FFF0000000000000"; - IS_Ill := "0000000000000080FFFF0000"; - - -- -Shi (high values) - - elsif Opt.Initialize_Scalars_Mode = 'H' then - IS_Is1 := "7F"; - IS_Is2 := "7FFF"; - IS_Is4 := "7FFFFFFF"; - IS_Is8 := "7FFFFFFFFFFFFFFF"; - IS_Iu1 := "FF"; - IS_Iu2 := "FFFF"; - IS_Iu4 := "FFFFFFFF"; - IS_Iu8 := "FFFFFFFFFFFFFFFF"; - IS_Isf := "7F800000"; - IS_Ifl := IS_Isf; - IS_Ilf := "7FF0000000000000"; - IS_Ill := "0000000000000080FF7F0000"; - - -- -Shh (hex byte) - - else pragma Assert (Opt.Initialize_Scalars_Mode = 'X'); - IS_Is1 (1 .. 2) := Opt.Initialize_Scalars_Val; - IS_Is2 (1 .. 2) := Opt.Initialize_Scalars_Val; - IS_Is2 (3 .. 4) := Opt.Initialize_Scalars_Val; - - for J in 1 .. 4 loop - IS_Is4 (2 * J - 1 .. 2 * J) := Opt.Initialize_Scalars_Val; - end loop; - - for J in 1 .. 8 loop - IS_Is8 (2 * J - 1 .. 2 * J) := Opt.Initialize_Scalars_Val; - end loop; - - IS_Iu1 := IS_Is1; - IS_Iu2 := IS_Is2; - IS_Iu4 := IS_Is4; - IS_Iu8 := IS_Is8; - - IS_Isf := IS_Is4; - IS_Ifl := IS_Is4; - IS_Ilf := IS_Is8; - - for J in 1 .. 12 loop - IS_Ill (2 * J - 1 .. 2 * J) := Opt.Initialize_Scalars_Val; - end loop; - end if; - - -- Generate output, Ada case - - if Ada_Bind_File then - WBI (""); - - Set_String (" IS_Is1 : constant System.Scalar_Values.Byte1 := 16#"); - Set_String (IS_Is1); - Write_Statement_Buffer ("#;"); - - Set_String (" IS_Is2 : constant System.Scalar_Values.Byte2 := 16#"); - Set_String (IS_Is2); - Write_Statement_Buffer ("#;"); - - Set_String (" IS_Is4 : constant System.Scalar_Values.Byte4 := 16#"); - Set_String (IS_Is4); - Write_Statement_Buffer ("#;"); - - Set_String (" IS_Is8 : constant System.Scalar_Values.Byte8 := 16#"); - Set_String (IS_Is8); - Write_Statement_Buffer ("#;"); - - Set_String (" IS_Iu1 : constant System.Scalar_Values.Byte1 := 16#"); - Set_String (IS_Iu1); - Write_Statement_Buffer ("#;"); - - Set_String (" IS_Iu2 : constant System.Scalar_Values.Byte2 := 16#"); - Set_String (IS_Iu2); - Write_Statement_Buffer ("#;"); - - Set_String (" IS_Iu4 : constant System.Scalar_Values.Byte4 := 16#"); - Set_String (IS_Iu4); - Write_Statement_Buffer ("#;"); - - Set_String (" IS_Iu8 : constant System.Scalar_Values.Byte8 := 16#"); - Set_String (IS_Iu8); - Write_Statement_Buffer ("#;"); - - Set_String (" IS_Isf : constant System.Scalar_Values.Byte4 := 16#"); - Set_String (IS_Isf); - Write_Statement_Buffer ("#;"); - - Set_String (" IS_Ifl : constant System.Scalar_Values.Byte4 := 16#"); - Set_String (IS_Ifl); - Write_Statement_Buffer ("#;"); - - Set_String (" IS_Ilf : constant System.Scalar_Values.Byte8 := 16#"); - Set_String (IS_Ilf); - Write_Statement_Buffer ("#;"); - - -- Special case of Long_Long_Float. This is a 10-byte value used - -- only on the x86. We could omit it for other architectures, but - -- we don't easily have that kind of target specialization in the - -- binder, and it's only 10 bytes, and only if -Sxx is used. Note - -- that for architectures where Long_Long_Float is the same as - -- Long_Float, the expander uses the Long_Float constant for the - -- initializations of Long_Long_Float values. - - WBI (" IS_Ill : constant array (1 .. 12) of"); - WBI (" System.Scalar_Values.Byte1 := ("); - Set_String (" "); - - for J in 1 .. 6 loop - Set_String (" 16#"); - Set_Char (IS_Ill (2 * J - 1)); - Set_Char (IS_Ill (2 * J)); - Set_String ("#,"); - end loop; - - Write_Statement_Buffer; - Set_String (" "); - - for J in 7 .. 12 loop - Set_String (" 16#"); - Set_Char (IS_Ill (2 * J - 1)); - Set_Char (IS_Ill (2 * J)); - - if J = 12 then - Set_String ("#);"); - else - Set_String ("#,"); - end if; - end loop; - - Write_Statement_Buffer; - - -- Output export statements to export to System.Scalar_Values - - WBI (""); - - WBI (" pragma Export (Ada, IS_Is1, ""__gnat_Is1"");"); - WBI (" pragma Export (Ada, IS_Is2, ""__gnat_Is2"");"); - WBI (" pragma Export (Ada, IS_Is4, ""__gnat_Is4"");"); - WBI (" pragma Export (Ada, IS_Is8, ""__gnat_Is8"");"); - WBI (" pragma Export (Ada, IS_Iu1, ""__gnat_Iu1"");"); - WBI (" pragma Export (Ada, IS_Iu2, ""__gnat_Iu2"");"); - WBI (" pragma Export (Ada, IS_Iu4, ""__gnat_Iu4"");"); - WBI (" pragma Export (Ada, IS_Iu8, ""__gnat_Iu8"");"); - WBI (" pragma Export (Ada, IS_Isf, ""__gnat_Isf"");"); - WBI (" pragma Export (Ada, IS_Ifl, ""__gnat_Ifl"");"); - WBI (" pragma Export (Ada, IS_Ilf, ""__gnat_Ilf"");"); - WBI (" pragma Export (Ada, IS_Ill, ""__gnat_Ill"");"); - - -- Generate output C case - - else - -- The lines we generate in this case are of the form - -- typ __gnat_I?? = 0x??; - -- where typ is appropriate to the length - - WBI (""); - - Set_String ("unsigned char __gnat_Is1 = 0x"); - Set_String (IS_Is1); - Write_Statement_Buffer (";"); - - Set_String ("unsigned short __gnat_Is2 = 0x"); - Set_String (IS_Is2); - Write_Statement_Buffer (";"); - - Set_String ("unsigned __gnat_Is4 = 0x"); - Set_String (IS_Is4); - Write_Statement_Buffer (";"); - - Set_String ("long long unsigned __gnat_Is8 = 0x"); - Set_String (IS_Is8); - Write_Statement_Buffer ("LL;"); - - Set_String ("unsigned char __gnat_Iu1 = 0x"); - Set_String (IS_Is1); - Write_Statement_Buffer (";"); - - Set_String ("unsigned short __gnat_Iu2 = 0x"); - Set_String (IS_Is2); - Write_Statement_Buffer (";"); - - Set_String ("unsigned __gnat_Iu4 = 0x"); - Set_String (IS_Is4); - Write_Statement_Buffer (";"); - - Set_String ("long long unsigned __gnat_Iu8 = 0x"); - Set_String (IS_Is8); - Write_Statement_Buffer ("LL;"); - - Set_String ("unsigned __gnat_Isf = 0x"); - Set_String (IS_Isf); - Write_Statement_Buffer (";"); - - Set_String ("unsigned __gnat_Ifl = 0x"); - Set_String (IS_Ifl); - Write_Statement_Buffer (";"); - - Set_String ("long long unsigned __gnat_Ilf = 0x"); - Set_String (IS_Ilf); - Write_Statement_Buffer ("LL;"); - - -- For Long_Long_Float, we generate - -- char __gnat_Ill[12] = {0x??, 0x??, 0x??, 0x??, 0x??, 0x??, - -- 0x??, 0x??, 0x??, 0x??, 0x??, 0x??); - - Set_String ("unsigned char __gnat_Ill[12] = {"); - - for J in 1 .. 6 loop - Set_String ("0x"); - Set_Char (IS_Ill (2 * J - 1)); - Set_Char (IS_Ill (2 * J)); - Set_String (", "); - end loop; - - Write_Statement_Buffer; - Set_String (" "); - - for J in 7 .. 12 loop - Set_String ("0x"); - Set_Char (IS_Ill (2 * J - 1)); - Set_Char (IS_Ill (2 * J)); - - if J = 12 then - Set_String ("};"); - else - Set_String (", "); - end if; - end loop; - - Write_Statement_Buffer; - end if; - end Gen_Scalar_Values; - ---------------------- -- Gen_Versions_Ada -- ---------------------- --- 2453,2458 ---- *************** package body Bindgen is *** 2632,2642 **** ------------------- function Get_Main_Name return String is - Target : constant String_Ptr := Target_Name; - VxWorks_Target : constant Boolean := - Target (Target'Last - 7 .. Target'Last) = "vxworks/" - or else Target (Target'Last - 9 .. Target'Last) = "vxworksae/"; - begin -- Explicit name given with -M switch --- 2669,2674 ---- *************** package body Bindgen is *** 2645,2651 **** -- Case of main program name to be used directly ! elsif VxWorks_Target then -- Get main program name --- 2677,2683 ---- -- Case of main program name to be used directly ! elsif Use_Ada_Main_Program_Name_On_Target then -- Get main program name *************** package body Bindgen is *** 2710,2715 **** --- 2742,2819 ---- end Move_Linker_Option; ---------------------------- + -- Public_Version_Warning -- + ---------------------------- + + procedure Public_Version_Warning is + Time : constant Int := Time_From_Last_Bind; + + -- Constants to help defining periods + + Hour : constant := 60; + Day : constant := 24 * Hour; + + Never : constant := Integer'Last; + -- Special value indicating no warnings should be given + + -- Constants defining when the warning is issued. Programs with more + -- than Large Units will issue a warning every Period_Large amount of + -- time. Smaller programs will generate a warning every Period_Small + -- amount of time. + + Large : constant := 20; + -- Threshold for considering a program small or large + + Period_Large : constant := Day; + -- Periodic warning time for large programs + + Period_Small : constant := Never; + -- Periodic warning time for small programs + + Nb_Unit : Int; + + begin + -- Compute the number of units that are not GNAT internal files + + Nb_Unit := 0; + for A in ALIs.First .. ALIs.Last loop + if not Is_Internal_File_Name (ALIs.Table (A).Sfile) then + Nb_Unit := Nb_Unit + 1; + end if; + end loop; + + -- Do not emit the message if the last message was emitted in the + -- specified period taking into account the number of units. + + pragma Warnings (Off); + -- Turn off warning of constant condition, which may happen here + -- depending on the choice of constants in the above declarations. + + if Nb_Unit < Large and then Time <= Period_Small then + return; + elsif Time <= Period_Large then + return; + end if; + + pragma Warnings (On); + + Write_Eol; + Write_Str ("IMPORTANT NOTICE:"); + Write_Eol; + Write_Str (" This version of GNAT is unsupported" + & " and comes with absolutely no warranty."); + Write_Eol; + Write_Str (" If you intend to evaluate or use GNAT for building " + & "commercial applications,"); + Write_Eol; + Write_Str (" please consult http://www.gnat.com/ for information"); + Write_Eol; + Write_Str (" on the GNAT Professional product line."); + Write_Eol; + Write_Eol; + end Public_Version_Warning; + + ---------------------------- -- Resolve_Binder_Options -- ---------------------------- *************** package body Bindgen is *** 2719,2732 **** Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); -- The procedure of looking for specific packages and setting ! -- flags is very wrong, but there isn't a good alternative at ! -- this time. if Name_Buffer (1 .. 19) = "system.os_interface" then With_GNARL := True; end if; ! if Hostparm.OpenVMS and then Name_Buffer (1 .. 3) = "dec" then With_DECGNAT := True; end if; end loop; --- 2823,2836 ---- Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); -- The procedure of looking for specific packages and setting ! -- flags is somewhat dubious, but there isn't a good alternative ! -- at the current time ??? if Name_Buffer (1 .. 19) = "system.os_interface" then With_GNARL := True; end if; ! if Hostparm.OpenVMS and then Name_Buffer (1 .. 5) = "dec%s" then With_DECGNAT := True; end if; end loop; *************** package body Bindgen is *** 2763,2768 **** --- 2867,2899 ---- end if; end Set_Int; + ------------------------- + -- Set_IS_Pragma_Table -- + ------------------------- + + procedure Set_IS_Pragma_Table is + begin + for F in ALIs.First .. ALIs.Last loop + for K in ALIs.Table (F).First_Interrupt_State .. + ALIs.Table (F).Last_Interrupt_State + loop + declare + Inum : constant Int := + Interrupt_States.Table (K).Interrupt_Id; + Stat : constant Character := + Interrupt_States.Table (K).Interrupt_State; + + begin + while IS_Pragma_Settings.Last < Inum loop + IS_Pragma_Settings.Append ('n'); + end loop; + + IS_Pragma_Settings.Table (Inum) := Stat; + end; + end loop; + end loop; + end Set_IS_Pragma_Table; + --------------------------- -- Set_Main_Program_Name -- --------------------------- *************** package body Bindgen is *** 2863,2869 **** if Ada_Bind_File then declare S : String (1 .. Ada'Length + Common'Length); - begin S (1 .. Ada'Length) := Ada; S (Ada'Length + 1 .. S'Length) := Common; --- 2994,2999 ---- *************** package body Bindgen is *** 2873,2879 **** else declare S : String (1 .. C'Length + Common'Length); - begin S (1 .. C'Length) := C; S (C'Length + 1 .. S'Length) := Common; --- 3003,3008 ---- diff -Nrc3pad gcc-3.3.3/gcc/ada/bindgen.ads gcc-3.4.0/gcc/ada/bindgen.ads *** gcc-3.3.3/gcc/ada/bindgen.ads 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/bindgen.ads 2003-04-24 17:53:58.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992,1993,1994,1995,1996 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/bindusg.adb gcc-3.4.0/gcc/ada/bindusg.adb *** gcc-3.3.3/gcc/ada/bindusg.adb 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/bindusg.adb 2004-01-05 15:20:43.000000000 +0000 *************** *** 1,13 **** ------------------------------------------------------------------------------ -- -- ! -- GBIND BINDER COMPONENTS -- -- -- -- B I N D U S G -- -- -- -- 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- -- --- 1,12 ---- ------------------------------------------------------------------------------ -- -- ! -- GNAT COMPILER COMPONENTS -- -- -- -- B I N D U S G -- -- -- -- 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- -- *************** begin *** 74,79 **** --- 73,83 ---- Write_Str (" -C Generate binder program in C"); Write_Eol; + -- Line for D switch + + Write_Str (" -Dnnn Default secondary stack size = nnn bytes"); + Write_Eol; + -- Line for -e switch Write_Str (" -e Output complete list of elabor"); *************** begin *** 85,90 **** --- 89,101 ---- Write_Str (" -E Store tracebacks in Exception occurrences"); Write_Eol; + -- The -f switch is voluntarily omitted, because it is obsolete + + -- Line for -F switch + + Write_Str (" -F Force checking of elaboration Flags"); + Write_Eol; + -- Line for -h switch Write_Str (" -h Output this usage (help) infor"); *************** begin *** 124,130 **** -- Line for -m switch Write_Str (" -mnnn Limit number of detected error"); ! Write_Str ("s to nnn (1-999)"); Write_Eol; -- Line for -n switch --- 135,141 ---- -- Line for -m switch Write_Str (" -mnnn Limit number of detected error"); ! Write_Str ("s to nnn (1-999999)"); Write_Eol; -- Line for -n switch *************** begin *** 195,201 **** -- Line for -T switch ! Write_Str (" -Tn Set time slice value to n microseconds (n >= 0)"); Write_Eol; -- Line for -v switch --- 206,212 ---- -- Line for -T switch ! Write_Str (" -Tn Set time slice value to n milliseconds (n >= 0)"); Write_Eol; -- Line for -v switch diff -Nrc3pad gcc-3.3.3/gcc/ada/bindusg.ads gcc-3.4.0/gcc/ada/bindusg.ads *** gcc-3.3.3/gcc/ada/bindusg.ads 2002-10-23 07:33:22.000000000 +0000 --- gcc-3.4.0/gcc/ada/bindusg.ads 2003-04-24 17:53:58.000000000 +0000 *************** *** 6,12 **** -- -- -- S p e c -- -- -- - -- -- -- Copyright (C) 1992,1993,1994 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/bld.adb gcc-3.4.0/gcc/ada/bld.adb *** gcc-3.3.3/gcc/ada/bld.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/ada/bld.adb 2004-01-12 11:36:12.000000000 +0000 *************** *** 0 **** --- 1,3549 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- B L D -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- + -- -- + -- GNAT is free software; you can redistribute it and/or modify it under -- + -- terms of the GNU General Public License as published by the Free Soft- -- + -- ware Foundation; either version 2, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING. If not, write -- + -- to the Free Software Foundation, 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 is still a work in progress. + + with Ada.Characters.Handling; use Ada.Characters.Handling; + with Ada.Strings.Fixed; use Ada.Strings.Fixed; + + with Bld.IO; + with Csets; + + with GNAT.HTable; + with GNAT.Case_Util; use GNAT.Case_Util; + with GNAT.Command_Line; use GNAT.Command_Line; + with GNAT.Directory_Operations; use GNAT.Directory_Operations; + with GNAT.OS_Lib; use GNAT.OS_Lib; + + with Erroutc; use Erroutc; + with Err_Vars; use Err_Vars; + with Gnatvsn; + with Namet; use Namet; + with Opt; use Opt; + with Output; use Output; + with Prj; use Prj; + with Prj.Com; use Prj.Com; + with Prj.Err; use Prj.Err; + with Prj.Part; + with Prj.Tree; use Prj.Tree; + with Snames; + with Table; + with Types; use Types; + + package body Bld is + + function "=" (Left, Right : IO.Position) return Boolean + renames IO."="; + + MAKE_ROOT : constant String := "MAKE_ROOT"; + + Process_All_Project_Files : Boolean := True; + -- Set to False by command line switch -R + + Copyright_Displayed : Boolean := False; + -- To avoid displaying the Copyright line several times + + Usage_Displayed : Boolean := False; + -- To avoid displaying the usage several times + + type Expression_Kind_Type is (Undecided, Static_String, Other); + + Expression_Kind : Expression_Kind_Type := Undecided; + -- After procedure Expression has been called, this global variable + -- indicates if the expression is a static string or not. + -- If it is a static string, then Expression_Value (1 .. Expression_Last) + -- is the static value of the expression. + + Expression_Value : String_Access := new String (1 .. 10); + Expression_Last : Natural := 0; + + -- The following variables indicates if the suffixs and the languages + -- are statically specified and, if they are, their values. + + C_Suffix : String_Access := new String (1 .. 10); + C_Suffix_Last : Natural := 0; + C_Suffix_Static : Boolean := True; + + Cxx_Suffix : String_Access := new String (1 .. 10); + Cxx_Suffix_Last : Natural := 0; + Cxx_Suffix_Static : Boolean := True; + + Ada_Spec_Suffix : String_Access := new String (1 .. 10); + Ada_Spec_Suffix_Last : Natural := 0; + Ada_Spec_Suffix_Static : Boolean := True; + + Ada_Body_Suffix : String_Access := new String (1 .. 10); + Ada_Body_Suffix_Last : Natural := 0; + Ada_Body_Suffix_Static : Boolean := True; + + Languages : String_Access := new String (1 .. 50); + Languages_Last : Natural := 0; + Languages_Static : Boolean := True; + + type Source_Kind_Type is (Unknown, Ada_Spec, Ada_Body, C, Cxx, None); + -- Used when post-processing Compiler'Switches to indicate the language + -- of a source. + + -- The following variables are used to controlled what attributes + -- Default_Switches and Switches are allowed in expressions. + + Default_Switches_Package : Name_Id := No_Name; + Default_Switches_Language : Name_Id := No_Name; + Switches_Package : Name_Id := No_Name; + Switches_Language : Source_Kind_Type := Unknown; + + -- Other attribute references are only allowed in attribute declarations + -- of the same package and of the same name. + + -- Other_Attribute is True only during attribute declarations other than + -- Switches or Default_Switches. + + Other_Attribute : Boolean := False; + Other_Attribute_Package : Name_Id := No_Name; + Other_Attribute_Name : Name_Id := No_Name; + + type Declaration_Type is (False, May_Be, True); + + Source_Files_Declaration : Declaration_Type := False; + + Source_List_File_Declaration : Declaration_Type := False; + + -- Names that are not in Snames + + Name_Ide : Name_Id := No_Name; + Name_Compiler_Command : Name_Id := No_Name; + Name_Main_Language : Name_Id := No_Name; + Name_C_Plus_Plus : Name_Id := No_Name; + + package Processed_Projects is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Project_Node_Id, + No_Element => Empty_Node, + Key => Name_Id, + Hash => Hash, + Equal => "="); + -- This hash table contains all processed projects. + -- It is used to avoid processing the same project file several times. + + package Externals is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Natural, + No_Element => 0, + Key => Project_Node_Id, + Hash => Hash, + Equal => "="); + -- This hash table is used to store all the external references. + -- For each project file, the tree is first traversed and all + -- external references are put in variables. Each of these variables + -- are identified by a number, so that the can be referred to + -- later during the second traversal of the tree. + + package Variable_Names is new Table.Table + (Table_Component_Type => Name_Id, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 10, + Table_Name => "Bld.Variable_Names"); + -- This table stores all the variables declared in a package. + -- It is used to distinguish project level and package level + -- variables identified by simple names. + -- This table is reset for each package. + + package Switches is new Table.Table + (Table_Component_Type => Name_Id, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 10, + Table_Name => "Bld.Switches"); + -- This table stores all the indexs of associative array attribute + -- Compiler'Switches specified in a project file. It is reset for + -- each project file. At the end of processing of a project file + -- this table is traversed to output targets for those files + -- that may be C or C++ source files. + + Last_External : Natural := 0; + -- For each external reference, this variable in incremented by 1, + -- and a Makefile variable __EXTERNAL__ is + -- declared. See procedure Process_Externals. + + Last_Case_Construction : Natural := 0; + -- For each case construction, this variable is incremented by 1, + -- and a Makefile variable __CASE__ is + -- declared. See procedure Process_Declarative_Items. + + Saved_Suffix : constant String := ".saved"; + -- Prefix to be added to the name of reserved variables (see below) when + -- used in external references. + + -- A number of environment variables, whose names are used in the + -- Makefiles are saved at the beginning of the main Makefile. + -- Each reference to any such environment variable is replaced + -- in the Makefiles with the name of the saved variable. + + Ada_Body_String : aliased String := "ADA_BODY"; + Ada_Flags_String : aliased String := "ADA_FLAGS"; + Ada_Mains_String : aliased String := "ADA_MAINS"; + Ada_Sources_String : aliased String := "ADA_SOURCES"; + Ada_Spec_String : aliased String := "ADA_SPEC"; + Ar_Cmd_String : aliased String := "AR_CMD"; + Ar_Ext_String : aliased String := "AR_EXT"; + Base_Dir_String : aliased String := "BASE_DIR"; + Cc_String : aliased String := "CC"; + C_Ext_String : aliased String := "C_EXT"; + Cflags_String : aliased String := "CFLAGS"; + Cxx_String : aliased String := "CXX"; + Cxx_Ext_String : aliased String := "CXX_EXT"; + Cxxflags_String : aliased String := "CXXFLAGS"; + Deps_Projects_String : aliased String := "DEPS_PROJECT"; + Exec_String : aliased String := "EXEC"; + Exec_Dir_String : aliased String := "EXEC_DIR"; + Gnatmake_String : aliased String := "GNATMAKE"; + Languages_String : aliased String := "LANGUAGES"; + Ld_Flags_String : aliased String := "LD_FLAGS"; + Libs_String : aliased String := "LIBS"; + Main_String : aliased String := "MAIN"; + Obj_Ext_String : aliased String := "OBJ_EXT"; + Obj_Dir_String : aliased String := "OBJ_DIR"; + Project_File_String : aliased String := "PROJECT_FILE"; + Src_Dirs_String : aliased String := "SRC_DIRS"; + + type Reserved_Variable_Array is array (Positive range <>) of String_Access; + Reserved_Variables : constant Reserved_Variable_Array := + (Ada_Body_String 'Access, + Ada_Flags_String 'Access, + Ada_Mains_String 'Access, + Ada_Sources_String 'Access, + Ada_Spec_String 'Access, + Ar_Cmd_String 'Access, + Ar_Ext_String 'Access, + Base_Dir_String 'Access, + Cc_String 'Access, + C_Ext_String 'Access, + Cflags_String 'Access, + Cxx_String 'Access, + Cxx_Ext_String 'Access, + Cxxflags_String 'Access, + Deps_Projects_String'Access, + Exec_String 'Access, + Exec_Dir_String 'Access, + Gnatmake_String 'Access, + Languages_String 'Access, + Ld_Flags_String 'Access, + Libs_String 'Access, + Main_String 'Access, + Obj_Ext_String 'Access, + Obj_Dir_String 'Access, + Project_File_String 'Access, + Src_Dirs_String 'Access); + + Main_Project_File_Name : String_Access; + -- The name of the main project file, given as argument. + + Project_Tree : Project_Node_Id; + -- The result of the parsing of the main project file. + + procedure Add_To_Expression_Value (S : String); + procedure Add_To_Expression_Value (S : Name_Id); + -- Add a string to variable Expression_Value + + procedure Display_Copyright; + -- Display name of the tool and the copyright + + function Equal_String (Left, Right : Name_Id) return Boolean; + -- Return True if Left and Right are the same string, without considering + -- the case. + + procedure Expression + (Project : Project_Node_Id; + First_Term : Project_Node_Id; + Kind : Variable_Kind; + In_Case : Boolean; + Reset : Boolean := False); + -- Process an expression. + -- If In_Case is True, all expressions are not static. + + procedure New_Line; + -- Add a line terminator in the Makefile + + procedure Process (Project : Project_Node_Id); + -- Process the project tree, result of the parsing. + + procedure Process_Case_Construction + (Current_Project : Project_Node_Id; + Current_Pkg : Name_Id; + Case_Project : Project_Node_Id; + Case_Pkg : Name_Id; + Name : Name_Id; + Node : Project_Node_Id); + -- Process a case construction. + -- The Makefile declations may be suppressed if no declarative + -- items in the case items are to be put in the Makefile. + + procedure Process_Declarative_Items + (Project : Project_Node_Id; + Pkg : Name_Id; + In_Case : Boolean; + Item : Project_Node_Id); + -- Process the declarative items for a project, a package + -- or a case item. + -- If In_Case is True, all expressions are not static + + procedure Process_Externals (Project : Project_Node_Id); + -- Look for all external references in one project file, populate the + -- table Externals, and output the necessary declarations, if any. + + procedure Put (S : String; With_Substitution : Boolean := False); + -- Add a string to the Makefile. + -- When With_Substitution is True, if the string is one of the reserved + -- variables, replace it with the name of the corresponding saved + -- variable. + + procedure Put (S : Name_Id); + -- Add a string to the Makefile. + + procedure Put (P : Positive); + -- Add the image of a number to the Makefile, without leading space + + procedure Put_Attribute + (Project : Project_Node_Id; + Pkg : Name_Id; + Name : Name_Id; + Index : Name_Id); + -- Put the full name of an attribute in the Makefile + + procedure Put_Directory_Separator; + -- Add a directory separator to the Makefile + + procedure Put_Include_Project + (Included_Project_Path : Name_Id; + Included_Project : Project_Node_Id; + Including_Project_Name : String); + -- Output an include directive for a project + + procedure Put_Line (S : String); + -- Add a string and a line terminator to the Makefile + + procedure Put_L_Name (N : Name_Id); + -- Put a name in lower case in the Makefile + + procedure Put_M_Name (N : Name_Id); + -- Put a name in mixed case in the Makefile + + procedure Put_U_Name (N : Name_Id); + -- Put a name in upper case in the Makefile + + procedure Special_Put_U_Name (S : Name_Id); + -- Put a name in upper case in the Makefile. + -- If "C++" change it to "CXX". + + procedure Put_Variable + (Project : Project_Node_Id; + Pkg : Name_Id; + Name : Name_Id); + -- Put the full name of a variable in the Makefile + + procedure Recursive_Process (Project : Project_Node_Id); + -- Process a project file and the project files it depends on iteratively + -- without processing twice the same project file. + + procedure Reset_Suffixes_And_Languages; + -- Indicate that all suffixes and languages have the default values + + function Source_Kind_Of (File_Name : Name_Id) return Source_Kind_Type; + -- From a source file name, returns the source kind of the file + + function Suffix_Of + (Static : Boolean; + Value : String_Access; + Last : Natural; + Default : String) return String; + -- Returns the current suffix, if it is statically known, or "" + -- if it is not statically known. Used on C_Suffix, Cxx_Suffix, + -- Ada_Body_Suffix and Ada_Spec_Suffix. + + procedure Usage; + -- Display the usage of gnatbuild + + ----------------------------- + -- Add_To_Expression_Value -- + ----------------------------- + + procedure Add_To_Expression_Value (S : String) is + begin + -- Check that the buffer is large enough. + -- If it is not, double it until it is large enough. + + while Expression_Last + S'Length > Expression_Value'Last loop + declare + New_Value : constant String_Access := + new String (1 .. 2 * Expression_Value'Last); + + begin + New_Value (1 .. Expression_Last) := + Expression_Value (1 .. Expression_Last); + Free (Expression_Value); + Expression_Value := New_Value; + end; + end loop; + + Expression_Value (Expression_Last + 1 .. Expression_Last + S'Length) + := S; + Expression_Last := Expression_Last + S'Length; + end Add_To_Expression_Value; + + procedure Add_To_Expression_Value (S : Name_Id) is + begin + Get_Name_String (S); + Add_To_Expression_Value (S => Name_Buffer (1 .. Name_Len)); + end Add_To_Expression_Value; + + ----------------------- + -- Display_Copyright -- + ----------------------- + + procedure Display_Copyright is + begin + if not Copyright_Displayed then + Copyright_Displayed := True; + Write_Str ("GPR2MAKE "); + Write_Str (Gnatvsn.Gnat_Version_String); + Write_Str (" Copyright 2002-2004 Free Software Foundation, Inc."); + Write_Eol; + Write_Eol; + end if; + end Display_Copyright; + + ------------------ + -- Equal_String -- + ------------------ + + function Equal_String (Left, Right : Name_Id) return Boolean is + begin + Get_Name_String (Left); + + declare + Left_Value : constant String := + To_Lower (Name_Buffer (1 .. Name_Len)); + + begin + Get_Name_String (Right); + return Left_Value = To_Lower (Name_Buffer (1 .. Name_Len)); + end; + end Equal_String; + + ---------------- + -- Expression -- + ---------------- + + procedure Expression + (Project : Project_Node_Id; + First_Term : Project_Node_Id; + Kind : Variable_Kind; + In_Case : Boolean; + Reset : Boolean := False) + is + Term : Project_Node_Id := First_Term; + -- The term in the expression list + + Current_Term : Project_Node_Id := Empty_Node; + -- The current term node id + + begin + if In_Case then + Expression_Kind := Other; + + elsif Reset then + Expression_Kind := Undecided; + Expression_Last := 0; + end if; + + while Term /= Empty_Node loop + + Current_Term := Tree.Current_Term (Term); + + case Kind_Of (Current_Term) is + + when N_Literal_String => + -- If we are in a string list, we precede this literal string + -- with a space; it does not matter if the output list + -- has a leading space. + -- Otherwise we just output the literal string: + -- if it is not the first term of the expression, it will + -- concatenate with was previously output. + + if Kind = List then + Put (" "); + end if; + + -- If in a static string expression, add to expression value + + if Expression_Kind = Undecided + or else Expression_Kind = Static_String + then + Expression_Kind := Static_String; + + if Kind = List then + Add_To_Expression_Value (" "); + end if; + + Add_To_Expression_Value (String_Value_Of (Current_Term)); + end if; + + Put (String_Value_Of (Current_Term)); + + when N_Literal_String_List => + -- For string list, we repetedly call Expression with each + -- element of the list. + + declare + String_Node : Project_Node_Id := + First_Expression_In_List (Current_Term); + + begin + if String_Node /= Empty_Node then + + -- If String_Node is nil, it is an empty list, + -- there is nothing to do + + Expression + (Project => Project, + First_Term => Tree.First_Term (String_Node), + Kind => Single, + In_Case => In_Case); + + loop + -- Add the other element of the literal string list + -- one after the other + + String_Node := + Next_Expression_In_List (String_Node); + + exit when String_Node = Empty_Node; + + Put (" "); + Add_To_Expression_Value (" "); + Expression + (Project => Project, + First_Term => Tree.First_Term (String_Node), + Kind => Single, + In_Case => In_Case); + end loop; + end if; + end; + + when N_Variable_Reference | N_Attribute_Reference => + -- A variable or attribute reference is never static + + Expression_Kind := Other; + + -- A variable or an attribute is identified by: + -- - its project name, + -- - its package name, if any, + -- - its name, and + -- - its index (if an associative array attribute). + + declare + Term_Project : Project_Node_Id := + Project_Node_Of (Current_Term); + Term_Package : constant Project_Node_Id := + Package_Node_Of (Current_Term); + + Name : constant Name_Id := Name_Of (Current_Term); + + Term_Package_Name : Name_Id := No_Name; + + begin + if Term_Project = Empty_Node then + Term_Project := Project; + end if; + + if Term_Package /= Empty_Node then + Term_Package_Name := Name_Of (Term_Package); + end if; + + -- If we are in a string list, we precede this variable or + -- attribute reference with a space; it does not matter if + -- the output list has a leading space. + + if Kind = List then + Put (" "); + end if; + + Put ("$("); + + if Kind_Of (Current_Term) = N_Variable_Reference then + Put_Variable + (Project => Term_Project, + Pkg => Term_Package_Name, + Name => Name); + + else + -- Attribute reference. + + -- If it is a Default_Switches attribute, check if it + -- is allowed in this expression (same package and same + -- language). + + if Name = Snames.Name_Default_Switches then + if Default_Switches_Package /= Term_Package_Name + or else not Equal_String + (Default_Switches_Language, + Associative_Array_Index_Of + (Current_Term)) + then + -- This Default_Switches attribute is not allowed + -- here; report an error and continue. + -- The Makefiles created will be deleted at the + -- end. + + Error_Msg_Name_1 := Term_Package_Name; + Error_Msg + ("reference to `%''Default_Switches` " & + "not allowed here", + Location_Of (Current_Term)); + end if; + + -- If it is a Switches attribute, check if it is allowed + -- in this expression (same package and same source + -- kind). + + elsif Name = Snames.Name_Switches then + if Switches_Package /= Term_Package_Name + or else Source_Kind_Of (Associative_Array_Index_Of + (Current_Term)) + /= Switches_Language + then + -- This Switches attribute is not allowed here; + -- report an error and continue. The Makefiles + -- created will be deleted at the end. + + Error_Msg_Name_1 := Term_Package_Name; + Error_Msg + ("reference to `%''Switches` " & + "not allowed here", + Location_Of (Current_Term)); + end if; + + else + -- Other attribute references are only allowed in + -- the declaration of an atribute of the same + -- package and of the same name. + + if not Other_Attribute + or else Other_Attribute_Package /= Term_Package_Name + or else Other_Attribute_Name /= Name + then + if Term_Package_Name = No_Name then + Error_Msg_Name_1 := Name; + Error_Msg + ("reference to % not allowed here", + Location_Of (Current_Term)); + + else + Error_Msg_Name_1 := Term_Package_Name; + Error_Msg_Name_2 := Name; + Error_Msg + ("reference to `%''%` not allowed here", + Location_Of (Current_Term)); + end if; + end if; + end if; + + Put_Attribute + (Project => Term_Project, + Pkg => Term_Package_Name, + Name => Name, + Index => Associative_Array_Index_Of (Current_Term)); + end if; + + Put (")"); + end; + + when N_External_Value => + -- An external reference is never static + + Expression_Kind := Other; + + -- As the external references have already been processed, + -- we just output the name of the variable that corresponds + -- to this external reference node. + + Put ("$("); + Put_U_Name (Name_Of (Project)); + Put (".external."); + Put (Externals.Get (Current_Term)); + Put (")"); + + when others => + + -- Should never happen + + pragma Assert + (False, + "illegal node kind in an expression"); + raise Program_Error; + end case; + + Term := Next_Term (Term); + end loop; + end Expression; + + -------------- + -- Gpr2make -- + -------------- + + procedure Gpr2make is + begin + -- First, get the switches, if any + + loop + case Getopt ("h q v R") is + when ASCII.NUL => + exit; + + -- -h: Help + + when 'h' => + Usage; + + -- -q: Quiet + + when 'q' => + Opt.Quiet_Output := True; + + -- -v: Verbose + + when 'v' => + Opt.Verbose_Mode := True; + Display_Copyright; + + -- -R: no Recursivity + + when 'R' => + Process_All_Project_Files := False; + + when others => + raise Program_Error; + end case; + end loop; + + -- Now, get the project file (maximum one) + + loop + declare + S : constant String := Get_Argument (Do_Expansion => True); + begin + exit when S'Length = 0; + + if Main_Project_File_Name /= null then + Fail ("only one project file may be specified"); + + else + Main_Project_File_Name := new String'(S); + end if; + end; + end loop; + + -- If no project file specified, display the usage and exit + + if Main_Project_File_Name = null then + Usage; + return; + end if; + + -- Do the necessary initializations + + Csets.Initialize; + Namet.Initialize; + + Snames.Initialize; + + Prj.Initialize; + + -- Parse the project file(s) + + Prj.Part.Parse (Project_Tree, Main_Project_File_Name.all, False); + + -- If parsing was successful, process the project tree + + if Project_Tree /= Empty_Node then + + -- Create some Name_Ids that are not in Snames + + Name_Len := 3; + Name_Buffer (1 .. Name_Len) := "ide"; + Name_Ide := Name_Find; + + Name_Len := 16; + Name_Buffer (1 .. Name_Len) := "compiler_command"; + Name_Compiler_Command := Name_Find; + + Name_Len := 13; + Name_Buffer (1 .. Name_Len) := "main_language"; + Name_Main_Language := Name_Find; + + Name_Len := 3; + Name_Buffer (1 .. Name_Len) := "c++"; + Name_C_Plus_Plus := Name_Find; + + Process (Project_Tree); + + if Compilation_Errors then + if not Verbose_Mode then + Write_Eol; + end if; + + Prj.Err.Finalize; + Write_Eol; + IO.Delete_All; + Fail ("no Makefile created"); + end if; + end if; + end Gpr2make; + + -------------- + -- New_Line -- + -------------- + + procedure New_Line is + begin + IO.New_Line; + end New_Line; + + ------------- + -- Process -- + ------------- + + procedure Process (Project : Project_Node_Id) is + begin + Processed_Projects.Reset; + Recursive_Process (Project); + end Process; + + ------------------------------- + -- Process_Case_Construction -- + ------------------------------- + + procedure Process_Case_Construction + (Current_Project : Project_Node_Id; + Current_Pkg : Name_Id; + Case_Project : Project_Node_Id; + Case_Pkg : Name_Id; + Name : Name_Id; + Node : Project_Node_Id) + is + Case_Project_Name : constant Name_Id := Name_Of (Case_Project); + Before : IO.Position; + Start : IO.Position; + After : IO.Position; + + procedure Put_Case_Construction; + -- Output the variable $__CASE__#, specific to + -- this case construction. It contains the number of the + -- branch to follow. + + procedure Recursive_Process + (Case_Item : Project_Node_Id; + Branch_Number : Positive); + -- A recursive procedure. Calls itself for each branch, increasing + -- Branch_Number by 1 each time. + + procedure Put_Variable_Name; + -- Output the case variable + + --------------------------- + -- Put_Case_Construction -- + --------------------------- + + procedure Put_Case_Construction is + begin + Put_U_Name (Case_Project_Name); + Put (".case."); + Put (Last_Case_Construction); + end Put_Case_Construction; + + ----------------------- + -- Recursive_Process -- + ----------------------- + + procedure Recursive_Process + (Case_Item : Project_Node_Id; + Branch_Number : Positive) + is + Choice_String : Project_Node_Id := First_Choice_Of (Case_Item); + + Before : IO.Position; + Start : IO.Position; + After : IO.Position; + + No_Lines : Boolean := False; + + begin + -- Nothing to do if Case_Item is empty. + -- That should happen only if the case construvtion is totally empty. + -- case Var is + -- end case; + + if Case_Item /= Empty_Node then + -- Remember where we are, to be able to come back here if this + -- case item is empty. + + IO.Mark (Before); + + if Choice_String = Empty_Node then + -- when others => + + -- Output a comment "# when others => ..." + + Put_Line ("# when others => ..."); + + -- Remember where we are, to detect if there is anything + -- put in the Makefile for this branch. + + IO.Mark (Start); + + -- Process the declarative items of this branch + + Process_Declarative_Items + (Project => Current_Project, + Pkg => Current_Pkg, + In_Case => True, + Item => First_Declarative_Item_Of (Case_Item)); + + -- Where are we now? + IO.Mark (After); + + -- If we are at the same place, the branch is totally empty: + -- suppress it completely. + + if Start = After then + IO.Release (Before); + end if; + else + -- Case Item with one or several case labels + + -- Output a comment + -- # case